;;; -*- 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.1 2003/07/16 16:02:21 kevin Exp $
;;;;
;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
;;;; *************************************************************************

(in-package #:wol)


(defun request-decompile-uri (req ent)
  "returns (VALUE PAGE PLIST QUERY-ALIST)"
  (multiple-value-bind (page plists query) 
      (decode-url (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))
  req)


;;; 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-html-url (page ent &optional query-args)
  (make-url (concatenate 'string page ".html")
	    :base-dir (project-prefix 
		       (entity-project ent))
	    :vars query-args :format :xhtml))

(defvar *unspecified* (cons :unspecified nil))

(defun make-wol-url (page ent
		 &key (session-id *unspecified*)
		      (object-id *unspecified*)
		      (func *unspecified*) (key *unspecified*)
		      (subobjects *unspecified*) (labels *unspecified*)
		      (english-only *unspecified*)
		      (format *unspecified*)
		      (lang *unspecified*) (logged *unspecified*)
		      (next-page *unspecified*) (caller *unspecified*)
		      asp html)
  (let ((plist (list :page page))
	(prefix (project-prefix (entity-project ent))))
    (unless (eq session-id *unspecified*)
      (setq plist (append plist (list :session-id session-id))))
    (unless (eq object-id *unspecified*)
      (setq plist (append plist (list :object-id object-id))))
    (unless (eq lang *unspecified*)
      (setq plist (append plist (list :lang lang))))
    (unless (eq logged *unspecified*)
      (setq plist (append plist (list :logged logged))))
    (unless (eq func *unspecified*)
      (setq plist (append plist (list :func func))))
    (unless (eq subobjects *unspecified*)
      (setq plist (append plist (list :subobjects subobjects))))
    (unless (eq key *unspecified*)
      (setq plist (append plist (list :key key))))
    (unless (eq labels *unspecified*)
      (setq plist (append plist (list :labels labels))))
    (unless (eq english-only *unspecified*)
      (setq plist (append plist (list :english-only english-only))))
    (unless (eq next-page *unspecified*)
      (setq plist (append plist (list :next-page next-page))))
    (unless (eq format *unspecified*)
      (setq plist (append plist (list :format format))))
    (unless (eq caller *unspecified*)
      (setq plist (append plist (list :caller caller))))
    (if (and (null asp)
	     (parameters-null session-id object-id lang logged func subobjects
			      key labels english-only next-page format caller))
	(concatenate 'string prefix page ".html")
      (concatenate 'string
	prefix
	(if html
	    (concatenate 'string page ".lsp")
	  (concatenate 'string
	    +asp-header+ +plist-header+ (plist-to-url-string plist)))))))

(defun parameters-null (&rest params)
  (every #'(lambda (p) (or (null p) (eq p *unspecified*))) params))


;; 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)
	(escape-uri-field str))))

(defun url-string-to-plist (str &key (base64 t))
  (let ((decode (if base64
		    (base64-string-to-string str :uri t)
		    (unescape-uri-field 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)
    
    ;; 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)
    
    ;; For posting to lookup-func1
    (:F :func)
    (:K :key)
    (:B :subobjects)
    (:A :labels)
    (:E :english-only)
    (:R :format)
    
    (:X :xml)
    (:P :page)

    (otherwise elem)))