-
Notifications
You must be signed in to change notification settings - Fork 0
/
web-server.lisp
68 lines (68 loc) · 2.47 KB
/
web-server.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
(defun http-char (c1 c2 &optional (default #\Space))
(let ((code (parse-integer
(coerce (list c1 c2) 'string)
:radix 16
:junk-allowed t)))
(if code
(code-char code)
default)))
(defun decode-param (s)
(labels ((f (lst)
(when lst
(case (car lst)
(#\% (cons (http-char (cadr lst) (caddr lst))
(f (cdddr lst))))
(#\+ (cons #\space (f (cdr lst))))
(otherwise (cons (car lst) (f (cdr lst))))))))
(coerce (f (coerce s 'list)) 'string)))
(defun parse-params (s)
(let* ((i1 (position #\= s))
(i2 (position #\& s)))
(cond (i1 (cons (cons (intern (string-upcase (subseq s 0 i1)))
(decode-param (subseq s (1+ i1) i2)))
(and i2 (parse-params (subseq s (1+ i2))))))
((equal s "") nil)
(t s))))
(defun parse-url (s)
(let* ((url (subseq s
(+ 2 (position #\space s))
(position #\space s :from-end t)))
(x (position #\? url)))
(if x
(cons (subseq url 0 x) (parse-params (subseq url (1+ x))))
(cons url '()))))
(defun get-header (stream)
(let* ((s (read-line stream))
(h (let ((i (position #\: s)))
(when i
(cons (intern (string-upcase (subseq s 0 i)))
(subseq s (+ i 2)))))))
(when h
(cons h (get-header stream)))))
(defun get-content-params (stream header)
(let ((length (cdr (assoc 'content-length header))))
(when length
(let ((content (make-string (parse-integer length))))
(read-sequence content stream)
(parse-params content)))))
(defun serve (request-handler)
(let ((socket (usocket:socket-listen #(127 0 0 1) 8080 :reuse-address t)))
(unwind-protect
(loop (with-open-stream (stream (usocket:socket-stream (usocket:socket-accept socket)))
(let* ((url (parse-url (read-line stream nil)))
(path (car url))
(header (get-header stream))
(params (append (cdr url)
(get-content-params stream header)))
(*standard-output* stream))
(funcall request-handler path header params))))
(usocket:socket-close socket))))
(defun hello-request-handler (path header params)
(if (equal path "greeting")
(let ((name (assoc 'name params)))
(format t "HTTP/1.1 200 OK~%~%")
(if (not name)
(princ "<html><form>What is your name?<input name='name' />
</form></html>")
(format t "<html>Nice to meet you, ~a!</html>" (cdr name))))
(princ "Sorry... I don't know that page.")))