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.5 2003/08/08 09:03:45 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 (puri:uri-path (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 #+ignore
  64 (defun make-html-url (page ent &optional query-args)
  65   (make-url (concatenate 'string page ".html")
  66             :base-dir (project-prefix
  67                        (entity-project ent))
  68             :vars query-args :format :xhtml))
  69
  70
  71 (defun make-wol-url (page ent &optional plist)
  72   (let ((url-plist (append (list :page page) plist))
  73         (prefix (project-prefix (entity-project ent))))
  74     (if (null plist)
  75         (concatenate 'string prefix page ".lsp")
  76       (concatenate 'string
  77         prefix
  78         +asp-header+
  79         (concatenate 'string +plist-header+
  80                      (plist-to-url-string url-plist))))))
  81
  82
  83 ;; Property lists
  84
  85 (defun plist-to-url-string (plist &key (base64 t))
  86   (let ((str (plist-to-compressed-string plist)))
  87     (if base64
  88         (string-to-base64-string str :uri t)
  89         (escape-uri-field str))))
  90
  91 (defun url-string-to-plist (str &key (base64 t))
  92   (let ((decode (if base64
  93                     (base64-string-to-string str :uri t)
  94                     (unescape-uri-field str))))
  95     (when decode
  96       (ignore-errors (compressed-string-to-plist decode)))))
  97
  98 (defun plist-to-compressed-string (plist)
  99   "Decode an encoded plist"
 100     (assert (evenp (length plist)))
 101     (do* ((output '())
 102           (list plist (cddr list)))
 103          ((null list)
 104           (prin1-to-string (nreverse output)))
 105       (push (compress-elem (car list)) output)
 106       (push (cadr list) output)))
 107
 108 (defun compress-elem (elem)
 109   "Encode a plist elem"
 110   (case elem
 111     (:page :p)
 112     (:posted :t)
 113     (:object-id :o)
 114     (:session-id :s)
 115     (:lang :l)
 116     (:logged :g)
 117     (:caller :c)
 118     (:db :d)
 119
 120     ;; For lookup-func1
 121     (:func :f)
 122     (:format :r)
 123     (:key :k)
 124     (:labels :a)
 125     (:subobjects :b)
 126     (:english-only :e)
 127
 128     (:xml :x)
 129     (:next-page :n)
 130
 131     (otherwise elem)))
 132
 133 (defun compressed-string-to-plist (encoded-str)
 134   (let ((encoded (ignore-errors (read-from-string encoded-str)))
 135         (output '()))
 136     (unless encoded
 137       (cmsg "invalid encoded string")
 138       #+ignore
 139       (gen-invalid-encoded-str encoded-str)
 140       nil)
 141     (assert (evenp (length encoded)))
 142     (do* ((elist encoded (cddr elist)))
 143          ((null elist) (nreverse output))
 144       (push (decompress-elem (car elist)) output)
 145       (push (cadr elist) output))))
 146
 147 (defun decompress-elem (elem)
 148   (case elem
 149     (:N :next-page)
 150     (:T :posted)
 151     (:O :object-id)
 152     (:S :session-id)
 153     (:L :lang)
 154     (:G :logged)
 155     (:C :caller)
 156     (:D :db)
 157
 158     ;; For posting to lookup-func1
 159     (:F :func)
 160     (:K :key)
 161     (:B :subobjects)
 162     (:A :labels)
 163     (:E :english-only)
 164     (:R :format)
 165
 166     (:X :xml)
 167     (:P :page)
 168
 169     (otherwise elem)))
 170
 171