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