Initial commit.

.gitignore

@@ -0,0 +1,8 @@
+*.fasl
+*.dx32fsl
+*.dx64fsl
+*.lx32fsl
+*.lx64fsl
+*.x86f
+*~
+.#*

README.md

@@ -0,0 +1,111 @@
+# Lack, a minimal Clack
+
+Lack is an experimental project for redesigning Clack with performance and simplicity in mind. This aims to be a gut of the next Clack major release.
+
+## Usage
+
+```common-lisp
+(defvar *app*
+  (lambda (env)
+    '(200 (:content-type "text/plain") ("Hello, World"))))
+
+(lack:lackup *app* :server :woo)
+
+;; `wrap`
+(funcall lack-middleware-session:*lack-middleware-session* *app*)
+
+(lack:builder
+  :session
+  (:static :path "/public/"
+           :root #P"/static-files/")
+  (lambda (app)
+    (lambda (env)
+      (prog1 (funcall app env)
+        (do-before-responding))))
+  *app*)
+```
+
+## The Environment
+
+The environment, an application takes, is a property list containing the following keys:
+
+- `:method` (Required, Keyword)
+  - The HTTP request method: `:GET`, `:HEAD`, `:OPTIONS`, `:PUT`, `:POST`, or `:DELETE`.
+- `:script-name` (Required, String)
+  - The initial portion of the request URI path that corresponds to the Clack application. The value of this key may be an empty string when the client is accessing the application represented by the server's root URI. Otherwise, it is a non-empty string starting with a forward slash (`/`).
+- `:path-info` (Required, String)
+  - The remainder of the request URI path. The value of this key may be an empty string when you access the application represented by the server’s root URI with no trailing slash.
+- `:query-string` (Optional, String)
+  - The portion of the request URI that follows the `?`, if any.
+- `:server-name` (Required, String)
+  - The resolved server name or the server IP address.
+- `:server-port` (Required, Integer)
+  - The port on which the request is being handled.
+- `:server-protocol` (Required, Keyword)
+  - The version of the protocol the client used to send the request: typically `:HTTP/1.0` or `:HTTP/1.1`.
+- `:uri` (Required, String)
+  - The request URI. Always starts with "/".
+- `:raw-body` (Optional, Stream)
+  - The new body of the request.
+- `:remote-addr` (Required, String)
+  - The remote address.
+- `:remote-port` (Required, Integer)
+  - The remote port.
+- `:headers` (Required, Hash-Table)
+  - A hash table of headers.
+
+## The Response
+
+### Normal response
+
+An application returns a list of three elements for a normal request, which respectively expresses an HTTP status code, headers, and response body data.
+
+```common-lisp
+(lambda (env)
+  (declare (ignore env))
+  '(200 (:content-type "text/plain") ("Hello, World")))
+```
+
+The status code must be an integer greater than or equal to 100, and should be an HTTP status code as documented in [RFC 2616](https://www.ietf.org/rfc/rfc2616.txt).
+
+The headers must be a property list. If the same key name appears multiple times in it, those header lines will be sent to the client separately (e.g. multiple `Set-Cookie` lines).
+
+The response body must be returned from the application in one of three formats, a list of strings, a list of byte vectors, or a pathname.
+
+### Delayed Response and Streaming Body
+
+Lack allows applications to provide a callback-style response instead of the three-element list. This allows for a delayed response and a streaming body.
+
+To enable a delayed response, the application should return a callback as its response.
+
+```common-lisp
+(lambda (env)
+  (lambda (responder)
+    (let ((content (fetch-something)))
+      (funcall responder `(200 (:content-type "text/plain") (,content))))))
+```
+
+An application may omit the third element (the body) when calling the responder. If the body is omitted, the responder will return a function which takes an exact one argument, a body chunk, and writes it to a client. When it gets `:eof`, it closes the connection.
+
+```common-lisp
+(lambda (env)
+  (lambda (responder)
+    (let ((writer (funcall responder '(200 (:content-type "application/json")))))
+      (loop for chunk = (fetch-something)
+            do (funcall writer (or chunk :eof))
+            while chunk))))
+```
+
+This delayed response and streaming API is useful if you want to implement a non-blocking I/O based server streaming or long-poll Comet push technology.
+
+## Author
+
+* Eitaro Fukamachi (e.arrows@gmail.com)
+
+## Copyright
+
+Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com)
+
+## License
+
+Licensed under the LLGPL License.

lack-handler-hunchentoot.asd

@@ -0,0 +1,15 @@
+(in-package :cl-user)
+(defpackage :lack-handler-hunchentoot-asd
+  (:use :cl :asdf))
+(in-package :lack-handler-hunchentoot-asd)
+
+(defsystem lack-handler-hunchentoot
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:hunchentoot
+               :flexi-streams
+               :alexandria
+               :split-sequence)
+  :components ((:file "src/handler/hunchentoot"))
+  :description "Lack handler for Hunchentoot.")

lack-middleware-accesslog.asd

@@ -0,0 +1,21 @@
+(in-package :cl-user)
+(defpackage :lack-middleware-accesslog-asd
+  (:use :cl :asdf))
+(in-package :lack-middleware-accesslog-asd)
+
+(defsystem lack-middleware-accesslog
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:lack-util
+               :local-time)
+  :components ((:module "src"
+                :components
+                ((:file "middleware/accesslog")))))
+
+
+
+
+
+
+

lack-middleware-session.asd

@@ -0,0 +1,25 @@
+(in-package :cl-user)
+(defpackage :lack-middleware-session-asd
+  (:use :cl :asdf))
+(in-package :lack-middleware-session-asd)
+
+(defsystem lack-middleware-session
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:lack-response
+               :lack-util
+               :cl-ppcre)
+  :components ((:module "src/middleware"
+                :components
+                ((:file "session" :depends-on ("store" "state"))
+                 (:module "store"
+                  :pathname "session"
+                  :components
+                  ((:file "store")
+                   (:file "store/memory")))
+                 (:module "state"
+                  :pathname "session"
+                  :components
+                  ((:file "state")
+                   (:file "state/cookie")))))))

lack-middleware-static.asd

@@ -0,0 +1,17 @@
+(in-package :cl-user)
+(defpackage :lack-middleware-static-asd
+  (:use :cl :asdf))
+(in-package :lack-middleware-static-asd)
+
+(defsystem lack-middleware-static
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:trivial-mimes
+               :local-time
+               :cl-fad
+               :alexandria)
+  :components ((:module "src"
+                :components
+                ((:file "middleware/static" :depends-on ("app/file"))
+                 (:file "app/file")))))

lack-request.asd

@@ -0,0 +1,13 @@
+(in-package :cl-user)
+(defpackage :lack-request-asd
+  (:use :cl :asdf))
+(in-package :lack-request-asd)
+
+(defsystem lack-request
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:quri
+               :http-body
+               :cl-ppcre)
+  :components ((:file "src/request")))

lack-response.asd

@@ -0,0 +1,12 @@
+(in-package :cl-user)
+(defpackage :lack-response-asd
+  (:use :cl :asdf))
+(in-package :lack-response-asd)
+
+(defsystem lack-response
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:quri
+               :local-time)
+  :components ((:file "src/response")))

lack-util.asd

@@ -0,0 +1,12 @@
+(in-package :cl-user)
+(defpackage :lack-util-asd
+  (:use :cl :asdf))
+(in-package :lack-util-asd)
+
+(defsystem lack-util
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:ironclad
+               :alexandria)
+  :components ((:file "src/util")))

lack.asd

@@ -0,0 +1,42 @@
+#|
+  This file is a part of lack project.
+  Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com)
+|#
+
+#|
+  A minimal Clack
+
+  Author: Eitaro Fukamachi (e.arrows@gmail.com)
+|#
+
+(in-package :cl-user)
+(defpackage lack-asd
+  (:use :cl :asdf))
+(in-package :lack-asd)
+
+(defsystem lack
+  :version "0.1"
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:lack-util
+               :bordeaux-threads
+               :alexandria)
+  :components ((:module "src"
+                :components
+                ((:file "lack" :depends-on ("builder" "handler"))
+                 (:file "builder")
+                 (:file "handler"))))
+  :description "A minimal Clack"
+  :long-description
+  #.(with-open-file (stream (merge-pathnames
+                             #p"README.md"
+                             (or *load-pathname* *compile-file-pathname*))
+                            :if-does-not-exist nil
+                            :direction :input)
+      (when stream
+        (let ((seq (make-array (file-length stream)
+                               :element-type 'character
+                               :fill-pointer t)))
+          (setf (fill-pointer seq) (read-sequence seq stream))
+          seq)))
+  :in-order-to ((test-op (test-op lack-test))))

src/app/file.lisp

@@ -0,0 +1,63 @@
+(in-package :cl-user)
+(defpackage lack.app.file
+  (:use :cl)
+  (:import-from :trivial-mimes
+                :mime)
+  (:import-from :local-time
+                :format-rfc1123-timestring
+                :universal-to-timestamp)
+  (:import-from :cl-fad
+                :file-exists-p
+                :directory-exists-p)
+  (:import-from :alexandria
+                :starts-with-subseq)
+  (:export :make-app))
+(in-package :lack.app.file)
+
+(define-condition bad-request (simple-condition) ())
+
+(defun make-app (&key file (root #P"./") (encoding "utf-8"))
+  (lambda (env)
+    (handler-case
+        (serve-path
+         (locate-file (or file
+                          ;; remove "/"
+                          (subseq (getf env :path-info) 1))
+                      root)
+         encoding)
+      (bad-request ()
+        '(400 (:content-type "text/plain"
+               :content-length 11)
+          ("Bad Request"))))))
+
+(defun locate-file (path root)
+  (when (find :up (pathname-directory path) :test #'eq)
+    (error 'bad-request))
+
+  (let ((file (merge-pathnames path root)))
+    (cond
+      ((position #\Null (namestring file))
+       (error 'bad-request))
+      ((not (and (file-exists-p file)
+                 (not (directory-exists-p file))))
+       (error 'bad-request))
+      (t file))))
+
+(defun serve-path (file encoding)
+  (let ((content-type (mimes:mime file "text/plain"))
+        (univ-time (or (file-write-date file)
+                       (get-universal-time))))
+    (when (starts-with-subseq "text" content-type)
+      (setf content-type
+            (format nil "~A~:[~;~:*; charset=~A~]"
+                    content-type encoding)))
+    (with-open-file (stream file
+                            :direction :input
+                            :if-does-not-exist nil)
+      `(200
+        (:content-type ,content-type
+         :content-length ,(file-length stream)
+         :last-modified
+         ,(format-rfc1123-timestring nil
+                                     (universal-to-timestamp univ-time))
+         ,file)))))

src/builder.lisp

@@ -0,0 +1,42 @@
+(in-package :cl-user)
+(defpackage lack.builder
+  (:use :cl)
+  (:import-from :lack.util
+                :find-package-or-load)
+  (:export :builder))
+(in-package :lack.builder)
+
+(defun find-middleware (identifier)
+  (let* ((package-name (concatenate 'string
+                                    #.(string '#:lack.middleware.)
+                                    (symbol-name identifier)))
+         (package (find-package-or-load package-name)))
+    (unless package
+      (error "Middleware ~S is not found" package-name))
+    (let ((mw-symbol (intern (format nil "*~A*"
+                                     (substitute #\- #\. package-name
+                                                 :test #'char=))
+                             package)))
+      (if (and (boundp mw-symbol)
+               (functionp (symbol-value mw-symbol)))
+          (symbol-value mw-symbol)
+          (error "Middleware ~S is unbound or not a function" mw-symbol)))))
+
+(defmacro builder (&rest app-or-middlewares)
+  (let ((middlewares (butlast app-or-middlewares)))
+    `(reduce #'funcall
+             (list
+              ,@(loop for mw in middlewares
+                      when mw
+                        collect (typecase mw
+                                  (function mw)
+                                  (keyword `(find-middleware ,mw))
+                                  (cons (if (keywordp (car mw))
+                                            (let ((app (gensym "APP")))
+                                              `(lambda (,app)
+                                                 (funcall (find-middleware ,(car mw)) ,app
+                                                          ,@(cdr mw))))
+                                            mw))
+                                  (otherwise mw))))
+             :initial-value ,(car (last app-or-middlewares))
+             :from-end t)))

src/handler.lisp

@@ -0,0 +1,41 @@
+(in-package :cl-user)
+(defpackage lack.handler
+  (:use :cl)
+  (:import-from :lack.util
+                :find-package-or-load)
+  (:export :run
+           :stop))
+(in-package :lack.handler)
+
+(defstruct handler
+  server
+  acceptor)
+
+(defun find-handler (server)
+  (flet ((find-with-prefix (prefix)
+           (find-package-or-load (concatenate 'string
+                                              prefix
+                                              (symbol-name server)))))
+    (or (find-with-prefix #.(string '#:lack.handler.))
+        (error "~S is unknown handler."
+               server))))
+
+(defun run (app server &rest args)
+  (let ((handler-package (find-handler server)))
+    (make-handler
+     :server server
+     :acceptor
+     (apply (intern #.(string '#:run) handler-package)
+            app
+            :allow-other-keys t
+            args))))
+
+(defun stop (handler)
+  (let ((acceptor (handler-acceptor handler)))
+    (if (bt:threadp acceptor)
+        (progn
+          (bt:destroy-thread acceptor)
+          (sleep 0.5))
+        (let ((package (find-handler (handler-server handler))))
+          (funcall (intern #.(string '#:stop) package) acceptor)))
+    t))

src/handler/hunchentoot.lisp

@@ -0,0 +1,154 @@
+#|
+  This file was ported from Clack project and made some modifications.
+  Copyright (c) 2011-2015 Clack contributors
+  Copyright (c) 2015 Eitaro Fukamachi <e.arrows@gmail.com>
+|#
+
+(in-package :cl-user)
+(defpackage lack.handler.hunchentoot
+  (:use :cl
+        :hunchentoot)
+  (:shadow :handle-request)
+  (:import-from :hunchentoot
+                :acceptor-taskmaster
+                :acceptor-shutdown-p)
+  (:import-from :flexi-streams
+                :make-external-format
+                :string-to-octets)
+  (:import-from :split-sequence
+                :split-sequence)
+  (:import-from :alexandria
+                :when-let)
+  (:export :run))
+(in-package :lack.handler.hunchentoot)
+
+(defun initialize ()
+  (setf *hunchentoot-default-external-format*
+        (flex:make-external-format :utf-8 :eol-style :lf)
+        *default-content-type* "text/html; charset=utf-8"
+        *catch-errors-p* nil))
+
+(defun run (app &key debug (port 5000)
+                  ssl ssl-key-file ssl-cert-file ssl-key-password
+                  max-thread-count max-accept-count (persistent-connections-p t))
+  (initialize)
+  (setf *dispatch-table*
+        (list
+         (let ((stdout *standard-output*)
+               (errout *error-output*))
+           (lambda (req)
+             (let ((env (handle-request req :ssl ssl)))
+               (lambda ()
+                 (let ((*standard-output* stdout)
+                       (*error-output* errout))
+                   (handle-response
+                    (if debug
+                        (funcall app env)
+                        (handler-case (funcall app env)
+                          (error (error)
+                            (princ error *error-output*)
+                            '(500 () ("Internal Server Error")))))))))))))
+  (let* ((taskmaster (when (and max-thread-count max-accept-count)
+                       (make-instance 'one-thread-per-connection-taskmaster
+                                      :max-thread-count max-thread-count
+                                      :max-accept-count max-accept-count)))
+         (acceptor
+           (if ssl
+               (apply #'make-instance 'easy-ssl-acceptor
+                      :port port
+                      :ssl-certificate-file ssl-cert-file
+                      :ssl-privatekey-file ssl-key-file
+                      :ssl-privatekey-password ssl-key-password
+                      :access-log-destination nil
+                      :persistent-connections-p persistent-connections-p
+                      (and taskmaster
+                           (list :taskmaster taskmaster)))
+               (apply #'make-instance 'easy-acceptor
+                      :port port
+                      :access-log-destination nil
+                      :error-template-directory nil
+                      :persistent-connections-p persistent-connections-p
+                      (and taskmaster
+                           (list :taskmaster taskmaster))))))
+    (setf (hunchentoot::acceptor-shutdown-p acceptor) nil)
+    (start-listening acceptor)
+    (let ((taskmaster (acceptor-taskmaster acceptor)))
+      (setf (taskmaster-acceptor taskmaster) acceptor)
+      (accept-connections acceptor))))
+
+(defun handle-response (res)
+  "Convert Response from Clack application into a string
+before passing to Hunchentoot."
+  (let ((no-body '#:no-body))
+    (flet ((handle-normal-response (res)
+             (destructuring-bind (status headers &optional (body no-body)) res
+               (setf (return-code*) status)
+               (loop for (k v) on headers by #'cddr
+                     with hash = (make-hash-table :test #'eq)
+                     if (gethash k hash)
+                       do (setf (gethash k hash)
+                                (format nil "~:[~;~:*~A, ~]~A" (gethash k hash) v))
+                     else do (setf (gethash k hash) v)
+                     finally
+                        (loop for k being the hash-keys in hash
+                                using (hash-value v)
+                              do (setf (header-out k) v)))
+
+               (when (eq body no-body)
+                 (return-from handle-normal-response
+                   (let ((out (send-headers)))
+                     (lambda (chunk)
+                       (if (eq chunk :eof)
+                           (finish-output out)
+                           (write-sequence
+                            (etypecase chunk
+                              (string (flex:string-to-octets chunk))
+                              ((vector (unsigned-byte 8)) chunk))
+                            out))))))
+
+               (etypecase body
+                 (null) ;; nothing to response
+                 (pathname
+                  (hunchentoot:handle-static-file body (getf headers :content-type)))
+                 (list
+                  (let ((out (send-headers)))
+                    (loop for chunk in body
+                          do (etypecase chunk
+                               (string (write-sequence (flex:string-to-octets chunk) out))
+                               ((vector (unsigned-byte 8))
+                                (write-sequence chunk out))))
+                    (finish-output out)))))))
+      (etypecase res
+        (list (handle-normal-response res))
+        (function (funcall res #'handle-normal-response))))))
+
+(defun handle-request (req &key ssl)
+  "Convert Request from server into a plist
+before passing to Clack application."
+  (destructuring-bind (server-name &optional (server-port "80"))
+      (split-sequence #\: (host req) :from-end t)
+    (list
+     :method (request-method* req)
+     :script-name ""
+     :path-info (url-decode (script-name* req))
+     :server-name server-name
+     :server-port (parse-integer server-port :junk-allowed t)
+     :server-protocol (server-protocol* req)
+     :uri (request-uri* req)
+     :url-scheme (if ssl :https :http)
+     :remote-addr (remote-addr* req)
+     :remote-port (remote-port* req)
+     ;; Request params
+     :query-string (query-string* req)
+     :raw-body (raw-post-data :request req :want-stream t)
+     :content-length (when-let (content-length (header-in* :content-length req))
+                       (parse-integer content-length :junk-allowed t))
+     :content-type (header-in* :content-type req)
+     :lack.streaming t
+
+     :headers (loop with headers = (make-hash-table :test 'equal)
+                    for (k . v) in (hunchentoot:headers-in* req)
+                    unless (or (eq k :content-length)
+                               (eq k :content-type))
+                      do (setf (gethash (string-downcase k) headers) v)
+                    finally (return headers)))))

src/lack.lisp

@@ -0,0 +1,24 @@
+(in-package :cl-user)
+(defpackage lack
+  (:use :cl)
+  (:import-from :lack.builder
+                :builder)
+  (:import-from :lack.handler
+                :run
+                :stop)
+  (:import-from :alexandria
+                :delete-from-plist)
+  (:export :lackup
+           :stop
+           :builder))
+(in-package :lack)
+
+(defun lackup (app &rest args
+               &key (server :hunchentoot)
+                 (port 5000)
+                 (debug t)
+               &allow-other-keys)
+  (apply #'lack.handler:run app server
+         :port port
+         :debug debug
+         (delete-from-plist args :server :use-thread :port :debug)))

src/middleware/accesslog.lisp

@@ -0,0 +1,42 @@
+(in-package :cl-user)
+(defpackage lack.middleware.accesslog
+  (:use :cl)
+  (:import-from :lack.util
+                :funcall-with-cb
+                :content-length)
+  (:import-from :local-time
+                :format-timestring
+                :now)
+  (:export :*lack-middleware-accesslog*
+           :*time-format*
+           :default-formatter))
+(in-package :lack.middleware.accesslog)
+
+(defvar *lack-middleware-accesslog*
+  (let ((no-body '#:no-body))
+    (lambda (app &key
+              (logger
+               (lambda (output) (format t "~&~A~%" output)))
+              (formatter #'default-formatter))
+      (lambda (env)
+        (funcall-with-cb
+         app env
+         (lambda (res)
+           (funcall logger
+                    (funcall formatter env res (now)))
+           res))))))
+
+(defvar *time-format*
+  '((:day 2) #\/ :short-month #\/ (:year 4) #\: (:hour 2) #\: (:min 2) #\: (:sec 2) #\Space :gmt-offset))
+
+(defun default-formatter (env res now)
+  (format nil "~A - [~A] \"~A ~A ~A\" ~A ~A \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\""
+          (getf env :remote-addr)
+          (local-time:format-timestring nil now :format *time-format*)
+          (getf env :request-method)
+          (getf env :request-uri)
+          (getf env :server-protocol)
+          (car res)
+          (content-length res)
+          (getf env :http-referer)
+          (getf env :http-user-agent)))

src/middleware/session.lisp

@@ -0,0 +1,53 @@
+(in-package :cl-user)
+(defpackage lack.middleware.session
+  (:use :cl)
+  (:import-from :lack.session.store
+                :fetch-session
+                :store-session
+                :remove-session)
+  (:import-from :lack.session.state
+                :expire-state
+                :extract-sid
+                :finalize-state
+                :generate-sid)
+  (:import-from :lack.session.store.memory
+                :make-memory-store)
+  (:import-from :lack.session.state.cookie
+                :make-cookie-state))
+(in-package :lack.middleware.session)
+
+(defvar *lack-middleware-session*
+  (lambda (app &key
+            (store (make-memory-store))
+            (state (make-cookie-state)))
+    (lambda (env)
+      (let* ((sid (extract-sid state env))
+             (session (and sid
+                           (fetch-session store sid)))
+             (sid (or sid
+                      (generate-sid state env))))
+        (setf (getf env :lack.session)
+              (or session (make-hash-table :test 'equal)))
+        (setf (getf env :lack.session.options)
+              (list :id sid))
+        (finalize store state env (funcall app env))))))
+
+(defun finalize (store state env res)
+  (let ((session (getf env :lack.session))
+        (options (getf env :lack.session.options)))
+    (when session
+      (apply #'commit store state session env options))
+    (if (getf options :expire)
+        (expire-state state (getf options :id) res options)
+        (finalize-state state (getf options :id) res options))))
+
+(defun commit (store state session env &key id expire change-id &allow-other-keys)
+  (cond
+    (expire
+     (remove-session store id))
+    (change-id
+     (remove-session store id)
+     (let ((new-sid (generate-sid state env)))
+       (store-session store new-sid session)))
+    (t
+     (store-session store id session))))

src/middleware/session/state.lisp

@@ -0,0 +1,42 @@
+(in-package :cl-user)
+(defpackage lack.middleware.session.state
+  (:nicknames :lack.session.state)
+  (:use :cl)
+  (:import-from :lack.util
+                :generate-random-id)
+  (:import-from :cl-ppcre
+                :scan)
+  (:export :state
+           :make-state
+           :generate-sid
+           :extract-sid
+           :expire-state
+           :finalize-state))
+(in-package :lack.middleware.session.state)
+
+(defstruct state
+  (sid-generator (lambda (env)
+                   (declare (ignore env))
+                   (generate-random-id)))
+  (sid-validator (lambda (sid)
+                   (not (null (ppcre:scan "\\A[0-9a-f]{40}\\Z" sid))))))
+
+(defun generate-sid (state env)
+  (funcall (state-sid-generator state) env))
+
+(defgeneric extract-sid (state env)
+  (:method ((state state) env)
+    (let ((sid (getf env :lack.session)))
+      (and sid
+           (funcall (state-sid-validator state) sid)
+           sid))))
+
+(defgeneric expire-state (state sid res options)
+  (:method ((state state) sid res options)
+    (declare (ignore state sid options))
+    res))
+
+(defgeneric finalize-state (state sid res options)
+  (:method ((state state) sid res options)
+    (declare (ignore state sid options))
+    res))

src/middleware/session/state/cookie.lisp

@@ -0,0 +1,43 @@
+(in-package :cl-user)
+(defpackage lack.middleware.session.state.cookie
+  (:nicknames :lack.session.state.cookie)
+  (:use :cl
+        :lack.middleware.session.state)
+  (:import-from :lack.response
+                :make-response
+                :generate-sid
+                :extract-sid
+                :finalize-response
+                :response-set-cookies)
+  (:export :cookie-state
+           :make-cookie-state
+           :generate-sid
+           :extract-sid
+           :expire-state
+           :finalize-session))
+(in-package :lack.middleware.session.state.cookie)
+
+(defstruct (cookie-state (:include state))
+  (path "/" :type string)
+  (domain nil :type (or string null))
+  (expires (get-universal-time) :type integer)
+  (secure nil :type boolean)
+  (httponly nil :type boolean))
+
+(defmethod expire-state ((state cookie-state) sid res options)
+  (setf (cookie-state-expires state) 0)
+  (finalize-state state sid res options))
+
+(defmethod finalize-state ((state cookie-state) sid res options)
+  (let ((res (apply #'make-response res))
+        (options (append options
+                         (with-slots (path domain expires secure httponly) state
+                           (list :path path
+                                 :domain domain
+                                 :secure secure
+                                 :httponly httponly
+                                 :expires (+ (get-universal-time) expires))))))
+    (setf (response-set-cookies res)
+          (append (response-set-cookies res)
+                  `(:|lack.session| (:value ,sid ,@options))))
+    (finalize-response res)))

src/middleware/session/store.lisp

@@ -0,0 +1,15 @@
+(in-package :cl-user)
+(defpackage lack.middleware.session.store
+  (:nicknames :lack.session.store)
+  (:use :cl)
+  (:export :store
+           :fetch-session
+           :store-session
+           :remove-session))
+(in-package :lack.middleware.session.store)
+
+(defstruct store)
+
+(defgeneric fetch-session (store sid))
+(defgeneric store-session (store sid session))
+(defgeneric remove-session (store sid))

src/middleware/session/store/memory.lisp

@@ -0,0 +1,24 @@
+(in-package :cl-user)
+(defpackage lack.middleware.session.store.memory
+  (:nicknames :lack.session.store.memory)
+  (:use :cl
+        :lack.middleware.session.store)
+  (:export :memory-store
+           :make-memory-store
+           :fetch-session
+           :store-session
+           :remove-session))
+(in-package :lack.middleware.session.store.memory)
+
+(defstruct (memory-store (:include store))
+  (stash (make-hash-table :test 'equal)))
+
+(defmethod fetch-session ((store memory-store) sid)
+  (gethash sid (memory-store-stash store)))
+
+(defmethod store-session ((store memory-store) sid session)
+  (setf (gethash sid (memory-store-stash store))
+        session))
+
+(defmethod remove-session ((store memory-store) sid)
+  (remhash sid (memory-store-stash store)))

src/middleware/static.lisp

@@ -0,0 +1,35 @@
+(in-package :cl-user)
+(defpackage lack.middleware.static
+  (:use :cl)
+  (:import-from :lack.app.file
+                :make-app)
+  (:import-from :alexandria
+                :starts-with-subseq
+                :if-let)
+  (:export :*lack-middleware-static*))
+(in-package :lack.middleware.static)
+
+(defvar *lack-middleware-static*
+  (lambda (app &key path (root #P"./"))
+    (etypecase path
+      (null app)
+      (string
+       (lambda (env)
+         (let ((path-info (getf env :path-info)))
+           (if (starts-with-subseq path path-info)
+               (progn
+                 (setf (getf env :path-info)
+                       (subseq path-info (1- (length path))))
+                 (call-app-file :TODO))
+               (funcall app env)))))
+      (function
+       (lambda (env)
+        (let ((path-info (getf env :path-info)))
+          (if-let (new-path (funcall path path-info))
+            (progn
+              (setf (getf env :path-info) new-path)
+              (call-app-file :TODO))
+            (funcall app env))))))))
+
+(defun call-app-file (root env)
+  (funcall (lack.app.file:make-app :root root) env))

src/request.lisp

@@ -0,0 +1,85 @@
+(in-package :cl-user)
+(defpackage lack.request
+  (:use :cl)
+  (:import-from :quri
+                :url-decode-params)
+  (:import-from :http-body
+                :parse)
+  (:import-from :cl-ppcre
+                :split)
+  (:export :request
+           :make-request
+           :request-env
+           :request-method
+           :request-script-name
+           :request-path-info
+           :request-server-name
+           :request-server-port
+           :request-server-protocol
+           :request-uri
+           :request-remote-addr
+           :request-remote-port
+           :request-query-string
+           :request-raw-body
+           :request-content-length
+           :request-content-type
+           :request-headers
+           :request-cookies
+           :request-body-parameters
+           :request-query-parameters
+           :request-parameters))
+(in-package :lack.request)
+
+(defstruct (request (:constructor %make-request))
+  env
+
+  method
+  script-name
+  path-info
+  server-name
+  server-port
+  server-protocol
+  uri
+  remote-addr
+  remote-port
+  query-string
+  raw-body
+  content-length
+  content-type
+  headers
+
+  cookies
+  body-parameters
+  query-parameters)
+
+(defun make-request (env)
+  (let ((req (apply #'%make-request :env env :allow-other-keys t env)))
+
+    ;; Cookies
+    (let* ((headers (request-headers req))
+           (cookie (and (hash-table-p headers)
+                        (gethash "cookie" headers))))
+      (when cookie
+        (setf (request-cookies req)
+              (loop for kv in (ppcre:split "\\s*[,;]\\s*" cookie)
+                    append (quri:url-decode-params kv :lenient t)))))
+
+    ;; GET parameters
+    (with-slots (query-parameters query-string) req
+      (when (and (null query-parameters)
+                 query-string)
+        (setf query-parameters
+              (quri:url-decode-params query-string :lenient t))))
+
+    ;; POST parameters
+    (with-slots (body-parameters raw-body content-type) req
+      (when (and (null body-parameters)
+                 raw-body)
+        (setf body-parameters
+              (http-body:parse content-type raw-body))))
+
+    req))
+
+(defun request-parameters (req)
+  (append (request-query-parameters req)
+          (request-body-parameters req)))

src/response.lisp

@@ -0,0 +1,61 @@
+(in-package :cl-user)
+(defpackage lack.response
+  (:use :cl)
+  (:import-from :quri
+                :url-encode)
+  (:import-from :local-time
+                :format-timestring
+                :universal-to-timestamp
+                :+gmt-zone+)
+  (:export :response
+           :make-response
+           :finalize-response
+           :response-status
+           :response-headers
+           :response-body
+           :response-set-cookies))
+(in-package :lack.response)
+
+(defstruct (response
+            (:constructor make-response (&optional status headers body)))
+  status
+  headers
+  body
+  set-cookies)
+
+(defgeneric finalize-response (res)
+  (:method ((res response))
+    (finalize-cookies res)
+    (with-slots (status headers body) res
+      (list status headers body))))
+
+(defun finalize-cookies (res)
+  (setf (response-headers res)
+        (nconc (response-headers res)
+               (loop for (k v) on (response-set-cookies res) by #'cddr
+                     append (list :set-cookie (bake-cookie k v))))))
+
+(defun bake-cookie (key value)
+  (unless value
+    (return-from bake-cookie ""))
+
+  (destructuring-bind (&key domain path expires secure httponly &allow-other-keys)
+      value
+    (with-output-to-string (s)
+      (format s "~A=~A"
+              (quri:url-encode (symbol-name key))
+              (quri:url-encode (getf value :value)))
+      (when domain
+        (format s "; domain=~A" domain))
+      (when path
+        (format s "; path=~A" path))
+      (when expires
+        (format s "; expires=")
+        (format-timestring
+         s (universal-to-timestamp expires)
+         :format '(:short-weekday ", " (:day 2) #\Space :short-month #\Space (:year 4) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) " GMT")
+         :timezone +gmt-zone+))
+      (when secure
+        (write-string "; secure" s))
+      (when httponly
+        (write-string "; HttpOnly" s)))))

src/util.lisp

@@ -0,0 +1,54 @@
+(in-package :cl-user)
+(defpackage lack.util
+  (:use :cl)
+  (:import-from :ironclad
+                :ascii-string-to-byte-array
+                :byte-array-to-hex-string
+                :digest-sequence
+                :make-digest)
+  (:import-from :alexandria
+                :when-let)
+  (:export :find-package-or-load
+           :funcall-with-cb
+           :content-length
+           :generate-random-id))
+(in-package :lack.util)
+
+(defun find-package-or-load (package-name)
+  (check-type package-name string)
+  (let ((package (find-package package-name)))
+    (or package
+        (let ((system-name (string-downcase (substitute #\- #\. package-name :test #'char=))))
+          (when (asdf:find-system system-name nil)
+            #+quicklisp (ql:quickload system-name)
+            #-quicklisp (asdf:load-system system-name :verbose nil)
+            (find-package package-name))))))
+
+(defun funcall-with-cb (app env cb)
+  (let ((res (funcall app env)))
+    (typecase res
+      (cons (funcall cb res))
+      (function
+       (lambda (responder)
+        (funcall res (lambda (res)
+                       (funcall responder (funcall cb res))))))
+      (otherwise res))))
+
+(defun content-length (res)
+  (destructuring-bind (status headers &optional body)
+      res
+    (declare (ignore status))
+    (or (getf headers :content-length)
+        (etypecase body
+          (list (reduce #'+ body :key #'length))
+          (pathname (with-open-file (in body)
+                      (file-length in)))))))
+
+(defun generate-random-id ()
+  "Generates a random token."
+  (byte-array-to-hex-string
+   (digest-sequence
+    (make-digest :SHA1)
+    (ascii-string-to-byte-array
+     (format nil "~A~A"
+      (random 1.0) (get-universal-time))))))

t-lack.asd

@@ -0,0 +1,23 @@
+#|
+  This file is a part of lack project.
+  Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com)
+|#
+
+(in-package :cl-user)
+(defpackage t-lack-asd
+  (:use :cl :asdf))
+(in-package :t-lack-asd)
+
+(defsystem t-lack
+  :author "Eitaro Fukamachi"
+  :license "LLGPL"
+  :depends-on (:lack
+               :prove)
+  :components ((:module "t"
+                :components
+                ((:test-file "lack"))))
+
+  :defsystem-depends-on (:prove-asdf)
+  :perform (test-op :after (op c)
+                    (funcall (intern #.(string :run-test-system) :prove-asdf) c)
+                    (asdf:clear-system c)))

t/lack.lisp

@@ -0,0 +1,14 @@
+(in-package :cl-user)
+(defpackage t.lack
+  (:use :cl
+        :lack
+        :prove))
+(in-package :t.lack)
+
+;; NOTE: To run this test file, execute `(asdf:test-system :lack)' in your Lisp.
+
+(plan nil)
+
+;; blah blah blah.
+
+(finalize)