initial commit

3 files changed, 266 insertions, 0 deletions

diff --git a/lazybones.asd b/lazybones.asd
new file mode 100644
index 0000000..1a63d11
--- /dev/null
+++ b/lazybones.asd
@@ -0,0 +1,11 @@
+;;;; lazybones.asd
+
+(asdf:defsystem #:lazybones
+  :description "Describe lazybones here"
+  :author "Your Name <your.name@example.com>"
+  :license  "Specify license here"
+  :version "0.0.1"
+  :serial t
+  :depends-on (#:clack #:jonathan #:iterate #:alexandria #:split-sequence)
+  :components ((:file "package")
+               (:file "lazybones")))
diff --git a/lazybones.lisp b/lazybones.lisp
new file mode 100644
index 0000000..feee92a
--- /dev/null
+++ b/lazybones.lisp
@@ -0,0 +1,237 @@
+;;;; lazybones.lisp
+
+(in-package #:lazybones)
+
+(defvar *handler* nil
+  "Clack handler top-level handler.")
+
+(defvar *routes* nil
+  "Datastructure tha tmaps routes to route handlers.")
+
+(defvar *req* nil
+  "A PLIST that bound by and available to route handlers.")
+
+(defvar *body* nil
+  "Holds body of a request, decoded according to known decoders. 
+
+If no known decoder matches, holds a stream. 
+
+Bound by route handlers for POST, PUT, and PATCH requests.")
+
+(defvar *resp-headers* nil
+  "A PLIST bound at the beginning of every response. Can be used to
+  add additional headers to responses valid responses.")
+
+(defvar *decoders* nil
+  "An ALIST holding (mimetype . decoder) pairs. Add a decoder to this
+  to customize decoding of POST and PUT bodies.")
+
+(defun add-header (key val)
+  "Adds a header to the response headers. Can be used within a handler
+definition."
+  (setf (getf *resp-headers* key) val))
+
+
+(defun read-body-to-string (stream content-length)
+  "Reads CONTENT-LENGTH characters from STREAM and returns a string."
+  (let ((string (make-string content-length)))
+    (read-sequence string stream)
+    string))
+
+
+(defun decode-json-body (stream len)
+  "Reads LEN characters from stream and decodes them as JSON, returning a PLIST"
+  (jonathan:parse (read-body-to-string stream len)))
+
+
+(defun add-decoder (mimetype decoder)
+  "Adds or replaces a DECODER function for supplied MIMETYPE"
+  (if-let ((decoder-pair (assoc mimetype *decoders* :test #'string-equal)))
+    (setf (cdr decoder-pair) decoder)
+    (push (cons mimetype decoder)
+          *decoders*)))
+
+(add-decoder "application/json" #'decode-json-body)
+
+
+(defun decode-body (stream content-type content-length)
+  "Decodes the body according to the Content-Type header.
+
+If no matching decoder is found in the *DECODERS* ALIST, then the 
+STREAM itself is returned unaltered.
+"
+  (if-let ((decoder (assoc content-type *decoders* :test #'string-equal)))
+    (funcall (cdr decoder) stream  content-length)
+    stream))
+
+
+(defun content-length (content)
+  "Utility for determining the Content-Length header for response bodies."
+  (cond ((consp content)
+         (reduce #'+ (mapcar #'length content)))
+        (t (length content))))
+
+
+(defun http-ok (content-type &rest content)
+  "Utility function for creating an 200 HTTP response. 
+
+CONTENT-TYPE is a string, a mimetype.
+
+CONTENT is a list of strings. It can be other stuff but CLACK has
+abysmal documentation."
+  (list 200
+        (list* :content-type content-type
+               :content-length (content-length content)
+               *resp-headers*)
+        content))
+
+
+(defun http-err (code text)
+  (let ((resp (format nil "~a ~a" code text)))
+    (list code
+          (list :content-type "text/plain"
+                :content-length (length resp))
+          (list resp))))
+
+
+(defun add-route (route-key route-handler)
+  "A Helper, used by DEFROUTE. Adds or replaces a handler for a route.
+
+ROUTE-KEY is of the form (METHOD . STRINGS) where METHOD is
+one of :GET :POST :PUT :HEAD etc, and where STRINGS is a list of strings.
+
+ROUTE-HANDLER is a function of several arguments. The first argument
+always binds the special variable *REQ* to the current request PLIST.
+Additional arguments are bound to variables that may appear in the
+route key.  A string in STRINGS that starts with a colon will
+correspond to a variable in the handler function.  This the value of
+this variable is extracted from a request path and passed to the
+handler function.
+
+For example: (:GET \"persons\" \":id\" \"view\") matched against the
+url path \"/persons/23/view\" would pass the value 23 to the route
+handler, bound to the variable ID.
+"
+  (let ((found (assoc route-key *routes* :test #'equal)))
+    (if found
+        (setf (cdr found) route-handler)
+        (push (cons route-key route-handler) *routes*))))
+
+(defun path-var-p (str)
+  "Returns T if STR is a string that looks like :foo, Nil otherwise."
+  (and
+   (stringp str)
+   (plusp (length str))
+   (eql #\: (aref str 0))))
+
+
+(defun path-to-arglist (path-spec)
+  "Parses a URL path and extracts any variables, returning a list of symbols.
+
+E.g.: /foo/bar/:goo/zar/:moo  would result in  (GOO MOO)"
+
+  (iter (for val in (split-sequence:split-sequence #\/ path-spec))
+        (when (path-var-p val)
+          (collect (read-from-string (subseq val 1))))))
+
+
+
+(defmacro defroute (method path &rest body)
+  "Defines a new route handler.
+
+Method is one of :GET :POST :PUT etc... 
+
+PATH is a string representing a URL path. The PATH may contain
+variable segmets, that start with a colon.
+
+The new route is added to the currently defined routes and is available for use.
+
+If the METHOD has a body, then the defined route handler will
+automatically decode the body according the the request's
+Content-Length and Content-Type headers, which will then be bound to
+*BODY* for the extent of the handler.
+
+A special variable *RESP-HEADERS* is also bound to NIL at the start of
+the handler, and can be used to add headers to a successful response. 
+
+The request PLIST is boudn to *REQ* for the extent of the handler."
+  (let ((arglist (path-to-arglist path))
+        (key (cons method (split-sequence:split-sequence #\/ path))))
+    (if (member method '(:post :put))
+        `(add-route ',key
+                    (lambda (*req* ,@arglist)
+                      (let ((*body* (decode-body (getf *req* :raw-body)
+                                                 (getf *req* :content-type)
+                                                 (getf *req* :content-length)))
+                            (*resp-headers* nil))
+                        ,@body)))
+        `(add-route ',key
+                    (lambda (*req* ,@arglist)
+                      (let (*resp-headers*) ,@body))))))
+
+
+(defun route-part-match-p (word1 word2)
+  "A utility function, returns T if word1 and word2 unify as
+non-variable URL path segments."
+  (or (eql word1 word2)
+      (and (stringp word1)
+           (stringp word2)
+           (string-equal word1 word2))))
+
+
+(defun match-route-key (req-key route-key)
+  "Compares a route keys extracted from an HTTP request path with an
+already extant route key.  
+
+Returns two values, a possible argument list to pass to the route
+handler and a boolean indicating success"
+  (let (args)
+    (loop
+       :for req-part :in req-key
+       :for route-part :in route-key
+       :do (cond
+             ((path-var-p route-part)
+              (push req-part args))
+
+             ((not (route-part-match-p req-part route-part))
+              (return-from match-route-key (values nil nil)))))
+
+    (values (reverse  args) t)))
+
+
+(defun lookup-route (req)
+  "Looks up a route and returns two values. The first is a list of
+arguments extracted from the request path. The second is the handler
+function itself.  Both are NIL if the lookup failed to find a handler
+for the request's path."
+  (when-let* ((path   (getf req :path-info))
+              (method (getf req :request-method))
+              (key    (cons method (split-sequence:split-sequence #\/ path))))
+    (loop :for (route-key . handler) :in *routes*
+       :do (multiple-value-bind (args match-p) (match-route-key key route-key)
+             (when match-p (return-from lookup-route (values args handler)))))
+    ;; otherwise
+    (values nil nil)))
+
+
+(defun main-handler (req)
+  (handler-case
+      (multiple-value-bind (args handler) (lookup-route req)
+        (if handler
+            (apply handler req args)
+            (http-err 404 "Not Found")))
+    (error (e)
+      (print e *error-output* )
+      (http-err 500 "Internal Server Error"))))
+
+
+
+(defun start ()
+  (setf *handler* (clack:clackup #'main-handler)))
+
+(defun stop ()
+  (clack:stop *handler*))
+
+(defun reload ()
+  (stop)
+  (start))
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..db0b0e2
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,18 @@
+;;;; package.lisp
+
+(defpackage #:lazybones
+  (:use #:cl #:alexandria #:iterate)
+  (:export
+
+   #:*body*
+   #:*req*
+   #:*resp-headers*
+   #:add-decoder
+   #:add-header
+   #:defroute
+   #:http-err
+   #:http-ok
+   #:reload
+   #:start
+   #:stop
+   ))