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