uri.lisp

   1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol  -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          uri.lisp
   6 ;;;; Purpose:       URI functions for wol
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  July 2003
   9 ;;;;
  10 ;;;; $Id: uri.lisp,v 1.2 2003/07/18 21:34:18 kevin Exp $
  11 ;;;;
  12 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package #:wol)
  16
  17
  18 (defun request-decompile-uri (req ent)
  19   "returns (VALUE PAGE PLIST QUERY-ALIST)"
  20   (multiple-value-bind (page plists query)
  21       (decode-url (request-raw-uri req))
  22     (when page
  23       (setf (request-page req) (base-page-name page ent)))
  24     (when plists
  25       (setf (request-plist req) (car plists))
  26       (setf (request-next-plists req) (cdr plists))
  27       (when (null page)
  28         (awhen (getf (request-plist req) :page)
  29                (setf (request-page req) it))))
  30     (setf (request-uri-query req) query))
  31   req)
  32
  33
  34 ;;; URI Functions
  35
  36 (defun base-page-name (page ent)
  37   "Return the base page name for a html url"
  38   (let ((len-prefix (length (project-prefix (entity-project ent)))))
  39     (assert (>= (length page) len-prefix))
  40     (string-strip-ending (subseq page len-prefix)
  41                          '(".html" ".lsp"))))
  42
  43 (defun split-plist-url (url)
  44   (string-delimited-string-to-list url +plist-header+))
  45
  46 (defun decode-url (url)
  47   "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
  48   (let* ((plists '())
  49          (qsplit (delimited-string-to-list url #\?))
  50          (query (cadr qsplit))
  51          (split (split-plist-url (car qsplit)))
  52          (page-name
  53           (when (and (plusp (length (car split)))
  54                      (not (string= +full-asp-header+ (car split)))
  55                      (not (string-starts-with +full-asp-header+ (car split))))
  56             (car split))))
  57     (dolist (elem (cdr split))
  58       (push (url-string-to-plist elem) plists))
  59     (values page-name (nreverse plists) query)))
  60
  61
  62
  63 (defun make-html-url (page ent &optional query-args)
  64   (make-url (concatenate 'string page ".html")
  65             :base-dir (project-prefix
  66                        (entity-project ent))
  67             :vars query-args :format :xhtml))
  68
  69 (defvar *unspecified* (cons :unspecified nil))
  70
  71 (defun make-wol-url (page ent
  72                  &key (session-id *unspecified*)
  73                       (object-id *unspecified*)
  74                       (func *unspecified*) (key *unspecified*)
  75                       (subobjects *unspecified*) (labels *unspecified*)
  76                       (english-only *unspecified*)
  77                       (format *unspecified*)
  78                       (lang *unspecified*) (logged *unspecified*)
  79                       (next-page *unspecified*) (caller *unspecified*)
  80                       asp html)
  81   (let ((plist (list :page page))
  82         (prefix (project-prefix (entity-project ent))))
  83     (unless (eq session-id *unspecified*)
  84       (setq plist (append plist (list :session-id session-id))))
  85     (unless (eq object-id *unspecified*)
  86       (setq plist (append plist (list :object-id object-id))))
  87     (unless (eq lang *unspecified*)
  88       (setq plist (append plist (list :lang lang))))
  89     (unless (eq logged *unspecified*)
  90       (setq plist (append plist (list :logged logged))))
  91     (unless (eq func *unspecified*)
  92       (setq plist (append plist (list :func func))))
  93     (unless (eq subobjects *unspecified*)
  94       (setq plist (append plist (list :subobjects subobjects))))
  95     (unless (eq key *unspecified*)
  96       (setq plist (append plist (list :key key))))
  97     (unless (eq labels *unspecified*)
  98       (setq plist (append plist (list :labels labels))))
  99     (unless (eq english-only *unspecified*)
 100       (setq plist (append plist (list :english-only english-only))))
 101     (unless (eq next-page *unspecified*)
 102       (setq plist (append plist (list :next-page next-page))))
 103     (unless (eq format *unspecified*)
 104       (setq plist (append plist (list :format format))))
 105     (unless (eq caller *unspecified*)
 106       (setq plist (append plist (list :caller caller))))
 107     (if (and (null asp)
 108              (parameters-null session-id object-id lang logged func subobjects
 109                               key labels english-only next-page format caller))
 110         (concatenate 'string prefix page ".html")
 111       (concatenate 'string
 112         prefix
 113         (if html
 114             (concatenate 'string page ".lsp")
 115           +asp-header+)
 116         (concatenate 'string +plist-header+ (plist-to-url-string plist))))))
 117
 118 (defun parameters-null (&rest params)
 119   (every #'(lambda (p) (or (null p) (eq p *unspecified*))) params))
 120
 121
 122 ;; Property lists
 123
 124 (defun plist-to-url-string (plist &key (base64 t))
 125   (let ((str (plist-to-compressed-string plist)))
 126     (if base64
 127         (string-to-base64-string str :uri t)
 128         (escape-uri-field str))))
 129
 130 (defun url-string-to-plist (str &key (base64 t))
 131   (let ((decode (if base64
 132                     (base64-string-to-string str :uri t)
 133                     (unescape-uri-field str))))
 134     (when decode
 135       (ignore-errors (compressed-string-to-plist decode)))))
 136
 137 (defun plist-to-compressed-string (plist)
 138   "Decode an encoded plist"
 139     (assert (evenp (length plist)))
 140     (do* ((output '())
 141           (list plist (cddr list)))
 142          ((null list)
 143           (prin1-to-string (nreverse output)))
 144       (push (compress-elem (car list)) output)
 145       (push (cadr list) output)))
 146
 147 (defun compress-elem (elem)
 148   "Encode a plist elem"
 149   (case elem
 150     (:page :p)
 151     (:posted :t)
 152     (:object-id :o)
 153     (:session-id :s)
 154     (:lang :l)
 155     (:logged :g)
 156     (:caller :c)
 157
 158     ;; For lookup-func1
 159     (:func :f)
 160     (:format :r)
 161     (:key :k)
 162     (:labels :a)
 163     (:subobjects :b)
 164     (:english-only :e)
 165
 166     (:xml :x)
 167     (:next-page :n)
 168
 169     (otherwise elem)))
 170
 171 (defun compressed-string-to-plist (encoded-str)
 172   (let ((encoded (ignore-errors (read-from-string encoded-str)))
 173         (output '()))
 174     (unless encoded
 175       (cmsg "invalid encoded string")
 176       #+ignore
 177       (gen-invalid-encoded-str encoded-str)
 178       nil)
 179     (assert (evenp (length encoded)))
 180     (do* ((elist encoded (cddr elist)))
 181          ((null elist) (nreverse output))
 182       (push (decompress-elem (car elist)) output)
 183       (push (cadr elist) output))))
 184
 185 (defun decompress-elem (elem)
 186   (case elem
 187     (:N :next-page)
 188     (:T :posted)
 189     (:O :object-id)
 190     (:S :session-id)
 191     (:L :lang)
 192     (:G :logged)
 193     (:C :caller)
 194
 195     ;; For posting to lookup-func1
 196     (:F :func)
 197     (:K :key)
 198     (:B :subobjects)
 199     (:A :labels)
 200     (:E :english-only)
 201     (:R :format)
 202
 203     (:X :xml)
 204     (:P :page)
 205
 206     (otherwise elem)))
 207
 208