1 | #| |
---|
2 | Copyright (c) 2006 Risto Laakso |
---|
3 | All rights reserved. |
---|
4 | |
---|
5 | Redistribution and use in source and binary forms, with or without |
---|
6 | modification, are permitted provided that the following conditions |
---|
7 | are met: |
---|
8 | 1. Redistributions of source code must retain the above copyright |
---|
9 | notice, this list of conditions and the following disclaimer. |
---|
10 | 2. Redistributions in binary form must reproduce the above copyright |
---|
11 | notice, this list of conditions and the following disclaimer in the |
---|
12 | documentation and/or other materials provided with the distribution. |
---|
13 | 3. The name of the author may not be used to endorse or promote products |
---|
14 | derived from this software without specific prior written permission. |
---|
15 | |
---|
16 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR |
---|
17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES |
---|
18 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. |
---|
19 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, |
---|
20 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT |
---|
21 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, |
---|
22 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
---|
23 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
---|
24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF |
---|
25 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
26 | |# |
---|
27 | (defpackage :nio-httpd (:use :cl :nio-server :nio) |
---|
28 | (:export start)) |
---|
29 | (in-package :nio-httpd) |
---|
30 | |
---|
31 | (defun method-sig (method) |
---|
32 | (logior (ash (logand (aref method 0) #xDF) 24) |
---|
33 | (ash (logand (aref method 1) #xDF) 16) |
---|
34 | (ash (logand (aref method 2) #xDF) 8) |
---|
35 | (ash (logand (aref method 3) #xDF) 0))) |
---|
36 | |
---|
37 | (defun map-method (method) |
---|
38 | (case (method-sig method) |
---|
39 | (#x47455400 :get) |
---|
40 | (#x504F5354 :post) |
---|
41 | (#x48454144 :head) |
---|
42 | (t :unknown))) |
---|
43 | |
---|
44 | (defun http-split-req (data) |
---|
45 | (let* ((line-end (position 13 data)) |
---|
46 | (line (subseq data 0 line-end)) |
---|
47 | (sp1 (position #.(char-code #\space) line)) |
---|
48 | (sp2 (position #.(char-code #\space) line :start (1+ sp1))) |
---|
49 | (req (subseq line 0 (1+ sp1))) |
---|
50 | (url (subseq line (1+ sp1) sp2)) |
---|
51 | (proto (subseq line (1+ sp2)))) |
---|
52 | |
---|
53 | (list (map-method req) |
---|
54 | url |
---|
55 | proto |
---|
56 | (+ line-end 2)))) |
---|
57 | |
---|
58 | (defun string-to-octets (string) |
---|
59 | (map 'vector #'char-code string)) |
---|
60 | |
---|
61 | (defparameter +status-lines+ |
---|
62 | (list (cons :ok |
---|
63 | (concatenate 'vector (string-to-octets "HTTP/1.0 200 OK") #(13 10))) |
---|
64 | (cons :not-found |
---|
65 | (concatenate 'vector (string-to-octets "HTTP/1.0 404 Not found") #(13 10))) |
---|
66 | (cons :method-not-implemented |
---|
67 | (concatenate 'vector (string-to-octets "HTTP/1.0 501 Method not implemented") #(13 10))) |
---|
68 | )) |
---|
69 | |
---|
70 | (defun make-status-line (status) |
---|
71 | (cdr (assoc status +status-lines+))) |
---|
72 | |
---|
73 | (defparameter +page-hash+ (make-hash-table :test #'equalp)) |
---|
74 | |
---|
75 | |
---|
76 | (defun integer-to-octets (int) |
---|
77 | (if (= int 0) |
---|
78 | #(48) |
---|
79 | (let* ((digits (floor (1+ (log int 10)))) |
---|
80 | (seq (make-sequence '(vector (unsigned-byte 8)) digits :initial-element 0)) |
---|
81 | (rem int)) |
---|
82 | (loop for idx from 0 below digits do |
---|
83 | (multiple-value-bind (rest last) (truncate rem 10) |
---|
84 | (setf (aref seq idx) (+ #.(char-code #\0) last) |
---|
85 | rem rest))) |
---|
86 | (nreverse seq)))) |
---|
87 | |
---|
88 | (defun file-to-octets (filename) |
---|
89 | (with-open-file (stream filename :direction :input :element-type 'unsigned-byte) |
---|
90 | (let* ((length (file-length stream)) |
---|
91 | (seq (make-sequence '(vector (unsigned-byte 8)) length :initial-element 0))) |
---|
92 | (read-sequence seq stream) |
---|
93 | seq))) |
---|
94 | |
---|
95 | |
---|
96 | (defun serve-content (client status content-type content) |
---|
97 | #+nio-debug (format t "serve-content :client ~A~%" client) |
---|
98 | (let ((status-line (make-status-line status)) |
---|
99 | (content-type |
---|
100 | (concatenate 'vector |
---|
101 | (string-to-octets "Content-type: ") |
---|
102 | (string-to-octets content-type) #(13 10))) |
---|
103 | (content-len |
---|
104 | (concatenate 'vector |
---|
105 | (string-to-octets "Content-length: ") |
---|
106 | (integer-to-octets (length content)) #(13 10))) |
---|
107 | ) |
---|
108 | |
---|
109 | (let ((packet (concatenate 'vector status-line content-type content-len #(13 10) content))) |
---|
110 | (async-write-seq client packet) |
---|
111 | (close-async-fd client) |
---|
112 | ))) |
---|
113 | |
---|
114 | |
---|
115 | |
---|
116 | (defun page-not-found (client) |
---|
117 | (serve-content client :not-found "text/html" |
---|
118 | (string-to-octets "<html><body><h3>404 Page not found</h3>The requested URL was not found on this server.</body></html>"))) |
---|
119 | |
---|
120 | |
---|
121 | (defun method-not-implemented (client) |
---|
122 | (serve-content client :method-not-implemented "text/html" |
---|
123 | (string-to-octets "<html><body><h3>501 Method not implemented</h3>The requested method is not supported by this server.</body></html>"))) |
---|
124 | |
---|
125 | (defun http-accept-filter (sequence len) |
---|
126 | (search #(13 10 13 10) sequence :end2 len)) |
---|
127 | |
---|
128 | (defun start () |
---|
129 | |
---|
130 | (start-server |
---|
131 | #'(lambda (client data) |
---|
132 | |
---|
133 | (destructuring-bind (req url proto hdrs-start) (http-split-req data) |
---|
134 | (declare (ignore proto)) |
---|
135 | |
---|
136 | (case req |
---|
137 | |
---|
138 | (:get |
---|
139 | (let ((page (gethash url +page-hash+))) |
---|
140 | |
---|
141 | (if page |
---|
142 | (if (vectorp page) |
---|
143 | (serve-content client :ok "text/html" page) |
---|
144 | (funcall page :get url data hdrs-start client)) |
---|
145 | |
---|
146 | (page-not-found client)))) |
---|
147 | |
---|
148 | (:head (method-not-implemented client)) |
---|
149 | (:post (method-not-implemented client)) |
---|
150 | (t (method-not-implemented client))) |
---|
151 | )) |
---|
152 | |
---|
153 | #'http-accept-filter |
---|
154 | |
---|
155 | ;; :protocol :inet6 :host "::1" |
---|
156 | |
---|
157 | :host "127.0.0.1" |
---|
158 | )) |
---|
159 | |
---|