src/net/common-parse.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: NETLIB; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Common Parsing Routines to Parse off Header Fields et al
   4 ;;;   Created: 2001-05-16
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: LGPL (See file COPYING for details).
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 2001 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 (in-package :NETLIB)
  30
  31 ;;; Basic parsing
  32
  33 (defun p/if (predicate string start end)
  34   (and (< start end)
  35        (funcall predicate (char string start))
  36        (+ start 1)))
  37
  38 (defun p/expect (c string start end)
  39   (p/if (lambda (d) (char= c d)) string start end))
  40
  41 (defun p/string (match string start end)
  42   (let ((p2 (+ start (length match))))
  43     (and (<= p2 end)
  44          (string= match string :start2 start :end2 p2)
  45          p2)))
  46
  47 (defun p/skip-opt-white-space (string start end)
  48   (do ()
  49       ((or (>= start end)
  50            (not (white-space-p (char string start))))
  51        start)
  52     (incf start)))
  53
  54 ;;; Meta parsers
  55
  56 (defun p/concat (funs string start end)
  57   (let ((res nil))
  58     (dolist (f funs
  59               ;; fall thru return value
  60               (values start (reverse res)))
  61       (setq start (p/skip-opt-white-space string start end))
  62       (multiple-value-bind (new-start semantic) (funcall f string start end)
  63         (unless new-start
  64           (return nil))
  65         (push semantic res)
  66         (setq start new-start) ))))
  67
  68 (defun p/star (fun string start end)
  69   (let ((res nil))
  70     (loop
  71       (setq start (p/skip-opt-white-space string start end))
  72       (multiple-value-bind (new-start semantic) (funcall fun string start end)
  73         (cond (new-start
  74                (push semantic res)
  75                (setf start new-start))
  76               (t
  77                (return)))))
  78     (values
  79      start
  80      (reverse res))))
  81
  82 (defun p/mungle (mungler subfun string start end)
  83   (multiple-value-bind (p v) (funcall subfun string start end)
  84     (when p
  85       (values p (funcall mungler v)))))
  86
  87 (defun p/or (funs string start end)
  88   (dolist (f funs nil)
  89     (multiple-value-bind (new-start sem) (funcall f string start end)
  90       (when new-start
  91         (return (values new-start sem))))))
  92
  93 (defun p/whole (subfun string start end)
  94   (multiple-value-bind (start sem) (funcall subfun string start end)
  95     (when start
  96       (setf start (p/skip-opt-white-space string start end))
  97       (when (= start end)
  98         (values start sem)))))
  99
 100 ;;; Toolbox
 101
 102 (defun p/separated-list (separator sub-parser string start end)
 103   (setf start (p/skip-opt-white-space string start end))
 104   (multiple-value-bind (p2 semantic) (funcall sub-parser string start end)
 105     (cond (p2
 106            (setf p2 (p/skip-opt-white-space string p2 end))
 107            (cond ((and (< p2 end) (char= (char string p2) separator))
 108                   (multiple-value-bind (p3 rest) (p/separated-list separator sub-parser string (+ p2 1) end)
 109                     (if p3
 110                         (values p3 (cons semantic rest))
 111                       (values nil nil))))
 112                  (t
 113                   (values p2 (list semantic)))))
 114           (t
 115            (values nil nil)))))
 116
 117 (defun p/generic-token (initial-predicate more-predicate string start end)
 118   (and (< start end)
 119        (funcall initial-predicate (char string start))
 120        (let ((j (or (position-if-not more-predicate
 121                                      string :start (+ start 1) :end end)
 122                     end)))
 123          (values
 124           j
 125           (subseq string start j)))))
 126
 127 ;;; More special parsers in the context of HTTP
 128
 129 (defvar +token-chars+
 130     "!#$%&'*+-.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`abcdefghijklmnopqrstuvwxyz|~")
 131
 132 (defvar +tspecial+
 133     (concatenate 'string "()<>@,;:\\\"/[]?={}" (string #\space) (string #\tab)))
 134
 135 (defun http-alpha-char-p (c)
 136   (find c "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))
 137
 138 (defun http-digit-char-p (c)
 139   (find c "0123456789"))
 140
 141 (defun http-token-char-p (c)
 142   (find c +token-chars+))
 143
 144 (defun p/token (string start end)
 145   (p/generic-token #'http-token-char-p #'http-token-char-p string start end))
 146
 147 (defun p/quoted-string (string start end)
 148   (let ((p start))
 149     (and (< p end)
 150          (char= (char string p) #\")
 151          (progn
 152            (incf p)
 153            (let ((sem
 154                   (with-output-to-string (bag)
 155                     (loop
 156                       (when (>= p end)
 157                         (return-from p/quoted-string nil))
 158                       (let ((c (char string p)))
 159                         (cond ((char= c #\")
 160                                (incf p)
 161                                (return))
 162                               ((char= c #\\)
 163                                (incf p)
 164                                (if (< p end)
 165                                    (write-char (char string p) bag)
 166                                  (return-from p/quoted-string nil)))
 167                               (t
 168                                (write-char c bag))))
 169                       (incf p)))))
 170              (values p sem))))))
 171
 172 ;;;; HTTP "Link:" header fields
 173
 174 (defun p/http-link-extension (string start end)
 175   ;; link-extension = token [ "=" ( token | quoted-string ) ]
 176   (multiple-value-bind (p2 sem) (p/concat (list #'p/token
 177                                                 (curry #'p/expect #\=)
 178                                                 (curry #'p/or (list #'p/token
 179                                                                     #'p/quoted-string)))
 180                                           string start end)
 181     (and p2 (values p2 (list (first sem) (third sem))))))
 182
 183 (defun p/URI-char-p (c)
 184   (find c "!#$%&'()*+,-./0123456789:;=?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"))
 185
 186 (defun p/URI-string (string start end)
 187   (p/generic-token #'p/URI-char-p #'p/URI-char-p string start end))
 188
 189 (defun parse-http-link-field (string &optional (start 0) (end (length string)))
 190   (multiple-value-bind (start links)
 191       (p/whole
 192        (curry #'p/separated-list #\,
 193               (curry #'p/mungle
 194                      (lambda (x)
 195                        (cons (second x) (fourth x)))
 196                      (curry #'p/concat (list (curry #'p/expect #\<)
 197                                              #'p/URI-string
 198                                              (curry #'p/expect #\>)
 199                                              (curry #'p/star
 200                                                     (curry #'p/mungle
 201                                                            #'second
 202                                                            (curry #'p/concat
 203                                                                   (list (curry #'p/expect #\;)
 204                                                                         #'p/http-link-extension))))))))
 205        string start end)
 206     (when start
 207       (mapcar (lambda (link)
 208                 ;; Since link header fields work like <LINK> elements,
 209                 ;; we build psuedo elements
 210                 (destructuring-bind (href &rest attributes) link
 211                   `(:LINK :HREF ,href
 212                           ,@(mapcan (lambda (attribute)
 213                                       (destructuring-bind (name value) attribute
 214                                         (list (intern (string-upcase name) :keyword)
 215                                               value)))
 216                                     attributes))))
 217               links))))
 218
 219 ;;;;
 220
 221 (defun apply-p (pfun string &rest args)
 222   (apply pfun (append args (list string 0 (length string)))))
 223
 224 ;;;