com.paskvil.uhttp-helpers.lisp

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110

;;; -*- Lisp -*- mode

(in-package #:com.paskvil.uhttp)

(defun http-char (c1 c2 &optional (default #\Space))
  "Function to convert HTTP-encoded character sequence to character."
  (let ((code (parse-integer
               (coerce (list c1 c2) 'string)
               :radix 16
               :junk-allowed t)))
    (if code
        (code-char code)
        default)))

(defun decode-param (s)
  "Function to decode HTTP encoded strings."
  (labels ((f (lst)
             (when lst
               (case (car lst)
                 (#\% (cons (http-char (cadr lst) (caddr lst))
                            (f (cdddr lst))))
                 (#\+ (cons #\Space (f (cdr lst))))
                 (t (cons (car lst) (f (cdr lst))))))))
    (coerce (f (coerce s 'list)) 'string)))

(defun parse-params-from-url (url &optional (offset 0))
  (let ((eqpos (position #\= url :start offset))
        (ampos (position #\& url :start offset)))
    (if ampos
        (if (and eqpos (< eqpos ampos))
            (cons (cons (decode-param (subseq url offset eqpos))
                        (decode-param (subseq url (1+ eqpos) ampos)))
                  (parse-params-from-url url (1+ ampos)))
            (cons (cons (decode-param (subseq url offset ampos)) "")
                  (parse-params-from-url url (1+ ampos))))
        (if eqpos
            (list (cons (decode-param (subseq url offset eqpos))
                        (decode-param (subseq url (1+ eqpos)))))
            (let ((s (subseq url offset)))
              (if (equal s "")
                  nil
                  (list (cons (decode-param s) ""))))))))

(defun parse-url-from-header (str)
  "Parses the URL and all GET parameters from the first
   line of the request header - \"GET /url?params HTTP/x.x\".
   Returns data as (url (param1 . value1) ...); second value
   is GET/POST - type of the request."
  (let ((pos1 (position #\Space str))
        (pos2 (position #\Space str :from-end t)))
    (if (and pos1 pos2 (< (1+ pos1) pos2))
        (let* ((url (subseq str (+ pos1 2) pos2))
               (qpos (position #\? url)))
          (if qpos
              (values (cons (subseq url 0 qpos)
                            (parse-params-from-url url (1+ qpos)))
                      (subseq str 0 pos1))
              (values (list url)
                      (subseq str 0 pos1))))
        (values nil nil))))

(defun parse-header-params (lst)
  "Parses lines 'Info-type: Info', and returns them as array
   of cons'es (\"Info-type\" . \"Info\")."
  (when (and (listp lst) lst (string-not-equal (car lst) ""))
    (let* ((str (car lst))
           (pos (position #\: str))
           (len (length str)))
      (if (and pos (> len (+ pos 2)))    ; skip malformed lines, or no data
          (cons (cons (subseq str 0 pos) (subseq str (+ pos 2)))
                (parse-header-params (cdr lst)))
          (parse-header-params (cdr lst))))))

(defun server-send-header (&key (code 200) (status "OK") (content "text/html"))
  (format t "HTTP/1.1 ~a ~a~%" code status)
  (format t "Server: com.paskvil.uhttp~%")
  (format t "Content-Type: ~a~%~%" content))

(defmacro with-accepted-client ((server url get head post) &body body)
  "Waits for client to connect to the 'server, then binds variables
   passed as 'url to the URL called, 'get to alist of GET parameters,
   and 'head to the alist of the request header parameters.
   You can also use *standard-output* for directly sending response."
  (let ((srvstr (gensym))
        (header-data (gensym))
        (url-data (gensym))
        (req-type (gensym))
        (post-len (gensym))
        (post-type (gensym)))
    `(let* ((,srvstr (server-wait-for-client ,server))
            (*standard-output* (usocket:socket-stream ,srvstr)))
       (unwind-protect
            (progn
              (let* ((,header-data (server-read-all-lines ,srvstr :stop-on ""))
                     (,url-data (multiple-value-list (parse-url-from-header (car ,header-data))))
                     (,url (caar ,url-data))
                     (,get (cdar ,url-data))
                     (,req-type (cadr ,url-data))
                     (,head (parse-header-params (cdr ,header-data)))
                     (,post nil)
                     (,post-len (cdr (assoc "Content-Length" ,head :test #'equal)))
                     (,post-type (cdr (assoc "Content-Type" ,head :test #'equal))))
                (when (and (string-equal ,req-type "POST")
                           ,post-len
                           (< 0 (parse-integer ,post-len :junk-allowed t))
                           ,post-type
                           (string-equal ,post-type "application/x-www-form-urlencoded"))
                  (setf ,post (parse-params-from-url (server-read ,srvstr :max-length ,post-len))))
                ,@body))
         (server-stop ,srvstr)))))