diff --git a/CLASH.system b/CLASH.system index 8783a58..a5d6ae8 100644 --- a/CLASH.system +++ b/CLASH.system @@ -28,7 +28,9 @@ #+CMU (:file "cmu-locking" :depends-on ("package")) #+LISPWORKS4.1 - (:file "lwl-locking" :depends-on ("package")))) + (:file "lwl-locking" :depends-on ("package")) + #+ALLEGRO + (:file "acl-locking" :depends-on ("package")))) (:module "main" :source-pathname "main" :components ((:file "status-codes") @@ -66,6 +68,8 @@ :depends-on ("messages" "entity" "server")) (:file "session" :depends-on ("resource" "entity" "messages")) + (:file "authorization" + :depends-on ("resource" "messages")) (:file "logging" :depends-on ("messages" "entity" "server")) (:file "readtable" @@ -78,5 +82,7 @@ :components (#+CMU (:file "simple-cmu") #+LISPWORKS4.1 - (:file "simple-lwl")) + (:file "simple-lwl") + #+ALLEGRO + (:file "simple-acl")) :depends-on ("base" "main")))) diff --git a/src/acl-locking.cl b/src/acl-locking.cl new file mode 100644 index 0000000..5127163 --- /dev/null +++ b/src/acl-locking.cl @@ -0,0 +1,24 @@ +;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; acl-locking.cl --- Platform independent locking primitives +;;;; +;;;; Checkout Tag: $Name$ +;;;; $Id$ + +(in-package :CLASH) + +;;;; %File Description: +;;;; +;;;; +;;;; + +;;; Locking primitives for ACL + +(defmacro pop-atomically (place) + `(mp:without-scheduling + (pop ,place))) + +(defmacro push-atomically (value place) + `(mp:without-scheduling + (push ,value ,place))) diff --git a/src/drivers/simple-acl.cl b/src/drivers/simple-acl.cl new file mode 100644 index 0000000..f870ea9 --- /dev/null +++ b/src/drivers/simple-acl.cl @@ -0,0 +1,54 @@ +;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server +;;;; This is copyrighted software. See documentation for terms. +;;;; +;;;; simple-acl.cl --- Simple driver for Allegro Common Lisp +;;;; +;;;; Checkout Tag: $Name$ +;;;; $Id$ + +(in-package :CLASH) + +;;;; %File Description: +;;;; +;;;; +;;;; + +(defclass acl-connection (connection) + ((stream :initarg :stream :reader connection-stream))) + +(defmethod connection-address ((connection acl-connection)) + (socket:remote-host (connection-stream connection))) + +(defmethod connection-hostname ((connection acl-connection)) + (socket:ipaddr-to-hostname (connection-address connection))) + +(defmethod close-connection ((connection acl-connection)) + (ignore-errors + (let ((stream (connection-stream connection))) + (finish-output stream) + (close stream)))) + +(defun start-http-handler (stream server) + (let ((connection (make-instance 'acl-connection :stream stream))) + (mp:process-run-function (format nil "HTTP connection from ~A" + (connection-address connection)) + #'serve-connection + server connection))) + +(defun http-listener (socket server) + (loop + (start-http-handler (socket:accept-connection socket) server))) + +(defun start-http-listener (port server) + (let ((socket (socket:make-socket :type :stream :format :text + :address-family :internet + :connect :passive + :local-port port))) + (mp:process-run-function (format nil + "HTTP connection listener for port ~D" + port) + #'http-listener + socket server))) + +(defun initialize-clash () + t) diff --git a/src/main/parsing.cl b/src/main/parsing.cl index d5ec040..6d063da 100644 --- a/src/main/parsing.cl +++ b/src/main/parsing.cl @@ -14,6 +14,8 @@ ;;;; with HTTP component constructs, based on the HTTP grammar. ;;;; +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +HTTP-LWS-Character-Bag+ '(#\Space #\Tab) "HTTP LWS characters.") @@ -26,6 +28,8 @@ (defconstant +HTTP-Pair-Delimiter+ #\= "HTTP key-value pair delimiter character.") +) + (defun char-lws-p (char) (declare (type character char)) (member char +HTTP-LWS-Character-Bag+ :test #'char=))