X-Git-Url: http://git.kpe.io/?p=wol.git;a=blobdiff_plain;f=uri.lisp;h=d86e1281a65c3bb4424cccfad2dd728b6b9c3d61;hp=ba476fed4850c5c79bb80b1b4bf50be744a0f4d7;hb=HEAD;hpb=115593575b49ab252692a959380e94707e385de3 diff --git a/uri.lisp b/uri.lisp index ba476fe..d86e128 100644 --- a/uri.lisp +++ b/uri.lisp @@ -18,37 +18,37 @@ "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)))) + (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)))))))))) + (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) + (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)))) + (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)))) + (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 @@ -69,18 +69,18 @@ (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))) - + (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 @@ -90,19 +90,19 @@ (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))) + (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-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 @@ -121,35 +121,35 @@ (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)))))) + (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))) + (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)))) + (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)) - "") + (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))))))) + (concatenate 'string page ".html") + (concatenate 'string + (concatenate 'string +plist-header+ + (plist-to-url-string url-plist))))))) ;; Property lists @@ -157,13 +157,13 @@ (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) - (uriencode-string str)))) + (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) - (uridecode-string str)))) + (base64-string-to-string str :uri t) + (decode-uri-string str)))) (when decode (ignore-errors (compressed-string-to-plist decode))))) @@ -171,12 +171,12 @@ "Decode an encoded plist" (assert (evenp (length plist))) (do* ((output '()) - (list plist (cddr list))) - ((null list) - (prin1-to-string (nreverse 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" @@ -189,7 +189,7 @@ (:logged :g) (:caller :c) (:db :d) - + ;; For lookup-func1 (:func :f) (:format :r) @@ -197,15 +197,15 @@ (: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 '())) + (output '())) (unless encoded (cmsg "invalid encoded string") #+ignore @@ -213,7 +213,7 @@ nil) (assert (evenp (length encoded))) (do* ((elist encoded (cddr elist))) - ((null elist) (nreverse output)) + ((null elist) (nreverse output)) (push (decompress-elem (car elist)) output) (push (cadr elist) output)))) @@ -229,7 +229,7 @@ (#\G :logged) (#\C :caller) (#\D :db) - + ;; For posting to lookup-func1 (#\F :func) (#\K :key) @@ -237,15 +237,15 @@ (#\A :labels) (#\E :english-only) (#\R :format) - + (#\X :xml) (#\P :page) - + (otherwise elem)))) - +