;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol  -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          uri.lisp
;;;; Purpose:       URI functions for wol
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  July 2003
;;;;
;;;; $Id: uri.lisp,v 1.8 2003/08/10 05:16:52 kevin Exp $
;;;;
;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
;;;; *************************************************************************

(in-package #:wol)

(defun req-recode-uri-sans-session-id (req)
  (let ((ppath (puri:uri-parsed-path (request-uri req))))
    (when (is-raw-session-id (second ppath))
      (let ((new-path (list* (car ppath) (cddr ppath))))
	(setf (uri-parsed-path (request-uri req)) new-path)
	(setf (uri-parsed-path (request-raw-uri req)) new-path))
      (setf (request-decoded-uri-path req)
	(uridecode-string (uri-path (request-raw-uri req))))
      (raw-session-id->session-id (second ppath)))))

(defun request-cookies (req)
  (aif (aserve-request req)
       (net.aserve:get-cookie-values it)
       (loop for h in (request-headers req)
	   when (eq :cookie (car h))
	   collect (cdr h))))

(defun header-lines-matching (key headers)
  (loop for hdr in headers
      when (eq key (car hdr))
      collect (cdr hdr)))

(defun set-cookies-in-headers (headers)
  (header-lines-matching :set-cookie headers))

(defun cookies-in-headers (headers)
  (header-lines-matching :cookie headers))

(defun cookie-session-key (ent cookies)
  "Return the session key from the alist of cookies"
  (let ((name (project-name (entity-project ent))))
    (cdr (assoc name cookies :test #'string-equal))))

(defun compute-uris (req ent)
  "Compute URI's of a request"
  (let ((url-session-id (req-recode-uri-sans-session-id req)))
    (compute-session req ent url-session-id)
    
    (multiple-value-bind (page plists query) 
	(decode-url (puri:uri-path (request-raw-uri req)))
      (when page
	(setf (request-page req) (base-page-name page ent)))
      (when plists
	(setf (request-plist req) (car plists))
	(setf (request-next-plists req) (cdr plists))
	(when (null page)
	  (awhen (getf (request-plist req) :page)
		 (setf (request-page req) it))))
      (setf (request-uri-query req) query))))


;;; URI Functions

(defun base-page-name (page ent)
  "Return the base page name for a html url"
  (let ((len-prefix (length (project-prefix (entity-project ent)))))
    (assert (>= (length page) len-prefix))
    (string-strip-ending (subseq page len-prefix)
			 '(".html" ".lsp"))))

(defun split-plist-url (url)
  (string-delimited-string-to-list url +plist-header+))

(defun decode-url (url)
  "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
  (let* ((plists '())
	 (qsplit (delimited-string-to-list url #\?))
	 (query (cadr qsplit))
	 (split (split-plist-url (car qsplit)))
	 (page-name 
	  (when (and (plusp (length (car split)))
		     (not (string= +full-asp-header+ (car split)))
		     (not (string-starts-with +full-asp-header+ (car split))))
	    (car split))))
    (dolist (elem (cdr split))
      (push (url-string-to-plist elem) plists))
    (values page-name (nreverse plists) query)))



(defun make-wol-url (page req ent &optional plist)
  (let ((session (websession-from-req req))
	(url-plist (append (list :page page) plist))
	(prefix (project-prefix (entity-project ent))))
    (concatenate 'string
      prefix
      (if (and session
		 (websession-key session)
		 (not (eq :cookies (websession-method session))))
	  (format nil "~~~A~~/" (websession-key session))
	"")
      (if (null plist)
	(concatenate 'string page ".html")
	(concatenate 'string
	  +asp-header+
	  (concatenate 'string +plist-header+ 
		       (plist-to-url-string url-plist)))))))


;; Property lists

(defun plist-to-url-string (plist &key (base64 t))
  (let ((str (plist-to-compressed-string plist)))
    (if base64
	(string-to-base64-string str :uri t)
	(uriencode-string str))))

(defun url-string-to-plist (str &key (base64 t))
  (let ((decode (if base64
		    (base64-string-to-string str :uri t)
		    (uridecode-string str))))
    (when decode
      (ignore-errors (compressed-string-to-plist decode)))))

(defun plist-to-compressed-string (plist)
  "Decode an encoded plist"
    (assert (evenp (length plist)))
    (do* ((output '())
	  (list plist (cddr list)))
	 ((null list)
	  (prin1-to-string (nreverse output)))
      (push (compress-elem (car list)) output)
      (push (cadr list) output)))

(defun compress-elem (elem)
  "Encode a plist elem"
  (case elem
    (:page :p)
    (:posted :t)
    (:object-id :o)
    (:session-id :s)
    (:lang :l)
    (:logged :g)
    (:caller :c)
    (:db :d)
    
    ;; For lookup-func1
    (:func :f)
    (:format :r)
    (:key :k)
    (:labels :a)
    (:subobjects :b)
    (:english-only :e)
   
    (:xml :x)
    (:next-page :n)
    
    (otherwise elem)))

(defun compressed-string-to-plist (encoded-str)
  (let ((encoded (ignore-errors (read-from-string encoded-str)))
	(output '()))
    (unless encoded
      (cmsg "invalid encoded string")
      #+ignore
      (gen-invalid-encoded-str encoded-str)
      nil)
    (assert (evenp (length encoded)))
    (do* ((elist encoded (cddr elist)))
	 ((null elist) (nreverse output))
      (push (decompress-elem (car elist)) output)
      (push (cadr elist) output))))

(defun decompress-elem (elem)
  (case elem
    (:N :next-page)
    (:T :posted)
    (:O :object-id)
    (:S :session-id)
    (:L :lang)
    (:G :logged)
    (:C :caller)
    (:D :db)
    
    ;; For posting to lookup-func1
    (:F :func)
    (:K :key)
    (:B :subobjects)
    (:A :labels)
    (:E :english-only)
    (:R :format)
    
    (:X :xml)
    (:P :page)

    (otherwise elem)))