/[clhp]/clhp/cgi.lisp
ViewVC logotype

Contents of /clhp/cgi.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (hide annotations)
Thu Nov 13 19:37:41 2003 UTC (10 years, 5 months ago) by aventimiglia
Branch: MAIN
CVS Tags: rel-0-2-1alpha, HEAD
Changes since 1.14: +1 -24 lines
Removed HEADER and INCLUDE functions, because they were not working
properly. mod_clhp generates a simple header. In the future, CLHP will
have to get control of this again, for doing things like setting
cookies and redirections.
1 aventimiglia 1.15 #+cmu (ext:file-comment "$Id: cgi.lisp,v 1.15 2003/11/13 19:37:41 aventimiglia Exp $")
2 aventimiglia 1.1 ;;
3     ;; CLHP the Common Lisp Hypertext Preprocessor
4     ;; (C) 2003 Anthony J Ventimiglia
5     ;;
6     ;; This library is free software; you can redistribute it and/or
7     ;; modify it under the terms of the GNU Lesser General Public
8     ;; License as published by the Free Software Foundation; either
9     ;; version 2.1 of the License, or (at your option) any later version.
10     ;;
11     ;; This library is distributed in the hope that it will be useful,
12     ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14     ;; Lesser General Public License for more details.
15     ;;
16     ;; You should have received a copy of the GNU Lesser General Public
17     ;; License along with this library; if not, write to the Free Software
18     ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19     ;;
20 aventimiglia 1.9 ;; email: aventimiglia@common-lisp.net
21 aventimiglia 1.1 ;; HomePage: http://common-lisp.net/project/clhp/
22    
23 aventimiglia 1.12 (in-package :clhp)
24 aventimiglia 1.1
25     (defmacro debug (expression)
26     "Print out EXPRESSION and the result of (EVAL EXPRESSION)"
27 aventimiglia 1.13 `(format t "(CLHP:DEBUG: ~s --> ~s)~%" ,expression (eval ,expression)))
28 aventimiglia 1.1
29     (defmacro explode-string (string)
30     "Converts a string to a list of chars, this is an aux function used
31     for string processing.
32     ex: (EXPLODE-STRING (\"Hello\") --> (#\H #\e #\l #\l #\o)"
33     `(concatenate 'list ,string))
34    
35     ;; External Symbol section
36    
37 aventimiglia 1.13 (defvar *server-env* (make-hash-table)
38     "This is a hash-table variables passed by the thw key is a keyword
39     and all values are stored as strings.")
40    
41 aventimiglia 1.14 (defvar *query-vars* (make-hash-table :test 'equal)
42 aventimiglia 1.13 "A hash-table of all variables passed through a GET or POST method, the
43     key is a string, and all values are stored in string form.")
44 aventimiglia 1.1
45     ;; This sets the main variables, since the library is already part of the lisp
46     ;; core, we can't use an eval-when, I may eventually make a cgi:init that also
47     ;; prints the header.
48     (defun init ()
49     "Initialize CGI, this should be called before any globals are
50     accessed"
51 aventimiglia 1.13 (mapcar #'(lambda (key/val)
52     (setf (gethash (car key/val) *server-env*)
53     (cdr key/val)))
54     *environment-list*)
55     (mapcar #'(lambda (key/val-list)
56     (setf (gethash (car key/val-list) *query-vars*)
57     (cadr key/val-list)))
58     (cond-bind
59     ((request-method (make-keyword
60     (gethash :REQUEST_METHOD *server-env*))))
61     ((eql request-method :POST)
62     (query-to-a-list (post-data)))
63     ((eql request-method :GET)
64     (query-to-a-list (get-data)))))
65     (values))
66 aventimiglia 1.1
67     ;;
68     ;; End of external symbols
69     ;;
70     ;;;;;;;;;;;;;;;;;;;;;;;;;;
71     ;;
72     ;; Internal symbols follow
73     ;;
74    
75    
76     ;; I know I could have used a regexp library for the string functions, but
77     ;; That would make a dependency and then I'd have to also install that
78     ;; regex lib in the core. I don't need a whole lot of string functions
79     ;; yet, so for now it's simple enough to write the stuff I need
80    
81    
82     ;; ex:
83     ;; (mapcar #'implode-string
84     ;; (split-char-list #\Space
85     ;; (explode-string "In God We Trust" ))) -->
86     ;; ("In" "God" "We" "Trust")
87     (defun split-char-list (char char-list)
88     "Splits a char-list (EXPLODEd string) on CHAR."
89     (labels
90     ((split
91     (char-list split-list)
92 aventimiglia 1.7 (if-bind ((position (position char char-list)))
93     (null position)
94 aventimiglia 1.1 (remove nil (nreverse (cons char-list split-list)))
95     (split (nthcdr (1+ position) char-list)
96     (cons (butlast char-list (- (length char-list) position))
97 aventimiglia 1.7 split-list)))))
98 aventimiglia 1.1 (split char-list nil)))
99    
100     ;; !!!!!!!!! This should most likely be tested and improved , because
101     ;; if the CGI program is given a bogus Content-Length header, this
102 aventimiglia 1.5 ;; will choke -- In other words, it's prone to attacks
103 aventimiglia 1.1 (defun read-n-chars (count &optional (stream *standard-input*))
104     "Reads N chars from STREAM, returning a list of chars. Be careful,
105     there is no check for EOF. This is specifically designed for POST
106     reading, where the exact amount of input data is known."
107     (labels
108     ((rec
109     (count char-list)
110     (if (zerop count)
111     (nreverse char-list)
112     (rec (1- count) (cons (read-char stream) char-list)))))
113     (rec count nil)))
114    
115     (defun get-data ()
116     "Returns GET data (QUERY_STRING) as an exploded string"
117 aventimiglia 1.13 (explode-string (gethash :QUERY_STRING *server-env*)))
118 aventimiglia 1.1
119     ;; The closure makes sure we don't try to read from stdin twice
120     (let ((get-switch nil)
121     (post-char-list nil))
122     (defun post-data ()
123     "Returns POST data as an exploded string"
124     (if (not get-switch)
125     (progn
126     (setf
127     get-switch t
128     post-char-list (read-n-chars
129     (read-from-string
130 aventimiglia 1.13 (gethash :CONTENT_LENGTH *server-env*))))
131 aventimiglia 1.1 post-char-list)
132     post-char-list)))
133 aventimiglia 1.6
134 aventimiglia 1.1 (defun query-to-a-list (get/post-data)
135 aventimiglia 1.6 (list-to-a-list
136     (mapcar #'implode-string
137     (mapcan #'(lambda (c) (split-char-list #\= c))
138     (split-char-list
139     #\& (url-decode-char-list get/post-data))))))
140 aventimiglia 1.1
141     (defun url-decode-char-list (char-list)
142     "Decodes encoded URL chars as per RFC 1738"
143     (handler-bind
144     ((general-error #'handle-general-error))
145     (labels
146     ((decode-error
147     ()
148     (signal 'general-error
149     :message (format nil
150     "~S is a malformed URL encoded string."
151     (implode-string char-list))))
152 aventimiglia 1.7 (decode-next
153     (encoded-part &optional decoded-part)
154     (cond-bind ((front-char (car encoded-part)))
155     ((null encoded-part) (nreverse decoded-part))
156     ((char= #\% front-char)
157     (if (<= 3 (length encoded-part))
158     (decode-next (cdddr encoded-part)
159     (cons (decode-char
160     (subseq encoded-part 1 3))
161     decoded-part))
162     (decode-error)))
163     ((char= #\+ front-char)
164     (decode-next (cdr encoded-part)
165     (cons #\Space decoded-part)))
166     (t (decode-next (cdr encoded-part)
167     (cons front-char decoded-part)))))
168 aventimiglia 1.1 (hex2dec (string-num)
169     (setf *read-base* 16)
170     (prog1
171     (read-from-string string-num)
172     (setf *read-base* 10)))
173     (decode-char (char-code-list)
174 aventimiglia 1.7 (if-bind ((great (car char-code-list))
175     (least (cadr char-code-list)))
176     (and (digit-char-p great 16)
177     (digit-char-p least 16))
178     (code-char (hex2dec
179     (format nil "~a~a" great least)))
180     (decode-error))))
181 aventimiglia 1.1 (decode-next char-list))))
182    
183     (defun implode-string (char-list)
184     "Converts EXPLODEd CHAR-LIST into string, used as an aux function
185     for string processing.
186     ex: (IMPLODE-STRING '(#\H #\e #\l #\l #\o)) --> \"Hello\"
187     (IMPLODE-STRING (EXPLODE-STRING \"Hello\")) --> \"Hello\""
188     (coerce char-list 'string))
189    
190     (define-condition general-error (error)
191     ((message :initarg :message
192     :reader error-message))
193     (:documentation "This is a top level error condition for the CGI Package."))
194    
195     (defun handle-general-error (condition)
196     "A generic error handler function, this will basicall just print a
197     text header, echoing the error-message."
198     (format t "CL-CGI: ~A~%" (error-message condition))
199 aventimiglia 1.13 (quit))
200 aventimiglia 1.1

  ViewVC Help
Powered by ViewVC 1.1.5