001 ;;; -*- Lisp -*- mode
002 
003 (in-package #:com.paskvil.uhttp)
004 
005 (defun http-char (c1 c2 &optional (default #\Space))
006   "Function to convert HTTP-encoded character sequence to character."
007   (let ((code (parse-integer
008                (coerce (list c1 c2) 'string)
009                :radix 16
010                :junk-allowed t)))
011     (if code
012         (code-char code)
013         default)))
014 
015 (defun decode-param (s)
016   "Function to decode HTTP encoded strings."
017   (labels ((f (lst)
018              (when lst
019                (case (car lst)
020                  (#\% (cons (http-char (cadr lst) (caddr lst))
021                             (f (cdddr lst))))
022                  (#\+ (cons #\Space (f (cdr lst))))
023                  (t (cons (car lst) (f (cdr lst))))))))
024     (coerce (f (coerce s 'list)) 'string)))
025 
026 (defun parse-params-from-url (url &optional (offset 0))
027   (let ((eqpos (position #\= url :start offset))
028         (ampos (position #\& url :start offset)))
029     (if ampos
030         (if (and eqpos (< eqpos ampos))
031             (cons (cons (decode-param (subseq url offset eqpos))
032                         (decode-param (subseq url (1+ eqpos) ampos)))
033                   (parse-params-from-url url (1+ ampos)))
034             (cons (cons (decode-param (subseq url offset ampos)) "")
035                   (parse-params-from-url url (1+ ampos))))
036         (if eqpos
037             (list (cons (decode-param (subseq url offset eqpos))
038                         (decode-param (subseq url (1+ eqpos)))))
039             (let ((s (subseq url offset)))
040               (if (equal s "")
041                   nil
042                   (list (cons (decode-param s) ""))))))))
043 
044 (defun parse-url-from-header (str)
045   "Parses the URL and all GET parameters from the first
046    line of the request header - \"GET /url?params HTTP/x.x\".
047    Returns data as (url (param1 . value1) ...); second value
048    is GET/POST - type of the request."
049   (let ((pos1 (position #\Space str))
050         (pos2 (position #\Space str :from-end t)))
051     (if (and pos1 pos2 (< (1+ pos1) pos2))
052         (let* ((url (subseq str (+ pos1 2) pos2))
053                (qpos (position #\? url)))
054           (if qpos
055               (values (cons (subseq url 0 qpos)
056                             (parse-params-from-url url (1+ qpos)))
057                       (subseq str 0 pos1))
058               (values (list url)
059                       (subseq str 0 pos1))))
060         (values nil nil))))
061 
062 (defun parse-header-params (lst)
063   "Parses lines 'Info-type: Info', and returns them as array
064    of cons'es (\"Info-type\" . \"Info\")."
065   (when (and (listp lst) lst (string-not-equal (car lst) ""))
066     (let* ((str (car lst))
067            (pos (position #\: str))
068            (len (length str)))
069       (if (and pos (> len (+ pos 2)))    ; skip malformed lines, or no data
070           (cons (cons (subseq str 0 pos) (subseq str (+ pos 2)))
071                 (parse-header-params (cdr lst)))
072           (parse-header-params (cdr lst))))))
073 
074 (defun server-send-header (&key (code 200) (status "OK") (content "text/html"))
075   (format t "HTTP/1.1 ~a ~a~%" code status)
076   (format t "Server: com.paskvil.uhttp~%")
077   (format t "Content-Type: ~a~%~%" content))
078 
079 (defmacro with-accepted-client ((server url get head post) &body body)
080   "Waits for client to connect to the 'server, then binds variables
081    passed as 'url to the URL called, 'get to alist of GET parameters,
082    and 'head to the alist of the request header parameters.
083    You can also use *standard-output* for directly sending response."
084   (let ((srvstr (gensym))
085         (header-data (gensym))
086         (url-data (gensym))
087         (req-type (gensym))
088         (post-len (gensym))
089         (post-type (gensym)))
090     `(let* ((,srvstr (server-wait-for-client ,server))
091             (*standard-output* (usocket:socket-stream ,srvstr)))
092        (unwind-protect
093             (progn
094               (let* ((,header-data (server-read-all-lines ,srvstr :stop-on ""))
095                      (,url-data (multiple-value-list (parse-url-from-header (car ,header-data))))
096                      (,url (caar ,url-data))
097                      (,get (cdar ,url-data))
098                      (,req-type (cadr ,url-data))
099                      (,head (parse-header-params (cdr ,header-data)))
100                      (,post nil)
101                      (,post-len (cdr (assoc "Content-Length" ,head :test #'equal)))
102                      (,post-type (cdr (assoc "Content-Type" ,head :test #'equal))))
103                 (when (and (string-equal ,req-type "POST")
104                            ,post-len
105                            (< 0 (parse-integer ,post-len :junk-allowed t))
106                            ,post-type
107                            (string-equal ,post-type "application/x-www-form-urlencoded"))
108                   (setf ,post (parse-params-from-url (server-read ,srvstr :max-length ,post-len))))
109                 ,@body))
110          (server-stop ,srvstr)))))
111