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