;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: wol -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: uri.lisp ;;;; Purpose: URI functions for wol ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: July 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file and Wol are Copyright (c) 2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:wol) (defun path->session-id (path ent) "Returns session-id,remainder-path" (let ((prefix (project-prefix (entity-project ent)))) (when (and (> (length path) (length prefix)) (string= prefix (subseq path 0 (length prefix)))) (let ((sans-prefix (subseq path (length prefix)))) (when (char= #\~ (schar sans-prefix 0)) (let* ((len (length sans-prefix)) (next-tilde (position-char #\~ sans-prefix 1 len)) (next-slash (position-char #\/ sans-prefix 1 len))) (when (and next-tilde next-slash (< next-tilde next-slash)) (values (subseq sans-prefix 0 (1+ next-tilde)) (subseq sans-prefix (1+ next-tilde)))))))))) (defun req-recode-uri-sans-session-id (req ent) (multiple-value-bind (raw-session-id remainder) (path->session-id (request-decoded-uri-path req) ent) (when raw-session-id (let ((new-path (concatenate 'string (project-prefix (entity-project ent)) (subseq remainder 1)))) (setf (uri-path (request-uri req)) new-path) (setf (uri-path (request-raw-uri req)) new-path) (setf (request-decoded-uri-path req) new-path)) (raw-session-id->session-id raw-session-id)))) (defun request-cookies (req) (aif (aserve-request req) (net.aserve:get-cookie-values it) (loop for h in (request-headers req) when (eq :cookie (car h)) collect (cdr h)))) (defun header-lines-matching (key headers) (loop for hdr in headers when (eq key (car hdr)) collect (cdr hdr))) (defun set-cookies-in-headers (headers) (header-lines-matching :set-cookie headers)) (defun cookies-in-headers (headers) (header-lines-matching :cookie headers)) (defun cookie-session-key (ent cookies) "Return the session key from the alist of cookies" (let ((name (project-name (entity-project ent)))) (cdr (assoc name cookies :test #'string-equal)))) (defun entity-project-prefix-string (ent) (let ((prefix (project-prefix (entity-project ent)))) (if (= 1 (length prefix)) "" (subseq prefix 1 (1- (length prefix)))))) (defun compute-uris (req ent) "Compute URI's of a request" (let* ((url-session-id (req-recode-uri-sans-session-id req ent)) (uri (request-raw-uri req)) (ppath (puri:uri-parsed-path uri)) (prefix-string (entity-project-prefix-string ent))) (assert (eq (first ppath) :absolute)) (cond ((zerop (length prefix-string)) ;; strip :absolute (setq ppath (cdr ppath))) ((string-equal (second ppath) (entity-project-prefix-string ent)) (setq ppath (cddr ppath))) (t (warn "Non-prefix path ~S" ppath) (return-from compute-uris nil))) (compute-session req ent url-session-id) (multiple-value-bind (page plists) (decode-url ppath) (when page (setf (request-page req) (base-page-name page))) (when plists (setf (request-url-plist req) (car plists)) (setf (request-url-next-plists req) (cdr plists)) (when (null page) (awhen (getf (request-url-plist req) :page) (setf (request-page req) it)))) (setf (request-uri-query req) (puri:uri-query uri))))) ;;; URI Functions (defun base-page-name (page) "Return the base page name for a html url" (string-strip-ending page '(".html" ".lsp"))) (defun split-plist-url (url) (string-delimited-string-to-list url +plist-header+)) (defun is-plist-header (str) (string= +plist-header+ (subseq str 0 +plist-header-length+))) (defun decode-url (ppath) "Decode raw url. Returns (values `.html' list-of-plists query)" (when (is-raw-session-id (car ppath)) (setq ppath (cdr ppath))) (let* ((plists '()) (page-name (unless (is-plist-header (car ppath)) (prog1 (car ppath) (setq ppath (cdr ppath)))))) (dolist (elem ppath) (if (is-plist-header elem) (push (url-string-to-plist (subseq elem +plist-header-length+)) plists) (warn "Non plist header found in url ~S" elem))) (values page-name (nreverse plists)))) (defun make-wol-url (page req ent &optional plist) (let ((session (websession-from-req req)) (url-plist (append (list :page page) plist)) (prefix (project-prefix (entity-project ent)))) (concatenate 'string prefix (if (and session (websession-key session) (not (eq :cookies (websession-method session)))) (format nil "~~~A~~/" (websession-key session)) "") (if (null plist) (concatenate 'string page ".html") (concatenate 'string (concatenate 'string +plist-header+ (plist-to-url-string url-plist))))))) ;; Property lists (defun plist-to-url-string (plist &key (base64 t)) (let ((str (plist-to-compressed-string plist))) (if base64 (string-to-base64-string str :uri t) (encode-uri-string str)))) (defun url-string-to-plist (str &key (base64 t)) (let ((decode (if base64 (base64-string-to-string str :uri t) (decode-uri-string str)))) (when decode (ignore-errors (compressed-string-to-plist decode))))) (defun plist-to-compressed-string (plist) "Decode an encoded plist" (assert (evenp (length plist))) (do* ((output '()) (list plist (cddr list))) ((null list) (prin1-to-string (nreverse output))) (push (compress-elem (car list)) output) (push (cadr list) output))) (defun compress-elem (elem) "Encode a plist elem" (case elem (:page :p) (:posted :t) (:object-id :o) (:session-id :s) (:lang :l) (:logged :g) (:caller :c) (:db :d) ;; For lookup-func1 (:func :f) (:format :r) (:key :k) (:labels :a) (:subobjects :b) (:english-only :e) (:xml :x) (:next-page :n) (otherwise elem))) (defun compressed-string-to-plist (encoded-str) (let ((encoded (ignore-errors (read-from-string encoded-str))) (output '())) (unless encoded (cmsg "invalid encoded string") #+ignore (gen-invalid-encoded-str encoded-str) nil) (assert (evenp (length encoded))) (do* ((elist encoded (cddr elist))) ((null elist) (nreverse output)) (push (decompress-elem (car elist)) output) (push (cadr elist) output)))) (defun decompress-elem (elem) (if (> (length (symbol-name elem)) 1) elem (case (char-upcase (schar (symbol-name elem ) 0)) (#\N :next-page) (#\T :posted) (#\O :object-id) (#\S :session-id) (#\L :lang) (#\G :logged) (#\C :caller) (#\D :db) ;; For posting to lookup-func1 (#\F :func) (#\K :key) (#\B :subobjects) (#\A :labels) (#\E :english-only) (#\R :format) (#\X :xml) (#\P :page) (otherwise elem))))