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 | (in-package :nio-http) |
---|
28 | |
---|
29 | |
---|
30 | ;TODO move to utils |
---|
31 | |
---|
32 | (defun string-to-octets (string) |
---|
33 | (map 'vector #'char-code string)) |
---|
34 | |
---|
35 | |
---|
36 | (defun integer-to-octets (int) |
---|
37 | (if (= int 0) |
---|
38 | #(48) |
---|
39 | (let* ((digits (floor (1+ (log int 10)))) |
---|
40 | (seq (make-sequence '(vector (unsigned-byte 8)) digits :initial-element 0)) |
---|
41 | (rem int)) |
---|
42 | (loop for idx from 0 below digits do |
---|
43 | (multiple-value-bind (rest last) (truncate rem 10) |
---|
44 | (setf (aref seq idx) (+ #.(char-code #\0) last) |
---|
45 | rem rest))) |
---|
46 | (nreverse seq)))) |
---|
47 | |
---|
48 | (defun file-to-octets (filename) |
---|
49 | (with-open-file (stream filename :direction :input :element-type 'unsigned-byte) |
---|
50 | (let* ((length (file-length stream)) |
---|
51 | (seq (make-sequence '(vector (unsigned-byte 8)) length :initial-element 0))) |
---|
52 | (read-sequence seq stream) |
---|
53 | seq))) |
---|
54 | |
---|
55 | ;end utils |
---|
56 | |
---|
57 | ;TODO move to web-server |
---|
58 | (defparameter +page-hash+ (make-hash-table :test #'equalp)) |
---|
59 | |
---|
60 | ;end |
---|
61 | |
---|
62 | (defclass http-response (packet) |
---|
63 | ((status :initarg :status) |
---|
64 | (html :initarg :html)) |
---|
65 | ) |
---|
66 | |
---|
67 | (defun http-response (&key status html) |
---|
68 | (make-instance 'http-response :status status :html html)) |
---|
69 | |
---|
70 | (defmethod get-bytes ((http-response http-response)) |
---|
71 | (with-slots (status html) http-response |
---|
72 | (get-packet status "text/html" html))) |
---|
73 | |
---|
74 | |
---|
75 | |
---|
76 | (defparameter +status-lines+ |
---|
77 | (list (cons :ok |
---|
78 | (concatenate 'vector (string-to-octets "HTTP/1.0 200 OK") #(13 10))) |
---|
79 | (cons :not-found |
---|
80 | (concatenate 'vector (string-to-octets "HTTP/1.0 404 Not found") #(13 10))) |
---|
81 | (cons :method-not-implemented |
---|
82 | (concatenate 'vector (string-to-octets "HTTP/1.0 501 Method not implemented") #(13 10))) |
---|
83 | )) |
---|
84 | |
---|
85 | (defun make-status-line (status) |
---|
86 | (cdr (assoc status +status-lines+))) |
---|
87 | |
---|
88 | |
---|
89 | (defun get-packet (status content-type html) |
---|
90 | #+nio-debug (format t "serve-content ~%") |
---|
91 | (let* ((content (string-to-octets html)) |
---|
92 | (status-line (make-status-line status)) |
---|
93 | (content-type |
---|
94 | (concatenate 'vector |
---|
95 | (string-to-octets "Content-type: ") |
---|
96 | (string-to-octets content-type) #(13 10))) |
---|
97 | (content-len |
---|
98 | (concatenate 'vector |
---|
99 | (string-to-octets "Content-length: ") |
---|
100 | (integer-to-octets (length content)) #(13 10))) |
---|
101 | ) |
---|
102 | (concatenate 'vector status-line content-type content-len #(13 10) content))) |
---|
103 | |
---|