source: trunk/src/nio-httpd.lisp

Last change on this file was 6, checked in by psmith, 16 years ago

Moved to standard directory structure

File size: 5.1 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  (let ((status-line (make-status-line status))
98        (content-type 
99         (concatenate 'vector 
100                      (string-to-octets "Content-type: ") 
101                      (string-to-octets content-type) #(13 10)))
102        (content-len 
103         (concatenate 'vector 
104                      (string-to-octets "Content-length: ") 
105                      (integer-to-octets (length content)) #(13 10)))
106        )
107
108    (let ((packet (concatenate 'vector status-line content-type content-len #(13 10) content)))
109      (async-write-seq client packet)
110      (close-async-fd client)
111      )))
112
113
114
115(defun page-not-found (client)
116  (serve-content client :not-found "text/html"
117                 (string-to-octets "<html><body><h3>404 Page not found</h3>The requested URL was not found on this server.</body></html>")))
118
119
120(defun method-not-implemented (client)
121  (serve-content client :method-not-implemented "text/html"
122                 (string-to-octets "<html><body><h3>501 Method not implemented</h3>The requested method is not supported by this server.</body></html>")))
123
124(defun http-accept-filter (sequence len)
125  (search #(13 10 13 10) sequence :end2 len))
126
127(defun start ()
128
129  (start-server 
130   #'(lambda (client data)
131
132       (destructuring-bind (req url proto hdrs-start) (http-split-req data)
133         (declare (ignore proto))
134
135         (case req
136
137           (:get 
138            (let ((page (gethash url +page-hash+)))
139
140              (if page
141                  (if (vectorp page)
142                      (serve-content client :ok "text/html" page)
143                      (funcall page :get url data hdrs-start client))
144                 
145                  (page-not-found client))))
146
147           (:head (method-not-implemented client))
148           (:post (method-not-implemented client))
149           (t (method-not-implemented client)))
150       ))
151
152   #'http-accept-filter
153 
154;;   :protocol :inet6   :host "::1"
155
156   :host "127.0.0.1"
157   ))
158   
Note: See TracBrowser for help on using the repository browser.