source: branches/home/psmith/restructure/src/old/nio-httpd.lisp

Last change on this file was 14, checked in by psmith, 18 years ago

Part way thru doing a major restructure primarily to abstract the protocols from the IO layer. Moving more towards event driven SM approach. Lots more todo...

File size: 5.2 KB
Line 
1#|
2Copyright (c) 2006 Risto Laakso
3All rights reserved.
4
5Redistribution and use in source and binary forms, with or without
6modification, are permitted provided that the following conditions
7are met:
81. Redistributions of source code must retain the above copyright
9   notice, this list of conditions and the following disclaimer.
102. 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.
133. 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
16THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
17IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
18OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
19IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
20INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
22DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
24(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
25THIS 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   
Note: See TracBrowser for help on using the repository browser.