├── .github └── FUNDING.yml ├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── LICENSE ├── README.markdown ├── clack-handler-hunchentoot.asd ├── clack-handler-toot.asd ├── clack-handler-wookie.asd ├── clack-socket.asd ├── clack-test.asd ├── clack.asd ├── roswell └── clackup.ros ├── src ├── clack.lisp ├── handler.lisp ├── handler │ ├── hunchentoot.lisp │ ├── toot.lisp │ └── wookie.lisp ├── socket.lisp ├── test.lisp ├── test │ └── suite.lisp └── util.lisp ├── t-clack-handler-hunchentoot.asd ├── t-clack-handler-toot.asd ├── t-clack-handler-wookie.asd ├── t ├── handler │ ├── hunchentoot.lisp │ ├── toot.lisp │ └── wookie.lisp └── nginx.conf └── tmp ├── file.txt ├── jellyfish.jpg └── redhat.png /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: [fukamachi] 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *.fas 8 | *.lib 9 | 10 | # editor backup/temp files 11 | *~ 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | 3 | # Wookie handler fails with memory corruption when using Travis CI's new container-based architecture. 4 | sudo: required 5 | 6 | env: 7 | global: 8 | - PATH=~/.roswell/bin:~/nginx/sbin:$PATH 9 | - LD_LIBRARY_PATH=$HOME/libuv/lib:$LD_LIBRARY_PATH 10 | - C_INCLUDE_PATH=$HOME/libuv/include:$C_INCLUDE_PATH 11 | - ROSWELL_BRANCH=release 12 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 13 | - COVERAGE_EXCLUDE=t 14 | matrix: 15 | - LISP=sbcl-bin COVERALLS=true 16 | - LISP=ccl-bin 17 | - LISP=abcl 18 | - LISP=ecl 19 | - LISP=clisp 20 | 21 | matrix: 22 | allow_failures: 23 | - env: LISP=ecl 24 | - env: LISP=clisp 25 | 26 | addons: 27 | apt: 28 | packages: 29 | - libfcgi-dev 30 | 31 | install: 32 | # Install Roswell 33 | - curl -L https://raw.githubusercontent.com/snmsts/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh 34 | # libuv for Wookie 35 | - if ! [ -f "$HOME/libuv/include/uv.h" ]; then 36 | curl -L https://github.com/libuv/libuv/archive/v1.31.0.tar.gz | tar xzf -; 37 | (cd libuv-1.31.0 && ./autogen.sh && ./configure --prefix=$HOME/libuv && make && make install); 38 | fi 39 | # nginx 40 | - if ! [ -f "$HOME/nginx/sbin/nginx" ]; then 41 | curl -L http://nginx.org/download/nginx-1.8.0.tar.gz | tar xzf -; 42 | (cd nginx-1.8.0 && ./configure --prefix=$HOME/nginx && make && make install); 43 | fi 44 | - ros install rove 45 | - ros install fukamachi/dexador 46 | - ros install fukamachi/fast-http 47 | 48 | before_script: 49 | - nginx -c "$TRAVIS_BUILD_DIR/t/nginx.conf" -p "$HOME/nginx" 50 | - ros --version 51 | - ros config 52 | 53 | script: 54 | - if [ "$LISP" = "sbcl-bin" ]; then 55 | for file in `ls t-*.asd | grep -v wookie`; do rove $file; done 56 | else 57 | rove t-clack-handler-hunchentoot.asd; 58 | fi 59 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Clack 2 | 3 | Clack is an open source project and we appreciate your help! 4 | 5 | ## Reporting bugs 6 | 7 | Please [open an issue](https://github.com/fukamachi/clack/issues/new) at GitHub. 8 | 9 | Good reports must include these informations: 10 | 11 | - The full backtrace with your error 12 | - Minimum steps to reproduce it 13 | - Names and versions you are using: OS, Common Lisp implementation, ASDF and Quicklisp dist 14 | 15 | You can get informations about your environment by this code: 16 | 17 | ```common-lisp 18 | (flet ((put (k v &rest vs) 19 | (format t "~&~A: ~A~{ ~A~}~%" k v vs))) 20 | (put "Machine" (software-type) (software-version)) 21 | (put "Lisp" (lisp-implementation-type) (lisp-implementation-version) 22 | #+(and sbcl (not sb-thread)) "(without threads)") 23 | (put "ASDF" (asdf:asdf-version)) 24 | (let ((qlversion (ql:dist-version "quicklisp"))) 25 | (put "Quicklisp" qlversion 26 | (if (string= (car (first (ql:available-dist-versions "quicklisp"))) 27 | qlversion) 28 | "(latest)" 29 | "(update available)")))) 30 | ;-> Machine: Darwin 15.2.0 31 | ; Lisp: SBCL 1.3.1 32 | ; ASDF: 3.1.5 33 | ; Quicklisp: 2015-10-31 (latest) 34 | ;=> NIL 35 | ``` 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2011 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.markdown: -------------------------------------------------------------------------------- 1 | # Clack - Web Application Environment for Common Lisp 2 | 3 | [![Build Status](https://travis-ci.org/fukamachi/clack.svg?branch=master)](https://travis-ci.org/fukamachi/clack) 4 | [![Coverage Status](https://coveralls.io/repos/fukamachi/clack/badge.svg?branch=master)](https://coveralls.io/r/fukamachi/clack) 5 | [![Quicklisp dist](http://quickdocs.org/badge/clack.svg)](http://quickdocs.org/clack/) 6 | 7 | Clack is a web application environment for Common Lisp inspired by Python's WSGI and Ruby's Rack. 8 | 9 | ## Usage 10 | 11 | ```common-lisp 12 | (defvar *handler* 13 | (clack:clackup 14 | (lambda (env) 15 | (declare (ignore env)) 16 | '(200 (:content-type "text/plain") ("Hello, Clack!"))))) 17 | ``` 18 | 19 | Open your web browser and go to [http://localhost:5000/](http://localhost:5000/). You should get "Hello, Clack!". 20 | 21 | To stop the server, use `(clack:stop *handler*)`. 22 | 23 | ## Command-line interface 24 | 25 | Clack provides a script to start a web server. It's useful when you deploy to production environment. 26 | 27 | NOTE: Install [Roswell](https://github.com/snmsts/roswell) before as it depends on it. 28 | 29 | When you execute `ros install clack`, it copies `clackup` script to `$HOME/.roswell/bin`. Make sure the path is in your shell `$PATH`. 30 | 31 | $ ros install clack 32 | $ which clackup 33 | /Users/nitro_idiot/.roswell/bin/clackup 34 | 35 | $ cat <> app.lisp 36 | (lambda (env) 37 | (declare (ignore env)) 38 | '(200 (:content-type "text/plain") ("Hello, Clack!"))) 39 | EOF 40 | $ clackup app.lisp 41 | Hunchentoot server is started. 42 | Listening on localhost:5000. 43 | 44 | ## Installation 45 | 46 | ```common-lisp 47 | (ql:quickload :clack) 48 | ``` 49 | 50 | ## Documentation 51 | 52 | - [Quickdocs Page](http://quickdocs.org/clack/) 53 | 54 | ## Resources 55 | 56 | * [How to build a web app with Clack/Lack (1)](https://fukamachi.hashnode.dev/how-to-build-a-web-app-with-clack-and-lack-1) 57 | * [jasom/clack-tutorial](https://github.com/jasom/clack-tutorial/blob/src/pages/getting-started-with-clack.org) 58 | 59 | ## Server 60 | 61 | * [Hunchentoot](http://weitz.de/hunchentoot/) 62 | * [Wookie](http://wookie.beeets.com/) 63 | * [Toot](https://github.com/gigamonkey/toot) 64 | * [Woo](https://github.com/fukamachi/woo) 65 | 66 | ## How to contribute 67 | 68 | See [CONTRIBUTING.md](CONTRIBUTING.md). 69 | 70 | ## See Also 71 | 72 | * [Lack](https://github.com/fukamachi/lack): Clack application builder 73 | 74 | ## Author 75 | 76 | * Eitaro Fukamachi (e.arrows@gmail.com) 77 | 78 | ## Copyright 79 | 80 | Copyright (c) 2011 Eitaro Fukamachi & [contributors](https://github.com/fukamachi/clack/graphs/contributors) 81 | 82 | ## License 83 | 84 | Licensed under the MIT License. 85 | -------------------------------------------------------------------------------- /clack-handler-hunchentoot.asd: -------------------------------------------------------------------------------- 1 | (defsystem "clack-handler-hunchentoot" 2 | :version "0.5.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("hunchentoot" 6 | "clack-socket" 7 | "flexi-streams" 8 | "bordeaux-threads" 9 | "split-sequence" 10 | "alexandria") 11 | :components ((:file "src/handler/hunchentoot")) 12 | :description "Clack handler for Hunchentoot.") 13 | -------------------------------------------------------------------------------- /clack-handler-toot.asd: -------------------------------------------------------------------------------- 1 | (defsystem "clack-handler-toot" 2 | :version "0.3.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("toot" 6 | "flexi-streams" 7 | "bordeaux-threads" 8 | "cl-ppcre" 9 | "split-sequence" 10 | "alexandria") 11 | :components ((:file "src/handler/toot")) 12 | :description "Clack handler for Toot.") 13 | -------------------------------------------------------------------------------- /clack-handler-wookie.asd: -------------------------------------------------------------------------------- 1 | (defsystem "clack-handler-wookie" 2 | :version "0.3.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("wookie" 6 | "clack-socket" 7 | "cl-async" 8 | "fast-http" 9 | "quri" 10 | "flexi-streams" 11 | "babel" 12 | "fast-io" 13 | "split-sequence" 14 | "alexandria") 15 | :components ((:file "src/handler/wookie")) 16 | :description "Clack handler for Wookie.") 17 | -------------------------------------------------------------------------------- /clack-socket.asd: -------------------------------------------------------------------------------- 1 | (defsystem "clack-socket" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :components ((:file "src/socket"))) 6 | -------------------------------------------------------------------------------- /clack-test.asd: -------------------------------------------------------------------------------- 1 | (defsystem "clack-test" 2 | :version "0.2.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("clack" 6 | "clack-handler-hunchentoot" 7 | "rove" 8 | "bordeaux-threads" 9 | "ironclad" 10 | "usocket" 11 | "dexador" 12 | "flexi-streams" 13 | "http-body") 14 | :components ((:file "src/test") 15 | (:file "src/test/suite" :depends-on ("src/test"))) 16 | :description "Testing Clack Applications.") 17 | -------------------------------------------------------------------------------- /clack.asd: -------------------------------------------------------------------------------- 1 | (defsystem "clack" 2 | :version "2.1.0" 3 | :author "Eitaro Fukamachi" 4 | :license "MIT" 5 | :depends-on ("lack" 6 | "lack-middleware-backtrace" 7 | "lack-util" 8 | "bordeaux-threads" 9 | "usocket" 10 | "swank" 11 | "alexandria" 12 | "uiop") 13 | :components ((:module "src" 14 | :components 15 | ((:file "clack" :depends-on ("handler" "util")) 16 | (:file "handler" :depends-on ("util")) 17 | (:file "util")))) 18 | :description "Web application environment for Common Lisp") 19 | -------------------------------------------------------------------------------- /roswell/clackup.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | #| 8 | A command-line interface for clack:clackup. 9 | |# 10 | 11 | (ql:quickload '(:uiop :split-sequence) :silent t) 12 | 13 | (import 'split-sequence:split-sequence) 14 | 15 | (defun help () 16 | (format t "~&Usage: 17 | # run the .lisp file 18 | ~A hello.lisp 19 | 20 | # switch server handler with --server 21 | ~:*~A --server :wookie --port 8080 hello.lisp 22 | 23 | The .lisp file is a Common Lisp file which ends with a form 24 | that returns a Clack application, typically LAMBDA. 25 | 26 | Options: 27 | --server 28 | Selects a specific server handler to run on. 29 | The value has to be a keyword like \":wookie\". 30 | 31 | --address 32 | Binds to a TCP interface. Defaults to 127.0.0.1. This option is only valid for servers which support TCP sockets. 33 | 34 | --port 35 | Binds to a TCP port. Defaults to 5000. 36 | 37 | --swank-interface 38 | --swank-port 39 | Runs Swank server. 40 | 41 | --use-default-middlewares 42 | A flag if use default middlewares. The default is T. 43 | Specify NIL for preventing from loading those middlewares. 44 | 45 | -S, --source-registry 46 | Append ASDF source registry to the default. 47 | (Unlike Roswell's, this doesn't override it) 48 | 49 | -s, --system 50 | Load systems. 51 | 52 | -l, --load 53 | Load a file before starting a server. 54 | 55 | --help 56 | Shows this message. 57 | " 58 | (read-from-string 59 | (second (assoc "script" 60 | (let ((*read-eval*)) 61 | (read-from-string (uiop:getenv "ROS_OPTS"))) 62 | :test 'equal))))) 63 | 64 | ;; Prevent a symbol conflict with CCL:TERMINATE. 65 | (defun %terminate (code &optional message args) 66 | (when message 67 | (format *error-output* "~&Error: ~A~%" 68 | (apply #'format nil (princ-to-string message) args))) 69 | (uiop:quit code)) 70 | 71 | (defun starts-with (x starts) 72 | (and (<= (length starts) (length x)) 73 | (string= x starts :end1 (length starts)))) 74 | 75 | (defun parse-args (args) 76 | (flet ((parse-value (value) 77 | (handler-case 78 | (let ((read-value (read-from-string value))) 79 | (typecase read-value 80 | (boolean read-value) 81 | ((and symbol (not keyword)) value) 82 | (otherwise read-value))) 83 | (error () 84 | value)))) 85 | (loop with app-file = nil 86 | for option = (pop args) 87 | for value = (pop args) 88 | while option 89 | if (or (string= option "--source-registry") 90 | (string= option "-S")) 91 | append (list :source-registry value) 92 | into opt-args 93 | else if (or (string= option "--system") 94 | (string= option "-s")) 95 | collect value into load-systems 96 | else if (or (string= option "--load") 97 | (string= option "-l")) 98 | collect value into load-files 99 | else if (not (starts-with option "--")) 100 | do (if app-file 101 | (error "Invalid option: ~S" option) 102 | (progn 103 | (setf app-file option) 104 | (push value args))) 105 | else if (string-equal option "--server") 106 | append (list :server 107 | (let ((parsed (parse-value value))) 108 | (if (keywordp parsed) 109 | parsed 110 | (intern (string-upcase value) :keyword)))) 111 | into key-args 112 | else 113 | append (list (intern (string-upcase (subseq option 2)) :keyword) 114 | (parse-value value)) 115 | into key-args 116 | finally 117 | (return (values app-file key-args 118 | (list* :load load-files :systems load-systems opt-args)))))) 119 | 120 | (defun parse-server-starter-port () 121 | (flet ((parse-host-port (host-port) 122 | (parse-integer 123 | (let ((colon-pos (position #\: host-port))) 124 | (if colon-pos 125 | (subseq host-port (1+ colon-pos)) 126 | host-port))))) 127 | (let ((ss-ports (uiop:getenv "SERVER_STARTER_PORT"))) 128 | (when (stringp ss-ports) 129 | (destructuring-bind (host-port fd) 130 | (split-sequence #\= 131 | ;; Assuming the first binding is for the Clack web server. 132 | (car (split-sequence #\; ss-ports :count 1))) 133 | (values (parse-host-port host-port) 134 | (parse-integer fd))))))) 135 | 136 | (defun main (&rest args) 137 | (when (or (null args) 138 | (equal (first args) "--help")) 139 | (help) 140 | (uiop:quit -1)) 141 | 142 | (ql:quickload :clack :silent t) 143 | 144 | (multiple-value-bind (app-file key-args opt-args) 145 | (parse-args args) 146 | (unless (probe-file app-file) 147 | (%terminate -1 "File doesn't exist: ~A" app-file)) 148 | 149 | ;; Add ASDF source-registry 150 | (when (getf opt-args :source-registry) 151 | (asdf:compute-source-registry (truename (getf opt-args :source-registry)))) 152 | 153 | ;; Load systems 154 | (mapc #'ql:quickload (getf opt-args :systems)) 155 | 156 | ;; Load files 157 | (mapc #'load (getf opt-args :load)) 158 | 159 | ;; Add :port and :fd from Server::Starter's environment var. 160 | (multiple-value-bind (port fd) 161 | (parse-server-starter-port) 162 | (when port 163 | (setf key-args (append key-args (list :port port :fd fd))))) 164 | 165 | ;; Disable threads 166 | (setf (getf key-args :use-thread) nil) 167 | 168 | ;; Disable debugger 169 | (setf (getf key-args :debug) nil) 170 | 171 | (apply (intern (string :clackup) :clack) app-file key-args))) 172 | -------------------------------------------------------------------------------- /src/clack.lisp: -------------------------------------------------------------------------------- 1 | (defpackage clack 2 | (:use :cl) 3 | (:import-from :clack.handler 4 | :run 5 | :stop) 6 | (:import-from :clack.util 7 | :find-handler) 8 | (:import-from :lack 9 | :builder) 10 | (:import-from :alexandria 11 | :delete-from-plist) 12 | (:export :clackup 13 | :eval-file 14 | :stop)) 15 | (in-package :clack) 16 | 17 | (defvar *app-file-cache* 18 | (make-hash-table :test 'equal)) 19 | 20 | (defun %load-file (file) 21 | (with-open-file (in file) 22 | (let ((*package* *package*) 23 | (*readtable* *readtable*) 24 | (*load-pathname* file) 25 | (*load-truename* file)) 26 | (loop with results 27 | with eof = '#:eof 28 | for form = (read in nil eof) 29 | until (eq form eof) 30 | do (setf results (multiple-value-list (eval form))) 31 | finally 32 | (return (apply #'values results)))))) 33 | 34 | (defun eval-file (file) 35 | "Safer way to read and eval a file content. This function returns the last value." 36 | (setf file (probe-file file)) 37 | (check-type file pathname) 38 | (let ((modified-at (file-write-date file))) 39 | (cond 40 | ((< (car (gethash file *app-file-cache* '(0 . nil))) 41 | modified-at) 42 | (let ((app (%load-file file))) 43 | (setf (gethash file *app-file-cache*) 44 | (cons modified-at app)) 45 | app)) 46 | (t 47 | (cdr (gethash file *app-file-cache*)))))) 48 | 49 | (defmacro with-handle-interrupt (int-handler &body body) 50 | (let ((main (gensym "MAIN"))) 51 | `(flet ((,main () ,@body)) 52 | #+(or sbcl ccl clisp allegro ecl) 53 | (handler-case 54 | (let (#+ccl (ccl:*break-hook* (lambda (condition hook) 55 | (declare (ignore hook)) 56 | (error condition)))) 57 | (,main)) 58 | (#+sbcl sb-sys:interactive-interrupt 59 | #+ccl ccl:interrupt-signal-condition 60 | #+clisp system::simple-interrupt-condition 61 | #+ecl ext:interactive-interrupt 62 | #+allegro excl:interrupt-signal 63 | () 64 | (funcall ,int-handler))) 65 | #-(or sbcl ccl clisp allegro ecl) 66 | (,main)))) 67 | 68 | (defun clackup (app &rest args 69 | &key (server :hunchentoot) 70 | (address "127.0.0.1") 71 | (port 5000) 72 | swank-interface 73 | swank-port 74 | (debug t) 75 | silent 76 | (use-thread #+thread-support t #-thread-support nil) 77 | (use-default-middlewares t) 78 | &allow-other-keys) 79 | (declare (ignore swank-interface swank-port)) 80 | #-thread-support 81 | (when use-thread 82 | (error ":use-thread is T though there's no thread support.")) 83 | (flet ((buildapp (app) 84 | (let* ((*features* (cons :clackup *features*)) 85 | (app (typecase app 86 | ((or pathname string) 87 | (eval-file app)) 88 | (otherwise app)))) 89 | (builder 90 | (if use-default-middlewares 91 | :backtrace 92 | nil) 93 | app)))) 94 | (let ((app (buildapp app))) 95 | ;; Ensure the handler to be loaded. 96 | (find-handler server) 97 | (when (and (not use-thread) 98 | (not silent)) 99 | (format t "~&~:(~A~) server is going to start.~%Listening on ~A:~A.~%" server address port)) 100 | (with-handle-interrupt (lambda () 101 | (format *error-output* "Interrupted")) 102 | (prog1 103 | (apply #'clack.handler:run app server 104 | :port port 105 | :debug debug 106 | :use-thread use-thread 107 | (delete-from-plist args :server :port :debug :silent :use-thread)) 108 | (when (and use-thread 109 | (not silent)) 110 | (format t "~&~:(~A~) server is started.~%Listening on ~A:~A.~%" server address port))))))) 111 | -------------------------------------------------------------------------------- /src/handler.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.handler 3 | (:use :cl) 4 | (:import-from :clack.util 5 | :find-handler) 6 | (:import-from :bordeaux-threads 7 | :threadp 8 | :make-thread 9 | :thread-alive-p 10 | :destroy-thread) 11 | (:import-from :usocket) 12 | (:export :run 13 | :stop)) 14 | (in-package :clack.handler) 15 | 16 | (defstruct handler 17 | server 18 | swank-port 19 | acceptor) 20 | 21 | (defun run (app server &rest args 22 | &key (address nil address-specified-p) use-thread 23 | (swank-interface "127.0.0.1") swank-port debug 24 | &allow-other-keys) 25 | (let ((handler-package (find-handler server)) 26 | (bt2:*default-special-bindings* `((*standard-output* . ,*standard-output*) 27 | (*error-output* . ,*error-output*) 28 | ,@bt2:*default-special-bindings*))) 29 | (when debug 30 | (format t "NOTICE: Running in debug mode. Debugger will be invoked on errors. 31 | Specify ':debug nil' to turn it off on remote environments.")) 32 | (flet ((run-server () 33 | (when swank-port 34 | (swank:create-server :interface swank-interface :port swank-port :dont-close t)) 35 | (apply (intern #.(string '#:run) handler-package) 36 | app 37 | :allow-other-keys t 38 | (append 39 | (and address-specified-p 40 | (list :address 41 | (usocket:host-to-hostname 42 | (usocket:get-host-by-name address)))) 43 | args)))) 44 | (make-handler 45 | :server server 46 | :swank-port swank-port 47 | :acceptor (if use-thread 48 | (bt2:make-thread #'run-server 49 | :name (format nil "clack-handler-~(~A~)" server) 50 | :initial-bindings 51 | `((bt2:*default-special-bindings* . ',bt2:*default-special-bindings*) 52 | ,@bt2:*default-special-bindings*)) 53 | (run-server)))))) 54 | 55 | (defun stop (handler) 56 | (let ((acceptor (handler-acceptor handler)) 57 | (swank-port (handler-swank-port handler))) 58 | (if (bt2:threadp acceptor) 59 | (progn 60 | (when (bt2:thread-alive-p acceptor) 61 | (bt2:destroy-thread acceptor)) 62 | (sleep 0.5)) 63 | (let ((package (find-handler (handler-server handler)))) 64 | (funcall (intern #.(string '#:stop) package) acceptor))) 65 | (when swank-port 66 | (swank:stop-server swank-port)) 67 | t)) 68 | -------------------------------------------------------------------------------- /src/handler/hunchentoot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.handler.hunchentoot 3 | (:use :cl 4 | :split-sequence) 5 | (:import-from :hunchentoot 6 | :acceptor-taskmaster 7 | :acceptor-process 8 | :acceptor-shutdown-p) 9 | (:import-from :flexi-streams 10 | :make-external-format 11 | :string-to-octets 12 | :*substitution-char*) 13 | (:import-from #:bordeaux-threads 14 | #:make-lock 15 | #:with-lock-held) 16 | (:import-from :alexandria 17 | :when-let) 18 | (:export :run)) 19 | (in-package :clack.handler.hunchentoot) 20 | 21 | (defvar *client-socket*) 22 | 23 | (defclass client () 24 | ((stream :initarg :stream 25 | :reader client-stream) 26 | (socket :initarg :socket 27 | :reader client-socket) 28 | (read-callback :initarg :read-callback 29 | :initform nil 30 | :accessor client-read-callback) 31 | (write-lock :initform (bt2:make-lock) 32 | :reader client-write-lock))) 33 | 34 | (defun initialize () 35 | (setf hunchentoot:*hunchentoot-default-external-format* 36 | (flex:make-external-format :utf-8 :eol-style :lf) 37 | hunchentoot:*default-content-type* "text/html; charset=utf-8" 38 | hunchentoot:*catch-errors-p* t 39 | ;; Not logging 'Broken pipe' 40 | hunchentoot:*log-lisp-errors-p* nil)) 41 | 42 | (defclass clack-acceptor (hunchentoot:acceptor) 43 | ((app :initarg :app 44 | :initform (error ":app is required") 45 | :accessor acceptor-app) 46 | (debug :initarg :debug 47 | :initform nil 48 | :accessor acceptor-debug))) 49 | 50 | #-hunchentoot-no-ssl 51 | (defclass clack-ssl-acceptor (clack-acceptor hunchentoot:ssl-acceptor) ()) 52 | 53 | (defgeneric acceptor-handle-request (acceptor req) 54 | (:method ((acceptor clack-acceptor) req) 55 | (handle-request req :ssl nil)) 56 | #-hunchentoot-no-ssl 57 | (:method ((acceptor clack-ssl-acceptor) req) 58 | (handle-request req :ssl t))) 59 | 60 | (defmethod hunchentoot:acceptor-dispatch-request ((acceptor clack-acceptor) req) 61 | (let ((app (acceptor-app acceptor)) 62 | (env (acceptor-handle-request acceptor req)) 63 | (hunchentoot:*catch-errors-p* nil)) 64 | (if (acceptor-debug acceptor) 65 | (handle-response (funcall app env)) 66 | (handler-case (handle-response (funcall app env)) 67 | (error (error) 68 | (princ error *error-output*) 69 | (handle-response '(500 () ("Internal Server Error")))))))) 70 | 71 | (defmethod hunchentoot:process-connection :around ((acceptor clack-acceptor) socket) 72 | (let ((flex:*substitution-char* #-(or abcl lispworks) #\Replacement_Character 73 | #+lispworks #\Replacement-Character 74 | #+abcl #\?) 75 | (*client-socket* socket)) 76 | (call-next-method))) 77 | 78 | (defun run (app &rest args 79 | &key debug (address "127.0.0.1") (port 5000) 80 | ssl ssl-key-file ssl-cert-file ssl-key-password 81 | max-thread-count max-accept-count (persistent-connections-p t)) 82 | "Start Hunchentoot server." 83 | (cond 84 | ((asdf::getenv "SERVER_STARTER_PORT") 85 | (error "Hunchentoot handler doesn't work with Server::Starter.")) 86 | ((getf args :fd) 87 | (error ":fd is specified though Hunchentoot handler cannot listen on fd"))) 88 | 89 | (initialize) 90 | (let* ((taskmaster (when (and max-thread-count max-accept-count) 91 | (make-instance 'hunchentoot:one-thread-per-connection-taskmaster 92 | :max-thread-count max-thread-count 93 | :max-accept-count max-accept-count))) 94 | (acceptor 95 | (if ssl 96 | (apply #'make-instance 'clack-ssl-acceptor 97 | :app app 98 | :debug debug 99 | :address address 100 | :port port 101 | :ssl-certificate-file ssl-cert-file 102 | :ssl-privatekey-file ssl-key-file 103 | :ssl-privatekey-password ssl-key-password 104 | :access-log-destination nil 105 | :persistent-connections-p persistent-connections-p 106 | (and taskmaster 107 | (list :taskmaster taskmaster))) 108 | (apply #'make-instance 'clack-acceptor 109 | :app app 110 | :debug debug 111 | :address address 112 | :port port 113 | :access-log-destination nil 114 | :error-template-directory nil 115 | :persistent-connections-p persistent-connections-p 116 | (and taskmaster 117 | (list :taskmaster taskmaster)))))) 118 | (let* ((taskmaster (acceptor-taskmaster acceptor)) 119 | (threadedp (typep taskmaster 'hunchentoot:multi-threaded-taskmaster))) 120 | (setf (hunchentoot:taskmaster-acceptor taskmaster) acceptor) 121 | (unwind-protect 122 | (progn 123 | (hunchentoot:start acceptor) 124 | #-lispworks 125 | (when threadedp 126 | (let ((thread (hunchentoot::acceptor-process taskmaster))) 127 | (bt2:join-thread 128 | (if (typep thread 'bt2:thread) 129 | thread 130 | (bt2::ensure-thread-wrapper thread))))) 131 | #+lispworks 132 | (loop (sleep (expt 2 32)))) 133 | (hunchentoot:stop acceptor))))) 134 | 135 | (defun handle-response (res) 136 | "Convert Response from Clack application into a string 137 | before passing to Hunchentoot." 138 | (flet ((handle-normal-response (res) 139 | (destructuring-bind (status headers &optional (body nil body-p)) res 140 | (setf (hunchentoot:return-code*) status) 141 | (loop for (k v) on headers by #'cddr 142 | if (eq k :set-cookie) 143 | do (rplacd (last (hunchentoot:headers-out*)) 144 | (list (cons k v))) 145 | else if (eq k :content-type) do 146 | (setf (hunchentoot:content-type*) v) 147 | else if (eq k :content-length) do 148 | (setf (hunchentoot:content-length*) v) 149 | else if (hunchentoot:header-out k) do 150 | (setf (hunchentoot:header-out k) 151 | (format nil "~A, ~A" (hunchentoot:header-out k) v)) 152 | else 153 | do (setf (hunchentoot:header-out k) v)) 154 | 155 | (unless body-p 156 | (return-from handle-normal-response 157 | (let ((out (hunchentoot:send-headers))) 158 | (lambda (body &key (start 0) (end (length body)) (close nil)) 159 | (handler-case 160 | (etypecase body 161 | (null) 162 | (string 163 | (write-sequence 164 | (flex:string-to-octets body 165 | :start start :end end 166 | :external-format hunchentoot:*hunchentoot-default-external-format*) 167 | out)) 168 | ((vector (unsigned-byte 8)) 169 | (write-sequence body out :start start :end end))) 170 | (type-error (e) 171 | (format *error-output* "Error when writing to socket: ~a~%" e))) 172 | (if close 173 | (finish-output out) 174 | (force-output out)))))) 175 | 176 | (handler-case 177 | (etypecase body 178 | (null) ;; nothing to response 179 | (pathname 180 | (hunchentoot:handle-static-file body (getf headers :content-type))) 181 | (list 182 | (let ((out (hunchentoot:send-headers))) 183 | (dolist (chunk body) 184 | (write-sequence (flex:string-to-octets chunk 185 | :external-format hunchentoot:*hunchentoot-default-external-format*) 186 | out)))) 187 | ((vector (unsigned-byte 8)) 188 | ;; I'm not convinced with this header should be send automatically or not 189 | ;; and not sure how to handle same way in other method so comment out 190 | ;;(setf (content-length*) (length body)) 191 | (let ((out (hunchentoot:send-headers))) 192 | (write-sequence body out) 193 | (finish-output out)))) 194 | (type-error (e) 195 | (format *error-output* "Error when writing to socket: ~a~%" e)))))) 196 | (etypecase res 197 | (list (handle-normal-response res)) 198 | (function (funcall res #'handle-normal-response))) 199 | (values))) 200 | 201 | (defun handle-request (req &key ssl) 202 | "Convert Request from server into a plist 203 | before passing to Clack application." 204 | (destructuring-bind (server-name &optional (server-port "80")) 205 | (split-sequence #\: (hunchentoot:host req) :from-end t) 206 | (list 207 | :request-method (hunchentoot:request-method* req) 208 | :script-name "" 209 | :path-info (hunchentoot:script-name* req) 210 | :server-name server-name 211 | :server-port (parse-integer server-port :junk-allowed t) 212 | :server-protocol (hunchentoot:server-protocol* req) 213 | :request-uri (hunchentoot:request-uri* req) 214 | :url-scheme (if ssl "https" "http") 215 | :remote-addr (hunchentoot:remote-addr* req) 216 | :remote-port (hunchentoot:remote-port* req) 217 | ;; Request params 218 | :query-string (hunchentoot:query-string* req) 219 | :raw-body (hunchentoot:raw-post-data :request req :want-stream t) 220 | :content-length (when-let (content-length (hunchentoot:header-in* :content-length req)) 221 | (parse-integer content-length :junk-allowed t)) 222 | :content-type (hunchentoot:header-in* :content-type req) 223 | :clack.streaming t 224 | :clack.io (make-instance 'client 225 | :socket *client-socket* 226 | :stream (hunchentoot::content-stream req)) 227 | 228 | :headers (loop with headers = (make-hash-table :test 'equal) 229 | for (k . v) in (hunchentoot:headers-in* req) 230 | unless (or (eq k :content-length) 231 | (eq k :content-type)) 232 | do (setf (gethash (string-downcase k) headers) v) 233 | finally (return headers))))) 234 | 235 | (defmethod clack.socket:read-callback ((client client)) 236 | (client-read-callback client)) 237 | 238 | (defmethod (setf clack.socket:read-callback) (callback (client client)) 239 | (setf (client-read-callback client) callback)) 240 | 241 | (defmethod clack.socket:write-sequence-to-socket ((client client) data &key callback) 242 | (bt2:with-lock-held ((client-write-lock client)) 243 | (let ((stream (client-stream client))) 244 | (write-sequence data stream) 245 | (force-output stream))) 246 | (when callback 247 | (funcall callback))) 248 | 249 | (defmethod clack.socket:close-socket ((client client)) 250 | (bt2:with-lock-held ((client-write-lock client)) 251 | (finish-output (client-stream client)))) 252 | 253 | (defmethod clack.socket:flush-socket-buffer ((client client) &key callback) 254 | (bt2:with-lock-held ((client-write-lock client)) 255 | (force-output (client-stream client))) 256 | (when callback 257 | (funcall callback))) 258 | 259 | (defmethod clack.socket:socket-async-p ((client client)) 260 | nil) 261 | 262 | (defmethod clack.socket:socket-stream ((client client)) 263 | (client-stream client)) 264 | -------------------------------------------------------------------------------- /src/handler/toot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.handler.toot 3 | (:use :cl 4 | :toot 5 | :split-sequence 6 | :ppcre) 7 | (:shadow :handle-request) 8 | (:import-from :toot 9 | :shutdown-p 10 | :listen-socket 11 | :listen-backlog 12 | :acceptor-process 13 | :accept-connections) 14 | (:import-from :flexi-streams 15 | :octets-to-string 16 | :*substitution-char*) 17 | (:import-from :alexandria 18 | :if-let) 19 | (:export :run)) 20 | (in-package :clack.handler.toot) 21 | 22 | (defun run (app &rest args 23 | &key debug (address "127.0.0.1") (port 5000) 24 | ssl ssl-key-file ssl-cert-file ssl-key-password) 25 | "Start Toot server." 26 | (cond 27 | ((asdf::getenv "SERVER_STARTER_PORT") 28 | (error "Toot handler doesn't work with Server::Starter.")) 29 | ((getf args :fd) 30 | (error ":fd is specified though Toot handler cannot listen on fd"))) 31 | 32 | (let* ((stdout *standard-output*) 33 | (errout *error-output*) 34 | (acceptor (apply #'make-instance 'toot:acceptor 35 | :handler (lambda (req) 36 | (let ((env (handle-request req :ssl ssl)) 37 | (*standard-output* stdout) 38 | (*error-output* errout)) 39 | (handle-response 40 | req 41 | (if debug 42 | (restart-case 43 | (funcall app env) 44 | (throw-internal-server-error () 45 | '(500 () ("Internal Server Error")))) 46 | (handler-case (funcall app env) 47 | (error (error) 48 | (princ error *error-output*) 49 | '(500 () ("Internal Server Error")))))))) 50 | :address address 51 | :port port 52 | :access-logger nil 53 | (if ssl 54 | (list :ssl-certificate-file ssl-cert-file 55 | :ssl-private-key-file ssl-key-file 56 | :ssl-private-key-password ssl-key-password) 57 | '())))) 58 | (setf (shutdown-p acceptor) nil) 59 | (setf (listen-socket acceptor) 60 | (usocket:socket-listen 61 | (or (address acceptor) usocket:*wildcard-host*) port 62 | :reuseaddress t 63 | :backlog (listen-backlog acceptor) 64 | :element-type '(unsigned-byte 8))) 65 | (setf (acceptor-process (toot:taskmaster acceptor)) (bt2:current-thread)) 66 | (unwind-protect 67 | (accept-connections acceptor) 68 | (toot:stop-acceptor acceptor)))) 69 | 70 | (defun handle-request (req &key ssl) 71 | "Convert Request from server into a plist 72 | before pass to Clack application." 73 | (let ((content-length (if-let (content-length (request-header :content-length req)) 74 | (parse-integer content-length :junk-allowed t) 75 | (progn 76 | (setf (slot-value req 'request-headers) (acons :content-length "" (slot-value req 'request-headers))) 77 | nil)))) 78 | (destructuring-bind (server-name &optional server-port) 79 | (split-sequence #\: (cdr (assoc :host (request-headers req)))) 80 | (list 81 | :request-method (request-method req) 82 | :script-name "" 83 | :path-info (let ((flex:*substitution-char* #-abcl #\Replacement_Character 84 | #+abcl #\?)) 85 | (url-decode (request-path req))) 86 | :server-name server-name 87 | :server-port (if server-port 88 | (parse-integer server-port) 89 | 80) 90 | :server-protocol (server-protocol req) 91 | :request-uri (request-uri req) 92 | :url-scheme (if ssl "https" "http") 93 | :remote-addr (remote-addr req) 94 | :remote-port (remote-port req) 95 | :query-string (request-query req) 96 | :content-length content-length 97 | :content-type (request-header :content-type req) 98 | :raw-body (toot::request-body-stream req) 99 | :clack.streaming t 100 | :clack.handler :toot 101 | :headers (loop with headers = (make-hash-table :test 'equal) 102 | for (k . v) in (toot::request-headers req) 103 | unless (or (eq k :content-length) 104 | (eq k :content-type)) 105 | do (setf (gethash (string-downcase k) headers) v) 106 | finally (return headers)))))) 107 | 108 | (defun handle-response (req res) 109 | (let ((no-body '#:no-body)) 110 | (flet ((handle-normal-response (req res) 111 | (destructuring-bind (status headers &optional (body no-body)) res 112 | (when (pathnamep body) 113 | (multiple-value-call #'serve-file 114 | (values req body (parse-charset (getf headers :content-type)))) 115 | (return-from handle-normal-response)) 116 | 117 | (setf (status-code req) status) 118 | (loop for (k v) on headers by #'cddr 119 | if (eq k :set-cookie) 120 | do (rplacd (last (toot::response-headers req)) 121 | (list (cons k v))) 122 | else if (eq k :content-type) do 123 | (multiple-value-bind (v charset) 124 | (parse-charset v) 125 | (setf (response-header k req) v) 126 | (setf (toot::response-charset req) charset)) 127 | else if (response-header k req) do 128 | (setf (response-header k req) 129 | (format nil "~A, ~A" (response-header k req) v)) 130 | else do 131 | (setf (response-header k req) v)) 132 | (toot::send-response-headers 133 | req 134 | (getf headers :content-length) 135 | nil 136 | (toot::response-charset req)) 137 | (let ((out (toot::content-stream req))) 138 | (when (eq body no-body) 139 | (return-from handle-normal-response 140 | (lambda (body &key (start 0) (end (length body)) (close nil)) 141 | (declare (ignore close)) 142 | (etypecase body 143 | (null) 144 | (string 145 | (write-sequence (flex:string-to-octets body 146 | :start start :end end 147 | :external-format toot::*default-charset*) 148 | out)) 149 | ((vector (unsigned-byte 8)) 150 | (write-sequence body out :start start :end end)))))) 151 | 152 | (etypecase body 153 | (null) ;; nothing to response 154 | (list 155 | (write-sequence (flex:string-to-octets (format nil "~{~A~}" body) 156 | :external-format toot::*default-charset*) 157 | out))))))) 158 | (etypecase res 159 | (list (handle-normal-response req res)) 160 | (function (funcall res (lambda (res) 161 | (handle-normal-response req res)))))))) 162 | 163 | (defun parse-charset (content-type) 164 | (multiple-value-bind (start end reg1 reg2) 165 | (ppcre:scan "(;\\s*?charset=([-_a-zA-Z0-9]+))" content-type) 166 | (declare (ignore end)) 167 | (if start 168 | (values (subseq content-type 0 (aref reg1 0)) 169 | (subseq content-type (aref reg1 1) (aref reg2 1))) 170 | ;; there is no ";charset=" 171 | (values content-type toot::*default-charset*)))) 172 | -------------------------------------------------------------------------------- /src/handler/wookie.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.handler.wookie 3 | (:use :cl) 4 | (:import-from :wookie 5 | :*state* 6 | :wookie-state 7 | :start-response 8 | :send-response 9 | :finish-response 10 | :add-hook 11 | :defroute 12 | :listener 13 | :ssl-listener 14 | :start-server 15 | :request-headers 16 | :request-resource 17 | :request-http 18 | :request-body 19 | :request-store-body 20 | :request-method 21 | :request-uri 22 | :request-socket) 23 | (:import-from :cl-async 24 | :with-event-loop 25 | :close-tcp-server 26 | :async-io-stream 27 | :socket-data 28 | :write-socket-data) 29 | (:import-from :fast-http 30 | :http-version) 31 | (:import-from :quri 32 | :uri-path 33 | :uri-query 34 | :parse-uri 35 | :url-decode) 36 | (:import-from :flexi-streams 37 | :make-in-memory-input-stream) 38 | (:import-from :babel 39 | :string-to-octets) 40 | (:import-from :fast-io 41 | :with-fast-output 42 | :fast-write-sequence 43 | :fast-write-byte) 44 | (:import-from :split-sequence 45 | :split-sequence) 46 | (:import-from :alexandria 47 | :copy-stream) 48 | (:export :run)) 49 | (in-package :clack.handler.wookie) 50 | 51 | ;; XXX: :store-body keeps the whole POST data in-memory. 52 | (defun parsed-headers-hook (request) 53 | (setf (wookie:request-store-body request) t)) 54 | 55 | (defun run (app &rest args 56 | &key (debug t) (address "127.0.0.1") (port 5000) 57 | ssl ssl-key-file ssl-cert-file ssl-key-password) 58 | (cond 59 | ((asdf::getenv "SERVER_STARTER_PORT") 60 | (error "Wookie handler doesn't work with Server::Starter.")) 61 | ((getf args :fd) 62 | (error ":fd is specified though Wookie handler cannot listen on fd"))) 63 | 64 | (let ((*state* (make-instance 'wookie:wookie-state))) 65 | (add-hook :parsed-headers 'parsed-headers-hook :clack-handler-wookie-parsed-headers-hook) 66 | (defroute (:* ".*" :chunk nil) (req res) 67 | (let ((env (handle-request req :ssl ssl))) 68 | (handle-response 69 | res 70 | (if debug 71 | (restart-case 72 | (funcall app env) 73 | (throw-internal-server-error () 74 | '(500 nil ("Internal Server Error")))) 75 | (handler-case (funcall app env) 76 | (error (error) 77 | (princ error *error-output*) 78 | '(500 nil ("Internal Server Error")))))))) 79 | (handler-case 80 | (as:with-event-loop () 81 | (let ((listener 82 | (if ssl 83 | (make-instance 'wookie:ssl-listener 84 | :bind address 85 | :port port 86 | :key ssl-key-file 87 | :certificate ssl-cert-file 88 | :password ssl-key-password) 89 | (make-instance 'wookie:listener 90 | :bind address 91 | :port port)))) 92 | (start-server listener))) 93 | (as:socket-closed () nil)))) 94 | 95 | (defun handle-request (req &key ssl) 96 | (let* ((quri (request-uri req)) 97 | (http-version (http-version (request-http req))) 98 | (headers (request-headers req)) 99 | (content-length (gethash "content-length" headers))) 100 | 101 | (destructuring-bind (server-name &optional server-port) 102 | (split-sequence #\: (gethash "host" headers "") :from-end t :count 2) 103 | (setf (quri:uri-path quri) 104 | (nth-value 4 (quri:parse-uri (request-resource req)))) 105 | (list :request-method (request-method req) 106 | :script-name "" 107 | :server-name server-name 108 | :server-port (if server-port 109 | (parse-integer server-port :junk-allowed t) 110 | 80) 111 | :server-protocol (intern (format nil "HTTP/~A" http-version) 112 | :keyword) 113 | :path-info (quri:url-decode (uri-path quri) :lenient t) 114 | :query-string (uri-query quri) 115 | :url-scheme (if ssl "https" "http") 116 | :request-uri (request-resource req) 117 | :raw-body (flex:make-in-memory-input-stream (wookie:request-body req)) 118 | :content-length (when content-length 119 | (parse-integer content-length :junk-allowed t)) 120 | :content-type (gethash "content-type" headers) 121 | :clack.streaming t 122 | :clack.nonblocking t 123 | :clack.io (request-socket req) 124 | :headers headers)))) 125 | 126 | (defun handle-response (res clack-res) 127 | (etypecase clack-res 128 | (list (handle-normal-response res clack-res)) 129 | (function (funcall clack-res (lambda (clack-res) 130 | (handler-case 131 | (handle-normal-response res clack-res) 132 | ;; Ignore when the socket is closed. 133 | (as:socket-closed ()))))))) 134 | 135 | (defun handle-normal-response (res clack-res) 136 | (let ((no-body '#:no-body)) 137 | (destructuring-bind (status headers &optional (body no-body)) clack-res 138 | ;; Returns a writer function for streaming response 139 | (when (eq body no-body) 140 | (let ((stream (start-response res 141 | :status status 142 | :headers headers))) 143 | (return-from handle-normal-response 144 | (lambda (body &key (start 0) (end (length body)) (close nil)) 145 | (etypecase body 146 | (null) 147 | (string (write-sequence (babel:string-to-octets body :start start :end end) stream)) 148 | ((vector (unsigned-byte 8)) (write-sequence body stream :start start :end end))) 149 | (when close 150 | (finish-response res)))))) 151 | 152 | (etypecase body 153 | ;; Just send the headers and status. 154 | (null (send-response res :status status :headers headers)) 155 | (pathname 156 | (let ((stream (start-response res 157 | :status status 158 | :headers headers))) 159 | (with-open-file (in body 160 | :direction :input 161 | :element-type '(unsigned-byte 8)) 162 | (copy-stream in stream)) 163 | (finish-response res))) 164 | (list 165 | (send-response res 166 | :status status 167 | :headers headers 168 | :body (if (null (cdr body)) 169 | (car body) 170 | (with-fast-output (buffer :vector) 171 | (dolist (str body) 172 | (fast-write-sequence (babel:string-to-octets str) buffer)))))) 173 | ((vector (unsigned-byte 8)) 174 | (send-response res 175 | :status status 176 | :headers headers 177 | :body body)))))) 178 | 179 | (defmethod clack.socket:read-callback ((socket as:socket)) 180 | (getf (as:socket-data socket) :parser)) 181 | 182 | (defmethod (setf clack.socket:read-callback) (callback (socket as:socket)) 183 | (setf (getf (as:socket-data socket) :parser) callback)) 184 | 185 | (defmethod clack.socket:write-sequence-to-socket ((socket as:socket) data &key callback) 186 | (as:write-socket-data socket data 187 | :write-cb 188 | (and callback 189 | (lambda (socket) 190 | (declare (ignore socket)) 191 | (funcall callback))))) 192 | 193 | (defmethod clack.socket:close-socket ((socket as:socket)) 194 | (unless (as:socket-closed-p socket) 195 | (as:close-socket socket))) 196 | 197 | (defmethod clack.socket:socket-async-p ((socket as:socket)) 198 | t) 199 | -------------------------------------------------------------------------------- /src/socket.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.socket 3 | (:use :cl) 4 | (:export :read-callback 5 | :close-socket 6 | :write-sequence-to-socket 7 | :write-byte-to-socket 8 | :write-sequence-to-socket-buffer 9 | :write-byte-to-socket-buffer 10 | :flush-socket-buffer 11 | :socket-async-p 12 | :socket-stream)) 13 | (in-package :clack.socket) 14 | 15 | ;; required 16 | (defgeneric read-callback (socket)) 17 | 18 | ;; required 19 | (defgeneric (setf read-callback) (callback socket)) 20 | 21 | ;; required 22 | (defgeneric close-socket (socket)) 23 | 24 | ;; required. 25 | (defgeneric write-sequence-to-socket (socket data &key callback)) 26 | 27 | ;; optional. fallback to write-sequence-to-socket 28 | (defgeneric write-byte-to-socket (socket byte &key callback) 29 | (:method (socket byte &key callback) 30 | (write-sequence-to-socket socket 31 | (make-array 1 :element-type '(unsigned-byte 8) 32 | :initial-contents (list byte)) 33 | :callback callback))) 34 | 35 | ;; optional. fallback to synchronous version 36 | (defgeneric write-sequence-to-socket-buffer (socket data) 37 | (:method (socket data) 38 | (write-sequence-to-socket socket data))) 39 | 40 | ;; optional. fallback to synchronous version 41 | (defgeneric write-byte-to-socket-buffer (socket byte) 42 | (:method (socket byte) 43 | (write-byte-to-socket socket byte))) 44 | 45 | ;; optional. 46 | (defgeneric flush-socket-buffer (socket &key callback) 47 | (:method (socket &key callback) 48 | (write-sequence-to-socket socket 49 | #.(make-array 0 :element-type '(unsigned-byte 8)) 50 | :callback callback))) 51 | 52 | ;; optional 53 | (defgeneric socket-async-p (socket) 54 | (:method (socket) 55 | t)) 56 | 57 | ;; optional 58 | ;: required if socket-async-p returns nil 59 | (defgeneric socket-stream (socket)) 60 | -------------------------------------------------------------------------------- /src/test.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.test 3 | (:use :cl) 4 | (:import-from :clack 5 | :clackup 6 | :stop) 7 | (:import-from :dexador 8 | :*use-connection-pool*) 9 | (:import-from :rove 10 | :testing) 11 | (:import-from :usocket 12 | :socket-listen 13 | :socket-close 14 | :address-in-use-error 15 | :socket-error) 16 | (:export :*clack-test-handler* 17 | :*clack-test-port* 18 | :*clack-test-access-port* 19 | :*clackup-additional-args* 20 | :*enable-debug* 21 | :*use-https* 22 | :*random-port* 23 | :localhost 24 | :testing-app)) 25 | (in-package :clack.test) 26 | 27 | (defvar *clack-test-handler* :hunchentoot 28 | "Backend Handler to run tests on. String or Symbol are allowed.") 29 | 30 | (defvar *clack-test-port* 4242 31 | "HTTP port number of Handler.") 32 | 33 | (defvar *clackup-additional-args* '() 34 | "Additional arguments for clackup.") 35 | 36 | (defvar *clack-test-access-port* *clack-test-port* 37 | "Port of localhost to request. 38 | Use if you want to set another port. The default is `*clack-test-port*`.") 39 | 40 | (defvar *enable-debug* t) 41 | (defvar *use-https* nil) 42 | 43 | (defvar *random-port* t) 44 | 45 | (defun port-available-p (port) 46 | (let (socket) 47 | (unwind-protect 48 | (handler-case (progn 49 | (setq socket (usocket:socket-listen "127.0.0.1" port :reuse-address t)) 50 | t) 51 | (usocket:address-in-use-error () nil) 52 | #+(and sbcl win32) 53 | (sb-bsd-sockets:socket-error () nil) 54 | (usocket:socket-error (e) 55 | (warn "USOCKET:SOCKET-ERROR: ~A" e) 56 | nil)) 57 | (when socket 58 | (usocket:socket-close socket) 59 | t)))) 60 | 61 | (defun server-running-p (port) 62 | (handler-case (let ((socket (usocket:socket-connect "127.0.0.1" port))) 63 | (usocket:socket-close socket) 64 | t) 65 | #+sbcl (sb-bsd-sockets:interrupted-error () nil) 66 | (usocket:socket-error () nil) 67 | (usocket:connection-refused-error () nil) 68 | (usocket:connection-reset-error () nil))) 69 | 70 | (defun random-port () 71 | "Return a port number not in use from 50000 to 60000." 72 | (loop for port from (+ 50000 (random 1000)) upto 60000 73 | if (port-available-p port) 74 | return port)) 75 | 76 | (defun localhost (&optional (path "/") (port *clack-test-access-port*)) 77 | (check-type path string) 78 | (setf path 79 | (cond 80 | ((= 0 (length path)) "/") 81 | ((not (char= (aref path 0) #\/)) 82 | (concatenate 'string "/" path)) 83 | (t path))) 84 | (format nil "http~@[~*s~]://127.0.0.1:~D~A" 85 | *use-https* 86 | port path)) 87 | 88 | (defun %testing-app (app client) 89 | (let* ((*clack-test-port* (if *random-port* 90 | (random-port) 91 | *clack-test-port*)) 92 | (*clack-test-access-port* (if *random-port* 93 | *clack-test-port* 94 | *clack-test-access-port*)) 95 | (threads #+thread-support (bt2:all-threads) 96 | #-thread-support '())) 97 | (loop repeat 5 98 | until (port-available-p *clack-test-port*) 99 | do (sleep 0.1) 100 | finally 101 | (unless (port-available-p *clack-test-port*) 102 | (error "Port ~D is already in use." *clack-test-port*))) 103 | (let ((acceptor (apply #'clackup app 104 | :server *clack-test-handler* 105 | :port *clack-test-port* 106 | :debug *enable-debug* 107 | :use-thread t 108 | :silent t 109 | *clackup-additional-args*)) 110 | (dex:*use-connection-pool* nil)) 111 | (loop until (server-running-p *clack-test-port*) 112 | do (sleep 0.1)) 113 | 114 | (multiple-value-prog1 115 | (unwind-protect (funcall client) 116 | (stop acceptor) 117 | ;; Ensure all threads are finished for preventing from leaking 118 | #+thread-support 119 | (dolist (thread (bt2:all-threads)) 120 | (when (and (not (find thread threads)) 121 | (bt2:thread-alive-p thread)) 122 | (bt2:destroy-thread thread)))) 123 | 124 | (loop while (server-running-p *clack-test-port*) 125 | do (sleep 0.1)))))) 126 | 127 | (defmacro testing-app (desc app &body body) 128 | `(%testing-app ,app (lambda () (testing ,desc ,@body)))) 129 | -------------------------------------------------------------------------------- /src/test/suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.test.suite 3 | (:use :cl 4 | :rove) 5 | (:import-from :clack.test 6 | :*clack-test-handler* 7 | :*clack-test-port* 8 | :*clack-test-access-port* 9 | :*enable-debug* 10 | :testing-app) 11 | (:import-from :flexi-streams 12 | :octet 13 | :octets-to-string) 14 | (:import-from :http-body 15 | :parse) 16 | (:import-from :cl-ppcre 17 | :scan) 18 | (:export :run-server-tests)) 19 | (in-package :clack.test.suite) 20 | 21 | (defvar *clack-pathname* 22 | (asdf:system-source-directory :clack)) 23 | 24 | (defun localhost (&optional (path "/")) 25 | (clack.test:localhost path *clack-test-access-port*)) 26 | 27 | (defun run-server-tests (handler-name) 28 | "Run tests for clack.handler. 29 | Handler name is a keyword and doesn't include the clack.handler prefix. 30 | For example, if you have a handler `clack.handler.foo', 31 | you would call like this: `(run-server-tests :foo)'." 32 | (let ((*clack-test-handler* handler-name) 33 | (*package* (find-package :clack.test.suite)) 34 | (dex:*use-connection-pool* nil)) 35 | #+thread-support 36 | (rove:run-suite :clack.test.suite) 37 | #-thread-support 38 | (skip "Handler tests because your Lisp doesn't support threads"))) 39 | 40 | (defun get-header (headers key) 41 | (gethash (string-downcase key) headers)) 42 | 43 | (defun file-size (file) 44 | (with-open-file (in file :direction :input) 45 | (file-length in))) 46 | 47 | 48 | ;; Tests 49 | 50 | (deftest response-tests 51 | (testing-app "list" 52 | (lambda (env) 53 | (declare (ignore env)) 54 | '(200 (:content-type "text/plain") ("Hello" "World"))) 55 | (multiple-value-bind (body status) 56 | (dex:get (localhost)) 57 | (ok (eql status 200)) 58 | (ok (equal body "HelloWorld")))) 59 | 60 | (testing-app "pathname (plain/text)" 61 | (lambda (env) 62 | (declare (ignore env)) 63 | `(200 64 | (:content-type "text/plain; charset=utf-8") 65 | ,(merge-pathnames #p"tmp/file.txt" *clack-pathname*))) 66 | (multiple-value-bind (body status headers) 67 | (dex:get (localhost)) 68 | (ok (eql status 200)) 69 | (ok (equal (get-header headers :content-type) "text/plain; charset=utf-8")) 70 | (ok (ppcre:scan "This is a text for test." body)))) 71 | 72 | (testing-app "pathname (binary)" 73 | (lambda (env) 74 | (declare (ignore env)) 75 | (let ((file (merge-pathnames #p"tmp/redhat.png" *clack-pathname*))) 76 | `(200 77 | (:content-type "image/png" 78 | :content-length ,(file-size file)) 79 | ,file))) 80 | (multiple-value-bind (body status headers) 81 | (dex:get (localhost "/redhat.png")) 82 | (ok (eql status 200)) 83 | (ok (equal (get-header headers :content-type) "image/png")) 84 | (if (eq *clack-test-handler* :wookie) 85 | (ok (equal (get-header headers :transfer-encoding) "chunked") 86 | "Wookie always returns with Transfer-Encoding: chunked and no Content-Length.") 87 | (ok (get-header headers :content-length))) 88 | (ok (eql (length body) 12155)))) 89 | 90 | (testing-app "bigger file" 91 | (lambda (env) 92 | (declare (ignore env)) 93 | (let ((file (merge-pathnames #p"tmp/jellyfish.jpg" *clack-pathname*))) 94 | `(200 95 | (:content-type "image/jpeg" 96 | :content-length ,(file-size file)) 97 | ,file))) 98 | (multiple-value-bind (body status headers) 99 | (dex:get (localhost "/jellyfish.jpg")) 100 | (ok (eql status 200)) 101 | (ok (equal (get-header headers :content-type) "image/jpeg")) 102 | (if (eq *clack-test-handler* :wookie) 103 | (ok (equal (get-header headers :transfer-encoding) "chunked") 104 | "Wookie always returns with Transfer-Encoding: chunked and no Content-Length.") 105 | (ok (get-header headers :content-length))) 106 | (ok (eql (length body) 139616)))) 107 | 108 | (testing-app "multi headers (response)" 109 | (lambda (env) 110 | (declare (ignore env)) 111 | `(200 112 | (:content-type "text/plain; charset=utf-8" 113 | :x-foo "foo" 114 | :x-foo "bar, baz") 115 | ("hi"))) 116 | (let ((headers (nth-value 2 (dex:get (localhost))))) 117 | (ok (ppcre:scan "foo,\\s*bar,\\s*baz" (get-header headers :x-foo))))) 118 | 119 | ;; NOTE: This may fail on Hunchentoot because of its bug. 120 | ;; Hunchentoot returns Content-Type header 121 | ;; though 304 Not Modified. 122 | ;; And Wookie also always returns Transfer-Encoding header. 123 | (testing-app "no entity headers on 304" 124 | (lambda (env) 125 | (declare (ignore env)) 126 | `(304 nil nil)) 127 | (if (or (eq *clack-test-handler* :hunchentoot) 128 | (eq *clack-test-handler* :toot) 129 | (eq *clack-test-handler* :wookie)) 130 | (skip (format nil "Skipped because of ~:(~A~)'s bug" *clack-test-handler*)) 131 | (multiple-value-bind (body status headers) 132 | (dex:get (localhost)) 133 | (ok (eql status 304)) 134 | (ok (equalp body #())) 135 | (ok (null (nth-value 1 (get-header headers :content-type))) "No Content-Type") 136 | (ok (null (nth-value 1 (get-header headers :content-length))) "No Content-Length") 137 | (ok (null (nth-value 1 (get-header headers :transfer-encoding))) "No Transfer-Encoding")))) 138 | 139 | (testing-app "CRLF output" 140 | (lambda (env) 141 | (declare (ignore env)) 142 | `(200 143 | (:content-type "text/plain; charset=utf-8") 144 | (,(format nil "Foo: Bar~A~A~A~AHello World" 145 | #\Return #\NewLine #\Return #\NewLine)))) 146 | (multiple-value-bind (body status headers) 147 | (dex:get (localhost)) 148 | (ok (eql status 200)) 149 | (ok (null (get-header headers :foo))) 150 | (ok (equal body (format nil "Foo: Bar~A~A~A~AHello World" 151 | #\Return #\NewLine #\Return #\NewLine))))) 152 | 153 | (testing-app "test 404" 154 | (lambda (env) 155 | (declare (ignore env)) 156 | '(404 157 | (:content-type "text/plain; charset=utf-8") 158 | ("Not Found"))) 159 | (multiple-value-bind (body status) 160 | (handler-bind ((dex:http-request-not-found #'dex:ignore-and-continue)) 161 | (dex:get (localhost))) 162 | (ok (eql status 404)) 163 | (ok (equal body "Not Found")))) 164 | 165 | (testing-app "Content-Length 0 is not set Transfer-Encoding" 166 | (lambda (env) 167 | (declare (ignore env)) 168 | `(200 169 | (:content-length 0 170 | :content-type "text/plain") 171 | (""))) 172 | (multiple-value-bind (body status headers) 173 | (dex:get (localhost)) 174 | (ok (eql status 200)) 175 | (ok (null (get-header headers :client-transfer-encoding))) 176 | (ok (equal body ""))))) 177 | 178 | (deftest env-tests 179 | (testing-app "SCRIPT-NAME" 180 | (lambda (env) 181 | `(200 182 | (:content-type "text/plain; charset=utf-8") 183 | (,(getf env :script-name)))) 184 | (ok (member (dex:get (localhost)) '(nil "") :test #'equal))) 185 | 186 | (testing-app "url-scheme" 187 | (lambda (env) 188 | `(200 189 | (:content-type "text/plain; charset=utf-8") 190 | (,(getf env :url-scheme)))) 191 | (multiple-value-bind (body status headers) 192 | (dex:post (localhost)) 193 | (ok (eql status 200)) 194 | (ok (equal (get-header headers :content-type) "text/plain; charset=utf-8")) 195 | (ok (equal body "http")))) 196 | 197 | (testing-app "handle HTTP-Header" 198 | (lambda (env) 199 | `(200 200 | (:content-type "text/plain; charset=utf-8") 201 | (,(gethash "foo" (getf env :headers))))) 202 | (multiple-value-bind (body status headers) 203 | (dex:get (localhost "/foo/?ediweitz=weitzedi") 204 | :headers '(("Foo" . "Bar"))) 205 | (ok (eql status 200)) 206 | (ok (equal (get-header headers :content-type) "text/plain; charset=utf-8")) 207 | (ok (equal body "Bar")))) 208 | 209 | (testing-app "validate env" 210 | (lambda (env) 211 | `(200 212 | (:content-type "text/plain; charset=utf-8") 213 | (,(with-output-to-string (str) 214 | (loop for h in '(:request-method 215 | :path-info 216 | :query-string 217 | :server-name 218 | :server-port) 219 | do (format str "~A:~S~%" h (getf env h))))))) 220 | (multiple-value-bind (body status headers) 221 | (dex:get (localhost "/foo/?ediweitz=weitzedi")) 222 | (ok (eql status 200)) 223 | (ok (equal (get-header headers :content-type) "text/plain; charset=utf-8")) 224 | (ok (equal body (format nil "~{~A~%~}" 225 | `("REQUEST-METHOD::GET" 226 | "PATH-INFO:\"/foo/\"" 227 | "QUERY-STRING:\"ediweitz=weitzedi\"" 228 | "SERVER-NAME:\"127.0.0.1\"" 229 | ,(format nil "SERVER-PORT:~D" *clack-test-access-port*))))))) 230 | 231 | (testing-app "validate env (must be integer)" 232 | (lambda (env) 233 | `(200 234 | (:content-type "text/plain; charset=utf-8") 235 | (,(with-output-to-string (str) 236 | (loop for h in '(:server-port 237 | :remote-port 238 | :content-length) 239 | do (format str "~A:~A~%" h (typep (getf env h) '(or integer null)))))))) 240 | (multiple-value-bind (body status headers) 241 | (dex:post (localhost) 242 | :content '(("name" . "eitaro"))) 243 | (ok (eql status 200)) 244 | (ok (equal (get-header headers :content-type) "text/plain; charset=utf-8")) 245 | (ok (equal body (format nil "~{~{~A:~A~%~}~}" 246 | `((:server-port t) 247 | (:remote-port t) 248 | (:content-length t))))))) 249 | 250 | (testing-app "% encoding in PATH-INFO" 251 | (lambda (env) 252 | `(200 253 | (:content-type "text/plain; charset=utf-8") 254 | (,(getf env :path-info)))) 255 | (ok (equal (dex:get (localhost "/foo/bar%2cbaz")) "/foo/bar,baz"))) 256 | 257 | (testing-app "% double encoding in PATH-INFO" 258 | (lambda (env) 259 | `(200 260 | (:content-type "text/plain; charset=utf-8") 261 | (,(getf env :path-info)))) 262 | (ok (equal (dex:get (localhost "/foo/bar%252cbaz")) "/foo/bar%2cbaz"))) 263 | 264 | (testing-app "% encoding in PATH-INFO (outside of URI characters)" 265 | (lambda (env) 266 | `(200 267 | (:content-type "text/plain; charset=utf-8") 268 | (,(getf env :path-info)))) 269 | (ok (equal (dex:get (localhost "/foo%E3%81%82")) 270 | (format nil "/foo~A" 271 | (flex:octets-to-string #(#xE3 #x81 #x82) :external-format :utf-8))))) 272 | 273 | (testing-app "Invalid UTF-8 encoded PATH-INFO" 274 | (lambda (env) 275 | `(200 276 | (:content-type "text/plain; charset=utf-8") 277 | (,(getf env :path-info)))) 278 | (if (eq *clack-test-handler* :wookie) 279 | (skip "Skipped because do-urlencode Wookie uses cannot decode invalid UTF8 strings anyways") 280 | (ok (ppcre:scan (format nil "/あ~A" 281 | #+abcl "\\?" 282 | #-abcl #\Replacement_Character) 283 | (dex:get (localhost "/%E3%81%82%BF%27%22%28")))))) 284 | 285 | (testing-app "SERVER-PROTOCOL is required" 286 | (lambda (env) 287 | `(200 288 | (:content-type "text/plain; charset=utf-8") 289 | (,(prin1-to-string (getf env :server-protocol))))) 290 | (multiple-value-bind (body status headers) 291 | (dex:get (localhost "/foo/?ediweitz=weitzedi")) 292 | (ok (eql status 200)) 293 | (ok (equal (get-header headers :content-type) "text/plain; charset=utf-8")) 294 | (ok (ppcre:scan "^:HTTP/1\\.[01]$" body)))) 295 | 296 | (testing-app "SCRIPT-NAME should not be nil" 297 | (lambda (env) 298 | `(200 299 | (:content-type "text/plain; charset=utf-8") 300 | (,(princ-to-string (not (null (getf env :script-name))))))) 301 | (ok (equal (dex:get (localhost "/foo/?ediweitz=weitzedi")) 302 | (string t)))) 303 | 304 | (testing-app "Do not set COOKIE" 305 | (lambda (env) 306 | `(200 307 | (:content-type "text/plain; charset=utf-8" 308 | :x-cookie ,(not (null (getf env :cookie)))) 309 | (,(gethash "cookie" (getf env :headers))))) 310 | (multiple-value-bind (body status headers) 311 | (dex:get (localhost) 312 | :headers '(("Cookie" . "foo=bar"))) 313 | (ok (eql status 200)) 314 | (ok (null (get-header headers :x-cookie))) 315 | (ok (equal body "foo=bar")))) 316 | 317 | (testing-app "REQUEST-URI is set" 318 | (lambda (env) 319 | `(200 320 | (:content-type "text/plain; charset=utf-8") 321 | (,(getf env :request-uri)))) 322 | (if (eq *clack-test-handler* :toot) 323 | (skip "Skipped because of Toot's bug") 324 | (ok (equal (dex:get (localhost "/foo/bar%20baz%73?x=a")) "/foo/bar%20baz%73?x=a"))))) 325 | 326 | (deftest request-tests 327 | (testing-app "GET" 328 | (lambda (env) 329 | `(200 330 | (:content-type "text/plain; charset=utf-8") 331 | (,(format nil "Hello, ~A" (getf env :query-string))))) 332 | (multiple-value-bind (body status headers) 333 | (dex:get (localhost "/?name=fukamachi")) 334 | (ok (eql status 200)) 335 | (ok (equal (get-header headers :content-type) 336 | "text/plain; charset=utf-8")) 337 | (ok (equal body "Hello, name=fukamachi")))) 338 | 339 | (testing-app "POST" 340 | (lambda (env) 341 | (let ((body (make-array 11 :element-type '(unsigned-byte 8)))) 342 | (read-sequence body (getf env :raw-body)) 343 | `(200 344 | (:content-type "text/plain; charset=utf-8" 345 | :client-content-length ,(getf env :content-length) 346 | :client-content-type ,(getf env :content-type)) 347 | (,(format nil "Hello, ~A" (babel:octets-to-string body)))))) 348 | (multiple-value-bind (body status headers) 349 | (dex:post (localhost) 350 | :content '(("name" . "eitaro"))) 351 | (ok (eql status 200)) 352 | (ok (equal (get-header headers :client-content-length) "11")) 353 | (ok (equal (get-header headers :client-content-type) "application/x-www-form-urlencoded")) 354 | (ok (equal body "Hello, name=eitaro")))) 355 | 356 | (testing-app "big POST" 357 | (lambda (env) 358 | (let ((body 359 | (make-array (getf env :content-length) 360 | :element-type 'octet))) 361 | (read-sequence body (getf env :raw-body)) 362 | `(200 363 | (:content-type "text/plain; charset=utf-8" 364 | :client-content-length ,(getf env :content-length) 365 | :client-content-type ,(getf env :content-type)) 366 | (,(flex:octets-to-string body))))) 367 | (let* ((chunk 368 | (with-output-to-string (chunk) 369 | (dotimes (i 12000) (write-string "abcdefgh" chunk)) 370 | chunk)) 371 | (len (length chunk))) 372 | (multiple-value-bind (body status headers) 373 | (dex:post (localhost) 374 | :headers 375 | `((:content-type . "application/octet-stream") 376 | (:content-length . ,len)) 377 | :content chunk) 378 | (ok (eql status 200)) 379 | (ok (equal (get-header headers :client-content-length) 380 | (princ-to-string len))) 381 | (ok (equal (length body) len))))) 382 | 383 | (testing-app "big POST (chunked)" 384 | (lambda (env) 385 | `(200 386 | (:content-type "text/plain; charset=utf-8" 387 | :client-content-length ,(getf env :content-length) 388 | :client-content-type ,(getf env :content-type)) 389 | (,(let* ((body (getf env :raw-body)) 390 | (buffer (make-array 1024 :element-type '(unsigned-byte 8)))) 391 | (apply #'concatenate 'string 392 | (loop for read-bytes = (read-sequence buffer body) 393 | collect (flex:octets-to-string (subseq buffer 0 read-bytes)) 394 | while (= read-bytes 1024))))))) 395 | (let* ((chunk 396 | (with-output-to-string (chunk) 397 | (dotimes (i 12000) (write-string "abcdefgh" chunk)) 398 | chunk)) 399 | (len (length chunk))) 400 | (multiple-value-bind (body status headers) 401 | (dex:post (localhost) 402 | :headers '((:content-type . "application/octet-stream") 403 | (:content-length . nil)) 404 | :content chunk) 405 | (ok (eql status 200)) 406 | (ok (null (get-header headers :client-content-length))) 407 | (ok (equal (length body) len))))) 408 | 409 | (testing-app "multi headers (request)" 410 | (lambda (env) 411 | `(200 412 | (:content-type "text/plain; charset=utf-8") 413 | (,(gethash "foo" (getf env :headers))))) 414 | (ok (ppcre:scan 415 | "^bar,\\s*baz$" 416 | (dex:get (localhost) 417 | :headers '(("Foo" . "bar") 418 | ("Foo" . "baz")))))) 419 | 420 | (testing-app "a big header value > 128 bytes" 421 | (lambda (env) 422 | `(200 423 | (:content-type "text/plain; charset=utf-8") 424 | (,(gethash "x-foo" (getf env :headers))))) 425 | (let ((chunk 426 | (with-output-to-string (chunk) 427 | (dotimes (i 12000) (write-string "abcdefgh" chunk)) 428 | chunk))) 429 | (handler-bind ((dex:http-request-failed #'dex:ignore-and-continue)) 430 | (multiple-value-bind (body status) 431 | (dex:get (localhost) 432 | :headers `(("X-Foo" . ,chunk))) 433 | (ok (eql status 200)) 434 | (ok (equal body chunk)))))) 435 | 436 | (testing-app "request -> input seekable" 437 | (lambda (env) 438 | (let ((body (make-array 4 :element-type '(unsigned-byte 8)))) 439 | (read-sequence body (getf env :raw-body)) 440 | `(200 441 | (:content-type "text/plain; charset=utf-8") 442 | (,(babel:octets-to-string body))))) 443 | (ok (equal (dex:post (localhost) 444 | :content "body") 445 | "body"))) 446 | 447 | (testing-app "handle Authorization header" 448 | (lambda (env) 449 | `(200 450 | (:content-type "text/plain; charset=utf-8" 451 | :x-authorization ,(not (null (gethash "authorization" (getf env :headers))))) 452 | (,(gethash "authorization" (getf env :headers) "")))) 453 | (multiple-value-bind (body status headers) 454 | (dex:get (localhost) 455 | :headers '(("Authorization" . "Basic XXXX"))) 456 | (ok (eql status 200)) 457 | (ok (equal (get-header headers :x-authorization) 458 | (string t))) 459 | (ok (equal body "Basic XXXX"))) 460 | ;; XXX: On Wookie handler, this raises USOCKET:CONNECTION-REFUSED-ERROR. 461 | (unless (eq *clack-test-handler* :wookie) 462 | (multiple-value-bind (body status headers) 463 | (dex:get (localhost)) 464 | (ok (eql status 200)) 465 | (ok (null (get-header headers :x-authorization))) 466 | (ok (member body '(nil "") :test #'equal))))) 467 | 468 | (testing-app "repeated slashes" 469 | (lambda (env) 470 | `(200 471 | (:content-type "text/plain; charset=utf-8") 472 | (,(getf env :path-info)))) 473 | (multiple-value-bind (body status headers) 474 | (dex:get (localhost "/foo///bar/baz")) 475 | (ok (eql status 200)) 476 | (ok (equal (get-header headers :content-type) "text/plain; charset=utf-8")) 477 | (ok (equal body "/foo///bar/baz")))) 478 | 479 | (testing-app "file upload" 480 | (lambda (env) 481 | (destructuring-bind (name body params headers) 482 | (car (http-body:parse 483 | (getf env :content-type) 484 | (getf env :content-length) 485 | (getf env :raw-body))) 486 | (declare (ignore name params headers)) 487 | `(200 488 | (:content-type "text/plain; charset=utf-8") 489 | (,(let* ((buffer (make-array 1024 :element-type '(unsigned-byte 8))) 490 | (read-bytes (read-sequence buffer body))) 491 | (flex:octets-to-string (subseq buffer 0 read-bytes))))))) 492 | (multiple-value-bind (body status) 493 | (dex:post (localhost) 494 | :content 495 | `(("file" . ,(merge-pathnames #p"tmp/file.txt" *clack-pathname*)))) 496 | (ok (eql status 200)) 497 | (ok (equal body "This is a text for test. 498 | ")))) 499 | 500 | (testing-app "large file upload" 501 | (lambda (env) 502 | (destructuring-bind (name body params headers) 503 | (car (http-body:parse 504 | (getf env :content-type) 505 | (getf env :content-length) 506 | (getf env :raw-body))) 507 | (declare (ignore name params headers)) 508 | (let ((body-file 509 | (uiop:with-temporary-file (:stream out :pathname tmp 510 | :direction :output 511 | :element-type '(unsigned-byte 8) 512 | :keep t) 513 | (alexandria:copy-stream body out) 514 | tmp))) 515 | `(200 516 | (:content-type "text/plain") 517 | (,(if (equalp (ironclad:digest-file :sha1 body-file) 518 | (ironclad:digest-file :sha1 (merge-pathnames #p"tmp/jellyfish.jpg" *clack-pathname*))) 519 | "ok" 520 | (format nil "ng (~A)" body-file))))))) 521 | (multiple-value-bind (body status) 522 | (dex:post (localhost) 523 | :content 524 | `(("file" . ,(merge-pathnames #p"tmp/jellyfish.jpg" *clack-pathname*)))) 525 | (ok (eql status 200)) 526 | (ok (equal body "ok")))) 527 | 528 | (testing-app "streaming" 529 | (lambda (env) 530 | (declare (ignore env)) 531 | (lambda (res) 532 | (let ((writer (funcall res '(200 (:content-type "text/plain"))))) 533 | (loop for i from 0 to 2 534 | do (sleep 1) 535 | (funcall writer (format nil "~S~%" i))) 536 | (funcall writer "" :close t)))) 537 | (if (find *clack-test-handler* '(:hunchentoot 538 | :toot 539 | :wookie 540 | :woo)) 541 | (multiple-value-bind (body status) 542 | (dex:get (localhost)) 543 | (ok (eql status 200)) 544 | (ok (equal body (format nil "0~%1~%2~%")))) 545 | (skip (format nil "Skipped because ~:(~A~) doesn't support streaming" *clack-test-handler*))))) 546 | 547 | (deftest debug-tests 548 | (let ((*enable-debug* nil) 549 | (*error-output* (make-broadcast-stream))) 550 | (testing-app "Do not crash when the app dies" 551 | (lambda (env) 552 | (declare (ignore env)) 553 | (error "Throwing an exception from app handler. Server shouldn't crash.")) 554 | (handler-case (dex:get (localhost)) 555 | (dex:http-request-internal-server-error () 556 | (pass "500 Internal Server Error")))))) 557 | -------------------------------------------------------------------------------- /src/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack.util 3 | (:use :cl) 4 | (:import-from :lack.util 5 | :find-package-or-load) 6 | (:export :find-handler)) 7 | (in-package :clack.util) 8 | 9 | (defun find-handler (server) 10 | (flet ((find-with-prefix (prefix) 11 | (find-package-or-load (concatenate 'string 12 | prefix 13 | (symbol-name server))))) 14 | (or (find-with-prefix #.(string '#:clack.handler.)) 15 | (error "~S is unknown handler." 16 | server)))) 17 | -------------------------------------------------------------------------------- /t-clack-handler-hunchentoot.asd: -------------------------------------------------------------------------------- 1 | (defsystem "t-clack-handler-hunchentoot" 2 | :depends-on ("clack-handler-hunchentoot" 3 | "clack-test") 4 | :components 5 | ((:file "t/handler/hunchentoot")) 6 | :perform (test-op (op c) (symbol-call '#:rove '#:run c))) 7 | -------------------------------------------------------------------------------- /t-clack-handler-toot.asd: -------------------------------------------------------------------------------- 1 | (defsystem "t-clack-handler-toot" 2 | :depends-on ("clack-handler-toot" 3 | "clack-test") 4 | :components 5 | ((:file "t/handler/toot")) 6 | :perform (test-op (op c) (symbol-call '#:rove '#:run c))) 7 | -------------------------------------------------------------------------------- /t-clack-handler-wookie.asd: -------------------------------------------------------------------------------- 1 | (defsystem "t-clack-handler-wookie" 2 | :depends-on (;; Some environment cannot load Wookie due to like non FFI support. 3 | ;; :clack-handler-wookie 4 | "clack-test") 5 | :components 6 | ((:file "t/handler/wookie")) 7 | :perform (test-op (op c) (symbol-call '#:rove '#:run c))) 8 | -------------------------------------------------------------------------------- /t/handler/hunchentoot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage t.clack.handler.hunchentoot 3 | (:use :cl 4 | :clack.test 5 | :clack.test.suite 6 | :rove)) 7 | (in-package :t.clack.handler.hunchentoot) 8 | 9 | (deftest hunchentoot-tests 10 | (clack.test.suite:run-server-tests :hunchentoot)) 11 | -------------------------------------------------------------------------------- /t/handler/toot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage clack-test.handler.toot 4 | (:use :cl 5 | :clack.test.suite 6 | :rove)) 7 | 8 | (in-package :clack-test.handler.toot) 9 | 10 | (deftest toot-tests 11 | (let ((*error-output* (make-broadcast-stream))) 12 | (clack.test.suite:run-server-tests :toot))) 13 | -------------------------------------------------------------------------------- /t/handler/wookie.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage clack-test.handler.wookie 3 | (:use :cl 4 | :clack.test.suite 5 | :rove)) 6 | (in-package :clack-test.handler.wookie) 7 | 8 | (deftest wookie-tests 9 | (let ((*error-output* (make-broadcast-stream))) 10 | (clack.test.suite:run-server-tests :wookie))) 11 | -------------------------------------------------------------------------------- /t/nginx.conf: -------------------------------------------------------------------------------- 1 | events { 2 | worker_connections 1024; 3 | } 4 | 5 | http { 6 | include /home/travis/nginx/conf/mime.types; 7 | access_log off; 8 | error_log /dev/null crit; 9 | server { 10 | listen 4949; 11 | server_name localhost; 12 | location / { 13 | fastcgi_intercept_errors on; 14 | fastcgi_pass 127.0.0.1:14949; 15 | fastcgi_connect_timeout 30; 16 | include /home/travis/nginx/conf/fastcgi_params; 17 | } 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /tmp/file.txt: -------------------------------------------------------------------------------- 1 | This is a text for test. 2 | -------------------------------------------------------------------------------- /tmp/jellyfish.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/clack/935be5b7c862225556a312ed5ed5521a4afd98ae/tmp/jellyfish.jpg -------------------------------------------------------------------------------- /tmp/redhat.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/clack/935be5b7c862225556a312ed5ed5521a4afd98ae/tmp/redhat.png --------------------------------------------------------------------------------