-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathweb-server.lisp
86 lines (78 loc) · 3.45 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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
;; Only works in CLisp; need to find different socket library for others
;; like SBCL.
(defun http-char (first-character second-character &optional (default #\Space))
(let ((code (parse-integer
(coerce (list first-character second-character) 'string)
:radix 16
:junk-allowed t)))
(if code
(code-char code)
default)))
(defun decode-parameters (input-string)
(labels ((f (list)
(when list
(case (car list)
(#\% (cons (http-char (cadr list) (caddr list))
(f (cdddr list))))
(#\+ (cons #\space (f (cdr list))))
(otherwise (cons (car list) (f (cdr list))))))))
(coerce (f (coerce input-string 'list)) 'string)))
(defun parse-parameters (input-string)
(let ((first-index (position #\= input-string))
(second-index (position #\& input-string)))
(cond
(first-index
(cons (cons (intern
(string-upcase (subseq input-string 0 first-index)))
(decode-parameters
(subseq input-string (1+ first-index) second-index)))
(and second-index
(parse-parameters
(subseq input-string (1+ second-index))))))
((equal input-string "") nil)
(t input-string))))
(defun parse-url (input-string)
(let* ((url (subseq input-string
(+ 2 (position #\space input-string))
(position #\space input-string :from-end t)))
(query-position (position #\? url)))
(if query-position
(cons (subseq url 0 query-position)
(parse-parameters (subseq url (1+ query-position))))
(cons url '()))))
(defun get-header (stream)
(let* ((input-string (read-line stream))
(header (let ((index (position #\: input-string)))
(when index
(cons (intern (string-upcase (subseq input-string 0 index)))
(subseq input-string (+ index 2)))))))
(when header
(cons header (get-header stream)))))
(defun get-content-parameters (stream header)
(let ((length (cdr (assoc 'content-length header))))
(when length
(let ((content (make-string (parse-integer length))))
(read-sequence content stream)
(parse-parameters content)))))
(defun serve (request-handler &optional (listen-port 4321))
(let ((socket (socket-server listen-port)))
(unwind-protect
(loop (with-open-stream (stream (socket-accept socket))
(let* ((url (parse-url (read-line stream)))
(path (car url))
(header (get-header stream))
(parameters
(append (cdr url)
(get-content-parameters stream header)))
(*standard-output* stream))
(funcall request-handler path header parameters))))
(socket-server-close socket))))
(defun hello-request-handler (path header parameters)
(if (equal path "greeting")
(let ((name (assoc 'name parameters)))
(format t "HTTP/1.1 200 OK")
(format t "Content-type: text/html; charset=UTF-8~%~%")
(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.")))