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.7 2003/08/09 21:42:24 kevin Exp $
  11 ;;;;
  12 ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package #:wol)
  16
  17 (defun req-recode-uri-sans-session-id (req)
  18   (setq cl-user::r req)
  19   (let ((ppath (puri:uri-parsed-path (request-uri req))))
  20     (when (is-raw-session-id (second ppath))
  21       (let ((new-path (list* (car ppath) (cddr ppath))))
  22         (setf (uri-parsed-path (request-uri req)) new-path)
  23         (setf (uri-parsed-path (request-raw-uri req)) new-path))
  24       (setf (request-decoded-uri-path req)
  25         (uridecode-string (uri-path (request-raw-uri req))))
  26       (raw-session-id->session-id (second ppath)))))
  27
  28 (defun request-cookies (req)
  29   (aif (aserve-request req)
  30        (net.aserve:get-cookie-values it)
  31        (loop for h in (request-headers req)
  32            when (eq :cookie (car h))
  33            collect (cdr h))))
  34
  35 (defun cookie-session-key (ent cookies)
  36   (let ((name (project-name (entity-project ent))))
  37     (cdr (assoc name cookies :test #'string-equal))))
  38
  39 (defun compute-uris (req ent)
  40   "Compute URI's of a request"
  41   (let ((url-session-id (req-recode-uri-sans-session-id req)))
  42     (compute-session req ent url-session-id)
  43
  44     (multiple-value-bind (page plists query)
  45         (decode-url (puri:uri-path (request-raw-uri req)))
  46       (when page
  47         (setf (request-page req) (base-page-name page ent)))
  48       (when plists
  49         (setf (request-plist req) (car plists))
  50         (setf (request-next-plists req) (cdr plists))
  51         (when (null page)
  52           (awhen (getf (request-plist req) :page)
  53                  (setf (request-page req) it))))
  54       (setf (request-uri-query req) query))))
  55
  56
  57 ;;; URI Functions
  58
  59 (defun base-page-name (page ent)
  60   "Return the base page name for a html url"
  61   (let ((len-prefix (length (project-prefix (entity-project ent)))))
  62     (assert (>= (length page) len-prefix))
  63     (string-strip-ending (subseq page len-prefix)
  64                          '(".html" ".lsp"))))
  65
  66 (defun split-plist-url (url)
  67   (string-delimited-string-to-list url +plist-header+))
  68
  69 (defun decode-url (url)
  70   "Decode raw url. Returns (values `<pagename>.html' list-of-plists query)"
  71   (let* ((plists '())
  72          (qsplit (delimited-string-to-list url #\?))
  73          (query (cadr qsplit))
  74          (split (split-plist-url (car qsplit)))
  75          (page-name
  76           (when (and (plusp (length (car split)))
  77                      (not (string= +full-asp-header+ (car split)))
  78                      (not (string-starts-with +full-asp-header+ (car split))))
  79             (car split))))
  80     (dolist (elem (cdr split))
  81       (push (url-string-to-plist elem) plists))
  82     (values page-name (nreverse plists) query)))
  83
  84
  85
  86 (defun make-wol-url (page req ent &optional plist)
  87   (let ((session (websession-from-req req))
  88         (url-plist (append (list :page page) plist))
  89         (prefix (project-prefix (entity-project ent))))
  90     (concatenate 'string
  91       prefix
  92       (if (and session
  93                  (websession-key session)
  94                  (not (eq :cookies (websession-method session))))
  95           (format nil "~~~A~~/" (websession-key session))
  96         "")
  97       (if (null plist)
  98         (concatenate 'string page ".html")
  99         (concatenate 'string
 100           +asp-header+
 101           (concatenate 'string +plist-header+
 102                        (plist-to-url-string url-plist)))))))
 103
 104
 105 ;; Property lists
 106
 107 (defun plist-to-url-string (plist &key (base64 t))
 108   (let ((str (plist-to-compressed-string plist)))
 109     (if base64
 110         (string-to-base64-string str :uri t)
 111         (uriencode-string str))))
 112
 113 (defun url-string-to-plist (str &key (base64 t))
 114   (let ((decode (if base64
 115                     (base64-string-to-string str :uri t)
 116                     (uridecode-string str))))
 117     (when decode
 118       (ignore-errors (compressed-string-to-plist decode)))))
 119
 120 (defun plist-to-compressed-string (plist)
 121   "Decode an encoded plist"
 122     (assert (evenp (length plist)))
 123     (do* ((output '())
 124           (list plist (cddr list)))
 125          ((null list)
 126           (prin1-to-string (nreverse output)))
 127       (push (compress-elem (car list)) output)
 128       (push (cadr list) output)))
 129
 130 (defun compress-elem (elem)
 131   "Encode a plist elem"
 132   (case elem
 133     (:page :p)
 134     (:posted :t)
 135     (:object-id :o)
 136     (:session-id :s)
 137     (:lang :l)
 138     (:logged :g)
 139     (:caller :c)
 140     (:db :d)
 141
 142     ;; For lookup-func1
 143     (:func :f)
 144     (:format :r)
 145     (:key :k)
 146     (:labels :a)
 147     (:subobjects :b)
 148     (:english-only :e)
 149
 150     (:xml :x)
 151     (:next-page :n)
 152
 153     (otherwise elem)))
 154
 155 (defun compressed-string-to-plist (encoded-str)
 156   (let ((encoded (ignore-errors (read-from-string encoded-str)))
 157         (output '()))
 158     (unless encoded
 159       (cmsg "invalid encoded string")
 160       #+ignore
 161       (gen-invalid-encoded-str encoded-str)
 162       nil)
 163     (assert (evenp (length encoded)))
 164     (do* ((elist encoded (cddr elist)))
 165          ((null elist) (nreverse output))
 166       (push (decompress-elem (car elist)) output)
 167       (push (cadr elist) output))))
 168
 169 (defun decompress-elem (elem)
 170   (case elem
 171     (:N :next-page)
 172     (:T :posted)
 173     (:O :object-id)
 174     (:S :session-id)
 175     (:L :lang)
 176     (:G :logged)
 177     (:C :caller)
 178     (:D :db)
 179
 180     ;; For posting to lookup-func1
 181     (:F :func)
 182     (:K :key)
 183     (:B :subobjects)
 184     (:A :labels)
 185     (:E :english-only)
 186     (:R :format)
 187
 188     (:X :xml)
 189     (:P :page)
 190
 191     (otherwise elem)))
 192
 193