├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── LICENSE ├── README.md ├── benchmark ├── clack.lisp ├── hunchentoot.lisp └── lack.lisp ├── data ├── file.txt ├── jellyfish.jpg └── redhat.png ├── lack-app-directory.asd ├── lack-app-file.asd ├── lack-component.asd ├── lack-middleware-accesslog.asd ├── lack-middleware-auth-basic.asd ├── lack-middleware-backtrace.asd ├── lack-middleware-csrf.asd ├── lack-middleware-dbpool.asd ├── lack-middleware-mount.asd ├── lack-middleware-session.asd ├── lack-middleware-static.asd ├── lack-request.asd ├── lack-response.asd ├── lack-session-store-dbi.asd ├── lack-session-store-redis.asd ├── lack-test.asd ├── lack-util-writer-stream.asd ├── lack-util.asd ├── lack.asd ├── qlfile ├── src ├── app │ ├── directory.lisp │ └── file.lisp ├── builder.lisp ├── component.lisp ├── lack.lisp ├── media-type.lisp ├── middleware │ ├── accesslog.lisp │ ├── auth │ │ └── basic.lisp │ ├── backtrace.lisp │ ├── csrf.lisp │ ├── dbpool.lisp │ ├── mount.lisp │ ├── session.lisp │ ├── session │ │ ├── state.lisp │ │ ├── state │ │ │ └── cookie.lisp │ │ ├── store.lisp │ │ └── store │ │ │ ├── dbi.lisp │ │ │ ├── memory.lisp │ │ │ └── redis.lisp │ └── static.lisp ├── request.lisp ├── response.lisp ├── test.lisp ├── util.lisp └── util │ └── writer-stream.lisp └── tests ├── builder.lisp ├── component.lisp ├── media-type.lisp ├── middleware ├── accesslog.lisp ├── auth │ └── basic.lisp ├── backtrace.lisp ├── csrf.lisp ├── mount.lisp ├── session.lisp └── static.lisp ├── request.lisp ├── session └── store │ ├── dbi.lisp │ └── redis.lisp ├── util.lisp └── util └── writer-stream.lisp /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: push 4 | 5 | jobs: 6 | test: 7 | name: ${{ matrix.lisp }} on ubuntu-latest 8 | runs-on: ubuntu-latest 9 | strategy: 10 | matrix: 11 | lisp: [sbcl-bin] 12 | 13 | steps: 14 | - uses: actions/checkout@v4 15 | - name: Install Roswell 16 | env: 17 | LISP: ${{ matrix.lisp }} 18 | ROSWELL_INSTALL_DIR: /usr 19 | run: | 20 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 21 | - name: Install Ultralisp 22 | run: ros -e '(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)' 23 | - name: Install Rove 24 | run: ros install rove 25 | - name: Run tests 26 | run: | 27 | PATH="~/.roswell/bin:$PATH" 28 | rove lack.asd 29 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* 9 | data/test.db 10 | data/test.log 11 | .qlot/ 12 | qlfile 13 | qlfile.lock 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2015 Eitaro Fukamachi 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Lack, the core of Clack 2 | 3 | [![Build Status](https://github.com/fukamachi/lack/workflows/CI/badge.svg)](https://github.com/fukamachi/lack/actions/workflows/ci.yaml) 4 | 5 | Lack is a Common Lisp library which allows web applications to be constructed of modular components. It was originally a part of [Clack](https://github.com/fukamachi/clack), however it's going to be rewritten as an individual project since Clack v2 with performance and simplicity in mind. 6 | 7 | The scope is defining Lack applications and wrapping it up with Lack middlewares. On the other hand, [Clack](https://github.com/fukamachi/clack) is an abstraction layer for HTTP and HTTP servers and provides unified API. 8 | 9 | ## Warning 10 | 11 | This software is still BETA quality. The APIs are being finalized. 12 | 13 | ## Usage 14 | 15 | ```common-lisp 16 | (defparameter *app* 17 | (lambda (env) 18 | '(200 (:content-type "text/plain") ("Hello, World")))) 19 | 20 | ;; `wrap` the app with middleware 21 | (setf *app* (funcall lack/middleware/session:*lack-middleware-session* *app*)) 22 | 23 | ;; to wrap with multiple middlewares at once, use lack's builder macro 24 | (setf *app* 25 | (lack:builder 26 | :session 27 | (:static :path "/public/" 28 | :root #P"/static-files/") 29 | (lambda (app) 30 | (lambda (env) 31 | (prog1 (funcall app env) 32 | (do-before-responding)))) 33 | *app*)) 34 | ``` 35 | 36 | Use Clack's `clackup` for starting a Lack application. 37 | 38 | ```common-lisp 39 | (clack:clackup *app* :server :woo) 40 | ``` 41 | 42 | ## The Environment 43 | 44 | The environment, an application takes, is a property list containing the following keys: 45 | 46 | - `:request-method` (Required, Keyword) 47 | - The HTTP request method: `:GET`, `:HEAD`, `:OPTIONS`, `:PUT`, `:POST`, or `:DELETE`. 48 | - `:script-name` (Required, String) 49 | - 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 (`/`). 50 | - `:path-info` (Required, String) 51 | - 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. 52 | - `:query-string` (Optional, String) 53 | - The portion of the request URI that follows the `?`, if any. 54 | - `:url-scheme` (Required, String) 55 | - `"http"` or `"https"`, depending on the request URI. 56 | - `:server-name` (Required, String) 57 | - The resolved server name or the server IP address. 58 | - `:server-port` (Required, Integer) 59 | - The port on which the request is being handled. 60 | - `:server-protocol` (Required, Keyword) 61 | - The version of the protocol the client used to send the request: typically `:HTTP/1.0` or `:HTTP/1.1`. 62 | - `:request-uri` (Required, String) 63 | - The request URI. Always starts with "/". 64 | - `:raw-body` (Optional, Stream) 65 | - The new body of the request. 66 | - `:remote-addr` (Required, String) 67 | - The remote address. 68 | - `:remote-port` (Required, Integer) 69 | - The remote port. 70 | - `:content-type` (Optional, String) 71 | - The header value of Content-Type. 72 | - `:content-length` (Optional, Integer) 73 | - The header value of Content-Length. 74 | - `:headers` (Required, Hash-Table) 75 | - A hash table of headers. 76 | 77 | ## The Response 78 | 79 | ### Normal response 80 | 81 | An application returns a list of three elements for a normal request, which respectively expresses an HTTP status code, headers, and response body data. 82 | 83 | ```common-lisp 84 | (lambda (env) 85 | (declare (ignore env)) 86 | '(200 (:content-type "text/plain") ("Hello, World"))) 87 | ``` 88 | 89 | 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). 90 | 91 | 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). 92 | 93 | The response body must be returned from the application in one of three formats, a list of strings, a byte vectors, or a pathname. 94 | 95 | ### Delayed Response and Streaming Body 96 | 97 | 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. 98 | 99 | To enable a delayed response, the application should return a callback as its response. 100 | 101 | ```common-lisp 102 | (lambda (env) 103 | (lambda (responder) 104 | (let ((content (fetch-something))) 105 | (funcall responder `(200 (:content-type "text/plain") (,content)))))) 106 | ``` 107 | 108 | 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 a body chunk, and optional `:start`, `:end` and `:close` keyword arguments. 109 | 110 | ```common-lisp 111 | (lambda (env) 112 | (lambda (responder) 113 | (let ((writer (funcall responder '(200 (:content-type "application/json"))))) 114 | (loop for chunk = (fetch-something) 115 | do (funcall writer chunk :close (null chunk)) 116 | while chunk)))) 117 | ``` 118 | 119 | In case of that you would prefer a stream to a function, `lack/util/writer-stream` wraps the function and allows you to treat it as a stream: 120 | 121 | ```common-lisp 122 | (import 'lack/util/writer-stream:make-writer-stream) 123 | 124 | (lambda (env) 125 | (lambda (responder) 126 | (let* ((writer (funcall responder '(200 (:content-type "application/json")))) 127 | (stream (make-writer-function writer))) 128 | (loop for chunk = (fetch-something) 129 | do (write-sequence chunk stream) 130 | while chunk 131 | finally 132 | (finish-output stream))))) 133 | ``` 134 | 135 | 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. 136 | 137 | ## Middlewares 138 | 139 | Lack middleware is a component wrapping an application. It is a function which takes an application and returns a new application. 140 | 141 | ```common-lisp 142 | (defvar *mw* 143 | (lambda (app) 144 | (lambda (env) 145 | ;; preprocessing 146 | (let ((res (funcall app env))) 147 | ;; postprocessing 148 | res)))) 149 | 150 | ;; getting a wrapped app 151 | (funcall *mw* *app*) 152 | ``` 153 | 154 | Lack provides some bundle middlewares. 155 | 156 | * Lack.Middleware.Accesslog 157 | * Lack.Middleware.Auth.Basic 158 | * Lack.Middleware.Backtrace 159 | * Lack.Middleware.Csrf 160 | * Lack.Middleware.Mount 161 | * Lack.Middleware.Session 162 | * Lack.Middleware.Static 163 | 164 | ```common-lisp 165 | ;; Using lack/middleware/accesslog 166 | (funcall lack/middleware/accesslog:*lack-middleware-accesslog* 167 | *app*) 168 | ``` 169 | 170 | ### Using Lack.Builder 171 | 172 | Lack.Builder gives you a quick DSL to wrap your application with Lack middlewares. 173 | 174 | ```common-lisp 175 | (lack:builder 176 | (:static :path (lambda (path) 177 | (if (ppcre:scan "^(?:/images/|/css/|/js/|/robot\\.txt$|/favicon.ico$)" path) 178 | path 179 | nil)) 180 | :root *static-directory*) 181 | :accesslog 182 | :session 183 | :backtrace 184 | (lambda (env) 185 | (declare (ignore env)) 186 | '(200 () ("Hello, World")))) 187 | ``` 188 | 189 | It takes a list of middlewares and an app at the last. 190 | 191 | ``` 192 | builder middleware* app 193 | 194 | middleware ::= keyword 195 | | null 196 | | symbol 197 | | function 198 | | (keyword arg*) 199 | | (symbol arg*) 200 | | normal-form 201 | 202 | app ::= function 203 | ``` 204 | 205 | Typical builder syntax is like this: 206 | 207 | ```common-lisp 208 | (lack:builder 209 | :foo 210 | (:bar :opt "val") 211 | *app*) 212 | ``` 213 | 214 | is syntactically equal to: 215 | 216 | ```common-lisp 217 | (funcall lack/middleware/foo:*lack-middleware-foo* 218 | (funcall lack/middleware/bar:*lack-middleware-bar* 219 | *app* 220 | :opt "val")) 221 | ``` 222 | 223 | ### Inline middleware 224 | 225 | ```common-lisp 226 | (lack:builder 227 | (lambda (app) 228 | (lambda (env) 229 | ;; preprocessing 230 | (let ((res (funcall app env))) 231 | ;; postprocessing 232 | res))) 233 | *app*) 234 | ``` 235 | 236 | ### Conditional middleware 237 | 238 | ```common-lisp 239 | (lack:builder 240 | (if (productionp) 241 | nil 242 | :accesslog) 243 | (if *error-log* 244 | `(:backtrace :output ,*error-log*) 245 | nil) 246 | :session 247 | *app*) 248 | ``` 249 | 250 | ## Session middleware table column names configuration 251 | 252 | If your session table cannot conform to the session middleware expectations, the session middleware column names need to be changed; two &key parameters exist to change them, namely `:data-column-name` and `:id-column-name`, 253 | 254 | ```common-lisp 255 | (lack:builder 256 | (:session 257 | :data-column-name "my_session_data_column" 258 | :id-column-name "my_id_column") 259 | *app*) 260 | ``` 261 | 262 | ## Using Lack in an existing Clack app 263 | 264 | Just replace `clack.builder:builder` by `lack:builder`, a superset of `clack.builder:builder`. 265 | 266 | ## Benchmark 267 | 268 | | Hunchentoot | Clack | Lack | 269 | |---------------|---------|---------| 270 | | 3384.15 | 3896.51 | 4252.68 | 271 | 272 | Lack is 1.25 times faster than Hunchentoot and 1.1 times faster than Clack. 273 | 274 | * MacBook Pro Retina, 13-inch, Early 2013 (CPU: 3GHz Intel Core i7 / Memory: 8GB 1600 MHz) 275 | * SBCL 1.2.6 276 | * wrk 3.1.1 277 | * Hunchentoot 1.2.29 278 | 279 | You can get the benchmark code at "[benchmark/](https://github.com/fukamachi/lack/tree/master/benchmark)". 280 | 281 | ### Hunchentoot 282 | 283 | ``` 284 | wrk -c 10 -t 4 -d 10 http://127.0.0.1:5000 285 | Running 10s test @ http://127.0.0.1:5000 286 | 4 threads and 10 connections 287 | Thread Stats Avg Stdev Max +/- Stdev 288 | Latency 1.32ms 8.92ms 78.41ms 98.62% 289 | Req/Sec 3.59k 0.93k 5.55k 73.51% 290 | 33857 requests in 10.00s, 7.62MB read 291 | Socket errors: connect 0, read 0, write 0, timeout 33 292 | Requests/sec: 3384.15 293 | Transfer/sec: 779.94KB 294 | ``` 295 | 296 | ### Clack 297 | 298 | ```common-lisp 299 | wrk -c 10 -t 4 -d 10 http://127.0.0.1:5000 300 | Running 10s test @ http://127.0.0.1:5000 301 | 4 threads and 10 connections 302 | Thread Stats Avg Stdev Max +/- Stdev 303 | Latency 3.52ms 23.39ms 170.24ms 98.07% 304 | Req/Sec 4.13k 768.76 4.67k 95.03% 305 | 38996 requests in 10.01s, 10.12MB read 306 | Socket errors: connect 0, read 0, write 0, timeout 33 307 | Requests/sec: 3896.51 308 | Transfer/sec: 1.01MB 309 | ``` 310 | 311 | ### Lack 312 | 313 | ```common-lisp 314 | wrk -c 10 -t 4 -d 10 http://127.0.0.1:5000 315 | Running 10s test @ http://127.0.0.1:5000 316 | 4 threads and 10 connections 317 | Thread Stats Avg Stdev Max +/- Stdev 318 | Latency 3.88ms 25.06ms 175.76ms 97.92% 319 | Req/Sec 4.52k 832.13 5.11k 94.92% 320 | 42601 requests in 10.02s, 11.01MB read 321 | Socket errors: connect 0, read 0, write 0, timeout 33 322 | Requests/sec: 4252.68 323 | Transfer/sec: 1.10MB 324 | ``` 325 | 326 | ## Author 327 | 328 | * Eitaro Fukamachi (e.arrows@gmail.com) 329 | 330 | ## Copyright 331 | 332 | Copyright (c) 2015 Eitaro Fukamachi & [contributors](https://github.com/fukamachi/lack/graphs/contributors) 333 | 334 | ## License 335 | 336 | Licensed under the MIT License. 337 | -------------------------------------------------------------------------------- /benchmark/clack.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (ql:quickload '(:clack :cl-ppcre)) 4 | 5 | (defpackage lack-benchmark.clack 6 | (:use :cl 7 | :clack.middleware.session 8 | :clack.middleware.static 9 | :clack.middleware.backtrace)) 10 | (in-package :lack-benchmark.clack) 11 | 12 | (clack:clackup 13 | (clack.builder:builder 14 | ( 15 | :path (lambda (path) 16 | (if (ppcre:scan "^(?:/images/|/css/|/js/|/robot\\.txt$|/favicon.ico$)" path) 17 | path 18 | nil)) 19 | :root (asdf:system-relative-pathname :lack #P"data/")) 20 | 21 | 22 | (lambda (env) 23 | (declare (ignore env)) 24 | '(200 (:content-type "text/plain; charset=utf-8") ("Hello, World")))) 25 | :server :hunchentoot 26 | :debug nil 27 | :use-thread nil 28 | :use-default-middlewares nil) 29 | -------------------------------------------------------------------------------- /benchmark/hunchentoot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (ql:quickload :hunchentoot) 4 | 5 | (defpackage lack-benchmark.hunchentoot 6 | (:use :cl 7 | :hunchentoot)) 8 | (in-package :lack-benchmark.hunchentoot) 9 | 10 | (setf *session-secret* "abcd") 11 | 12 | (define-easy-handler (index :uri "/") () 13 | (start-session) 14 | "Hello, World") 15 | 16 | (start (make-instance 'easy-acceptor 17 | :port 5000 18 | :access-log-destination nil 19 | :document-root (asdf:system-relative-pathname :lack #P"data/"))) 20 | -------------------------------------------------------------------------------- /benchmark/lack.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (ql:quickload '(:lack :clack)) 4 | 5 | (defpackage lack-benchmark.lack 6 | (:use :cl)) 7 | (in-package :lack-benchmark.lack) 8 | 9 | (clack:clackup 10 | (lack:builder 11 | (:static :path (lambda (path) 12 | (if (ppcre:scan "^(?:/images/|/css/|/js/|/robot\\.txt$|/favicon.ico$)" path) 13 | path 14 | nil)) 15 | :root (asdf:system-relative-pathname :lack #P"data/")) 16 | :backtrace 17 | :session 18 | (lambda (env) 19 | (declare (ignore env)) 20 | '(200 (:content-type "text/plain; charset=utf-8") ("Hello, World")))) 21 | :server :hunchentoot 22 | :debug nil 23 | :use-thread nil) 24 | -------------------------------------------------------------------------------- /data/file.txt: -------------------------------------------------------------------------------- 1 | This is a text for test. 2 | -------------------------------------------------------------------------------- /data/jellyfish.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/lack/9347d3ef830aabaa9e20969fea1dcdeeffc7e74c/data/jellyfish.jpg -------------------------------------------------------------------------------- /data/redhat.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/lack/9347d3ef830aabaa9e20969fea1dcdeeffc7e74c/data/redhat.png -------------------------------------------------------------------------------- /lack-app-directory.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-app-directory" 2 | :depends-on ("lack-app-file" 3 | "cl-ppcre" 4 | "trivial-rfc-1123" 5 | "trivial-mimes" 6 | "quri") 7 | :components ((:file "src/app/directory"))) 8 | 9 | (register-system-packages "lack-app-directory" '(:lack.app.directory)) 10 | -------------------------------------------------------------------------------- /lack-app-file.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-app-file" 2 | :depends-on ("lack-component" 3 | "trivial-mimes" 4 | "trivial-rfc-1123" 5 | "alexandria") 6 | :components ((:file "src/app/file"))) 7 | 8 | (register-system-packages "lack-app-file" '(:lack.app.file)) 9 | -------------------------------------------------------------------------------- /lack-component.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-component" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :components ((:file "src/component"))) 6 | 7 | (register-system-packages "lack-component" '(:lack.component)) 8 | -------------------------------------------------------------------------------- /lack-middleware-accesslog.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-accesslog" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-util" 6 | "local-time") 7 | :components ((:module "src" 8 | :components 9 | ((:file "middleware/accesslog"))))) 10 | 11 | (register-system-packages "lack-middleware-accesslog" '(:lack.middleware.accesslog)) 12 | -------------------------------------------------------------------------------- /lack-middleware-auth-basic.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-auth-basic" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("cl-base64" 6 | "split-sequence") 7 | :components ((:module "src" 8 | :components 9 | ((:file "middleware/auth/basic"))))) 10 | 11 | (register-system-packages "lack-middleware-auth-basic" '(:lack.middleware.auth.basic)) 12 | -------------------------------------------------------------------------------- /lack-middleware-backtrace.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-backtrace" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("uiop") 6 | :components ((:file "src/middleware/backtrace"))) 7 | 8 | (register-system-packages "lack-middleware-backtrace" '(:lack.middleware.backtrace)) 9 | -------------------------------------------------------------------------------- /lack-middleware-csrf.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-csrf" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-request" 6 | "lack-util") 7 | :components ((:module "src" 8 | :components 9 | ((:file "middleware/csrf"))))) 10 | 11 | (register-system-packages "lack-middleware-csrf" '(:lack.middleware.csrf)) 12 | -------------------------------------------------------------------------------- /lack-middleware-dbpool.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-dbpool" 2 | :version "0.1.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("dbi" 6 | "anypool") 7 | :components ((:file "src/middleware/dbpool"))) 8 | 9 | (register-system-packages "lack-middleware-dbpool" '(:lack.middleware.dbpool 10 | :lack/middleware/dbpool)) 11 | -------------------------------------------------------------------------------- /lack-middleware-mount.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-mount" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-component") 6 | :components ((:file "src/middleware/mount"))) 7 | 8 | (register-system-packages "lack-middleware-mount" '(:lack.middleware.mount)) 9 | -------------------------------------------------------------------------------- /lack-middleware-session.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-session" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-request" 6 | "lack-response" 7 | "lack-util" 8 | "bordeaux-threads" 9 | "cl-ppcre") 10 | :components ((:module "src/middleware" 11 | :components 12 | ((:file "session" :depends-on ("store" "state")) 13 | (:module "store" 14 | :pathname "session" 15 | :components 16 | ((:file "store") 17 | (:file "store/memory"))) 18 | (:module "state" 19 | :pathname "session" 20 | :components 21 | ((:file "state") 22 | (:file "state/cookie"))))))) 23 | 24 | (register-system-packages "lack-middleware-session" '(:lack.middleware.session)) 25 | -------------------------------------------------------------------------------- /lack-middleware-static.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-middleware-static" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-app-file" 6 | "lack-component" 7 | "alexandria") 8 | :components ((:module "src" 9 | :components 10 | ((:file "middleware/static"))))) 11 | 12 | (register-system-packages "lack-middleware-static" '(:lack.middleware.static)) 13 | -------------------------------------------------------------------------------- /lack-request.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-request" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("quri" 6 | "http-body" 7 | "circular-streams" 8 | "cl-ppcre") 9 | :components ((:module "src" 10 | :components 11 | ((:file "request" :depends-on ("media-type")) 12 | (:file "media-type"))))) 13 | 14 | (register-system-packages "lack-request" '(:lack.request)) 15 | -------------------------------------------------------------------------------- /lack-response.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-response" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("quri" 6 | "local-time") 7 | :components ((:file "src/response"))) 8 | 9 | (register-system-packages "lack-response" '(:lack.response)) 10 | -------------------------------------------------------------------------------- /lack-session-store-dbi.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-session-store-dbi" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-middleware-session" 6 | "dbi" 7 | "marshal" 8 | "trivial-utf-8" 9 | "cl-base64") 10 | :components ((:file "src/middleware/session/store/dbi"))) 11 | 12 | (register-system-packages "lack-session-store-dbi" '(:lack.session.store.dbi)) 13 | -------------------------------------------------------------------------------- /lack-session-store-redis.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-session-store-redis" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-middleware-session" 6 | "cl-redis" 7 | "marshal" 8 | "cl-base64" 9 | "trivial-utf-8") 10 | :components ((:file "src/middleware/session/store/redis"))) 11 | 12 | (register-system-packages "lack-session-store-redis" '(:lack.session.store.redis)) 13 | -------------------------------------------------------------------------------- /lack-test.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-test" 2 | :author "Eitaro Fukamachi" 3 | :license "MIT" 4 | :depends-on ("lack" 5 | "quri" 6 | "cl-cookie" 7 | "flexi-streams") 8 | :components ((:file "src/test"))) 9 | 10 | (register-system-packages "lack-test" '(:lack.test)) 11 | -------------------------------------------------------------------------------- /lack-util-writer-stream.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-util-writer-stream" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("trivial-gray-streams" 6 | "babel") 7 | :components ((:file "src/util/writer-stream"))) 8 | 9 | (register-system-packages "lack-util-writer-stream" '(:lack.util.writer-stream)) 10 | -------------------------------------------------------------------------------- /lack-util.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack-util" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ((:feature (:or :windows :mswindows :win32 :cormanlisp) "ironclad") 6 | (:feature (:not (:or :windows :mswindows :win32 :cormanlisp)) "cl-isaac") 7 | "bordeaux-threads") 8 | :components ((:file "src/util"))) 9 | 10 | (register-system-packages "lack-util" '(:lack.util)) 11 | -------------------------------------------------------------------------------- /lack.asd: -------------------------------------------------------------------------------- 1 | (defsystem "lack" 2 | :version "0.3.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack-component" 6 | "lack-util") 7 | :pathname "src" 8 | :components ((:file "lack" :depends-on ("builder")) 9 | (:file "builder")) 10 | :description "A minimal Clack" 11 | :in-order-to ((test-op (test-op "lack/tests")))) 12 | 13 | (defsystem "lack/app/directory" :depends-on ("lack-app-directory")) 14 | (defsystem "lack/app/file" :depends-on ("lack-app-file")) 15 | (defsystem "lack/component" :depends-on ("lack-component")) 16 | (defsystem "lack/middleware/accesslog" :depends-on ("lack-middleware-accesslog")) 17 | (defsystem "lack/middleware/auth/basic" :depends-on ("lack-middleware-auth-basic")) 18 | (defsystem "lack/middleware/backtrace" :depends-on ("lack-middleware-backtrace")) 19 | (defsystem "lack/middleware/csrf" :depends-on ("lack-middleware-csrf")) 20 | (defsystem "lack/middleware/dbpool" :depends-on ("lack-middleware-dbpool")) 21 | (defsystem "lack/middleware/mount" :depends-on ("lack-middleware-mount")) 22 | (defsystem "lack/middleware/session" :depends-on ("lack-middleware-session")) 23 | (defsystem "lack/middleware/static" :depends-on ("lack-middleware-static")) 24 | (defsystem "lack/request" :depends-on ("lack-request")) 25 | (defsystem "lack/response" :depends-on ("lack-response")) 26 | (defsystem "lack/session/store/dbi" :depends-on ("lack-session-store-dbi")) 27 | (defsystem "lack/session/store/redis" :depends-on ("lack-session-store-redis")) 28 | (defsystem "lack/test" :depends-on ("lack-test")) 29 | (defsystem "lack/util/writer/stream" :depends-on ("lack-util-writer-stream")) 30 | (defsystem "lack/util" :depends-on ("lack-util")) 31 | 32 | (defsystem "lack/tests" 33 | :depends-on ("lack" 34 | "lack/request" 35 | "lack/component" 36 | "lack/test" 37 | "lack/util" 38 | "lack/middleware/static" 39 | "lack/middleware/accesslog" 40 | "lack/middleware/session" 41 | "lack/middleware/mount" 42 | "lack/middleware/csrf" 43 | "lack/middleware/auth/basic" 44 | "lack/session/store/redis" 45 | "lack/session/store/dbi" 46 | "clack" 47 | "clack-test" 48 | "hunchentoot" 49 | "dexador" 50 | "cl-cookie" 51 | "flexi-streams" 52 | "dbi" 53 | "sqlite" 54 | "cl-ppcre" 55 | "cl-base64" 56 | "rove" 57 | "alexandria" 58 | "split-sequence") 59 | :pathname "tests" 60 | :serial t 61 | :components ((:file "builder") 62 | (:file "util") 63 | (:file "request") 64 | (:file "component") 65 | (:file "media-type") 66 | (:module "middleware" 67 | :components 68 | ((:file "static") 69 | (:file "session") 70 | (:file "mount") 71 | (:file "backtrace") 72 | (:file "csrf") 73 | (:file "auth/basic") 74 | (:file "accesslog"))) 75 | (:module "session" 76 | :components 77 | ((:module "store" 78 | :components 79 | ((:file "dbi") 80 | #+todo 81 | (:file "redis")))))) 82 | :perform (test-op (op c) (symbol-call :rove :run c))) 83 | -------------------------------------------------------------------------------- /qlfile: -------------------------------------------------------------------------------- 1 | github clack fukamachi/clack -------------------------------------------------------------------------------- /src/app/directory.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lack/app/directory 2 | (:nicknames #:lack.app.directory) 3 | (:use #:cl) 4 | (:import-from #:lack/app/file 5 | #:lack-app-file 6 | #:should-handle 7 | #:serve-path) 8 | (:import-from #:cl-ppcre 9 | #:regex-replace-all) 10 | (:import-from #:trivial-rfc-1123 11 | #:as-rfc-1123) 12 | (:import-from #:trivial-mimes 13 | #:mime-lookup) 14 | (:import-from #:quri 15 | #:url-encode) 16 | (:export #:lack-app-directory)) 17 | (in-package #:lack/app/directory) 18 | 19 | (defun html-encode (str) 20 | (ppcre:regex-replace-all 21 | "([&><\"'])" 22 | str 23 | #'(lambda (match &rest regs) 24 | (declare (ignore regs)) 25 | (cond 26 | ((string= "&" match) "&") 27 | ((string= ">" match) ">") 28 | ((string= "<" match) "<") 29 | ((string= "\"" match) """) 30 | ((string= "'" match) "'"))) 31 | :simple-calls t)) 32 | 33 | (defun dir-file (file &key uri name) 34 | (let* ((dir-p (uiop:directory-pathname-p file)) 35 | (uri (or uri 36 | (if dir-p 37 | (car (last (pathname-directory file))) 38 | (file-namestring file))))) 39 | (format nil "~A~A~:[--~;~:*~:D bytes~]~A~A" 40 | (quri:url-encode uri) 41 | (if dir-p "/" "") 42 | (html-encode (or name uri)) 43 | (if dir-p "/" "") 44 | (unless dir-p 45 | (with-open-file (in file) 46 | (file-length in))) 47 | (if dir-p 48 | "directory" 49 | (or (mime-lookup file) "text/plain")) 50 | (as-rfc-1123 (file-write-date file))))) 51 | 52 | (defun dir-page (path-info body) 53 | (format nil " 54 | Index of ~A 55 | 56 | 64 | 65 |

Index of ~:*~A

66 |
67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | ~A 75 |
NameSizeTypeLast Modified
76 |
77 | " 78 | (html-encode path-info) 79 | body)) 80 | 81 | (defun list-directory (dir) 82 | (sort (nconc (uiop:subdirectories dir) (uiop:directory-files dir)) 83 | #'string< 84 | :key (lambda (path) 85 | (if (uiop:directory-pathname-p path) 86 | (car (last (pathname-directory path))) 87 | (file-namestring path))))) 88 | 89 | (defclass lack-app-directory (lack-app-file) ()) 90 | 91 | (defmethod should-handle ((this lack-app-directory) file) 92 | (or (uiop:file-exists-p file) 93 | (uiop:directory-exists-p file))) 94 | 95 | (defun index-file-exists-p (path) 96 | (assert (uiop:directory-pathname-p path)) 97 | (or (uiop:file-exists-p (merge-pathnames #P"index.html" path)) 98 | (uiop:file-exists-p (merge-pathnames #P"index.htm" path)))) 99 | 100 | (defmethod serve-path ((app lack-app-directory) env file encoding) 101 | (if (uiop:directory-pathname-p file) 102 | (let ((index-file (index-file-exists-p file))) 103 | (if index-file 104 | (call-next-method app env index-file encoding) 105 | `(200 nil (,(dir-page 106 | (getf env :path-info) 107 | (format nil "~A~{~A~}" 108 | (dir-file (merge-pathnames "../" file) 109 | :uri ".." 110 | :name "Parent Directory") 111 | (mapcar #'dir-file (list-directory file)))))))) 112 | (call-next-method))) 113 | -------------------------------------------------------------------------------- /src/app/file.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lack/app/file 2 | (:nicknames #:lack.app.file) 3 | (:use #:cl) 4 | (:import-from #:lack/component 5 | #:lack-component 6 | #:call) 7 | (:import-from #:trivial-mimes 8 | #:mime) 9 | (:import-from #:trivial-rfc-1123 10 | #:parse-date 11 | #:as-rfc-1123) 12 | (:import-from #:uiop 13 | #:file-exists-p 14 | #:directory-exists-p) 15 | (:import-from #:alexandria 16 | #:starts-with-subseq) 17 | (:export #:lack-app-file 18 | #:should-handle 19 | #:serve-path)) 20 | (in-package #:lack/app/file) 21 | 22 | (define-condition bad-request (simple-condition) ()) 23 | (define-condition not-found (simple-condition) ()) 24 | 25 | (defclass lack-app-file (lack-component) 26 | ((file :initarg :file 27 | :initform nil) 28 | (root :initarg :root 29 | :initform #P"./") 30 | (encoding :initarg :encoding 31 | :initform "utf-8"))) 32 | 33 | (defmethod call ((app lack-app-file) env) 34 | (with-slots (file root encoding) app 35 | (handler-case 36 | (serve-path 37 | app 38 | env 39 | (locate-file app 40 | (or file 41 | ;; remove "/" 42 | (subseq (getf env :path-info) 1)) 43 | root) 44 | encoding) 45 | (bad-request () 46 | '(400 (:content-type "text/plain" 47 | :content-length 11) 48 | ("Bad Request"))) 49 | (not-found () 50 | '(404 (:content-type "text/plain" 51 | :content-length 9) 52 | ("Not Found")))))) 53 | 54 | (defgeneric should-handle (app file) 55 | (:method ((app lack-app-file) file) 56 | (and (ignore-errors 57 | ;; Ignore simple-file-error in a case that 58 | ;; the file path contains some special characters like "?". 59 | ;; See https://github.com/fukamachi/clack/issues/111 60 | (uiop:file-exists-p file)) 61 | (not (uiop:directory-exists-p file))))) 62 | 63 | (defgeneric locate-file (app path root) 64 | (:method ((app lack-app-file) path root) 65 | (when (find :up (pathname-directory path) :test #'eq) 66 | (error 'bad-request)) 67 | 68 | (let ((file (merge-pathnames path root))) 69 | (cond 70 | ((position #\Null (namestring file)) 71 | (error 'bad-request)) 72 | ((not (should-handle app file)) 73 | (error 'not-found)) 74 | (t file))))) 75 | 76 | (defgeneric serve-path (app env file encoding) 77 | (:method ((app lack-app-file) env file encoding) 78 | (let ((content-type (or (mimes:mime-lookup file) 79 | "application/octet-stream")) 80 | (file-modified-at (or (file-write-date file) 81 | (get-universal-time))) 82 | (if-modified-since (gethash "if-modified-since" (getf env :headers)))) 83 | (when (and if-modified-since 84 | (<= file-modified-at (parse-date if-modified-since))) 85 | (return-from serve-path 86 | '(304 () ()))) 87 | (when (starts-with-subseq "text" content-type) 88 | (setf content-type 89 | (format nil "~A~:[~;~:*; charset=~A~]" 90 | content-type encoding))) 91 | (with-open-file (stream file 92 | :direction :input 93 | :if-does-not-exist nil) 94 | `(200 95 | (:content-type ,content-type 96 | :content-length ,(file-length stream) 97 | :last-modified 98 | ,(as-rfc-1123 file-modified-at)) 99 | ,file))))) 100 | -------------------------------------------------------------------------------- /src/builder.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/builder 2 | (:nicknames :lack.builder) 3 | (:use :cl) 4 | (:import-from :lack/component 5 | :to-app) 6 | (:import-from :lack/util 7 | :find-middleware) 8 | (:export :builder)) 9 | (in-package :lack/builder) 10 | 11 | (defun clack-middleware-symbol-p (symbol) 12 | (and (symbolp symbol) 13 | (find-package :clack.middleware) 14 | (find-class symbol nil) 15 | (subtypep (find-class symbol) 16 | (intern (string :) 17 | :clack.middleware)))) 18 | 19 | (defun convert-to-middleware-form (mw) 20 | (let ((app (gensym "APP")) 21 | (res-mw (gensym "RES-MW"))) 22 | (etypecase mw 23 | (null) 24 | (function mw) 25 | (keyword `(find-middleware ,mw)) 26 | ;; for old Clack middlewares 27 | (symbol (if (clack-middleware-symbol-p mw) 28 | `(lambda (,app) 29 | (funcall (intern (string :wrap) :clack.middleware) 30 | (make-instance ',mw) 31 | ,app)) 32 | mw)) 33 | (cons 34 | (typecase (car mw) 35 | (keyword `(lambda (,app) 36 | (funcall (find-middleware ,(car mw)) ,app 37 | ,@(cdr mw)))) 38 | (symbol 39 | ;; for old Clack middlewares 40 | (if (clack-middleware-symbol-p (car mw)) 41 | `(lambda (,app) 42 | (funcall (intern (string :wrap) :clack.middleware) 43 | (make-instance ',(car mw) ,@(cdr mw)) 44 | ,app)) 45 | ;; Normal form 46 | (let ((res (gensym "RES"))) 47 | ;; reconvert the result of the form 48 | `(let ((,res ,mw)) 49 | (typecase ,res 50 | (keyword (find-middleware ,res)) 51 | (cons (if (keywordp (car ,res)) 52 | (let ((,res-mw (find-middleware (car ,res)))) 53 | (lambda (,app) 54 | (apply ,res-mw ,app (cdr ,res)))) 55 | ,res)) 56 | (standard-object 57 | (lambda (,app) 58 | (funcall (intern (string :wrap) :clack.middleware) ,res ,app))) 59 | (otherwise ,res)))))) 60 | (otherwise mw)))))) 61 | 62 | (defmacro builder (&rest app-or-middlewares) 63 | (let ((middlewares (butlast app-or-middlewares))) 64 | `(reduce #'funcall 65 | (remove-if 66 | #'null 67 | (list 68 | ,@(loop for mw in middlewares 69 | when mw 70 | collect (convert-to-middleware-form mw)))) 71 | :initial-value (to-app ,(car (last app-or-middlewares))) 72 | :from-end t))) 73 | -------------------------------------------------------------------------------- /src/component.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/component 2 | (:nicknames :lack.component) 3 | (:use :cl) 4 | (:export :lack-component 5 | :call 6 | :to-app)) 7 | (in-package :lack/component) 8 | 9 | (defclass lack-component () ()) 10 | 11 | (defgeneric call (component env) 12 | (:method ((component function) env) 13 | (funcall component env))) 14 | 15 | (defgeneric to-app (component) 16 | (:method ((component lack-component)) 17 | (lambda (env) (call component env))) 18 | (:method ((component t)) 19 | component)) 20 | -------------------------------------------------------------------------------- /src/lack.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack 2 | (:use :cl) 3 | (:import-from :lack/builder 4 | :builder) 5 | (:export :builder)) 6 | (in-package :lack) 7 | -------------------------------------------------------------------------------- /src/media-type.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/media-type 2 | (:nicknames :lack.media-type) 3 | (:use :cl) 4 | (:import-from :quri 5 | :url-decode-params) 6 | (:import-from :cl-ppcre 7 | :split) 8 | (:export :media-type 9 | :make-media-type 10 | :media-type-main-type 11 | :media-type-sub-type 12 | :media-type-params 13 | :match-media-type)) 14 | (in-package :lack/media-type) 15 | 16 | (defstruct (media-type (:constructor %make-media-type)) 17 | (main-type nil :type (or null string)) 18 | (sub-type nil :type (or null string)) 19 | (params nil :type list)) 20 | 21 | (defun make-media-type (media-type-string) 22 | (let* ((media-type-pair (ppcre:split "\\s*[;]\\s*" media-type-string)) 23 | (media-type (ppcre:split "\\s*[/]\\s*" (first media-type-pair))) 24 | (params (if (second media-type-pair) 25 | (quri:url-decode-params (second media-type-pair)) 26 | nil))) 27 | (%make-media-type :main-type (first media-type) 28 | :sub-type (second media-type) 29 | :params params))) 30 | 31 | (defun match-media-type (request-media-type other-media-type) 32 | (with-slots ((request-main-type main-type) (request-sub-type sub-type)) request-media-type 33 | (with-slots ((other-main-type main-type) (other-sub-type sub-type)) other-media-type 34 | (cond ((and (string= request-main-type "*") 35 | (string= request-sub-type "*")) 36 | t) 37 | ((and (string= request-main-type other-main-type) 38 | (member request-sub-type (list "*" other-sub-type) :test #'string=)) 39 | t) 40 | (t nil))))) 41 | -------------------------------------------------------------------------------- /src/middleware/accesslog.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/accesslog 2 | (:nicknames :lack.middleware.accesslog) 3 | (:use :cl) 4 | (:import-from :lack/util 5 | :funcall-with-cb 6 | :content-length) 7 | (:import-from :local-time 8 | :format-timestring 9 | :now) 10 | (:export :*lack-middleware-accesslog* 11 | :*time-format* 12 | :default-formatter)) 13 | (in-package :lack/middleware/accesslog) 14 | 15 | (defparameter *lack-middleware-accesslog* 16 | (let ((no-body '#:no-body)) 17 | (lambda (app &key 18 | (logger 19 | (lambda (output) (format t "~&~A~%" output))) 20 | (formatter #'default-formatter)) 21 | (lambda (env) 22 | (funcall-with-cb 23 | app env 24 | (lambda (res) 25 | (funcall logger 26 | (funcall formatter env res (now))) 27 | res))))) 28 | "Middleware for logging requests") 29 | 30 | (defvar *time-format* 31 | '((:day 2) #\/ :short-month #\/ (:year 4) #\: (:hour 2) #\: (:min 2) #\: (:sec 2) #\Space :gmt-offset)) 32 | 33 | (defun default-formatter (env res now) 34 | (format nil "~A - [~A] \"~A ~A ~A\" ~A ~A \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"" 35 | (getf env :remote-addr) 36 | (local-time:format-timestring nil now :format *time-format*) 37 | (getf env :request-method) 38 | (getf env :request-uri) 39 | (getf env :server-protocol) 40 | (car res) 41 | (content-length res) 42 | (gethash "referer" (getf env :headers)) 43 | (gethash "user-agent" (getf env :headers)))) 44 | -------------------------------------------------------------------------------- /src/middleware/auth/basic.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/auth/basic 2 | (:nicknames :lack.middleware.auth.basic) 3 | (:use :cl) 4 | (:import-from :cl-base64 5 | :base64-string-to-string) 6 | (:import-from :split-sequence 7 | :split-sequence)) 8 | (in-package :lack/middleware/auth/basic) 9 | 10 | (defparameter *lack-middleware-auth-basic* 11 | (lambda (app &key authenticator (realm "restricted area")) 12 | (unless authenticator 13 | (error ":authenticator is required in lack-middleware-auth-basic")) 14 | (check-type authenticator function) 15 | (lambda (env) 16 | (block nil 17 | (let ((authorization (gethash "authorization" (getf env :headers)))) 18 | (unless authorization 19 | (return (return-401 realm))) 20 | 21 | (destructuring-bind (user &optional (pass "")) 22 | (parse-authorization-header authorization) 23 | (if user 24 | (multiple-value-bind (result returned-user) 25 | (funcall authenticator user pass) 26 | (if result 27 | (progn 28 | (setf (getf env :remote-user) 29 | (or returned-user user)) 30 | (funcall app env)) 31 | (return-401 realm))) 32 | (return-401 realm))))))) 33 | "Middleware for Basic Authentication") 34 | 35 | (defun return-401 (realm) 36 | `(401 37 | (:content-type "text/plain" 38 | :content-length 22 39 | :www-authenticate ,(format nil "Basic realm=~A" realm)) 40 | ("Authorization required"))) 41 | 42 | (defun parse-authorization-header (authorization) 43 | (when (string= authorization "Basic " :end1 6) 44 | (let ((user-and-pass (base64-string-to-string (subseq authorization 6)))) 45 | (split-sequence #\: user-and-pass)))) 46 | -------------------------------------------------------------------------------- /src/middleware/backtrace.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/backtrace 2 | (:nicknames :lack.middleware.backtrace) 3 | (:use :cl) 4 | (:import-from :uiop/image 5 | :print-condition-backtrace) 6 | (:export :*lack-middleware-backtrace*)) 7 | (in-package :lack/middleware/backtrace) 8 | 9 | (defparameter *lack-middleware-backtrace* 10 | (lambda (app &key 11 | (output '*error-output*) 12 | result-on-error) 13 | (check-type output (or symbol stream pathname string)) 14 | (check-type result-on-error (or function cons null)) 15 | (flet ((error-handler (condition) 16 | (if (functionp result-on-error) 17 | (funcall result-on-error condition) 18 | result-on-error)) 19 | (output-backtrace (condition env) 20 | (etypecase output 21 | (symbol (print-error condition env (symbol-value output))) 22 | (stream (print-error condition env output)) 23 | ((or pathname string) 24 | (ensure-directories-exist output) 25 | (with-open-file (out output 26 | :direction :output 27 | :external-format #+clisp charset:utf-8 #-clisp :utf-8 28 | :if-exists :append 29 | :if-does-not-exist :create) 30 | (print-error condition env out)))))) 31 | (lambda (env) 32 | (block nil 33 | (handler-bind ((error (lambda (condition) 34 | (output-backtrace condition env) 35 | (when result-on-error 36 | (return (error-handler condition)))))) 37 | (funcall app env)))))) 38 | "Middleware for outputting backtraces when an error occured") 39 | 40 | (defun print-error (error env &optional (stream *error-output*)) 41 | (print-condition-backtrace error :stream stream) 42 | (format stream "~2&Request:~%") 43 | (loop for (k v) on env by #'cddr 44 | if (hash-table-p v) do 45 | (format stream "~& ~A:~%" k) 46 | (maphash (lambda (k v) 47 | (format stream "~& ~A: ~S~%" 48 | k v)) 49 | v) 50 | else do 51 | (format stream 52 | "~& ~A: ~S~%" 53 | k v)) 54 | (values)) 55 | -------------------------------------------------------------------------------- /src/middleware/csrf.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/csrf 2 | (:nicknames :lack.middleware.csrf) 3 | (:use :cl) 4 | (:import-from :lack.request 5 | :make-request 6 | :request-body-parameters) 7 | (:import-from :lack.util 8 | :generate-random-id) 9 | (:export :*lack-middleware-csrf* 10 | :csrf-token 11 | :csrf-html-tag)) 12 | (in-package :lack/middleware/csrf) 13 | 14 | (defvar *csrf-session-key*) 15 | (defvar *csrf-middleware-token*) 16 | 17 | (defparameter *lack-middleware-csrf* 18 | (lambda (app &key (block-app #'return-400) one-time 19 | (session-key "_csrf_token") 20 | (form-token "_csrf_token")) 21 | (lambda (env) 22 | (let ((*csrf-session-key* session-key) 23 | (*csrf-middleware-token* form-token)) 24 | (block nil 25 | (unless (danger-method-p (getf env :request-method)) 26 | (return (funcall app env))) 27 | 28 | (let ((session (getf env :lack.session))) 29 | (unless session 30 | (error ":lack.session is missing in ENV. Wrap this app up with lack.middleware.session")) 31 | 32 | (if (valid-token-p env) 33 | (progn 34 | (when one-time 35 | (remhash *csrf-session-key* session)) 36 | (funcall app env)) 37 | (funcall block-app env))))))) 38 | "Middleware for easy CSRF protection") 39 | 40 | (defun return-400 (env) 41 | (declare (ignore env)) 42 | '(400 43 | (:content-type "text/plain" 44 | :content-length 31) 45 | ("Bad Request: invalid CSRF token"))) 46 | 47 | (defun danger-method-p (request-method) 48 | (member request-method 49 | '(:POST :PUT :DELETE :PATCH) 50 | :test #'eq)) 51 | 52 | (defun valid-token-p (env) 53 | (let ((req (make-request env)) 54 | (csrf-token (gethash *csrf-session-key* 55 | (getf env :lack.session)))) 56 | (and csrf-token 57 | (let ((received-csrf-token 58 | (cdr (assoc *csrf-middleware-token* (request-body-parameters req) :test #'string=)))) 59 | ;; for multipart/form-data 60 | (when (listp received-csrf-token) 61 | (setf received-csrf-token (first received-csrf-token))) 62 | (equal csrf-token received-csrf-token))))) 63 | 64 | (defun csrf-token (session) 65 | (unless (gethash *csrf-session-key* session) 66 | (setf (gethash *csrf-session-key* session) (generate-random-id))) 67 | (gethash *csrf-session-key* session)) 68 | 69 | (defun csrf-html-tag (session) 70 | (format nil "" 71 | *csrf-middleware-token* 72 | (csrf-token session))) 73 | -------------------------------------------------------------------------------- /src/middleware/dbpool.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lack/middleware/dbpool 2 | (:use #:cl) 3 | (:nicknames #:lack.middleware.dbpool) 4 | (:import-from #:dbi 5 | #:connect 6 | #:disconnect 7 | #:ping) 8 | (:import-from #:anypool 9 | #:make-pool 10 | #:too-many-open-connection) 11 | (:export #:*lack-middleware-dbpool* 12 | #:with-connection)) 13 | (in-package #:lack/middleware/dbpool) 14 | 15 | (defparameter *connection-pool-storage* 16 | (make-hash-table :test 'eq)) 17 | 18 | (defun make-connection-pool (connect-args pool-args) 19 | (apply #'anypool:make-pool 20 | :connector (lambda () (apply #'dbi:connect connect-args)) 21 | :disconnector #'dbi:disconnect 22 | :ping #'dbi:ping 23 | pool-args)) 24 | 25 | (defun get-connection-pool (database-id) 26 | (or (gethash database-id *connection-pool-storage*) 27 | (error "No connection pool found for ~S" database-id))) 28 | 29 | (defmacro with-connection ((var database-id) &body body) 30 | (let ((e (gensym "E"))) 31 | `(block nil 32 | (handler-bind ((anypool:too-many-open-connection 33 | (lambda (,e) 34 | (declare (ignore ,e)) 35 | (return '(503 (:content-type "text/plain") ("Service Temporarily Unavailable")))))) 36 | (anypool:with-connection (,var (get-connection-pool ,database-id)) 37 | ,@body))))) 38 | 39 | (defparameter *lack-middleware-dbpool* 40 | (lambda (app database-id &key connect-args pool-args) 41 | (check-type database-id symbol) 42 | (assert connect-args) 43 | (let ((pool (make-connection-pool connect-args pool-args))) 44 | (setf (gethash database-id *connection-pool-storage*) pool) 45 | (lambda (env) 46 | (funcall app env))))) 47 | -------------------------------------------------------------------------------- /src/middleware/mount.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/mount 2 | (:nicknames :lack.middleware.mount) 3 | (:use :cl) 4 | (:import-from :lack/component 5 | :to-app) 6 | (:export :*lack-middleware-mount*)) 7 | (in-package :lack/middleware/mount) 8 | 9 | (defparameter *lack-middleware-mount* 10 | (lambda (app path mount-app) 11 | (let ((len (length path))) 12 | (lambda (env) 13 | (let ((path-info (getf env :path-info))) 14 | (cond 15 | ((string= path-info path) 16 | (setf (getf env :path-info) "/") 17 | (funcall (to-app mount-app) env)) 18 | ((and (< len (length path-info)) 19 | (string= path-info path :end1 len) 20 | (char= (aref path-info len) #\/)) 21 | (setf (getf env :path-info) 22 | (subseq path-info (length path))) 23 | (funcall (to-app mount-app) env)) 24 | (t 25 | (funcall app env))))))) 26 | "Middleware for attaching another Lack application on a specific URL") 27 | -------------------------------------------------------------------------------- /src/middleware/session.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/session 2 | (:nicknames :lack.middleware.session) 3 | (:use :cl) 4 | (:import-from :lack/session/store 5 | :fetch-session 6 | :store-session 7 | :remove-session) 8 | (:import-from :lack/session/state 9 | :expire-state 10 | :extract-sid 11 | :finalize-state 12 | :generate-sid) 13 | (:import-from :lack/middleware/session/store/memory 14 | :make-memory-store) 15 | (:import-from :lack/middleware/session/state/cookie 16 | :make-cookie-state) 17 | (:export :*lack-middleware-session*)) 18 | (in-package :lack/middleware/session) 19 | 20 | (defparameter *lack-middleware-session* 21 | (lambda (app &key 22 | (store (make-memory-store)) 23 | (state (make-cookie-state)) 24 | (keep-empty t)) 25 | (lambda (env) 26 | (let* ((sid (extract-sid state env)) 27 | (session (and sid 28 | (fetch-session store sid))) 29 | (sid (or sid 30 | (generate-sid state env))) 31 | (new-session-p (not session)) 32 | (session (or session (make-hash-table :test 'equal)))) 33 | (setf (getf env :lack.session) session) 34 | (setf (getf env :lack.session.options) 35 | (if new-session-p 36 | (list :id sid :new-session t :change-id nil :expire nil) 37 | (list :id sid :new-session nil :change-id nil :expire nil))) 38 | (let ((res (funcall app env)) 39 | (process-session (lambda (result) 40 | (if (and (not keep-empty) 41 | new-session-p 42 | (zerop (hash-table-count session))) 43 | result 44 | (finalize store state env result))))) 45 | (typecase res 46 | (function (lambda (responder) 47 | (funcall res (lambda (result) 48 | (funcall responder (funcall process-session result)))))) 49 | (t (funcall process-session res))))))) 50 | "Middleware for session management") 51 | 52 | (defun finalize (store state env res) 53 | (let* ((session (getf env :lack.session)) 54 | (options (getf env :lack.session.options)) 55 | (id (getf options :id)) 56 | (new-id (if (getf options :change-id) 57 | (generate-sid state env) 58 | id))) 59 | (when session 60 | (apply #'commit store new-id session options)) 61 | (if (getf options :expire) 62 | (expire-state state id res options) 63 | (finalize-state state new-id res options)))) 64 | 65 | (defun commit (store new-sid session &key id expire change-id &allow-other-keys) 66 | (cond 67 | (expire 68 | (remove-session store id)) 69 | (change-id 70 | (remove-session store id) 71 | (store-session store new-sid session)) 72 | (t 73 | (store-session store id session)))) 74 | -------------------------------------------------------------------------------- /src/middleware/session/state.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/session/state 2 | (:nicknames :lack.middleware.session.state 3 | :lack.session.state 4 | :lack/session/state) 5 | (:use :cl) 6 | (:import-from :lack/util 7 | :generate-random-id) 8 | (:import-from :cl-ppcre 9 | :scan) 10 | (:export :state 11 | :make-state 12 | :generate-sid 13 | :extract-sid 14 | :expire-state 15 | :finalize-state)) 16 | (in-package :lack/middleware/session/state) 17 | 18 | (defstruct state 19 | (sid-generator (lambda (env) 20 | (declare (ignore env)) 21 | (generate-random-id))) 22 | (sid-validator (lambda (sid) 23 | (not (null (ppcre:scan "\\A[0-9a-f]{40}\\Z" sid)))))) 24 | 25 | (defun generate-sid (state env) 26 | (funcall (state-sid-generator state) env)) 27 | 28 | (defgeneric extract-sid (state env)) 29 | (defmethod extract-sid :around ((state state) env) 30 | (let ((sid (call-next-method))) 31 | (when (and sid 32 | (funcall (state-sid-validator state) sid)) 33 | sid))) 34 | 35 | (defgeneric expire-state (state sid res options)) 36 | 37 | (defgeneric finalize-state (state sid res options)) 38 | -------------------------------------------------------------------------------- /src/middleware/session/state/cookie.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/session/state/cookie 2 | (:nicknames :lack.middleware.session.state.cookie 3 | :lack.session.state.cookie 4 | :lack/session/state/cookie) 5 | (:use :cl 6 | :lack/middleware/session/state) 7 | (:import-from :lack/request 8 | :make-request 9 | :request-cookies) 10 | (:import-from :lack/response 11 | :make-response 12 | :finalize-response 13 | :response-set-cookies) 14 | (:export :cookie-state 15 | :make-cookie-state 16 | :generate-sid 17 | :extract-sid 18 | :expire-state 19 | :finalize-session)) 20 | (in-package :lack/middleware/session/state/cookie) 21 | 22 | (defstruct (cookie-state (:include state)) 23 | (path "/" :type string) 24 | (domain nil :type (or string null)) 25 | (expires (get-universal-time) :type integer) 26 | (secure nil :type boolean) 27 | (httponly nil :type boolean) 28 | (cookie-key "lack.session" :type string) 29 | (samesite :lax :type keyword)) 30 | 31 | (defmethod extract-sid ((state cookie-state) env) 32 | (let ((req (make-request env))) 33 | (cdr (assoc (cookie-state-cookie-key state) 34 | (request-cookies req) :test #'string=)))) 35 | 36 | (defmethod expire-state ((state cookie-state) sid res options) 37 | (setf (getf options :expires) 0) 38 | (finalize-state state sid res options)) 39 | 40 | (defmethod finalize-state ((state cookie-state) sid (res function) options) 41 | (lambda (responder) 42 | (funcall res (lambda (actual-res) 43 | (funcall responder (finalize-state state sid actual-res options)))))) 44 | 45 | (defmethod finalize-state ((state cookie-state) sid (res list) options) 46 | ;; Don't send Set-Cookie header when it's not necessary. 47 | (destructuring-bind (&key no-store new-session change-id expire &allow-other-keys) 48 | options 49 | (when (or no-store 50 | (not (or new-session change-id expire))) 51 | (return-from finalize-state res))) 52 | 53 | (let ((res (apply #'make-response res)) 54 | (options (with-slots (path domain expires secure httponly samesite) state 55 | (list :path path 56 | :domain domain 57 | :secure secure 58 | :httponly httponly 59 | :samesite samesite 60 | :expires (+ (get-universal-time) 61 | (getf options :expires expires)))))) 62 | (setf (getf (response-set-cookies res) (cookie-state-cookie-key state)) 63 | `(:value ,sid ,@options)) 64 | (finalize-response res))) 65 | -------------------------------------------------------------------------------- /src/middleware/session/store.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/session/store 2 | (:nicknames :lack.middleware.session.store 3 | :lack.session.store 4 | :lack/session/store) 5 | (:use :cl) 6 | (:export :store 7 | :fetch-session 8 | :store-session 9 | :remove-session)) 10 | (in-package :lack/middleware/session/store) 11 | 12 | (defstruct store) 13 | 14 | (defgeneric fetch-session (store sid)) 15 | (defgeneric store-session (store sid session)) 16 | (defgeneric remove-session (store sid)) 17 | -------------------------------------------------------------------------------- /src/middleware/session/store/dbi.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/session/store/dbi 2 | (:nicknames :lack.middleware.session.store.dbi 3 | :lack.session.store.dbi 4 | :lack/session/store/dbi) 5 | (:use :cl 6 | :lack/middleware/session/store) 7 | (:import-from :marshal 8 | :marshal 9 | :unmarshal) 10 | (:import-from :cl-base64 11 | :base64-string-to-usb8-array 12 | :usb8-array-to-base64-string) 13 | (:import-from :trivial-utf-8 14 | :string-to-utf-8-bytes 15 | :utf-8-bytes-to-string) 16 | (:export :dbi-store 17 | :make-dbi-store 18 | :fetch-session 19 | :store-session 20 | :remove-session)) 21 | (in-package :lack/middleware/session/store/dbi) 22 | 23 | 24 | (defmacro with-db-connection (connection store &body body) 25 | `(let ((,connection (funcall (dbi-store-connector ,store)))) 26 | (unwind-protect 27 | (progn ,@body) 28 | (when (dbi-store-disconnector ,store) 29 | (funcall (dbi-store-disconnector ,store) ,connection))))) 30 | 31 | (defstruct (dbi-store (:include store)) 32 | (connector nil :type function) 33 | (disconnector nil) 34 | (serializer (lambda (data) 35 | (usb8-array-to-base64-string 36 | (string-to-utf-8-bytes (prin1-to-string (marshal data)))))) 37 | (deserializer (lambda (data) 38 | (unmarshal (read-from-string 39 | (utf-8-bytes-to-string (base64-string-to-usb8-array data)))))) 40 | (record-timestamps nil :type boolean) 41 | (table-name "sessions") 42 | (data-column-name "session_data") 43 | (id-column-name "id")) 44 | 45 | (defmethod fetch-session ((store dbi-store) sid) 46 | (with-db-connection conn store 47 | (let* ((query (dbi:prepare conn 48 | (format nil "SELECT ~A FROM ~A WHERE ~A = ?" 49 | (dbi-store-data-column-name store) 50 | (dbi-store-table-name store) 51 | (dbi-store-id-column-name store)))) 52 | (result (dbi:fetch (dbi:execute query (list sid))))) 53 | (if result 54 | (handler-case (funcall (dbi-store-deserializer store) (getf result :|session_data|)) 55 | (error (e) 56 | (warn "Error (~A) occured while deserializing a session. Ignoring.~2% Data:~% ~A~2% Error:~% ~A" 57 | (class-name (class-of e)) 58 | (getf result :|session_data|) 59 | e) 60 | nil)) 61 | nil)))) 62 | 63 | (defun current-timestamp () 64 | (multiple-value-bind (sec min hour date month year) 65 | (decode-universal-time (get-universal-time)) 66 | (format nil "~D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D" 67 | year month date 68 | hour min sec))) 69 | 70 | (defmethod store-session ((store dbi-store) sid session) 71 | (with-db-connection conn store 72 | (let ((serialized-session (funcall (dbi-store-serializer store) session))) 73 | (dbi:with-transaction conn 74 | (let* ((query (dbi:prepare conn 75 | (format nil "SELECT ~A FROM ~A WHERE ~A = ?" 76 | (dbi-store-data-column-name store) 77 | (dbi-store-table-name store) 78 | (dbi-store-id-column-name store)))) 79 | (current-session (getf (dbi:fetch (dbi:execute query (list sid))) :|session_data|))) 80 | (cond 81 | ;; Session exists but not changed 82 | ((equal current-session serialized-session)) 83 | ;; Session exists and is going to be changed 84 | (current-session 85 | (dbi:do-sql conn 86 | (format nil "UPDATE ~A SET ~A = ?~:[~*~;, updated_at = '~A'~] WHERE ~A = ?" 87 | (dbi-store-table-name store) 88 | (dbi-store-data-column-name store) 89 | (dbi-store-record-timestamps store) 90 | (current-timestamp) 91 | (dbi-store-id-column-name store)) 92 | (list serialized-session sid))) 93 | ;; New session 94 | (t 95 | (dbi:do-sql conn (format nil "INSERT INTO ~A (~A, ~A~:[~;, created_at, updated_at~]) VALUES (?, ?~:*~:[~*~;, '~A', ~:*'~A'~])" 96 | (dbi-store-table-name store) 97 | (dbi-store-id-column-name store) 98 | (dbi-store-data-column-name store) 99 | (dbi-store-record-timestamps store) 100 | (current-timestamp)) 101 | (list sid serialized-session))))))))) 102 | 103 | (defmethod remove-session ((store dbi-store) sid) 104 | (with-db-connection conn store 105 | (dbi:do-sql conn 106 | (format nil "DELETE FROM ~A WHERE ~A = ?" 107 | (dbi-store-table-name store) 108 | (dbi-store-id-column-name store)) 109 | (list sid)))) 110 | -------------------------------------------------------------------------------- /src/middleware/session/store/memory.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/session/store/memory 2 | (:nicknames :lack.middleware.session.store.memory 3 | :lack.session.store.memory 4 | :lack/session/store/memory) 5 | (:use :cl 6 | :lack/middleware/session/store) 7 | (:export :memory-store 8 | :make-memory-store 9 | :fetch-session 10 | :store-session 11 | :remove-session)) 12 | (in-package :lack/middleware/session/store/memory) 13 | 14 | (defstruct (memory-store (:include store)) 15 | (stash (make-hash-table :test 'equal)) 16 | (lock (bordeaux-threads-2:make-lock :name "session store lock"))) 17 | 18 | (defmethod fetch-session ((store memory-store) sid) 19 | (bordeaux-threads-2:with-lock-held ((memory-store-lock store)) 20 | (gethash sid (memory-store-stash store)))) 21 | 22 | (defmethod store-session ((store memory-store) sid session) 23 | (bordeaux-threads-2:with-lock-held ((memory-store-lock store)) 24 | (setf (gethash sid (memory-store-stash store)) 25 | session))) 26 | 27 | (defmethod remove-session ((store memory-store) sid) 28 | (bordeaux-threads-2:with-lock-held ((memory-store-lock store)) 29 | (remhash sid (memory-store-stash store)))) 30 | -------------------------------------------------------------------------------- /src/middleware/session/store/redis.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/session/store/redis 2 | (:nicknames :lack.middleware.session.store.redis 3 | :lack.session.store.redis 4 | :lack/session/store/redis) 5 | (:use :cl 6 | :lack/middleware/session/store) 7 | (:import-from :marshal 8 | :marshal 9 | :unmarshal) 10 | (:import-from :cl-base64 11 | :base64-string-to-usb8-array 12 | :usb8-array-to-base64-string) 13 | (:import-from :trivial-utf-8 14 | :string-to-utf-8-bytes 15 | :utf-8-bytes-to-string) 16 | (:export :redis-store 17 | :make-redis-store 18 | :fetch-session 19 | :store-session 20 | :remove-session)) 21 | (in-package :lack/middleware/session/store/redis) 22 | 23 | (defun open-connection (&key host port auth) 24 | (make-instance 'redis:redis-connection 25 | :host host 26 | :port port 27 | :auth auth)) 28 | 29 | (defstruct (redis-store (:include store) 30 | (:constructor %make-redis-store)) 31 | (host "127.0.0.1") 32 | (port 6379) 33 | (auth nil :type (or null string)) 34 | (namespace "session" :type string) 35 | (expires nil :type (or null integer)) 36 | (serializer (lambda (data) 37 | (usb8-array-to-base64-string 38 | (string-to-utf-8-bytes (prin1-to-string (marshal data)))))) 39 | (deserializer (lambda (data) 40 | (unmarshal (read-from-string 41 | (utf-8-bytes-to-string (base64-string-to-usb8-array data)))))) 42 | 43 | connection) 44 | 45 | (defun make-redis-store (&rest args &key (host "127.0.0.1") (port 6379) auth connection namespace expires serializer deserializer) 46 | (declare (ignore namespace expires serializer deserializer)) 47 | (if connection 48 | (setf (getf args :host) (redis::conn-host connection) 49 | (getf args :port) (redis::conn-port connection) 50 | (getf args :auth) (redis::conn-auth connection)) 51 | (setf (getf args :connection) 52 | (open-connection :host host :port port :auth auth))) 53 | (apply #'%make-redis-store args)) 54 | 55 | (defun redis-connection (store) 56 | (check-type store redis-store) 57 | (with-slots (host port auth connection) store 58 | (unless (redis::connection-open-p connection) 59 | (setf connection 60 | (open-connection :host host :port port :auth auth))) 61 | connection)) 62 | 63 | (defmacro with-connection (store &body body) 64 | `(let ((redis::*connection* (redis-connection ,store))) 65 | ,@body)) 66 | 67 | (defmethod fetch-session ((store redis-store) sid) 68 | (let ((data (with-connection store 69 | (red:get (format nil "~A:~A" 70 | (redis-store-namespace store) 71 | sid))))) 72 | (if data 73 | (handler-case (funcall (redis-store-deserializer store) data) 74 | (error (e) 75 | (warn "Error (~A) occured while deserializing a session. Ignoring.~2% Data:~% ~A~2% Error:~% ~A" 76 | (class-name (class-of e)) 77 | data 78 | e) 79 | nil)) 80 | nil))) 81 | 82 | (defmethod store-session ((store redis-store) sid session) 83 | (let ((data (funcall (redis-store-serializer store) session)) 84 | (key (format nil "~A:~A" (redis-store-namespace store) sid))) 85 | (with-connection store 86 | (red:set key data) 87 | (when (redis-store-expires store) 88 | (red:expire key (redis-store-expires store)))))) 89 | 90 | (defmethod remove-session ((store redis-store) sid) 91 | (with-connection store 92 | (red:del (format nil "~A:~A" 93 | (redis-store-namespace store) 94 | sid)))) 95 | -------------------------------------------------------------------------------- /src/middleware/static.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/middleware/static 2 | (:nicknames :lack.middleware.static) 3 | (:use :cl) 4 | (:import-from :lack/component 5 | :call) 6 | (:import-from :lack/app/file 7 | :lack-app-file) 8 | (:import-from :alexandria 9 | :starts-with-subseq 10 | :if-let) 11 | (:export :*lack-middleware-static* 12 | :call-app-file)) 13 | (in-package :lack/middleware/static) 14 | 15 | (defparameter *lack-middleware-static* 16 | (lambda (app &key path (root #P"./")) 17 | (etypecase path 18 | (null app) 19 | (string 20 | (lambda (env) 21 | (let ((path-info (getf env :path-info))) 22 | (if (starts-with-subseq path path-info) 23 | (progn 24 | (setf (getf env :path-info) 25 | (subseq path-info (1- (length path)))) 26 | (call-app-file root env)) 27 | (funcall app env))))) 28 | (function 29 | (lambda (env) 30 | (let ((path-info (getf env :path-info))) 31 | (if-let (new-path (funcall path path-info)) 32 | (progn 33 | (setf (getf env :path-info) new-path) 34 | (call-app-file root env)) 35 | (funcall app env))))))) 36 | "Middleware for serving static files") 37 | 38 | (defun call-app-file (root env) 39 | (call (make-instance 'lack-app-file :root root) env)) 40 | -------------------------------------------------------------------------------- /src/request.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/request 2 | (:nicknames :lack.request) 3 | (:use :cl) 4 | (:import-from :quri 5 | :url-decode-params) 6 | (:import-from :http-body 7 | :parse) 8 | (:import-from :circular-streams 9 | :circular-input-stream 10 | :make-circular-input-stream) 11 | (:import-from :cl-ppcre 12 | :split) 13 | (:import-from :lack/media-type 14 | :media-type 15 | :make-media-type 16 | :match-media-type) 17 | (:export :request 18 | :make-request 19 | :request-env 20 | :request-method 21 | :request-script-name 22 | :request-path-info 23 | :request-server-name 24 | :request-server-port 25 | :request-server-protocol 26 | :request-uri 27 | :request-uri-scheme 28 | :request-remote-addr 29 | :request-remote-port 30 | :request-query-string 31 | :request-raw-body 32 | :request-content-length 33 | :request-content-type 34 | :request-headers 35 | :request-cookies 36 | :request-body-parameters 37 | :request-query-parameters 38 | :request-parameters 39 | :request-content 40 | :request-has-body-p 41 | :request-accept 42 | :request-accepts-p)) 43 | (in-package :lack/request) 44 | 45 | (defstruct (request (:constructor %make-request)) 46 | (env nil :type list) 47 | 48 | (method nil :type (or null keyword)) 49 | (script-name nil :type (or null string)) 50 | (path-info nil :type (or null string)) 51 | (server-name nil :type (or null string)) 52 | (server-port nil :type (or null integer)) 53 | (server-protocol nil :type (or null keyword)) 54 | (uri nil :type (or null string)) 55 | (uri-scheme nil :type (or null string keyword)) 56 | (remote-addr nil :type (or null string)) 57 | (remote-port nil :type (or null keyword integer)) 58 | (query-string nil :type (or null string)) 59 | (raw-body nil :type (or null stream)) 60 | (content-length nil :type (or null integer)) 61 | (content-type nil :type (or null string)) 62 | (headers nil :type (or null hash-table)) 63 | 64 | (cookies nil :type list) 65 | (body-parameters nil :type list) 66 | (query-parameters nil :type list) 67 | (accept nil :type list)) 68 | 69 | (declaim (inline request-has-body-p)) 70 | (defun request-has-body-p (req) 71 | (or (request-content-length req) 72 | (string= (gethash "transfer-encoding" (request-headers req)) "chunked"))) 73 | 74 | (defun make-request (env) 75 | (let ((req (apply #'%make-request :env env :allow-other-keys t env))) 76 | (with-slots (method uri uri-scheme) req 77 | (unless method 78 | (setf method (getf env :request-method))) 79 | (unless uri 80 | (setf uri (getf env :request-uri))) 81 | (unless uri-scheme 82 | ;; for some reason, it is called url-scheme in the environment plist :( 83 | (setf uri-scheme (getf env :url-scheme)))) 84 | 85 | ;; Cookies 86 | (unless (request-cookies req) 87 | (let* ((headers (request-headers req)) 88 | (cookie (and (hash-table-p headers) 89 | (gethash "cookie" headers)))) 90 | (when cookie 91 | (setf (request-cookies req) 92 | (loop for kv in (ppcre:split "\\s*[,;]\\s*" cookie) 93 | append (quri:url-decode-params kv :lenient t))) 94 | (rplacd (last env) (list :cookies (request-cookies req)))))) 95 | 96 | ;; GET parameters 97 | (with-slots (query-parameters query-string) req 98 | (when (and (null query-parameters) 99 | query-string) 100 | (setf query-parameters 101 | (quri:url-decode-params query-string :lenient t)) 102 | (rplacd (last env) (list :query-parameters query-parameters)))) 103 | 104 | (with-slots (body-parameters raw-body content-length content-type) req 105 | (when raw-body 106 | (unless (typep raw-body 'circular-input-stream) 107 | (setf raw-body (make-circular-input-stream raw-body))) 108 | 109 | ;; POST parameters 110 | (when (and (null body-parameters) 111 | (request-has-body-p req) 112 | (stringp content-type)) 113 | (let ((parsed (http-body:parse content-type content-length raw-body))) 114 | (when (and (consp parsed) 115 | (every #'consp parsed)) 116 | (setf body-parameters parsed))) 117 | (file-position raw-body 0) 118 | (setf (getf env :raw-body) raw-body) 119 | (rplacd (last env) (list :body-parameters body-parameters))))) 120 | 121 | (setf (request-accept req) 122 | (mapcar #'lack/media-type:make-media-type (ppcre:split "\\s*[,]\\s*" (gethash "accept" (request-headers req))))) 123 | 124 | (setf (request-env req) env) 125 | 126 | req)) 127 | 128 | (defun request-parameters (req) 129 | (append (request-query-parameters req) 130 | (request-body-parameters req))) 131 | 132 | (defun request-content (req) 133 | (if (request-has-body-p req) 134 | (let ((raw-body (request-raw-body req))) 135 | (prog1 136 | (http-body.util:slurp-stream raw-body (request-content-length req)) 137 | (file-position raw-body 0))) 138 | #.(make-array 0 :element-type '(unsigned-byte 8)))) 139 | 140 | (defun request-accepts-p (request media-type-string) 141 | "Attempt to match media-type string against the values in the request ACCEPT header" 142 | (let ((media-type-obj (lack/media-type:make-media-type media-type-string))) 143 | (some #'(lambda (request-media-type) 144 | (lack/media-type:match-media-type request-media-type media-type-obj)) 145 | (request-accept request)))) 146 | 147 | (declaim (notinline request-has-body-p)) 148 | -------------------------------------------------------------------------------- /src/response.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/response 2 | (:nicknames :lack.response) 3 | (:use :cl) 4 | (:import-from :quri 5 | :url-encode) 6 | (:import-from :local-time 7 | :format-timestring 8 | :universal-to-timestamp 9 | :+gmt-zone+) 10 | (:export :response 11 | :make-response 12 | :finalize-response 13 | :response-status 14 | :response-headers 15 | :response-body 16 | :response-set-cookies)) 17 | (in-package :lack/response) 18 | 19 | (defstruct (response 20 | (:constructor make-response (&optional status headers (body nil has-body) 21 | &aux (no-body (not has-body))))) 22 | (status nil :type (integer 100 599)) 23 | (headers nil :type list) 24 | (body nil :type (or vector pathname list)) 25 | (no-body nil :type boolean) 26 | (set-cookies nil :type list)) 27 | 28 | (defun finalize-response (res) 29 | (finalize-cookies res) 30 | (with-slots (status headers body no-body) res 31 | (list* status headers 32 | (cond 33 | ((and no-body (not body)) nil) 34 | ((or (consp body) (pathnamep body) (and (not (stringp body)) (vectorp body))) 35 | (list body)) 36 | (t (list (list body))))))) 37 | 38 | (defun finalize-cookies (res) 39 | (setf (response-headers res) 40 | (append (response-headers res) 41 | (loop for (k v) on (response-set-cookies res) by #'cddr 42 | append (list :set-cookie (bake-cookie k v)))))) 43 | 44 | (defun bake-cookie (key value) 45 | (unless value 46 | (return-from bake-cookie "")) 47 | 48 | (destructuring-bind (&key domain path expires secure httponly samesite &allow-other-keys) 49 | value 50 | (unless (or (member samesite (list :lax :strict)) 51 | secure) 52 | (warn "Samesite=None cookies require Secure")) 53 | (with-output-to-string (s) 54 | (format s "~A=~A" 55 | (quri:url-encode (string key)) 56 | (quri:url-encode (getf value :value))) 57 | (when domain 58 | (format s "; domain=~A" domain)) 59 | (when path 60 | (format s "; path=~A" path)) 61 | (when expires 62 | (format s "; expires=") 63 | (format-timestring 64 | s (universal-to-timestamp expires) 65 | :format '(:short-weekday ", " (:day 2) #\Space :short-month #\Space (:year 4) #\Space (:hour 2) #\: (:min 2) #\: (:sec 2) " GMT") 66 | :timezone +gmt-zone+)) 67 | (when secure 68 | (write-string "; secure" s)) 69 | (when httponly 70 | (write-string "; HttpOnly" s)) 71 | (format s "; SameSite=~A" (cond ((eq samesite :lax) 72 | "Lax") 73 | ((eq samesite :strict) 74 | "Strict") 75 | (t "None")))))) 76 | -------------------------------------------------------------------------------- /src/test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/test 2 | (:nicknames :lack.test) 3 | (:use :cl) 4 | (:import-from :quri 5 | :uri 6 | :uri-path 7 | :uri-query 8 | :merge-uris 9 | :render-uri 10 | :url-encode-params) 11 | (:import-from :cl-cookie 12 | :make-cookie-jar 13 | :make-cookie 14 | :parse-set-cookie-header 15 | :merge-cookies 16 | :cookie-jar-cookies 17 | :write-cookie-header) 18 | (:import-from :flexi-streams 19 | :make-in-memory-input-stream 20 | :string-to-octets) 21 | (:export :generate-env 22 | :parse-lack-session 23 | :testing-app 24 | :request)) 25 | (in-package :lack/test) 26 | 27 | (defun generate-env (uri &key (method :get) content headers cookie-jar cookies) 28 | "Creates an ENV plist much like this do all Clack backends. 29 | 30 | Argument `uri' can be just a path or a full url with scheme and optional port." 31 | 32 | (let* ((uri (quri:uri uri)) 33 | (path (if (quri:uri-path uri) 34 | (quri:url-decode (quri:uri-path uri) :lenient t) 35 | "/")) 36 | (query (quri:uri-query uri)) 37 | (host (or (quri:uri-host uri) 38 | "localhost")) 39 | (port (or (quri:uri-port uri) 40 | 80)) 41 | (scheme (or (quri.uri:uri-scheme uri) 42 | "http"))) 43 | 44 | ;; default headers 45 | (setf headers (append `(("host" . ,host) ("accept" . "*/*")) headers)) 46 | 47 | (when content 48 | (let ((content-type (or (cdr (assoc "content-type" headers :test #'string-equal)) 49 | (if (and (consp content) 50 | (find-if #'pathnamep content :key #'cdr)) 51 | "multipart/form-data" 52 | "application/x-www-form-urlencoded")))) 53 | (if (assoc "content-type" headers :test #'string-equal) 54 | (setf (cdr (assoc "content-type" headers :test #'string-equal)) 55 | content-type) 56 | (setf headers (append headers `(("content-type" . ,content-type))))))) 57 | (when (or cookies cookie-jar) 58 | (let ((cookie-jar (or cookie-jar 59 | (make-cookie-jar)))) 60 | (merge-cookies cookie-jar 61 | (loop for (k . v) in cookies 62 | collect (make-cookie :name k :value v))) 63 | (let* ((cookie (assoc "cookie" headers :test 'equal)) 64 | (new-cookie (format nil "~@[~A; ~]~A" 65 | (cdr cookie) 66 | (write-cookie-header (cookie-jar-cookies cookie-jar))))) 67 | (if cookie 68 | (setf (cdr cookie) new-cookie) 69 | (setf headers 70 | (append headers 71 | `(("cookie" . ,new-cookie)))))))) 72 | (setf content 73 | (etypecase content 74 | (cons (flex:string-to-octets 75 | (quri:url-encode-params content) 76 | :external-format :utf-8)) 77 | (string (flex:string-to-octets content 78 | :external-format :utf-8)) 79 | (array content) 80 | (null nil))) 81 | (list :request-method method 82 | ;; Seems that all Clack handlers put into this field 83 | ;; only pathname with GET parameters 84 | :request-uri (format nil "~A~@[?~A~]" 85 | (or path "/") 86 | query) 87 | :script-name "" 88 | :path-info path 89 | :query-string query 90 | :server-name host 91 | :server-port port 92 | :server-protocol :http/1.1 93 | :url-scheme scheme 94 | :remote-addr "127.0.0.1" 95 | :remote-port 12345 96 | :content-type (cdr (assoc "content-type" headers :test #'string-equal)) 97 | :content-length (and content 98 | (length content)) 99 | :headers (loop with hash = (make-hash-table :test 'equal) 100 | for (k . v) in headers 101 | do (setf (gethash (string-downcase k) hash) v) 102 | finally (return hash)) 103 | :raw-body (and content 104 | (flex:make-in-memory-input-stream content))))) 105 | 106 | (defun parse-lack-session (headers) 107 | (let ((set-cookie (getf headers :set-cookie))) 108 | (when set-cookie 109 | (when (string= set-cookie "lack.session=" :end1 #.(length "lack.session=")) 110 | (subseq set-cookie 111 | #.(length "lack.session=") 112 | (position #\; set-cookie)))))) 113 | 114 | (defvar *current-app*) 115 | 116 | (defun request (uri &rest args &key (method :get) content headers cookie-jar 117 | (max-redirects 5)) 118 | (let ((env (generate-env uri 119 | :method method :content content :headers headers 120 | :cookie-jar cookie-jar)) 121 | (uri (quri:uri uri))) 122 | (unless (quri:uri-host uri) 123 | (setf (quri:uri-host uri) "localhost")) 124 | (unless (quri:uri-port uri) 125 | (setf (quri:uri-port uri) 80)) 126 | (unless (quri:uri-scheme uri) 127 | (setf uri (quri:merge-uris uri "http://"))) 128 | (destructuring-bind (status headers body) 129 | (funcall *current-app* env) 130 | (when cookie-jar 131 | (merge-cookies cookie-jar 132 | (loop for (k v) on headers by #'cddr 133 | when (eq k :set-cookie) 134 | collect 135 | (parse-set-cookie-header v 136 | (quri:uri-host uri) 137 | (quri:uri-path uri))))) 138 | (when (and (member status '(301 302 303 307) :test #'=) 139 | (getf headers :location) 140 | (not (eq method :head)) 141 | (/= max-redirects 0)) 142 | (return-from request 143 | (apply #'request (quri:merge-uris (quri:uri (getf headers :location)) uri) 144 | :method (if (or (= status 307) 145 | (member method '(:head :get))) 146 | method 147 | :get) 148 | :max-redirects (1- max-redirects) 149 | args))) 150 | ;; XXX: Framework sometimes return '(NIL) as body 151 | (when (consp body) 152 | (setf body (remove nil body))) 153 | (values 154 | ;; TODO: support pathname 155 | ;; TODO: check if the response content-type is text/binary 156 | (typecase body 157 | (cons (apply #'concatenate (type-of (first body)) body)) 158 | (null "") 159 | (otherwise body)) 160 | status 161 | (loop with hash = (make-hash-table :test 'equal) 162 | for (k v) on headers by #'cddr 163 | for down-k = (string-downcase k) 164 | do (setf (gethash down-k hash) 165 | (format nil "~@[~A, ~]~A" 166 | (gethash down-k hash) v)) 167 | finally (return hash)) 168 | uri 169 | nil)))) 170 | 171 | (defmacro testing-app (app &body body) 172 | `(let ((*current-app* ,app)) 173 | ,@body)) 174 | -------------------------------------------------------------------------------- /src/util.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/util 2 | (:nicknames :lack.util) 3 | (:use :cl) 4 | #+(or windows mswindows win32 cormanlisp) 5 | (:import-from :ironclad 6 | :byte-array-to-hex-string 7 | :random-data) 8 | #-(or windows mswindows win32 cormanlisp) 9 | (:import-from :bordeaux-threads 10 | :make-lock 11 | :with-lock-held) 12 | (:export :find-package-or-load 13 | :find-middleware 14 | :funcall-with-cb 15 | :content-length 16 | :generate-random-id)) 17 | (in-package :lack/util) 18 | 19 | (defun locate-symbol (symbol pkg) 20 | (check-type symbol (or symbol string)) 21 | (let* ((sym-name (if (symbolp symbol) (symbol-name symbol) symbol)) 22 | (sym (find-symbol sym-name pkg))) 23 | (unless sym 24 | (error "Unable to find symbol ~A in package ~S." symbol pkg)) 25 | sym)) 26 | 27 | (defun load-with-quicklisp (system) 28 | (let ((error-sym (locate-symbol '#:system-not-found '#:ql))) 29 | ;; We're going to trap on every condition, but only actually 30 | ;; handle ones of the type we're interested in. Conditions that we 31 | ;; don't explicitly handle will be propagated normally, because 32 | ;; HANDLER-BIND is cool like that. 33 | (handler-bind 34 | ((t (lambda (c) 35 | (when (and (typep c error-sym) 36 | (string-equal system (uiop:symbol-call :ql :system-not-found-name c))) 37 | (return-from load-with-quicklisp (values)))))) 38 | (uiop:symbol-call :ql :quickload system :silent t)))) 39 | 40 | (defun find-package-or-load (package-name) 41 | (check-type package-name string) 42 | (let ((package (find-package package-name))) 43 | (or package 44 | (let ((system-name (string-downcase (substitute #\- #\. package-name :test #'char=)))) 45 | (if (member :quicklisp *features*) 46 | (load-with-quicklisp system-name) 47 | (when (asdf:find-system system-name nil) 48 | (asdf:load-system system-name :verbose nil))) 49 | (find-package package-name))))) 50 | 51 | (defun find-middleware (identifier) 52 | (let* ((package-name (concatenate 'string 53 | #.(string '#:lack/middleware/) 54 | (symbol-name identifier))) 55 | (backward-compatible-package-name 56 | (concatenate 'string 57 | #.(string '#:lack.middleware.) 58 | (substitute #\. #\- (symbol-name identifier)))) 59 | (package (or (find-package-or-load package-name) 60 | (find-package-or-load backward-compatible-package-name)))) 61 | (unless package 62 | (error "Middleware ~S is not found" package-name)) 63 | (let ((mw-symbol (intern (format nil "*~A*" 64 | (substitute-if #\- 65 | (lambda (c) 66 | (member c '(#\. #\/) :test 'char=)) 67 | package-name)) 68 | package))) 69 | (if (and (boundp mw-symbol) 70 | (functionp (symbol-value mw-symbol))) 71 | (symbol-value mw-symbol) 72 | (error "Middleware ~S is unbound or not a function" mw-symbol))))) 73 | 74 | (defun funcall-with-cb (app env cb) 75 | (let ((res (funcall app env))) 76 | (typecase res 77 | (cons (funcall cb res)) 78 | (function 79 | (lambda (responder) 80 | (funcall res (lambda (res) 81 | (funcall responder (funcall cb res)))))) 82 | (otherwise res)))) 83 | 84 | (defun content-length (res) 85 | (destructuring-bind (status headers &optional body) 86 | res 87 | (declare (ignore status)) 88 | (or (getf headers :content-length) 89 | (etypecase body 90 | (list (reduce #'+ body :key #'length)) 91 | (pathname (with-open-file (in body) 92 | (file-length in))) 93 | ((vector (unsigned-byte 8)) 94 | (length body)))))) 95 | 96 | ;; Patch to fix bug in cl-isaac. 97 | ;; When PR is accepted in cl-isaac, the code below can be removed 98 | 99 | #-(or windows mswindows win32 cormanlisp) 100 | (defun cl-isaac:rand32 (ctx) 101 | ;;(declare (optimize (speed 3) (safety 0))) 102 | (cond 103 | ((zerop (cl-isaac::isaac-ctx-randcnt ctx)) 104 | (cl-isaac::generate-next-isaac-block ctx) 105 | (setf (cl-isaac::isaac-ctx-randcnt ctx) 255) 106 | (aref (cl-isaac::isaac-ctx-randrsl ctx) 255)) 107 | (t 108 | (aref (cl-isaac::isaac-ctx-randrsl ctx) 109 | (decf (cl-isaac::isaac-ctx-randcnt ctx)))))) 110 | 111 | #-(or windows mswindows win32 cormanlisp) 112 | (defun cl-isaac:rand64 (ctx) 113 | ;;(declare (optimize (speed 3) (safety 0))) 114 | (cond 115 | ((zerop (cl-isaac::isaac64-ctx-randcnt ctx)) 116 | (cl-isaac::generate-next-isaac64-block ctx) 117 | (setf (cl-isaac::isaac64-ctx-randcnt ctx) 255) 118 | (aref (cl-isaac::isaac64-ctx-randrsl ctx) 255)) 119 | (t 120 | (aref (cl-isaac::isaac64-ctx-randrsl ctx) 121 | (decf (cl-isaac::isaac64-ctx-randcnt ctx)))))) 122 | 123 | ;; End of cl-isaac patch 124 | 125 | ;; cl-isaac supports ISAAC-64 solely for implementations with x86-64 126 | ;; capabilities. Use whichever-best supported capability 127 | #-(or windows mswindows win32 cormanlisp) 128 | (defparameter *isaac-ctx* 129 | (isaac:init-self-seed :count 5 130 | :is64 #+:X86-64 t #-:X86-64 nil)) 131 | 132 | #-(or windows mswindows win32 cormanlisp) 133 | (defvar *isaac-ctx-lock* (bordeaux-threads:make-lock)) 134 | 135 | (defun generate-random-id () 136 | "Generates a random token." 137 | #+(or windows mswindows win32 cormanlisp) 138 | (ironclad:byte-array-to-hex-string 139 | (ironclad:random-data 20)) 140 | #-(or windows mswindows win32 cormanlisp) 141 | (format nil "~(~40,'0x~)" 142 | (let ((output-string NIL)) 143 | (bordeaux-threads:with-lock-held (*isaac-ctx-lock*) 144 | (setf output-string 145 | (#+:X86-64 isaac:rand-bits-64 146 | #-:X86-64 isaac:rand-bits 147 | *isaac-ctx* 160))) 148 | output-string))) 149 | -------------------------------------------------------------------------------- /src/util/writer-stream.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/util/writer-stream 2 | (:nicknames :lack.util.writer-stream) 3 | (:use :cl) 4 | (:import-from :trivial-gray-streams 5 | :fundamental-output-stream 6 | :stream-write-byte 7 | :stream-write-sequence 8 | :stream-write-char 9 | :stream-write-string 10 | :stream-element-type 11 | :stream-finish-output 12 | :open-stream-p) 13 | (:import-from :babel 14 | :string-to-octets) 15 | (:export :writer-stream 16 | :make-writer-stream)) 17 | (in-package :lack/util/writer-stream) 18 | 19 | (defclass writer-stream (fundamental-output-stream) 20 | ((writer :type function 21 | :initarg :writer 22 | :accessor writer-stream-writer) 23 | (closed-p :type boolean 24 | :initform nil 25 | :accessor writer-stream-closed-p))) 26 | 27 | (defun make-writer-stream (writer) 28 | (check-type writer function) 29 | (make-instance 'writer-stream :writer writer)) 30 | 31 | (defmethod stream-write-byte ((stream writer-stream) byte) 32 | (funcall (writer-stream-writer stream) 33 | (make-array 1 :element-type '(unsigned-byte 8) :initial-contents (list byte)))) 34 | 35 | (defmethod stream-write-sequence ((stream writer-stream) sequence start end &key) 36 | (funcall (writer-stream-writer stream) sequence :start start :end end)) 37 | 38 | (defmethod stream-write-char ((stream writer-stream) char) 39 | (let ((string (make-string 1 :initial-element char))) 40 | (funcall (writer-stream-writer stream) (babel:string-to-octets string)))) 41 | 42 | (defmethod stream-write-string ((stream writer-stream) string &optional (start 0) (end (length string))) 43 | (funcall (writer-stream-writer stream) (babel:string-to-octets string :start start :end end))) 44 | 45 | (defmethod stream-finish-output ((stream writer-stream)) 46 | (funcall (writer-stream-writer stream) nil :close t) 47 | (setf (writer-stream-closed-p stream) t) 48 | nil) 49 | 50 | (defmethod stream-element-type ((stream writer-stream)) 51 | '(unsigned-byte 8)) 52 | 53 | (defmethod open-stream-p ((stream writer-stream)) 54 | (not (writer-stream-closed-p stream))) 55 | -------------------------------------------------------------------------------- /tests/builder.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/builder 2 | (:use :cl 3 | :rove 4 | :lack/builder)) 5 | (in-package :lack/tests/builder) 6 | 7 | (defvar *app* 8 | (lambda (env) 9 | (declare (ignore env)) 10 | '(200 (:content-type "text/html") ("ok from app")))) 11 | 12 | (deftest builder 13 | (ok (typep 14 | (builder (lambda (app) 15 | (lambda (env) 16 | (funcall app env))) 17 | *app*) 18 | 'function) 19 | "Inline middleware") 20 | (ok (typep 21 | (builder 22 | (lambda (app) 23 | (lambda (env) 24 | (funcall app env))) 25 | *app*) 26 | 'function) 27 | "Can embed CL code") 28 | (ok (typep 29 | (builder 30 | (if t 31 | (lambda (app) 32 | (lambda (env) 33 | (funcall app env))) 34 | nil) 35 | *app*) 36 | 'function) 37 | "Can embed CL code") 38 | 39 | (ok (typep 40 | (builder nil (if t nil nil) nil *app*) 41 | 'function) 42 | "NIL is ignored")) 43 | 44 | (deftest mount 45 | (let ((mount-app (builder 46 | (:mount "/admin" (lambda (env) `(200 () ("admin" ,(getf env :path-info))))) 47 | *app*))) 48 | (ok (equalp (nth 2 (funcall mount-app '(:path-info "/login"))) 49 | '("ok from app"))) 50 | (ok (equalp (nth 2 (funcall mount-app '(:path-info "/admin/login"))) 51 | '("admin" "/login"))) 52 | (ok (equalp (nth 2 (funcall mount-app '(:path-info "/admin"))) 53 | '("admin" "/"))) 54 | (ok (equalp (nth 2 (funcall mount-app '(:path-info "/admin/"))) 55 | '("admin" "/"))) 56 | (ok (equalp (nth 2 (funcall mount-app '(:path-info "/administrators"))) 57 | '("ok from app"))))) 58 | 59 | (deftest auth-basic 60 | (ok (builder 61 | (:auth-basic 62 | :authenticator (lambda (user pass) 63 | (declare (ignore user pass)) 64 | t)) 65 | *app*)) 66 | (ok (builder 67 | (:auth/basic 68 | :authenticator (lambda (user pass) 69 | (declare (ignore user pass)) 70 | t)) 71 | *app*))) 72 | 73 | (uiop:define-package lack/middleware/sample 74 | (:use :cl)) 75 | 76 | (defvar lack/middleware/sample::*lack-middleware-sample* 77 | (lambda (app &key (out (lambda (out) (princ out)))) 78 | (lambda (env) 79 | (funcall out "sample") 80 | (funcall app env)))) 81 | 82 | (deftest embedded-code-when 83 | (testing "Embedded CL code with Middleware without keyword option." 84 | (let ((app (builder (when t :sample) *app*))) 85 | (ok (typep app 'function) 86 | "Can build.") 87 | 88 | (ok (outputs (funcall app '(:path-info "/")) 89 | "sample") 90 | "Can work.")))) 91 | 92 | (deftest embedded-code-sample 93 | (testing "Embedded CL code with Middleware with keyword option." 94 | (let ((app (builder (when t `(:sample :out ,(lambda (out) (format t "Got: ~a" out)))) *app*))) 95 | (ok (typep app 'function) 96 | "Can build.") 97 | 98 | (ok (outputs (funcall app '(:path-info "/")) 99 | "Got: sample") 100 | "Can work.")))) 101 | -------------------------------------------------------------------------------- /tests/component.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/component 2 | (:use :cl 3 | :lack/component 4 | :lack/test 5 | :rove)) 6 | (in-package :lack/tests/component) 7 | 8 | (defclass myapp (lack-component) ()) 9 | (defmethod call ((comp myapp) env) 10 | (declare (ignore env)) 11 | '(200 12 | (:content-type "text/plain") 13 | ("ok from myapp"))) 14 | 15 | (defvar *fn-app* 16 | (lambda (env) 17 | `(200 (:content-type "text/plain") ("ok" ,(getf env :path-info))))) 18 | 19 | (deftest lack-component 20 | (ok (equalp (call *fn-app* (generate-env "/hello")) 21 | '(200 (:content-type "text/plain") ("ok" "/hello")))) 22 | 23 | (ok (equalp (call (make-instance 'myapp) (generate-env "/")) 24 | '(200 (:content-type "text/plain") ("ok from myapp")))) 25 | 26 | (ok (typep (to-app *fn-app*) 'function)) 27 | (ok (typep (to-app (make-instance 'myapp)) 'function))) 28 | -------------------------------------------------------------------------------- /tests/media-type.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lack/tests/media-type 2 | (:use #:cl 3 | #:rove 4 | #:lack/media-type)) 5 | (in-package #:lack/tests/media-type) 6 | 7 | (defparameter *media-type* (make-media-type "application/json;q=0.8")) 8 | 9 | (deftest media-type 10 | (ok (equal (media-type-main-type *media-type*) 11 | "application")) 12 | 13 | (ok (equal (media-type-sub-type *media-type*) 14 | "json")) 15 | 16 | (ok (equalp (media-type-params *media-type*) 17 | '(("q" . "0.8")))) 18 | 19 | (ok (match-media-type (make-media-type "*/*;q=0.8") 20 | (make-media-type "text/html"))) 21 | 22 | (ok (match-media-type (make-media-type "application/*") 23 | (make-media-type "application/json"))) 24 | 25 | (ng (match-media-type (make-media-type "application/*") 26 | (make-media-type "text/html"))) 27 | 28 | (ok (match-media-type (make-media-type "application/json") 29 | (make-media-type "application/json"))) 30 | 31 | (ng (match-media-type (make-media-type "application/json") 32 | (make-media-type "application/xml")))) 33 | -------------------------------------------------------------------------------- /tests/middleware/accesslog.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/middleware/accesslog 2 | (:use :cl 3 | :lack 4 | :lack/test 5 | :rove 6 | :split-sequence)) 7 | (in-package :lack/tests/middleware/accesslog) 8 | 9 | (defmacro with-accesslogs ((var &rest forms) &body body) 10 | `(let* ((,var (string-right-trim '(#\Newline) 11 | (with-output-to-string (*standard-output*) 12 | ,@forms))) 13 | (,var (split-sequence #\Newline ,var))) 14 | ,@body)) 15 | 16 | (deftest accesslog-middleware 17 | (let ((app1 (builder :accesslog 18 | (lambda (env) 19 | (declare (ignore env)) 20 | '(200 () ("ok"))))) 21 | (app2 (builder :accesslog 22 | (lambda (env) 23 | (declare (ignore env)) 24 | `(200 () ,(babel:string-to-octets "ok")))))) 25 | 26 | (with-accesslogs (logs (funcall app1 (generate-env "/"))) 27 | (ok logs 28 | "Body of response is list of strings.")) 29 | 30 | (with-accesslogs (logs (funcall app2 (generate-env "/"))) 31 | (ok logs 32 | "Body of response is (vector (unsigned-byte 8)).")) 33 | 34 | (with-accesslogs (logs (funcall app1 (generate-env "/"))) 35 | (ok (eql (length logs) 1) "1 line") 36 | (ok (ppcre:scan "^127.0.0.1 - \\[.+?\\] \"GET / " 37 | (car logs)))) 38 | 39 | (with-accesslogs (logs (funcall app1 (generate-env "/")) 40 | (funcall app1 (generate-env "/users")) 41 | (funcall app1 (generate-env "/new" :method :post))) 42 | (ok (eql (length logs) 3) "3 lines") 43 | (ok (ppcre:scan "^127.0.0.1 - \\[.+?\\] \"GET / " (nth 0 logs))) 44 | (ok (ppcre:scan "^127.0.0.1 - \\[.+?\\] \"GET /users " (nth 1 logs))) 45 | (ok (ppcre:scan "^127.0.0.1 - \\[.+?\\] \"POST /new " (nth 2 logs)))) 46 | 47 | (with-accesslogs (logs (funcall app1 (generate-env "/")) 48 | (funcall app1 (generate-env "/" :headers '(("user-agent" . "Mozilla"))))) 49 | (ok (ppcre:scan "^.+\"-\"$" (nth 0 logs))) 50 | (ok (ppcre:scan "^.+\"Mozilla\"$" (nth 1 logs)))) 51 | 52 | (with-accesslogs (logs (funcall app1 (generate-env "/")) 53 | (funcall app1 (generate-env "/" :headers '(("referer" . "http://website.com/index.html"))))) 54 | (ok (ppcre:scan "^.+\"-\" \"-\"$" (nth 0 logs))) 55 | (ok (ppcre:scan "^.+\"http://website.com/index.html\" \"-\"$" (nth 1 logs)))))) 56 | -------------------------------------------------------------------------------- /tests/middleware/auth/basic.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/middleware/auth/basic 2 | (:use :cl 3 | :rove 4 | :lack 5 | :lack/test 6 | :cl-base64)) 7 | (in-package :lack/tests/middleware/auth/basic) 8 | 9 | (deftest lack-middleware-auth-basic 10 | (let ((app 11 | (builder 12 | (:auth/basic :authenticator (lambda (user pass) 13 | (and (string= user "hoge") 14 | (string= pass "fuga")))) 15 | (lambda (env) 16 | `(200 () (,(format nil "Hello, ~A" (getf env :remote-user)))))))) 17 | (generate-env "/") 18 | (destructuring-bind (status headers body) 19 | (funcall app (generate-env "/")) 20 | (ok (eql status 401)) 21 | (ok (equalp body '("Authorization required"))) 22 | (ok (equal (getf headers :www-authenticate) "Basic realm=restricted area"))) 23 | 24 | (destructuring-bind (status headers body) 25 | (funcall app (generate-env "/" 26 | :headers 27 | `(("authorization" . ,(format nil "Basic ~A" 28 | (string-to-base64-string "wrong:auth"))))) ) 29 | (ok (eql status 401)) 30 | (ok (equalp body '("Authorization required"))) 31 | (ok (equal (getf headers :www-authenticate) "Basic realm=restricted area"))) 32 | 33 | (destructuring-bind (status headers body) 34 | (funcall app (generate-env "/" 35 | :headers 36 | `(("authorization" . ,(format nil "Basic ~A" 37 | (string-to-base64-string "hoge:fuga")))))) 38 | (declare (ignore headers)) 39 | (ok (eql status 200)) 40 | (ok (equalp body '("Hello, hoge")))))) 41 | 42 | (deftest remote-user 43 | (let ((app 44 | (builder 45 | (:auth-basic :authenticator (lambda (user pass) 46 | (when (and (string= user "nitro_idiot") 47 | (string= pass "password")) 48 | (values t "Eitaro Fukamachi")))) 49 | (lambda (env) 50 | `(200 () (,(format nil "Hello, ~A" (getf env :remote-user)))))))) 51 | (destructuring-bind (status headers body) 52 | (funcall app (generate-env "/")) 53 | (ok (eql status 401)) 54 | (ok (equalp body '("Authorization required"))) 55 | (ok (equal (getf headers :www-authenticate) "Basic realm=restricted area"))) 56 | 57 | (destructuring-bind (status headers body) 58 | (funcall app (generate-env "/" 59 | :headers 60 | `(("authorization" . ,(format nil "Basic ~A" 61 | (string-to-base64-string "nitro_idiot:password")))))) 62 | (declare (ignore headers)) 63 | (ok (eql status 200)) 64 | (ok (equalp body '("Hello, Eitaro Fukamachi")))))) 65 | -------------------------------------------------------------------------------- /tests/middleware/backtrace.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/middleware/backtrace 2 | (:use :cl 3 | :lack 4 | :lack/test 5 | :rove)) 6 | (in-package :lack/tests/middleware/backtrace) 7 | 8 | (deftest backtrace-middleware 9 | (let ((app 10 | (builder (:backtrace 11 | :result-on-error `(500 (:content-type "text/plain") ("Internal Server Error"))) 12 | (lambda (env) 13 | (if (string= (getf env :path-info) "/error") 14 | (error "Error occured") 15 | '(200 () ("ok"))))))) 16 | (testing "normal case" 17 | (let ((*error-output* (make-string-output-stream))) 18 | (destructuring-bind (status headers body) 19 | (funcall app (generate-env "/")) 20 | (declare (ignore headers)) 21 | (ok (eql status 200)) 22 | (ok (equalp body '("ok")))) 23 | (ok (= 0 (length (get-output-stream-string *error-output*))) 24 | "No backtraces"))) 25 | 26 | (testing "internal server error" 27 | (let ((*error-output* (make-string-output-stream))) 28 | (destructuring-bind (status headers body) 29 | (funcall app (generate-env "/error")) 30 | (ok (eql status 500)) 31 | (ok (equal (getf headers :content-type) "text/plain")) 32 | (ok (equalp body '("Internal Server Error")))) 33 | (ok (< 0 (length (get-output-stream-string *error-output*))) 34 | "Got backtraces"))))) 35 | 36 | (define-condition test-error (error) ()) 37 | 38 | (deftest result-on-error 39 | (testing ":result-on-error is NIL" 40 | (let ((app 41 | (builder :backtrace (lambda (env) 42 | (declare (ignore env)) 43 | (error 'test-error))))) 44 | (let ((*error-output* (make-string-output-stream))) 45 | (ok (signals (funcall app (generate-env "/")) 'test-error) 46 | "Raise an error if :result-on-error is NIL") 47 | (ok (< 0 (length (get-output-stream-string *error-output*))) 48 | "Got backtraces")))) 49 | 50 | (testing ":result-on-error is function" 51 | (let ((app 52 | (builder (:backtrace 53 | :result-on-error (lambda (condition) 54 | (if (typep condition 'test-error) 55 | '(503 (:content-type "text/plain") ("Service Temporary Unavailable")) 56 | '(500 (:content-type "text/plain") ("Internal Server Error"))))) 57 | (lambda (env) 58 | (if (string= (getf env :path-info) "/503") 59 | (error 'test-error) 60 | (error "Error occured"))))) 61 | (*error-output* (make-broadcast-stream))) 62 | (ok (equalp (funcall app (generate-env "/")) 63 | '(500 (:content-type "text/plain") ("Internal Server Error")))) 64 | (ok (equalp (funcall app (generate-env "/503")) 65 | '(503 (:content-type "text/plain") ("Service Temporary Unavailable"))))))) 66 | 67 | (defparameter *test-error-output* (make-string-output-stream)) 68 | 69 | (deftest custom-output 70 | (testing "Custom :output (stream)" 71 | (let ((app 72 | (builder (:backtrace :output *test-error-output* 73 | :result-on-error '(500 (:content-type "text/plain") ("Internal Server Error"))) 74 | (lambda (env) 75 | (declare (ignore env)) 76 | (error "Error occured"))))) 77 | (let ((*error-output* (make-string-output-stream))) 78 | (funcall app (generate-env "/")) 79 | (ok (= 0 (length (get-output-stream-string *error-output*))) 80 | "Don't output to *error-output*") 81 | (ok (< 0 (length (get-output-stream-string *test-error-output*))) 82 | "Output to the custom :output")))) 83 | 84 | (testing "Custom :output (pathname)" 85 | (let* ((log-file (asdf:system-relative-pathname :lack #P"data/test.log")) 86 | (app 87 | (builder (:backtrace :output log-file 88 | :result-on-error '(500 (:content-type "text/plain") ("Internal Server Error"))) 89 | (lambda (env) 90 | (declare (ignore env)) 91 | (error "Error occured"))))) 92 | (when (probe-file log-file) 93 | (delete-file log-file)) 94 | (let ((*error-output* (make-string-output-stream))) 95 | (funcall app (generate-env "/")) 96 | (ok (= 0 (length (get-output-stream-string *error-output*))) 97 | "Don't output to *error-output*") 98 | (ok (< 0 (length (alexandria:read-file-into-string log-file))) 99 | "Output to the custom :output"))))) 100 | -------------------------------------------------------------------------------- /tests/middleware/csrf.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/middleware/csrf 2 | (:use :cl 3 | :rove 4 | :lack 5 | :lack/test 6 | :lack/request 7 | :lack/middleware/csrf) 8 | (:shadowing-import-from :lack/test 9 | :request)) 10 | (in-package :lack/tests/middleware/csrf) 11 | 12 | (defun html-form (env) 13 | (concatenate 14 | 'string 15 | " 16 | 17 | 18 |
19 | 20 | " 21 | (csrf-html-tag (getf env :lack.session)) 22 | " 23 | 24 |
25 | 26 | 27 | ")) 28 | 29 | (defun parse-csrf-token (body &optional (name "_csrf_token")) 30 | (let ((match (nth-value 31 | 1 32 | (ppcre:scan-to-strings 33 | (concatenate 'string "name=\"" name "\" value=\"(.+?)\"") 34 | body)))) 35 | (and match (elt match 0)))) 36 | 37 | (deftest csrf-middleware 38 | (testing "CSRF middleware" 39 | (let ((app 40 | (builder 41 | :session 42 | :csrf 43 | #'(lambda (env) 44 | (let ((req (make-request env))) 45 | `(200 46 | (:content-type "text/html") 47 | (,(if (and (eq :post (request-method req)) 48 | (assoc "name" (request-body-parameters req) :test #'string=)) 49 | (cdr (assoc "name" (request-body-parameters req) :test #'string=)) 50 | (html-form env)))))))) 51 | csrf-token 52 | session) 53 | (diag "first POST request") 54 | (destructuring-bind (status headers body) 55 | (funcall app (generate-env "/" :method :post)) 56 | (ok (eql status 400)) 57 | (ok (equalp body '("Bad Request: invalid CSRF token"))) 58 | (ok (ppcre:scan 59 | "^lack.session=.+; path=/; expires=" 60 | (getf headers :set-cookie))) 61 | 62 | (setf session (parse-lack-session headers))) 63 | 64 | (diag "first GET request") 65 | (destructuring-bind (status headers body) 66 | (funcall app (generate-env "/" 67 | :headers 68 | `(("cookie" . ,(format nil "lack.session=~A" session))))) 69 | (ok (eql status 200) "Status is 200") 70 | (ok (ppcre:scan "^text/html" (getf headers :content-type)) 71 | "Content-Type is text/html") 72 | (setf csrf-token (parse-csrf-token (car body))) 73 | (ok csrf-token "can get CSRF token") 74 | (ok (typep csrf-token 'string) "CSRF token is string") 75 | (ok (eql (length csrf-token) 40) "CSRF token is 40 chars")) 76 | 77 | (diag "bad POST request (no token)") 78 | (destructuring-bind (status headers body) 79 | (funcall app (generate-env "/" 80 | :method :post 81 | :headers 82 | `(("cookie" . ,(format nil "lack.session=~A" session))))) 83 | (ok (eql status 400) "Status is 400") 84 | (ok (ppcre:scan "^text/plain" (getf headers :content-type)) 85 | "Content-Type is text/plain") 86 | (ok (equalp body '("Bad Request: invalid CSRF token")) "Body is 'forbidden'")) 87 | 88 | (diag "bad POST request (wrong token)") 89 | (destructuring-bind (status headers body) 90 | (funcall app (generate-env "/" 91 | :method :post 92 | :headers 93 | `(("cookie" . ,(format nil "lack.session=~A" session))))) 94 | (ok (eql status 400) "Status is 400") 95 | (ok (ppcre:scan "^text/plain" (getf headers :content-type)) 96 | "Content-Type is text/plain") 97 | (ok (equalp body '("Bad Request: invalid CSRF token")) "Body is 'forbidden'")) 98 | 99 | (diag "valid POST request") 100 | (destructuring-bind (status headers body) 101 | (funcall app (generate-env "/" 102 | :method :post 103 | :cookies `(("lack.session" . ,session)) 104 | :content 105 | `(("name" . "Eitaro Fukamachi") 106 | ("_csrf_token" . ,csrf-token)))) 107 | (ok (eql status 200) "Status is 200") 108 | (ok (ppcre:scan "^text/html" (getf headers :content-type)) 109 | "Content-Type is text/html") 110 | (ok (equalp body '("Eitaro Fukamachi")) "can read body-parameter"))))) 111 | 112 | (deftest one-time-token 113 | (let (csrf-token 114 | session 115 | (app 116 | (builder 117 | :session 118 | (:csrf :one-time t) 119 | #'(lambda (env) 120 | (let ((req (make-request env))) 121 | `(200 122 | (:content-type "text/html") 123 | (,(if (and (eq :post (request-method req)) 124 | (assoc "name" (request-body-parameters req) :test #'string=)) 125 | (cdr (assoc "name" (request-body-parameters req) :test #'string=)) 126 | (html-form env))))))))) 127 | (destructuring-bind (status headers body) 128 | (funcall app (generate-env "/")) 129 | (declare (ignore status)) 130 | (setf csrf-token (parse-csrf-token (car body))) 131 | (setf session (parse-lack-session headers))) 132 | 133 | (destructuring-bind (status headers body) 134 | (funcall app (generate-env "/" 135 | :method :post 136 | :content `(("name" . "Eitaro Fukamachi") 137 | ("_csrf_token" . ,csrf-token)) 138 | :cookies `(("lack.session" . ,session)))) 139 | (declare (ignore headers body)) 140 | (ok (eql status 200))) 141 | 142 | (diag "send a request with an expired token") 143 | (destructuring-bind (status headers body) 144 | (funcall app (generate-env "/" 145 | :method :post 146 | :content `(("name" . "Eitaro Fukamachi") 147 | ("_csrf_token" . ,csrf-token)) 148 | :cookies `(("lack.session" . ,session)))) 149 | (ok (eql status 400)) 150 | (ok (equal (getf headers :content-type) "text/plain")) 151 | (ok (equalp body '("Bad Request: invalid CSRF token")))))) 152 | 153 | (deftest alternate-input-name 154 | (let (csrf-token 155 | session 156 | (app 157 | (builder 158 | :session 159 | (:csrf :form-token "test_input_name") 160 | #'(lambda (env) 161 | (let ((req (make-request env))) 162 | `(200 163 | (:content-type "text/html") 164 | (,(if (and (eq :post (request-method req)) 165 | (assoc "name" (request-body-parameters req) :test #'string=)) 166 | (cdr (assoc "name" (request-body-parameters req) :test #'string=)) 167 | (html-form env))))))))) 168 | (destructuring-bind (status headers body) 169 | (funcall app (generate-env "/")) 170 | (declare (ignore status)) 171 | (setf csrf-token (parse-csrf-token (car body) "test_input_name")) 172 | (setf session (parse-lack-session headers))) 173 | 174 | (diag "bad POST request (wrong token)") 175 | (destructuring-bind (status headers body) 176 | (funcall app (generate-env "/" 177 | :method :post 178 | :content `(("name" . "Eitaro Fukamachi") 179 | ("test_input_name" . "invalid token")) 180 | :cookies `(("lack.session" . ,session)))) 181 | (ok (eql status 400) "Status is 400") 182 | (ok (ppcre:scan "^text/plain" (getf headers :content-type)) 183 | "Content-Type is text/plain") 184 | (ok (equalp body '("Bad Request: invalid CSRF token")) "Body is 'forbidden'")) 185 | 186 | (diag "Valid POST request") 187 | (destructuring-bind (status headers body) 188 | (funcall app (generate-env "/" 189 | :method :post 190 | :content `(("name" . "Eitaro Fukamachi") 191 | ("test_input_name" . ,csrf-token)) 192 | :cookies `(("lack.session" . ,session)))) 193 | (declare (ignore headers body)) 194 | (ok (eql status 200))))) 195 | -------------------------------------------------------------------------------- /tests/middleware/mount.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/middleware/mount 2 | (:use :cl 3 | :lack 4 | :lack/test 5 | :lack/component 6 | :rove)) 7 | (in-package :lack/tests/middleware/mount) 8 | 9 | (defclass test-component (lack-component) ()) 10 | 11 | (defmethod call ((app test-component) env) 12 | (declare (ignore env)) 13 | '(200 () "mount2")) 14 | 15 | (deftest dispatch 16 | (macrolet ((mount-test (component) 17 | `(let* ((not-mounted '(200 () ("not-mounted"))) 18 | (app 19 | (builder 20 | (:mount "/mount" ,component) 21 | (lambda (env) 22 | (declare (ignore env)) 23 | not-mounted)))) 24 | (let ((expected (funcall (to-app ,component) (generate-env "/"))) 25 | (result1 (funcall app (generate-env "/mount"))) 26 | (result2 (funcall app (generate-env "/mount/test"))) 27 | (result3 (funcall app (generate-env "/test")))) 28 | (ok (equal result1 expected) 29 | "string=.") 30 | 31 | (ok (equal result2 32 | expected) 33 | "subseq.") 34 | 35 | (ok (equal result3 36 | not-mounted) 37 | "t."))))) 38 | (testing "(lambda (env) ...)" 39 | (mount-test 40 | (lambda (env) 41 | (declare (ignore env)) 42 | '(200 () ("mount"))))) 43 | (testing "lack-component" 44 | (mount-test (make-instance 'test-component))))) 45 | 46 | (deftest path-info 47 | (macrolet ((is-path-info (env expected &optional comment) 48 | `(ok (equal (getf ,env :path-info) 49 | ,expected) 50 | ,@(when comment (list comment))))) 51 | (let* ((response '(200 () ("ok"))) 52 | (app 53 | (builder 54 | (:mount "/mount1" 55 | (lambda (env) 56 | (is-path-info env "/" "string=.") 57 | response)) 58 | (:mount "/mount2" 59 | (lambda (env) 60 | (is-path-info env "/test" "subseq.") 61 | response)) 62 | (lambda (env) 63 | (is-path-info env "/test" "t.") 64 | response)))) 65 | (dolist (path (list "/mount1" "/mount2/test" "/test")) 66 | (funcall app (generate-env path)))))) 67 | -------------------------------------------------------------------------------- /tests/middleware/session.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/middleware/session 2 | (:use :cl 3 | :rove 4 | :lack 5 | :lack/test)) 6 | (in-package :lack/tests/middleware/session) 7 | 8 | (deftest session-middleware 9 | (ok (lack/session/state:make-state) 10 | "Base class of session state") 11 | (let ((app 12 | (builder 13 | :session 14 | (lambda (env) 15 | (unless (gethash :counter (getf env :lack.session)) 16 | (setf (gethash :counter (getf env :lack.session)) 0)) 17 | `(200 18 | (:content-type "text/plain") 19 | (,(format nil "Hello, you've been here for ~Ath times!" 20 | (incf (gethash :counter (getf env :lack.session))))))))) 21 | session) 22 | (diag "1st request") 23 | (destructuring-bind (status headers body) 24 | (funcall app (generate-env "/")) 25 | (ok (eql status 200)) 26 | (setf session (parse-lack-session headers)) 27 | (ok session) 28 | (ok (equalp body '("Hello, you've been here for 1th times!")))) 29 | 30 | (diag "2nd request") 31 | (destructuring-bind (status headers body) 32 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 33 | (declare (ignore headers)) 34 | (ok (eql status 200)) 35 | (ok (equalp body '("Hello, you've been here for 2th times!")))))) 36 | 37 | (deftest session-with-delayed-response 38 | (let ((app 39 | (builder 40 | :session 41 | (lambda (env) 42 | (unless (gethash :counter (getf env :lack.session)) 43 | (setf (gethash :counter (getf env :lack.session)) 0)) 44 | (lambda (responder) 45 | (funcall responder 46 | `(200 47 | (:content-type "text/plain") 48 | (,(format nil "Hello, you've been here for ~Ath times!" 49 | (incf (gethash :counter (getf env :lack.session))))))))))) 50 | session) 51 | (diag "1st request") 52 | (funcall (funcall app (generate-env "/")) 53 | (lambda (response) 54 | (destructuring-bind (status headers body) response 55 | (ok (eql status 200)) 56 | (setf session (parse-lack-session headers)) 57 | (ok session) 58 | (ok (equalp body '("Hello, you've been here for 1th times!")))))) 59 | 60 | (diag "2nd request") 61 | (funcall (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 62 | (lambda (response) 63 | (destructuring-bind (status headers body) response 64 | (declare (ignore headers)) 65 | (ok (eql status 200)) 66 | (ok (equalp body '("Hello, you've been here for 2th times!")))))))) 67 | 68 | (deftest set-cookie-header 69 | (let ((app (builder 70 | :session 71 | (lambda (env) 72 | (when (string= (getf env :path-info) "/expire") 73 | (setf (getf (getf env :lack.session.options) :expire) t)) 74 | '(200 () ("hi"))))) 75 | session) 76 | ;; 1st 77 | (destructuring-bind (status headers body) 78 | (funcall app (generate-env "/" :cookies '(("lack.session" . nil)))) 79 | (ok (eql status 200) "status") 80 | (ok (getf headers :set-cookie) 81 | "Set-Cookie header exists") 82 | (setf session 83 | (ppcre:scan-to-strings "(?<=lack.session=)[^;]+" (getf headers :set-cookie ""))) 84 | (ok (typep session 'string) 85 | "Set-Cookie header value is valid") 86 | (ok (equalp body '("hi")) "body")) 87 | ;; 2nd 88 | (destructuring-bind (status headers body) 89 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 90 | (ok (eql status 200) "status") 91 | (ng (getf headers :set-cookie) 92 | "Set-Cookie header doesn't exist") 93 | (ok (equalp body '("hi")) "body")) 94 | ;; invalid lack.session 95 | (destructuring-bind (status headers body) 96 | (funcall app (generate-env "/" :cookies '(("lack.session" . "")))) 97 | (ok (eql status 200) "status") 98 | (ok (getf headers :set-cookie) 99 | "Set-Cookie header exists") 100 | (ok (equalp body '("hi")) "body")) 101 | 102 | ;; expires 103 | (destructuring-bind (status headers body) 104 | (funcall app (generate-env "/expire" :cookies `(("lack.session" . ,session)))) 105 | (ok (eql status 200) "status") 106 | (ok (getf headers :set-cookie) 107 | "Set-Cookie header exists") 108 | (let ((cookie (cookie:parse-set-cookie-header (getf headers :set-cookie) "" ""))) 109 | (ok (<= (cookie:cookie-expires cookie) (get-universal-time)) "session expired")) 110 | (ok (equalp body '("hi")) "body")) 111 | 112 | ;; with expired session 113 | (destructuring-bind (status headers body) 114 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 115 | (ok (eql status 200) "status") 116 | (ok (getf headers :set-cookie) 117 | "Set-Cookie header exists") 118 | (let ((cookie (cookie:parse-set-cookie-header (getf headers :set-cookie) "" ""))) 119 | (ok (> (cookie:cookie-expires cookie) 120 | (get-universal-time)) 121 | "new session is not expired")) 122 | (ok (equalp body '("hi")) "body"))) 123 | 124 | (testing "session expiration with delayed response" 125 | (let ((app (builder 126 | :session 127 | (lambda (env) 128 | (if (equal (getf env :path-info) "/delayed-expire") 129 | (lambda (responder) 130 | (setf (getf (getf env :lack.session.options) :expire) t) 131 | (funcall responder '(200 () ("hi")))) 132 | (lambda (responder) 133 | (funcall responder '(200 () "hi"))))))) 134 | session) 135 | ;; Get a session. 136 | (funcall (funcall app (generate-env "/")) 137 | (lambda (result) 138 | (destructuring-bind (status headers body) result 139 | (declare (ignore status body)) 140 | (setf session 141 | (ppcre:scan-to-strings "(?<=lack.session=)[^;]+" 142 | (getf headers :set-cookie "")))))) 143 | ;; Make sure it expires when expiration is set in a delayed response. 144 | (funcall (funcall app (generate-env "/delayed-expire" :cookies `(("lack.session" . ,session)))) 145 | (lambda (result) 146 | (destructuring-bind (status headers body) result 147 | (declare (ignore status body)) 148 | (let ((cookie (cookie:parse-set-cookie-header (getf headers :set-cookie) "" ""))) 149 | (ok (equal (cookie:cookie-value cookie) session) 150 | "Set-Cookie header is for existing session") 151 | (ok (<= (cookie:cookie-expires cookie) (get-universal-time)) 152 | "Session expired"))))))) 153 | 154 | (testing ":keep-empty nil" 155 | (let ((app (builder 156 | (:session :keep-empty nil) 157 | (lambda (env) 158 | (when (string= (getf env :path-info) "/session") 159 | (setf (gethash "user" (getf env :lack.session)) "Eitaro")) 160 | '(200 () ("hi")))))) 161 | (destructuring-bind (status headers body) 162 | (funcall app (generate-env "/")) 163 | (declare (ignore status body)) 164 | (ng headers)) 165 | (destructuring-bind (status headers body) 166 | (funcall app (generate-env "/session")) 167 | (declare (ignore status body)) 168 | (ok (typep (getf headers :set-cookie) 'string))))) 169 | 170 | (testing "cookie-key other than lack.session=" 171 | (let ((app (builder 172 | (:session :state (lack.session.state.cookie:make-cookie-state 173 | :cookie-key "_myapp_cookie")) 174 | (lambda (env) 175 | (declare (ignore env)) 176 | '(200 () ("hi")))))) 177 | (destructuring-bind (status headers body) 178 | (funcall app (generate-env "/")) 179 | (declare (ignore status body)) 180 | (ok (ppcre:scan "^_myapp_cookie=" (getf headers :set-cookie))))))) 181 | -------------------------------------------------------------------------------- /tests/middleware/static.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/middleware/static 2 | (:use :cl 3 | :rove 4 | :lack 5 | :lack/test) 6 | (:import-from :alexandria 7 | :starts-with-subseq)) 8 | (in-package :lack/tests/middleware/static) 9 | 10 | (deftest static-middleware 11 | (testing ":path is string" 12 | (let ((app 13 | (builder 14 | (:static :path "/public/" 15 | :root (asdf:system-relative-pathname :lack #P"data/")) 16 | (lambda (env) 17 | (declare (ignore env)) 18 | `(200 (:content-type "text/plain") ("Happy Valentine!")))))) 19 | (destructuring-bind (status headers body) 20 | (funcall app (generate-env "/public/jellyfish.jpg")) 21 | (ok (eql status 200)) 22 | (ok (equal (getf headers :content-type) "image/jpeg")) 23 | (ok (equal (namestring body) 24 | (namestring (asdf:system-relative-pathname :lack #P"data/jellyfish.jpg"))))) 25 | 26 | (destructuring-bind (status headers body) 27 | (funcall app (generate-env "/public/hoge.png")) 28 | (declare (ignore headers)) 29 | (ok (eql status 404)) 30 | (ok (equalp body '("Not Found")))) 31 | 32 | (destructuring-bind (status headers body) 33 | (funcall app (generate-env "/")) 34 | (ok (eql status 200)) 35 | (ok (equal (getf headers :content-type) "text/plain")) 36 | (ok (equalp body '("Happy Valentine!")))))) 37 | 38 | (testing ":path is NIL" 39 | (let ((app 40 | (builder 41 | (:static :path nil 42 | :root (asdf:system-relative-pathname :lack #P"data/")) 43 | (lambda (env) 44 | (declare (ignore env)) 45 | `(200 (:content-type "text/plain") ("ok")))))) 46 | (destructuring-bind (status headers body) 47 | (funcall app (generate-env "/public/jellyfish.jpg")) 48 | (ok (eql status 200)) 49 | (ok (equal (getf headers :content-type) "text/plain")) 50 | (ok (equalp body '("ok")))))) 51 | 52 | (testing ":path is function" 53 | (let ((app 54 | (builder 55 | (:static :path (lambda (path-info) 56 | (when (starts-with-subseq "/static/" path-info) 57 | (subseq path-info #.(length "/static")))) 58 | :root (asdf:system-relative-pathname :lack #P"data/")) 59 | (lambda (env) 60 | (declare (ignore env)) 61 | `(200 (:content-type "text/plain") ("ok")))))) 62 | (destructuring-bind (status headers body) 63 | (funcall app (generate-env "/static/jellyfish.jpg")) 64 | (ok (eql status 200)) 65 | (ok (equal (getf headers :content-type) "image/jpeg")) 66 | (ok (equal (namestring body) 67 | (namestring (asdf:system-relative-pathname :lack #P"data/jellyfish.jpg"))))) 68 | 69 | (ok (eql (car (funcall app (generate-env "/static/not-found.png"))) 404)))) 70 | 71 | (testing "special character in path-info" 72 | (let ((app 73 | (builder 74 | (:static :path (lambda (path-info) 75 | (when (starts-with-subseq "/static/" path-info) 76 | (subseq path-info #.(length "/static")))) 77 | :root (asdf:system-relative-pathname :lack #P"data/")) 78 | (lambda (env) 79 | (declare (ignore env)) 80 | `(200 (:content-type "text/plain") ("ok")))))) 81 | (ok (eql (first (funcall app (generate-env "/static/?broken=yup"))) 404)) 82 | (ok (eql (first (funcall app (generate-env "/static/%3Fbroken=yup"))) 404))))) 83 | -------------------------------------------------------------------------------- /tests/request.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:lack/tests/request 2 | (:use #:cl 3 | #:rove 4 | #:lack/request 5 | #:clack.test 6 | #:flexi-streams) 7 | (:import-from #:dexador) 8 | (:import-from #:alexandria 9 | #:alist-hash-table)) 10 | (in-package #:lack/tests/request) 11 | 12 | (defparameter *request* 13 | (make-request `(:content-type "application/x-www-form-urlencoded; charset=utf-8" 14 | :content-length 20 15 | :uri-scheme :http 16 | :query-string "ediweitz=weitzedi&name=eitaro&q=C%2B%2B" 17 | :raw-body 18 | ,(flex:make-flexi-stream 19 | (flex:make-in-memory-input-stream 20 | #(110 97 109 101 61 230 183 177 231 148 186 232 139 177 229 164 170 233 131 142)) 21 | :external-format :utf-8) 22 | :headers ,(alexandria:alist-hash-table 23 | '(("referer" . "http://github.com/fukamachi/clack") 24 | ("user-agent" . "Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_6_6; en-US)") 25 | ("accept" . "text/html") 26 | ("cookie" . "hoge=1;fuga=semi;colon")) 27 | :test 'equal)))) 28 | 29 | (deftest lack-request 30 | (ok (typep *request* 'request)) 31 | 32 | (ok (request-env *request*) "request-env") 33 | 34 | (ok (equal (request-content-type *request*) "application/x-www-form-urlencoded; charset=utf-8") 35 | "request-content-type") 36 | 37 | (ok (equalp (request-query-parameters *request*) 38 | '(("ediweitz" . "weitzedi") ("name" . "eitaro") ("q" . "C++"))) 39 | "request-query-parameters") 40 | 41 | (ok (equalp (request-body-parameters *request*) 42 | `(("name" . ,(flex:octets-to-string 43 | #(230 183 177 231 148 186 232 139 177 229 164 170 233 131 142) 44 | :external-format :utf-8)))) 45 | "request-body-parameters") 46 | 47 | (ok (equalp (request-cookies *request*) 48 | '(("hoge" . "1") ("fuga" . "semi") ("colon"))) 49 | "request-cookies") 50 | 51 | (ok (request-accepts-p *request* "text/html")) 52 | 53 | (ng (request-accepts-p *request* "application/json")) 54 | 55 | (testing-app "make-request" 56 | (lambda (env) 57 | (make-request env) 58 | `(200 nil (,(third (assoc "file" (request-body-parameters (make-request env)) :test #'string=))))) 59 | (multiple-value-bind (body status) 60 | (dex:post (localhost) 61 | :content 62 | `(("file" . ,(asdf:system-relative-pathname :lack #P"data/jellyfish.jpg")))) 63 | (ok (eql status 200)) 64 | (ok (equal body "jellyfish.jpg"))) 65 | 66 | (multiple-value-bind (body status) 67 | (dex:post (localhost) 68 | :content 69 | `(("file" . ,(asdf:system-relative-pathname :lack #P"data/jellyfish.jpg")))) 70 | (ok (eql status 200)) 71 | (ok (equal body "jellyfish.jpg"))))) 72 | -------------------------------------------------------------------------------- /tests/session/store/dbi.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/session/store/dbi 2 | (:use :cl 3 | :lack 4 | :lack/test 5 | :lack/session/store/dbi 6 | :dbi 7 | :rove)) 8 | (in-package :lack/tests/session/store/dbi) 9 | 10 | (defvar *test-db* (asdf:system-relative-pathname :lack "data/test.db")) 11 | (defparameter *conn* nil) 12 | 13 | (defun init-db () 14 | (when (probe-file *test-db*) 15 | (delete-file *test-db*)) 16 | 17 | (setf *conn* (dbi:connect :sqlite3 :database-name *test-db*))) 18 | 19 | (defun clearup-db () 20 | (dbi:disconnect *conn*) 21 | (setf *conn* nil) 22 | (delete-file *test-db*)) 23 | 24 | (deftest session-middleware 25 | (init-db) 26 | (dbi:do-sql *conn* 27 | "CREATE TABLE sessions (id CHAR(72) PRIMARY KEY, session_data TEXT)") 28 | (let ((app 29 | (builder 30 | (:session 31 | :store (make-dbi-store 32 | :connector (lambda () *conn*))) 33 | (lambda (env) 34 | (unless (gethash :counter (getf env :lack.session)) 35 | (setf (gethash :counter (getf env :lack.session)) 0)) 36 | `(200 37 | (:content-type "text/plain") 38 | (,(format nil "Hello, you've been here for ~Ath times!" 39 | (incf (gethash :counter (getf env :lack.session))))))))) 40 | session) 41 | (diag "1st request") 42 | (destructuring-bind (status headers body) 43 | (funcall app (generate-env "/")) 44 | (ok (eql status 200)) 45 | (setf session (parse-lack-session headers)) 46 | (ok session) 47 | (ok (equalp body '("Hello, you've been here for 1th times!")))) 48 | 49 | (diag "2nd request") 50 | (destructuring-bind (status headers body) 51 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 52 | (declare (ignore headers)) 53 | (ok (eql status 200)) 54 | (ok (equalp body '("Hello, you've been here for 2th times!"))))) 55 | 56 | (testing "utf-8 session data" 57 | (let ((app 58 | (builder 59 | (:session 60 | :store (make-dbi-store 61 | :connector (lambda () *conn*))) 62 | (lambda (env) 63 | (unless (gethash :user (getf env :lack.session)) 64 | (setf (gethash :user (getf env :lack.session)) "深町英太郎")) 65 | (unless (gethash :counter (getf env :lack.session)) 66 | (setf (gethash :counter (getf env :lack.session)) 0)) 67 | `(200 68 | (:content-type "text/plain") 69 | (,(format nil "Hello, ~A! You've been here for ~Ath times!" 70 | (gethash :user (getf env :lack.session)) 71 | (incf (gethash :counter (getf env :lack.session))))))))) 72 | session) 73 | (destructuring-bind (status headers body) 74 | (funcall app (generate-env "/")) 75 | (ok (eql status 200)) 76 | (setf session (parse-lack-session headers)) 77 | (ok session) 78 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 1th times!")))) 79 | 80 | (destructuring-bind (status headers body) 81 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 82 | (declare (ignore headers)) 83 | (ok (eql status 200)) 84 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 2th times!")))))) 85 | 86 | (let ((session (dbi:fetch (dbi:execute (dbi:prepare *conn* "SELECT COUNT(*) AS count FROM sessions"))))) 87 | (ok (eql (getf session :|count|) 2) 88 | "'sessions' has two records")) 89 | (clearup-db)) 90 | 91 | ;; 92 | ;; record-timestamps t 93 | 94 | (deftest record-timestamps 95 | (init-db) 96 | (dbi:do-sql *conn* 97 | "CREATE TABLE sessions (id CHAR(72) PRIMARY KEY, session_data TEXT, created_at DATETIME, updated_at DATETIME)") 98 | (let ((app 99 | (builder 100 | (:session 101 | :store (make-dbi-store 102 | :connector (lambda () *conn*) 103 | :record-timestamps t)) 104 | (lambda (env) 105 | (unless (gethash :counter (getf env :lack.session)) 106 | (setf (gethash :counter (getf env :lack.session)) 0)) 107 | `(200 108 | (:content-type "text/plain") 109 | (,(format nil "Hello, you've been here for ~Ath times!" 110 | (incf (gethash :counter (getf env :lack.session))))))))) 111 | session 112 | now) 113 | (diag "1st request") 114 | (destructuring-bind (status headers body) 115 | (funcall app (generate-env "/")) 116 | (ok (eql status 200)) 117 | (setf session (parse-lack-session headers)) 118 | (ok session) 119 | (ok (equalp body '("Hello, you've been here for 1th times!")))) 120 | 121 | (let ((records (dbi:fetch-all 122 | (dbi:execute 123 | (dbi:prepare *conn* "SELECT * FROM sessions"))))) 124 | (ok (eql (length records) 1)) 125 | (ok (equal (getf (first records) :|id|) session)) 126 | (setf now (getf (first records) :|created_at|)) 127 | (ok (equal (getf (first records) :|updated_at|) now))) 128 | 129 | (sleep 2) 130 | 131 | (diag "2nd request") 132 | (destructuring-bind (status headers body) 133 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 134 | (declare (ignore headers)) 135 | (ok (eql status 200)) 136 | (ok (equalp body '("Hello, you've been here for 2th times!")))) 137 | 138 | (let ((records (dbi:fetch-all 139 | (dbi:execute 140 | (dbi:prepare *conn* "SELECT * FROM sessions"))))) 141 | (ok (eql (length records) 1)) 142 | (ok (equal (getf (first records) :|id|) session)) 143 | (ok (equal (getf (first records) :|created_at|) now)) 144 | (ng (equal (getf (first records) :|updated_at|) now)))) 145 | (clearup-db)) 146 | -------------------------------------------------------------------------------- /tests/session/store/redis.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/session/store/redis 2 | (:use :cl 3 | :lack 4 | :lack/test 5 | :lack/session/store/redis 6 | :rove) 7 | (:import-from :lack/session/store/redis 8 | :redis-store-connection)) 9 | (in-package :lack/tests/session/store/redis) 10 | 11 | (defvar *namespace* "session_test") 12 | (defvar *connection*) 13 | 14 | (setup 15 | (setf *connection* (redis-store-connection (make-redis-store))) 16 | 17 | (let ((redis::*connection* *connection*)) 18 | (let ((keys (red:keys (format nil "~A:*" *namespace*)))) 19 | (when keys 20 | (apply #'red:del keys))))) 21 | 22 | (deftest session-middleware 23 | (let ((app 24 | (builder 25 | (:session 26 | :store (make-redis-store :namespace *namespace* :connection *connection*)) 27 | (lambda (env) 28 | (unless (gethash :counter (getf env :lack.session)) 29 | (setf (gethash :counter (getf env :lack.session)) 0)) 30 | `(200 31 | (:content-type "text/plain") 32 | (,(format nil "Hello, you've been here for ~Ath times!" 33 | (incf (gethash :counter (getf env :lack.session))))))))) 34 | session) 35 | (diag "1st request") 36 | (destructuring-bind (status headers body) 37 | (funcall app (generate-env "/")) 38 | (ok (eql status 200)) 39 | (setf session (parse-lack-session headers)) 40 | (ok session) 41 | (ok (equalp body '("Hello, you've been here for 1th times!")))) 42 | 43 | (diag "2nd request") 44 | (destructuring-bind (status headers body) 45 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 46 | (declare (ignore headers)) 47 | (ok (eql status 200)) 48 | (ok (equalp body '("Hello, you've been here for 2th times!"))))) 49 | 50 | (testing "utf-8 session data" 51 | (let ((app 52 | (builder 53 | (:session 54 | :store (make-redis-store :namespace *namespace* :connection *connection*)) 55 | (lambda (env) 56 | (unless (gethash :user (getf env :lack.session)) 57 | (setf (gethash :user (getf env :lack.session)) "深町英太郎")) 58 | (unless (gethash :counter (getf env :lack.session)) 59 | (setf (gethash :counter (getf env :lack.session)) 0)) 60 | `(200 61 | (:content-type "text/plain") 62 | (,(format nil "Hello, ~A! You've been here for ~Ath times!" 63 | (gethash :user (getf env :lack.session)) 64 | (incf (gethash :counter (getf env :lack.session))))))))) 65 | session) 66 | (destructuring-bind (status headers body) 67 | (funcall app (generate-env "/")) 68 | (ok (eql status 200)) 69 | (setf session (parse-lack-session headers)) 70 | (ok session) 71 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 1th times!")))) 72 | 73 | (destructuring-bind (status headers body) 74 | (funcall app (generate-env "/" :cookies `(("lack.session" . ,session)))) 75 | (declare (ignore headers)) 76 | (ok (eql status 200)) 77 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 2th times!")))))) 78 | 79 | (testing "expires" 80 | (let ((app 81 | (builder 82 | (:session 83 | :store (make-redis-store :namespace *namespace* :connection *connection* 84 | :expires 3)) 85 | (lambda (env) 86 | (unless (gethash :user (getf env :lack.session)) 87 | (setf (gethash :user (getf env :lack.session)) "深町英太郎")) 88 | (unless (gethash :counter (getf env :lack.session)) 89 | (setf (gethash :counter (getf env :lack.session)) 0)) 90 | `(200 91 | (:content-type "text/plain") 92 | (,(format nil "Hello, ~A! You've been here for ~Ath times!" 93 | (gethash :user (getf env :lack.session)) 94 | (incf (gethash :counter (getf env :lack.session))))))))) 95 | session) 96 | 97 | (destructuring-bind (status headers body) 98 | (funcall app (generate-env "/")) 99 | (ok (eql status 200)) 100 | (setf session (parse-lack-session headers)) 101 | (ok session) 102 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 1th times!")))) 103 | 104 | (let ((body (nth 2 (funcall app (generate-env "/" :cookies `(("lack.session" . ,session))))))) 105 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 2th times!")))) 106 | 107 | (sleep 2) 108 | 109 | (let ((body (nth 2 (funcall app (generate-env "/" :cookies `(("lack.session" . ,session))))))) 110 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 3th times!")) 111 | "Still the session is alive")) 112 | 113 | (sleep 2) 114 | 115 | (let ((body (nth 2 (funcall app (generate-env "/" :cookies `(("lack.session" . ,session))))))) 116 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 4th times!")) 117 | "Reset the expiration when accessed")) 118 | 119 | (sleep 3.5) 120 | 121 | (let ((body (nth 2 (funcall app (generate-env "/" :cookies `(("lack.session" . ,session))))))) 122 | (ok (equalp body '("Hello, 深町英太郎! You've been here for 1th times!")) 123 | "Session has expired after 3 seconds since the last access")))) 124 | 125 | (let ((redis::*connection* *connection*)) 126 | (ok (eql (length (red:keys (format nil "~A:*" *namespace*))) 127 | 3) 128 | "'session' has three records"))) 129 | 130 | (teardown 131 | (redis:close-connection *connection*)) 132 | -------------------------------------------------------------------------------- /tests/util.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/util 2 | (:use :cl 3 | :rove 4 | :lack/util 5 | :lack/test)) 6 | (in-package :lack/tests/util) 7 | 8 | (deftest find-package-or-load 9 | (ok (eq (find-package-or-load "LACK") 10 | (find-package :lack))) 11 | (ok (eq (find-package-or-load "hoge") nil))) 12 | 13 | (deftest funcall-with-cb 14 | (let ((cb (lambda (res) 15 | (rplacd (car (last res)) (list "(ok from cb)")) 16 | res))) 17 | ;; cons 18 | (let ((app (lambda (env) 19 | (declare (ignore env)) 20 | '(200 (:content-type "text/plain") ("ok"))))) 21 | (ok (equalp (funcall-with-cb app (generate-env "/") cb) 22 | '(200 (:content-type "text/plain") ("ok" "(ok from cb)"))))) 23 | ;; function 24 | (let* ((app (lambda (env) 25 | (declare (ignore env)) 26 | (lambda (responder) 27 | (funcall responder '(200 (:content-type "text/plain") ("ok")))))) 28 | (cb-res (funcall-with-cb app (generate-env "/") cb))) 29 | (ok (typep cb-res 'function)) 30 | (let (res) 31 | (funcall cb-res (lambda (r) (setf res r))) 32 | (ok (equalp res '(200 (:content-type "text/plain") ("ok" "(ok from cb)")))))) 33 | ;; otherwise 34 | (let ((app (lambda (env) 35 | (declare (ignore env)) 36 | 1))) 37 | (ok (eql (funcall-with-cb app (generate-env "/") cb) 1))))) 38 | -------------------------------------------------------------------------------- /tests/util/writer-stream.lisp: -------------------------------------------------------------------------------- 1 | (defpackage lack/tests/util/writer-stream 2 | (:use :cl 3 | :lack/util/writer-stream 4 | :rove)) 5 | (in-package :lack/tests/util/writer-stream) 6 | 7 | (let* ((bodies '()) 8 | (writer 9 | (lambda (body &key &allow-other-keys) 10 | (push body bodies))) 11 | (stream (make-writer-stream writer))) 12 | (ok (typep stream 'writer-stream)) 13 | (ok (open-stream-p stream)) 14 | (write-sequence #(72 101 108 108 111) stream) 15 | (write-string "World" stream) 16 | (ok (equalp bodies '(#(87 111 114 108 100) #(72 101 108 108 111)))) 17 | (write-char #\! stream) 18 | (ok (equalp bodies '(#(33) #(87 111 114 108 100) #(72 101 108 108 111)))) 19 | (ok (open-stream-p stream)) 20 | (finish-output stream) 21 | (ok (not (open-stream-p stream)))) 22 | --------------------------------------------------------------------------------