├── .github ├── FUNDING.yml └── workflows │ ├── ci-windows.yml │ └── ci.yml ├── .gitignore ├── .travis.yml ├── Makefile ├── README.markdown ├── benchmark ├── 181B.html └── bench ├── dexador-test.asd ├── dexador-usocket.asd ├── dexador.asd ├── images └── benchmark.png ├── src ├── backend │ ├── usocket.lisp │ └── winhttp.lisp ├── body.lisp ├── connection-cache.lisp ├── decoding-stream.lisp ├── dexador.lisp ├── encoding.lisp ├── error.lisp ├── keep-alive-stream.lisp ├── restarts.lisp └── util.lisp └── t ├── Dockerfile ├── benchmark.lisp ├── data ├── bug139.txt ├── quote.txt ├── test.gz ├── test.zlib └── umb.bin ├── dexador.lisp └── nginx.conf /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: [fukamachi] 2 | -------------------------------------------------------------------------------- /.github/workflows/ci-windows.yml: -------------------------------------------------------------------------------- 1 | name: CI (Windows) 2 | 3 | on: 4 | push: 5 | pull_request: 6 | schedule: 7 | - cron: '0 15 * * *' 8 | 9 | jobs: 10 | test: 11 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | lisp: [sbcl-bin] 16 | os: [windows-latest] 17 | 18 | steps: 19 | - uses: actions/checkout@v1 20 | - name: Install Roswell 21 | env: 22 | LISP: ${{ matrix.lisp }} 23 | ROSWELL_INSTALL_DIR: /c/roswell 24 | shell: bash 25 | run: | 26 | PATH="/c/roswell/bin:$PATH" 27 | curl -L https://raw.githubusercontent.com/fukamachi/roswell/windows-source-registry-settings/scripts/install-for-ci.sh | sh 28 | - name: Install Ultralisp 29 | shell: bash 30 | run: /c/roswell/bin/ros -e '(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)' 31 | - name: Install Rove 32 | shell: bash 33 | run: /c/roswell/bin/ros install fukamachi/rove 34 | - name: Load Dexador 35 | shell: bash 36 | run: | 37 | /c/roswell/bin/ros -e '(handler-bind ((error (lambda (e) (uiop:print-condition-backtrace e) (uiop:quit -1)))) (ql:quickload :dexador))' 38 | - name: Run tests 39 | shell: bash 40 | run: | 41 | PATH="~/.roswell/bin:/c/roswell/bin:$PATH" 42 | rove dexador-test.asd 43 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | pull_request: 6 | schedule: 7 | - cron: '0 15 * * *' 8 | 9 | jobs: 10 | test_linux: 11 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | lisp: [sbcl-bin] 16 | os: [ubuntu-latest] 17 | 18 | steps: 19 | - uses: actions/checkout@v1 20 | - name: Run tests 21 | run: make test 22 | test_mac: 23 | name: ${{ matrix.lisp }} on ${{ matrix.os }} 24 | runs-on: ${{ matrix.os }} 25 | strategy: 26 | matrix: 27 | lisp: [sbcl-bin] 28 | os: [macOS-latest] 29 | 30 | steps: 31 | - uses: actions/checkout@v1 32 | - name: Install Roswell 33 | env: 34 | LISP: ${{ matrix.lisp }} 35 | run: | 36 | curl -L https://raw.githubusercontent.com/roswell/roswell/master/scripts/install-for-ci.sh | sh 37 | - name: Install Ultralisp 38 | run: ros -e '(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)' 39 | - name: Install Rove 40 | run: ros install fukamachi/rove 41 | - name: Run tests 42 | run: | 43 | PATH="~/.roswell/bin:$PATH" 44 | rove dexador-test.asd 45 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: common-lisp 2 | sudo: false 3 | 4 | env: 5 | global: 6 | - PATH=~/.roswell/bin:~/nginx/sbin:$PATH 7 | - ROSWELL_INSTALL_DIR=$HOME/.roswell 8 | - COVERAGE_EXCLUDE=t 9 | matrix: 10 | - LISP=sbcl-bin COVERALLS=true 11 | - LISP=ccl-bin 12 | 13 | matrix: 14 | allow_failures: 15 | # there is some issue with clisp, 16 | # roswell installs ASDF3, but clisp doesn't see it 17 | - env: LISP=ccl-bin 18 | 19 | addons: 20 | apt: 21 | packages: 22 | - default-jre 23 | 24 | install: 25 | # Roswell 26 | - curl -L https://raw.githubusercontent.com/roswell/roswell/release/scripts/install-for-ci.sh | sh 27 | # nginx 28 | - curl -L http://nginx.org/download/nginx-1.8.0.tar.gz | tar xzf - 29 | - (cd nginx-1.8.0 && ./configure --prefix=$HOME/nginx && make && make install) 30 | # rove 31 | - ros install rove 32 | - ros install fukamachi/clack 33 | - ros install fukamachi/fast-http 34 | 35 | cache: 36 | directories: 37 | - $HOME/.roswell 38 | - $HOME/nginx 39 | - $HOME/.config/common-lisp 40 | 41 | before_script: 42 | - nginx -c "$TRAVIS_BUILD_DIR/t/nginx.conf" -p "$HOME/nginx" 43 | - ros --version 44 | - ros config 45 | 46 | script: 47 | - rove dexador-test.asd 48 | - benchmark/bench 49 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: test 2 | 3 | .PHONY: build 4 | build: 5 | docker build -t dexador-test-image -f t/Dockerfile . 6 | 7 | .PHONY: test 8 | test: build 9 | docker run --rm -i -v ${PWD}:/app dexador-test-image 10 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Dexador 2 | 3 | [![Build Status](https://travis-ci.org/fukamachi/dexador.svg?branch=master)](https://travis-ci.org/fukamachi/dexador) 4 | [![Coverage Status](https://coveralls.io/repos/fukamachi/dexador/badge.svg?branch=master)](https://coveralls.io/r/fukamachi/dexador) 5 | 6 | Dexador is yet another HTTP client for Common Lisp with neat APIs and connection-pooling. 7 | 8 | ## Warning 9 | 10 | This software is still BETA quality. The APIs will be likely to change. 11 | 12 | ## Differences from Drakma 13 | 14 | * Fast, particularly when requesting to the same host (See [Benchmark](#benchmark)) 15 | * Neat APIs 16 | * Signal a condition when HTTP request failed 17 | * OpenSSL isn't required for Windows 18 | 19 | See also [a presentation given at Lisp Meetup #31](http://www.slideshare.net/fukamachi/dexador-rises). 20 | 21 | ## Usage 22 | 23 | ```common-lisp 24 | (dex:get "http://lisp.org/") 25 | 26 | (dex:post "https://example.com/login" 27 | :content '(("name" . "fukamachi") ("password" . "1ispa1ien"))) 28 | ``` 29 | 30 | ### Posting a form-data 31 | 32 | You can specify a form-data at `:content` in an association list. The data will be sent in `application/x-www-form-urlencoded` format. 33 | 34 | ```common-lisp 35 | (dex:post "http://example.com/entry/create" 36 | :content '(("title" . "The Truth About Lisp") 37 | ("body" . "In which the truth about lisp is revealed, and some alternatives are enumerated."))) 38 | ``` 39 | 40 | ### Auto-detects Multipart 41 | 42 | If the association list contains a pathname, the data will be sent as `multipart/form-data`. 43 | 44 | ```common-lisp 45 | (dex:post "http://example.com/entry/create" 46 | :content '(("photo" . #P"images/2015030201.jpg"))) 47 | ``` 48 | 49 | ### Following redirects (GET or HEAD) 50 | 51 | If the server reports that the requested page has moved to a different location (indicated with a Location header and a 3XX response code), Dexador will redo the request on the new place, the fourth return value shows. 52 | 53 | ```common-lisp 54 | (dex:head "http://lisp.org") 55 | ;=> "" 56 | ; 200 57 | ; # 58 | ; # 59 | ; NIL 60 | ``` 61 | 62 | You can limit the count of redirection by specifying `:max-redirects` with an integer. The default value is `5`. 63 | 64 | ### Using cookies 65 | 66 | Dexador adopts [cl-cookie](https://github.com/fukamachi/cl-cookie) for its cookie management. All functions takes a cookie-jar instance at `:cookie-jar`. 67 | 68 | ```common-lisp 69 | (defvar *cookie-jar* (cl-cookie:make-cookie-jar)) 70 | 71 | (dex:head "https://mixi.jp" :cookie-jar *cookie-jar* :verbose t) 72 | ;-> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 73 | ; HEAD / HTTP/1.1 74 | ; User-Agent: Dexador/0.1 (SBCL 1.2.9); Darwin; 14.1.0 75 | ; Host: mixi.jp 76 | ; Accept: */* 77 | ; 78 | ; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 79 | ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 80 | ; HTTP/1.1 200 OK 81 | ; Date: Tue, 10 Mar 2015 10:16:29 GMT 82 | ; Server: Apache 83 | ; X-Dealer: 152151 84 | ; X-XRDS-Location: https://mixi.jp/xrds.pl 85 | ; Cache-Control: no-cache 86 | ; Pragma: no-cache 87 | ; Vary: User-Agent 88 | ; Content-Type: text/html; charset=EUC-JP 89 | ; Set-Cookie: _auid=9d47ca5a00ce4980c41511beb2626fd4; domain=.mixi.jp; path=/; expires=Thu, 09-Mar-2017 10:16:29 GMT 90 | ; Set-Cookie: _lcp=8ee4121c9866435007fff2c90dc31a4d; domain=.mixi.jp; expires=Wed, 11-Mar-2015 10:16:29 GMT 91 | ; X-Content-Type-Options: nosniff 92 | ; 93 | ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 94 | 95 | ;; Again 96 | (dex:head "https://mixi.jp" :cookie-jar *cookie-jar* :verbose t) 97 | ;-> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 98 | ; HEAD / HTTP/1.1 99 | ; User-Agent: Dexador/0.1 (SBCL 1.2.9); Darwin; 14.1.0 100 | ; Host: mixi.jp 101 | ; Accept: */* 102 | ; Cookie: _auid=b878756ed71a0ed5bcf527e324c78f8c; _lcp=8ee4121c9866435007fff2c90dc31a4d 103 | ; 104 | ; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 105 | ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 106 | ; HTTP/1.1 200 OK 107 | ; Date: Tue, 10 Mar 2015 10:16:59 GMT 108 | ; Server: Apache 109 | ; X-Dealer: 152146 110 | ; X-XRDS-Location: https://mixi.jp/xrds.pl 111 | ; Cache-Control: no-cache 112 | ; Pragma: no-cache 113 | ; Vary: User-Agent 114 | ; Content-Type: text/html; charset=EUC-JP 115 | ; Set-Cookie: _auid=b878756ed71a0ed5bcf527e324c78f8c; domain=.mixi.jp; path=/; expires=Thu, 09-Mar-2017 10:16:59 GMT 116 | ; Set-Cookie: _lcp=8ee4121c9866435007fff2c90dc31a4d; domain=.mixi.jp; expires=Wed, 11-Mar-2015 10:16:59 GMT 117 | ; X-Content-Type-Options: nosniff 118 | ; 119 | ; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 120 | ``` 121 | 122 | ### Authorization 123 | You can only supply either basic or bearer authorization. 124 | 125 | #### Basic Authorization 126 | 127 | ```common-lisp 128 | (dex:head "http://www.hatena.ne.jp/" :basic-auth '("nitro_idiot" . "password") :verbose t) 129 | ;-> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 130 | ; HEAD / HTTP/1.1 131 | ; User-Agent: Dexador/0.1 (SBCL 1.2.9); Darwin; 14.1.0 132 | ; Host: www.hatena.ne.jp 133 | ; Accept: */* 134 | ; Authorization: Basic bml0cm9faWRpb3Q6cGFzc3dvcmQ= 135 | ; 136 | ; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 137 | ``` 138 | #### Bearer Authorization 139 | 140 | ```common-lisp 141 | (dex:head "http://www.hatena.ne.jp/" :bearer-auth "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9" 142 | :verbose t) 143 | ;-> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 144 | ; HEAD / HTTP/1.1 145 | ; User-Agent: Dexador/0.9.15 (SBCL 2.4.3); Linux; 6.7.0-20-amd64 146 | ; Host: www.hatena.ne.jp 147 | ; Accept: */* 148 | ; Authorization: Bearer eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9 149 | ; 150 | ; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 151 | ``` 152 | 153 | ### Faking a User-Agent header 154 | 155 | You can overwrite the default User-Agent header by simply specifying "User-Agent" in `:headers`. 156 | 157 | ```common-lisp 158 | (dex:head "http://www.sbcl.org/" :verbose t) 159 | ;-> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 160 | ; HEAD / HTTP/1.1 161 | ; User-Agent: Dexador/0.1 (SBCL 1.2.6); Darwin; 14.1.0 162 | ; Host: www.sbcl.org 163 | ; Accept: */* 164 | ; 165 | ; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 166 | 167 | (dex:head "http://www.sbcl.org/" 168 | :headers '(("User-Agent" . "Mozilla/5.0 (Macintosh; Intel Mac OS X 10_10_2) AppleWebKit/600.3.18 (KHTML, like Gecko) Version/8.0.3 Safari/600.3.18")) 169 | :verbose t) 170 | ;-> >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 171 | ; HEAD / HTTP/1.1 172 | ; User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10_10_2) AppleWebKit/600.3.18 (KHTML, like Gecko) Version/8.0.3 Safari/600.3.18 173 | ; Host: www.sbcl.org 174 | ; Accept: */* 175 | ; 176 | ; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 177 | ``` 178 | 179 | ### Reusing a connection 180 | 181 | Dexador reuses a connection by default. As it skips a TCP handshake, it would be much faster when you send requests to the same host continuously. 182 | 183 | ### Handling unexpected HTTP status code 184 | 185 | Dexador signals a condition `http-request-failed` when the server returned 4xx or 5xx status code. 186 | 187 | ```common-lisp 188 | ;; Handles 400 bad request 189 | (handler-case (dex:get "http://lisp.org") 190 | (dex:http-request-bad-request () 191 | ;; Runs when 400 bad request returned 192 | ) 193 | (dex:http-request-failed (e) 194 | ;; For other 4xx or 5xx 195 | (format *error-output* "The server returned ~D" (dex:response-status e)))) 196 | 197 | ;; Ignore 404 Not Found and continue 198 | (handler-bind ((dex:http-request-not-found #'dex:ignore-and-continue)) 199 | (dex:get "http://lisp.org")) 200 | 201 | ;; Retry 202 | (handler-bind ((dex:http-request-failed #'dex:retry-request)) 203 | (dex:get "http://lisp.org")) 204 | 205 | ;; Retry 5 times 206 | (let ((retry-request (dex:retry-request 5 :interval 3))) 207 | (handler-bind ((dex:http-request-failed retry-request)) 208 | (dex:get "http://lisp.org"))) 209 | ``` 210 | 211 | ### Proxy 212 | 213 | You can connect via proxy. 214 | 215 | ```common-lisp 216 | (dex:get "http://lisp.org/" :proxy "http://proxy.yourcompany.com:8080/") 217 | ``` 218 | 219 | You can connect via SOCKS5 proxy. 220 | 221 | ```common-lisp 222 | (dex:get "https://www.facebookcorewwwi.onion/" :proxy "socks5://127.0.0.1:9150") 223 | ``` 224 | 225 | You can set the default proxy by setting 226 | ```dex:*default-proxy*``` 227 | which defaults to the value of the environment variable HTTPS_PROXY or HTTP_PROXY 228 | 229 | ## Functions 230 | 231 | All functions take similar arguments. 232 | 233 | - `uri` (string or quri:uri) 234 | - `method` (keyword) 235 | - The HTTP request method: `:GET`, `:HEAD`, `:OPTIONS`, `:PUT`, `:POST`, or `:DELETE`. The default is `:GET`. 236 | - `version` (number) 237 | - The version of the HTTP protocol: typically `1.0` or `1.1`. The default is `1.1`. 238 | - `content` (string, alist or pathname) 239 | - The body of the request. content may be an alist containing key value pairs, where the value can be a string, pathname, an (array (unsigned-byte 8) (*)), or a cons. If the value is 240 | a cons, then it may contain a :content-type override such as: :content `(("key" ,(make-array 5 :element-type '(unsigned-byte 8)) :content-type "application/octets")) which will result in a 241 | multipart form encoded submission. 242 | - `headers` (alist) 243 | - The headers of the request. If the value of a pair is `NIL`, the header won't be sent. You can overwrite the default headers (Host, User-Agent, Accept, Content-Type) by this with the same header name. 244 | - `basic-auth` (cons of username and password) 245 | - Username and password for basic authorization. This is a cons having username at car and password at cdr. (e.g. `'("foo" . "bar")`) 246 | - `cookie-jar` (cookie-jar of [cl-cookie](https://github.com/fukamachi/cl-cookie)) 247 | - A cookie jar object. 248 | - `connect-timeout` (fixnum) 249 | - The seconds to timeout until the HTTP connection established. The default is `10`, the value of `*default-connect-timeout*`. 250 | - `read-timeout` (fixnum) 251 | - The seconds to timeout until the whole HTTP body read. The default is `10`, the value of `*default-read-timeout*`. 252 | - `keep-alive` (boolean) 253 | - A flag if the connection keep connected even after the HTTP request. The default is `T`. 254 | - `use-connection-pool` (boolean) 255 | - When combined with `:keep-alive t`, will internally cache the socket connection to web servers to avoid having to open new ones. This is compatible with `:want-stream t` (when you close the returned stream or it is garbage collected the connection will be returned to the pool). If you pass in a stream with `:stream` then the connection pool is not used (unless there is a redirect to a new web server). This is not supported when using the WINHTTP backend. The default is `T`. 256 | - `max-redirects` (fixnum) 257 | - The limit of redirections. The default is `5`. If the redirection exceeds the limit, functions return the last response (not raise a condition). 258 | - `ssl-key-file`, `ssl-cert-file`, `ssl-key-password` 259 | - for HTTPS connection 260 | - `stream` 261 | - The stream to write an HTTP request. This is a way to reuse a connection and commonly used with `:keep-alive T`. This allows the caller to do connection pooling, etc. It is easier to just use `:use-connection-pool t`, which is the default, and let the dexador internals take care of this for you (only supported for usocket backends). 262 | - `verbose` (boolean) 263 | - This option is for debugging. When `T`, it dumps the HTTP request headers. 264 | - `force-binary` (boolean) 265 | - A flag for suppressing auto-decoding of the response body. 266 | 267 | - `want-stream` (boolean) 268 | - A flag to get the response body as a stream. 269 | - `proxy` (string) 270 | - for use proxy. defaults to the value of `dex:*default-proxy*` which defaults to the value of environment variables HTTPS_PROXY or HTTP_PROXY. Not supported on windows currently 271 | - `insecure` (boolean) 272 | - To bypass SSL certificate verification (use at your own risk). The default is `NIL`, the value of `*not-verify-ssl*`. 273 | 274 | 275 | 276 | ### \[Function\] request 277 | 278 | ```common-lisp 279 | (dex:request uri &key (method get) (version 1.1) content headers 280 | basic-auth cookie-jar (connect-timeout *default-connect-timeout*) 281 | (read-timeout *default-read-timeout*) (keep-alive t) (use-connection-pool t) 282 | (max-redirects 5) ssl-key-file ssl-cert-file ssl-key-password stream 283 | (verbose *verbose*) force-binary force-string want-stream proxy 284 | (insecure *not-verify-ssl*) ca-path) 285 | ;=> body 286 | ; status 287 | ; response-headers 288 | ; uri 289 | ; stream 290 | ``` 291 | 292 | Send an HTTP request to `uri`. 293 | 294 | The `body` is an octet vector or a string if the `Content-Type` is `text/*`. If you always want it to return an octet vector, specify `:force-binary` as `T`. 295 | 296 | The `status` is an integer which represents HTTP status code. 297 | 298 | The `response-headers` is a hash table which represents HTTP response headers. Note that all hash keys are downcased like "content-type". If there's duplicate HTTP headers, those values are concatenated with a comma. 299 | 300 | The `uri` is a [QURI](https://github.com/fukamachi/quri) object which represents the last URI Dexador requested. 301 | 302 | The `stream` is a usocket stream to communicate with the HTTP server if the connection is still alive and can be reused. This value may be `NIL` if `:keep-alive` is `NIL` or the server closed the connection with `Connection: close` header or you are using `:use-connection-pool t` which handles re-using the connections for you. 303 | 304 | This function signals `http-request-failed` when the HTTP status code is 4xx or 5xx. 305 | 306 | ### \[Function\] get 307 | 308 | ```common-lisp 309 | (dex:get uri &key version headers basic-auth cookie-jar keep-alive 310 | use-connection-pool connect-timeout read-timeout max-redirects 311 | force-binary force-string want-stream ssl-key-file 312 | ssl-cert-file ssl-key-password stream verbose proxy insecure 313 | ca-path) 314 | ``` 315 | 316 | ### \[Function\] post 317 | 318 | ```common-lisp 319 | (dex:post uri &key version content headers basic-auth cookie-jar 320 | keep-alive use-connection-pool connect-timeout read-timeout 321 | force-binary force-string want-stream ssl-key-file 322 | ssl-cert-file ssl-key-password stream verbose proxy insecure 323 | ca-path) 324 | ``` 325 | 326 | ### \[Function\] head 327 | 328 | ```common-lisp 329 | (dex:head uri &key version headers basic-auth cookie-jar connect-timeout 330 | read-timeout max-redirects ssl-key-file ssl-cert-file 331 | ssl-key-password stream verbose proxy insecure ca-path) 332 | ``` 333 | 334 | ### \[Function\] put 335 | 336 | ```common-lisp 337 | (dex:put uri &key version content headers basic-auth cookie-jar 338 | keep-alive use-connection-pool connect-timeout read-timeout 339 | force-binary force-string want-stream ssl-key-file 340 | ssl-cert-file ssl-key-password stream verbose proxy insecure 341 | ca-path) 342 | ``` 343 | 344 | ### \[Function\] patch 345 | 346 | ```common-lisp 347 | (dex:patch uri &key version content headers basic-auth cookie-jar 348 | keep-alive use-connection-pool connect-timeout read-timeout 349 | force-binary force-string want-stream ssl-key-file 350 | ssl-cert-file ssl-key-password stream verbose proxy insecure 351 | ca-path) 352 | ``` 353 | 354 | ### \[Function\] delete 355 | 356 | ```common-lisp 357 | (dex:delete uri &key version headers basic-auth cookie-jar keep-alive 358 | use-connection-pool connect-timeout read-timeout 359 | force-binary force-string want-stream ssl-key-file 360 | ssl-cert-file ssl-key-password stream verbose proxy insecure 361 | ca-path) 362 | ``` 363 | 364 | ### \[Function\] fetch 365 | 366 | Send a GET request to `URI` and write the response body to the `DESTINATION`. 367 | 368 | ```common-lisp 369 | (dex:fetch uri destination &key (if-exists error) verbose proxy insecure) 370 | ``` 371 | 372 | ## Benchmark 373 | 374 | ![Benchmark graph](images/benchmark.png) 375 | 376 | * Server 377 | * Sakura VPS 1GB 378 | * nginx 1.2.7, KeepAlive On 379 | * Client 380 | * MacBook Pro OS X Yosemite (CPU: 3GHz Intel Core i7, Memory: 8GB) 381 | * SBCL 1.2.9 382 | * Downloads an HTML file (181 bytes). 383 | 384 | ### Drakma 385 | 386 | ``` 387 | (time (dotimes (i 30) (drakma:http-request "http://files.8arrow.org/181B.html"))) 388 | Evaluation took: 389 | 1.012 seconds of real time 390 | 0.174742 seconds of total run time (0.148141 user, 0.026601 system) 391 | 17.29% CPU 392 | 1,683 forms interpreted 393 | 500 lambdas converted 394 | 3,027,928,949 processor cycles 395 | 29,416,656 bytes consed 396 | ``` 397 | 398 | ### Dexador 399 | 400 | ``` 401 | (time (dotimes (i 30) (dex:get "http://files.8arrow.org/181B.html"))) 402 | Evaluation took: 403 | 0.499 seconds of real time 404 | 0.028057 seconds of total run time (0.019234 user, 0.008823 system) 405 | 5.61% CPU 406 | 56 forms interpreted 407 | 16 lambdas converted 408 | 1,494,851,690 processor cycles 409 | 1,472,992 bytes consed 410 | ``` 411 | 412 | ## See Also 413 | 414 | * [fast-http](https://github.com/fukamachi/fast-http) 415 | * [cl-cookie](https://github.com/fukamachi/cl-cookie) 416 | * [QURI](https://github.com/fukamachi/quri) 417 | 418 | ## Author 419 | 420 | * Eitaro Fukamachi (e.arrows@gmail.com) 421 | 422 | ## Copyright 423 | 424 | Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) 425 | 426 | ## License 427 | 428 | Licensed under the MIT License. 429 | -------------------------------------------------------------------------------- /benchmark/181B.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Hello, Dexador 6 | 7 | 8 | Hello, Dexador. I'm not a Zenekindarl. Go back to your home. 9 | 10 | 11 | -------------------------------------------------------------------------------- /benchmark/bench: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | 7 | (ql:quickload '(:dexador :drakma)) 8 | 9 | (defun main () 10 | (format *error-output* "~2&Drakma~%") 11 | (time 12 | (dotimes (i 30) 13 | (drakma:http-request "http://127.0.0.1:5000/181B.html"))) 14 | 15 | (format *error-output* "~2&Dexador~%") 16 | (time 17 | (dotimes (i 30) 18 | (dex:get "http://127.0.0.1:5000/181B.html"))) 19 | 20 | (dex:clear-connection-pool) 21 | (format *error-output* "~2&Dexador (without connection-pooling)~%") 22 | (time 23 | (dotimes (i 30) 24 | (dex:get "http://127.0.0.1:5000/181B.html" :use-connection-pool nil)))) 25 | -------------------------------------------------------------------------------- /dexador-test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of dexador project. 3 | Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) 4 | |# 5 | 6 | (defsystem "dexador-test" 7 | :author "Eitaro Fukamachi" 8 | :license "MIT" 9 | :depends-on ("dexador" 10 | "rove" 11 | "lack-request" 12 | "clack-test" 13 | "babel" 14 | "cl-cookie") 15 | :components ((:module "t" 16 | :components 17 | ((:file "dexador")))) 18 | :perform (test-op (op c) (symbol-call '#:rove '#:run c))) 19 | -------------------------------------------------------------------------------- /dexador-usocket.asd: -------------------------------------------------------------------------------- 1 | (defsystem "dexador-usocket" 2 | :depends-on ("dexador" 3 | (:feature (:not :dexador-no-ssl) "cl+ssl")) 4 | :components ((:file "src/backend/usocket"))) 5 | -------------------------------------------------------------------------------- /dexador.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of dexador project. 3 | Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Eitaro Fukamachi (e.arrows@gmail.com) 8 | |# 9 | 10 | (defsystem "dexador" 11 | :version "0.9.15" 12 | :author "Eitaro Fukamachi" 13 | :license "MIT" 14 | :defsystem-depends-on ("trivial-features") 15 | :depends-on ("fast-http" 16 | "quri" 17 | "fast-io" 18 | "babel" 19 | "trivial-gray-streams" 20 | "trivial-garbage" 21 | "chunga" 22 | "cl-ppcre" 23 | "cl-cookie" 24 | "trivial-mimes" 25 | "chipz" 26 | "cl-base64" 27 | "usocket" 28 | (:feature :windows "winhttp") 29 | (:feature :windows "flexi-streams") 30 | (:feature (:and (:not :windows) (:not :dexador-no-ssl)) "cl+ssl") 31 | "bordeaux-threads" 32 | "alexandria" 33 | (:version "uiop" "3.1.1")) 34 | :components ((:module "src" 35 | :components 36 | ((:file "dexador" :depends-on ("backend" "error" "restarts")) 37 | (:file "encoding") 38 | (:file "connection-cache") 39 | (:file "decoding-stream") 40 | (:file "keep-alive-stream") 41 | (:file "body" :depends-on ("encoding" "decoding-stream" "util")) 42 | (:file "error") 43 | (:file "restarts") 44 | (:file "util") 45 | (:module "backend" 46 | :depends-on ("encoding" "connection-cache" "decoding-stream" "keep-alive-stream" "body" "error" "restarts" "util") 47 | :components 48 | ((:file "usocket" :if-feature (:not :windows)) 49 | (:file "winhttp" :if-feature :windows)))))) 50 | :description "Yet another HTTP client for Common Lisp" 51 | :in-order-to ((test-op (test-op "dexador-test")))) 52 | -------------------------------------------------------------------------------- /images/benchmark.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/dexador/d7ac217819e9156abe10cd28ba7a2d548be03cad/images/benchmark.png -------------------------------------------------------------------------------- /src/backend/usocket.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador.backend.usocket 3 | (:nicknames :dex.usocket) 4 | (:use :cl 5 | :dexador.restarts 6 | :dexador.encoding 7 | :dexador.util) 8 | (:import-from :dexador.connection-cache 9 | :steal-connection 10 | :push-connection) 11 | (:import-from :dexador.decoding-stream 12 | :make-decoding-stream) 13 | (:import-from :dexador.keep-alive-stream 14 | :make-keep-alive-stream) 15 | (:import-from :dexador.body 16 | #:with-content-caches 17 | #:decompress-body 18 | #:decode-body 19 | #:write-multipart-content 20 | #:content-length 21 | #:multipart-content-length 22 | #:multipart-value-content-type) 23 | (:import-from :dexador.error 24 | :http-request-failed 25 | :http-request-not-found 26 | :socks5-proxy-request-failed) 27 | (:import-from :usocket 28 | :socket-connect 29 | :socket-stream) 30 | (:import-from :fast-http 31 | :make-http-response 32 | :make-parser 33 | :http-status 34 | :http-headers) 35 | (:import-from :fast-io 36 | :make-output-buffer 37 | :finish-output-buffer 38 | :with-fast-output 39 | :fast-write-sequence 40 | :fast-write-byte) 41 | (:import-from :chunga 42 | :chunked-stream-input-chunking-p 43 | :chunked-stream-output-chunking-p 44 | :make-chunked-stream) 45 | (:import-from :trivial-mimes 46 | :mime) 47 | (:import-from :cl-cookie 48 | :merge-cookies 49 | :parse-set-cookie-header 50 | :cookie-jar-host-cookies 51 | :write-cookie-header) 52 | (:import-from :quri 53 | :uri-p 54 | :uri-host 55 | :uri-port 56 | :uri-path 57 | :uri-authority 58 | :uri-scheme 59 | :url-encode 60 | :url-encode-params 61 | :merge-uris) 62 | (:import-from :cl-base64 63 | :string-to-base64-string) 64 | #-dexador-no-ssl 65 | (:import-from :cl+ssl 66 | :with-global-context 67 | :make-context 68 | :make-ssl-client-stream 69 | :ensure-initialized 70 | :ssl-check-verify-p) 71 | (:import-from :alexandria 72 | :copy-stream 73 | :if-let 74 | :when-let 75 | :ensure-list 76 | :ends-with-subseq) 77 | (:import-from :uiop) 78 | (:export :request 79 | :*ca-bundle*)) 80 | (in-package :dexador.backend.usocket) 81 | 82 | (defparameter *ca-bundle* nil) 83 | 84 | (defun-speedy read-until-crlf*2 (stream) 85 | (with-fast-output (buf) 86 | (tagbody 87 | read-cr 88 | (loop for byte of-type (or (unsigned-byte 8) null) = (read-byte stream nil nil) 89 | if byte 90 | do (fast-write-byte byte buf) 91 | else 92 | do (go eof) 93 | until (= byte (char-code #\Return))) 94 | 95 | read-lf 96 | (let ((next-byte (read-byte stream nil nil))) 97 | (unless next-byte 98 | (go eof)) 99 | (locally (declare (type (unsigned-byte 8) next-byte)) 100 | (cond 101 | ((= next-byte (char-code #\Newline)) 102 | (fast-write-byte next-byte buf) 103 | (go read-cr2)) 104 | ((= next-byte (char-code #\Return)) 105 | (fast-write-byte next-byte buf) 106 | (go read-lf)) 107 | (T 108 | (fast-write-byte next-byte buf) 109 | (go read-cr))))) 110 | 111 | read-cr2 112 | (let ((next-byte (read-byte stream nil nil))) 113 | (unless next-byte 114 | (go eof)) 115 | (locally (declare (type (unsigned-byte 8) next-byte)) 116 | (cond 117 | ((= next-byte (char-code #\Return)) 118 | (fast-write-byte next-byte buf) 119 | (go read-lf2)) 120 | (T 121 | (fast-write-byte next-byte buf) 122 | (go read-cr))))) 123 | 124 | read-lf2 125 | (let ((next-byte (read-byte stream nil nil))) 126 | (unless next-byte 127 | (go eof)) 128 | (locally (declare (type (unsigned-byte 8) next-byte)) 129 | (cond 130 | ((= next-byte (char-code #\Newline)) 131 | (fast-write-byte next-byte buf)) 132 | ((= next-byte (char-code #\Return)) 133 | (fast-write-byte next-byte buf) 134 | (go read-lf)) 135 | (T 136 | (fast-write-byte next-byte buf) 137 | (go read-cr))))) 138 | 139 | eof))) 140 | 141 | (defvar +empty-body+ 142 | (make-array 0 :element-type '(unsigned-byte 8))) 143 | 144 | (defun read-response (stream has-body collect-headers read-body) 145 | (let* ((http (make-http-response)) 146 | body 147 | body-data 148 | (headers-data (and collect-headers 149 | (make-output-buffer))) 150 | (header-finished-p nil) 151 | (finishedp nil) 152 | (content-length nil) 153 | (transfer-encoding-p) 154 | (parser (make-parser http 155 | :header-callback 156 | (lambda (headers) 157 | (setq header-finished-p t 158 | content-length (gethash "content-length" headers) 159 | transfer-encoding-p (gethash "transfer-encoding" headers)) 160 | (unless (and has-body 161 | (or content-length 162 | transfer-encoding-p)) 163 | (setq finishedp t))) 164 | :body-callback 165 | (lambda (data start end) 166 | (when body-data 167 | (fast-write-sequence data body-data start end))) 168 | :finish-callback 169 | (lambda () 170 | (setq finishedp t))))) 171 | (let ((buf (read-until-crlf*2 stream))) 172 | (declare (type octets buf)) 173 | (when collect-headers 174 | (fast-write-sequence buf headers-data)) 175 | (funcall parser buf)) 176 | (unless header-finished-p 177 | (error "maybe invalid header")) 178 | (cond 179 | ((not read-body) 180 | (setq body stream)) 181 | ((not has-body) 182 | (setq body +empty-body+)) 183 | ((and content-length (not transfer-encoding-p)) 184 | (let ((buf (make-array (etypecase content-length 185 | (integer content-length) 186 | (string (parse-integer content-length))) 187 | :element-type '(unsigned-byte 8)))) 188 | (read-sequence buf stream) 189 | (setq body buf))) 190 | ((let ((status (http-status http))) 191 | (or (= status 100) ;; Continue 192 | (= status 101) ;; Switching Protocols 193 | (= status 204) ;; No Content 194 | (= status 304))) ;; Not Modified 195 | (setq body +empty-body+)) 196 | (T 197 | (setq body-data (make-output-buffer)) 198 | (loop for buf of-type octets = (read-until-crlf*2 stream) 199 | do (funcall parser buf) 200 | until (or finishedp 201 | (zerop (length buf))) 202 | finally 203 | (setq body (finish-output-buffer body-data))))) 204 | (values http 205 | body 206 | (and collect-headers 207 | (finish-output-buffer headers-data)) 208 | transfer-encoding-p))) 209 | 210 | (defun print-verbose-data (direction &rest data) 211 | (flet ((boundary-line () 212 | (let ((char (ecase direction 213 | (:incoming #\<) 214 | (:outgoing #\>)))) 215 | (fresh-line) 216 | (dotimes (i 50) 217 | (write-char char)) 218 | (fresh-line)))) 219 | (boundary-line) 220 | (dolist (d data) 221 | (map nil (lambda (byte) 222 | (princ (code-char byte))) 223 | d)) 224 | (boundary-line))) 225 | 226 | (defun convert-body (body content-encoding content-type content-length chunkedp force-binary force-string keep-alive-p on-close) 227 | (when (streamp body) 228 | (cond 229 | ((and keep-alive-p chunkedp) 230 | (setf body (make-keep-alive-stream body :chunked-stream 231 | (let ((chunked-stream (chunga:make-chunked-stream body))) 232 | (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t) 233 | chunked-stream) :on-close-or-eof on-close))) 234 | ((and keep-alive-p content-length) 235 | (setf body (make-keep-alive-stream body :end content-length :on-close-or-eof on-close))) 236 | (chunkedp 237 | (let ((chunked-stream (chunga:make-chunked-stream body))) 238 | (setf (chunga:chunked-stream-input-chunking-p chunked-stream) t) 239 | (setf body chunked-stream))))) 240 | (let ((body (decompress-body content-encoding body))) 241 | (if force-binary 242 | body 243 | (decode-body content-type body 244 | :default-charset (if force-string 245 | babel:*default-character-encoding* 246 | nil))))) 247 | 248 | (defun content-disposition (key val) 249 | (if (pathnamep val) 250 | (let* ((filename (file-namestring val)) 251 | (utf8-filename-p (find-if (lambda (char) 252 | (< 127 (char-code char))) 253 | filename))) 254 | (format nil "Content-Disposition: form-data; name=\"~A\"; ~:[filename=\"~A\"~;filename*=UTF-8''~A~]~C~C" 255 | key 256 | utf8-filename-p 257 | (if utf8-filename-p 258 | (url-encode filename :encoding :utf-8) 259 | filename) 260 | #\Return #\Newline)) 261 | (format nil "Content-Disposition: form-data; name=\"~A\"~C~C" 262 | key 263 | #\Return #\Newline))) 264 | 265 | (defun build-cookie-headers (uri cookie-jar) 266 | (with-header-output (buffer) 267 | (let ((cookies (cookie-jar-host-cookies cookie-jar (uri-host uri) (or (uri-path uri) "/") 268 | :securep (string= (uri-scheme uri) "https")))) 269 | (when cookies 270 | (fast-write-sequence (ascii-string-to-octets "Cookie: ") buffer) 271 | (fast-write-sequence 272 | (ascii-string-to-octets (write-cookie-header cookies)) 273 | buffer) 274 | (fast-write-sequence +crlf+ buffer))))) 275 | 276 | (defun make-connect-stream (uri version stream &optional proxy-auth) 277 | (let ((header (with-fast-output (buffer) 278 | (write-connect-header uri version buffer proxy-auth)))) 279 | (write-sequence header stream) 280 | (force-output stream) 281 | (read-until-crlf*2 stream) 282 | stream)) 283 | 284 | (defun make-proxy-authorization (uri) 285 | (let ((proxy-auth (quri:uri-userinfo uri))) 286 | (when proxy-auth 287 | (format nil "Basic ~A" 288 | (string-to-base64-string proxy-auth))))) 289 | 290 | (defconstant +socks5-version+ 5) 291 | (defconstant +socks5-reserved+ 0) 292 | (defconstant +socks5-no-auth+ 0) 293 | (defconstant +socks5-connect+ 1) 294 | (defconstant +socks5-domainname+ 3) 295 | (defconstant +socks5-succeeded+ 0) 296 | (defconstant +socks5-ipv4+ 1) 297 | (defconstant +socks5-ipv6+ 4) 298 | 299 | (defun ensure-socks5-connected (input output uri http-method) 300 | (labels ((fail (condition &key reason) 301 | (error (make-condition condition 302 | :body nil :status nil :headers nil 303 | :uri uri 304 | :method http-method 305 | :reason reason))) 306 | (exact (n reason) 307 | (unless (eql n (read-byte input nil 'eof)) 308 | (fail 'dexador.error:socks5-proxy-request-failed :reason reason))) 309 | (drop (n reason) 310 | (dotimes (i n) 311 | (when (eq (read-byte input nil 'eof) 'eof) 312 | (fail 'dexador.error:socks5-proxy-request-failed :reason reason))))) 313 | ;; Send Version + Auth Method 314 | ;; Currently, only supports no-auth method. 315 | (write-byte +socks5-version+ output) 316 | (write-byte 1 output) 317 | (write-byte +socks5-no-auth+ output) 318 | (finish-output output) 319 | 320 | ;; Receive Auth Method 321 | (exact +socks5-version+ "Unexpected version") 322 | (exact +socks5-no-auth+ "Unsupported auth method") 323 | 324 | ;; Send domainname Request 325 | (let* ((host (babel:string-to-octets (uri-host uri))) 326 | (hostlen (length host)) 327 | (port (uri-port uri))) 328 | (unless (<= 1 hostlen 255) 329 | (fail 'dexador.error:socks5-proxy-request-failed :reason "domainname too long")) 330 | (unless (<= 1 port 65535) 331 | (fail 'dexador.error:socks5-proxy-request-failed :reason "Invalid port")) 332 | (write-byte +socks5-version+ output) 333 | (write-byte +socks5-connect+ output) 334 | (write-byte +socks5-reserved+ output) 335 | (write-byte +socks5-domainname+ output) 336 | (write-byte hostlen output) 337 | (write-sequence host output) 338 | (write-byte (ldb (byte 8 8) port) output) 339 | (write-byte (ldb (byte 8 0) port) output) 340 | (finish-output output) 341 | 342 | ;; Receive reply 343 | (exact +socks5-version+ "Unexpected version") 344 | (exact +socks5-succeeded+ "Unexpected result code") 345 | (drop 1 "Should be reserved byte") 346 | (let ((atyp (read-byte input nil 'eof))) 347 | (cond 348 | ((eql atyp +socks5-ipv4+) 349 | (drop 6 "Should be IPv4 address and port")) 350 | ((eql atyp +socks5-ipv6+) 351 | (drop 18 "Should be IPv6 address and port")) 352 | ((eql atyp +socks5-domainname+) 353 | (let ((n (read-byte input nil 'eof))) 354 | (when (eq n 'eof) 355 | (fail 'dexador.error:socks5-proxy-request-failed :reason "Invalid domainname length")) 356 | (drop n "Should be domainname and port"))) 357 | (t 358 | (fail 'dexador.error:socks5-proxy-request-failed :reason "Unknown address"))))))) 359 | 360 | (defun make-ssl-stream (stream ca-path ssl-key-file ssl-cert-file ssl-key-password hostname insecure) 361 | #+dexador-no-ssl 362 | (error "SSL not supported. Remove :dexador-no-ssl from *features* to enable SSL.") 363 | #-dexador-no-ssl 364 | (progn 365 | (cl+ssl:ensure-initialized) 366 | (let ((ctx (cl+ssl:make-context :verify-mode 367 | (if insecure 368 | cl+ssl:+ssl-verify-none+ 369 | cl+ssl:+ssl-verify-peer+) 370 | :verify-location 371 | (cond 372 | (ca-path (uiop:native-namestring ca-path)) 373 | ((and *ca-bundle* (probe-file *ca-bundle*)) *ca-bundle*) 374 | ;; In executable environment, perhaps *ca-bundle* doesn't exist. 375 | (t :default)))) 376 | (ssl-cert-pem-p (and ssl-cert-file 377 | (ends-with-subseq ".pem" ssl-cert-file)))) 378 | (cl+ssl:with-global-context (ctx :auto-free-p t) 379 | (when ssl-cert-pem-p 380 | (cl+ssl:use-certificate-chain-file ssl-cert-file)) 381 | (cl+ssl:make-ssl-client-stream stream 382 | :hostname hostname 383 | :verify (not insecure) 384 | :key ssl-key-file 385 | :certificate (and (not ssl-cert-pem-p) 386 | ssl-cert-file) 387 | :password ssl-key-password))))) 388 | 389 | (defstruct usocket-wrapped-stream 390 | stream) 391 | 392 | ;; Forward methods the user might want to use on this. 393 | ;; User is not meant to interact with this object except 394 | ;; potentially to close it when they decide they don't 395 | ;; need the :keep-alive connection anymore. 396 | (defmethod close ((u usocket-wrapped-stream) &key abort) 397 | (close (usocket-wrapped-stream-stream u) :abort abort)) 398 | 399 | (defmethod open-stream-p ((u usocket-wrapped-stream)) 400 | (open-stream-p (usocket-wrapped-stream-stream u))) 401 | 402 | (defun-careful request (uri &rest args 403 | &key (method :get) (version 1.1) 404 | content headers 405 | basic-auth bearer-auth 406 | cookie-jar 407 | (connect-timeout *default-connect-timeout*) (read-timeout *default-read-timeout*) 408 | (keep-alive t) (use-connection-pool t) 409 | (max-redirects 5) 410 | ssl-key-file ssl-cert-file ssl-key-password 411 | stream (verbose *verbose*) 412 | force-binary 413 | force-string 414 | want-stream 415 | (proxy *default-proxy*) 416 | (insecure *not-verify-ssl*) 417 | ca-path 418 | &aux 419 | (proxy-uri (and proxy (quri:uri proxy))) 420 | (original-user-supplied-stream stream) 421 | (user-supplied-stream (if (usocket-wrapped-stream-p stream) (usocket-wrapped-stream-stream stream) stream))) 422 | (declare (ignorable ssl-key-file ssl-cert-file ssl-key-password 423 | connect-timeout ca-path) 424 | (type real version) 425 | (type fixnum max-redirects)) 426 | (with-content-caches 427 | (labels ((make-new-connection (uri) 428 | (restart-case 429 | (let* ((con-uri (quri:uri (or proxy uri))) 430 | (connection (usocket:socket-connect (uri-host con-uri) 431 | (uri-port con-uri) 432 | #-(or ecl clasp clisp allegro) :timeout #-(or ecl clasp clisp allegro) connect-timeout 433 | :element-type '(unsigned-byte 8))) 434 | (stream 435 | (usocket:socket-stream connection)) 436 | (scheme (uri-scheme uri))) 437 | (declare (type string scheme)) 438 | (when read-timeout 439 | #+lispworks(setf (stream:stream-read-timeout stream) read-timeout) 440 | #-lispworks(setf (usocket:socket-option connection :receive-timeout) read-timeout)) 441 | (when (socks5-proxy-p proxy-uri) 442 | (ensure-socks5-connected stream stream uri method)) 443 | (if (string= scheme "https") 444 | (make-ssl-stream (if (http-proxy-p proxy-uri) 445 | (make-connect-stream uri version stream (make-proxy-authorization con-uri)) 446 | stream) ca-path ssl-key-file ssl-cert-file ssl-key-password (uri-host uri) insecure) 447 | stream)) 448 | (retry-request () 449 | :report "Retry the same request." 450 | (return-from request 451 | (apply #'request uri :use-connection-pool nil args))) 452 | (retry-insecure () 453 | :report "Retry the same request without checking for SSL certificate validity." 454 | (return-from request 455 | (apply #'request uri :use-connection-pool nil :insecure t args))))) 456 | (http-proxy-p (uri) 457 | (and uri 458 | (let ((scheme (uri-scheme uri))) 459 | (and (stringp scheme) 460 | (or (string= scheme "http") 461 | (string= scheme "https")))))) 462 | (socks5-proxy-p (uri) 463 | (and uri 464 | (let ((scheme (uri-scheme uri))) 465 | (and (stringp scheme) 466 | (string= scheme "socks5"))))) 467 | (connection-keep-alive-p (connection-header) 468 | (and keep-alive 469 | (or (and (= (the real version) 1.0) 470 | (equalp connection-header "keep-alive")) 471 | (not (equalp connection-header "close"))))) 472 | (return-stream-to-pool (stream uri) 473 | (push-connection (format nil "~A://~A" 474 | (uri-scheme uri) 475 | (uri-authority uri)) stream #'close)) 476 | (return-stream-to-pool-or-close (stream connection-header uri) 477 | (if (and (not user-supplied-stream) use-connection-pool (connection-keep-alive-p connection-header)) 478 | (return-stream-to-pool stream uri) 479 | (when (open-stream-p stream) 480 | (close stream)))) 481 | (finalize-connection (stream connection-header uri) 482 | "If KEEP-ALIVE is in the connection-header and the user is not requesting a stream, 483 | we will push the connection to our connection pool if allowed, otherwise we return 484 | the stream back to the user who must close it." 485 | (unless want-stream 486 | (cond 487 | ((and use-connection-pool (connection-keep-alive-p connection-header) (not user-supplied-stream)) 488 | (return-stream-to-pool stream uri)) 489 | ((not (connection-keep-alive-p connection-header)) 490 | (when (open-stream-p stream) 491 | (close stream))))))) 492 | (let* ((uri (quri:uri uri)) 493 | (proxy (when (http-proxy-p proxy-uri) proxy)) 494 | (content-type (cdr (find :content-type headers :key #'car :test #'string-equal))) 495 | (multipart-p (or (and content-type 496 | (>= (length content-type) 10) 497 | (string= content-type "multipart/" :end1 10)) 498 | (and (not content-type) 499 | (consp content) 500 | (find-if #'pathnamep content :key #'cdr)))) 501 | (form-urlencoded-p (or (string= content-type "application/x-www-form-urlencoded") 502 | (and (not content-type) 503 | (consp content) 504 | (not multipart-p)))) 505 | (boundary (and multipart-p 506 | (make-random-string 12))) 507 | (content (if (and form-urlencoded-p (not (stringp content))) ;; user can provide already encoded content, trust them. 508 | (quri:url-encode-params content) 509 | content)) 510 | (stream (or user-supplied-stream 511 | (and use-connection-pool 512 | (steal-connection (format nil "~A://~A" 513 | (uri-scheme uri) 514 | (uri-authority uri)))))) 515 | (reusing-stream-p (not (null stream))) ;; user provided or from connection-pool 516 | (stream (or stream 517 | (make-new-connection uri))) 518 | (content-length 519 | (assoc :content-length headers :test #'string-equal)) 520 | (transfer-encoding 521 | (assoc :transfer-encoding headers :test #'string-equal)) 522 | (chunkedp (or (and transfer-encoding 523 | (equalp (cdr transfer-encoding) "chunked")) 524 | (and content-length 525 | (null (cdr content-length))))) 526 | (first-line-data 527 | (with-fast-output (buffer) 528 | (write-first-line method uri version buffer))) 529 | (headers-data 530 | (flet ((write-header* (name value) 531 | (let ((header (assoc name headers :test #'string-equal))) 532 | (if header 533 | (when (cdr header) 534 | (write-header name (cdr header))) 535 | (write-header name value))) 536 | (values))) 537 | (with-header-output (buffer) 538 | (write-header* :user-agent #.*default-user-agent*) 539 | (write-header* :host (uri-authority uri)) 540 | (write-header* :accept "*/*") 541 | (cond 542 | ((and keep-alive 543 | (= (the real version) 1.0)) 544 | (write-header* :connection "keep-alive")) 545 | ((and (not keep-alive) 546 | (= (the real version) 1.1)) 547 | (write-header* :connection "close"))) 548 | (cond ((and bearer-auth basic-auth) 549 | (error "You should only use one Authorization header.")) 550 | (basic-auth 551 | (write-header* :authorization 552 | (format nil "Basic ~A" 553 | (string-to-base64-string 554 | (format nil "~A:~A" 555 | (car basic-auth) 556 | (cdr basic-auth)))))) 557 | (bearer-auth 558 | (write-header* :authorization 559 | (format nil "Bearer ~A" bearer-auth)))) 560 | (when proxy 561 | (let ((scheme (quri:uri-scheme uri))) 562 | (when (string= scheme "http") 563 | (let* ((uri (quri:uri proxy)) 564 | (proxy-authorization (make-proxy-authorization uri))) 565 | (when proxy-authorization 566 | (write-header* :proxy-authorization proxy-authorization)))))) 567 | (cond 568 | (multipart-p 569 | (write-header :content-type (format nil "~A; boundary=~A" 570 | (or content-type "multipart/form-data") 571 | boundary)) 572 | (unless chunkedp 573 | (write-header :content-length 574 | (multipart-content-length content boundary)))) 575 | (form-urlencoded-p 576 | (write-header* :content-type "application/x-www-form-urlencoded") 577 | (unless chunkedp 578 | (write-header* :content-length (length (the string content))))) 579 | (t 580 | (etypecase content 581 | (null 582 | (unless chunkedp 583 | (write-header* :content-length 0))) 584 | (string 585 | (write-header* :content-type (or content-type "text/plain")) 586 | (unless chunkedp 587 | (write-header* :content-length (content-length content)))) 588 | ((array (unsigned-byte 8) *) 589 | (write-header* :content-type (or content-type "text/plain")) 590 | (unless chunkedp 591 | (write-header* :content-length (length content)))) 592 | (pathname 593 | (write-header* :content-type (or content-type (dexador.body:content-type content))) 594 | (unless chunkedp 595 | (write-header :content-length 596 | (or (cdr (assoc :content-length headers :test #'string-equal)) 597 | (content-length content)))))))) 598 | ;; Transfer-Encoding: chunked 599 | (when (and chunkedp 600 | (not transfer-encoding)) 601 | (write-header* :transfer-encoding "chunked")) 602 | 603 | ;; Custom headers 604 | (loop for (name . value) in headers 605 | unless (member name '(:user-agent :host :accept 606 | :connection 607 | :content-type :content-length) :test #'string-equal) 608 | do (write-header name value))))) 609 | (cookie-headers (and cookie-jar 610 | (build-cookie-headers uri cookie-jar)))) 611 | (macrolet ((maybe-try-again-without-reusing-stream (&optional (force nil)) 612 | `(progn ;; retrying by go retry avoids generating the header, parsing, etc. 613 | (when (open-stream-p stream) 614 | (close stream :abort t) 615 | (setf stream nil)) 616 | 617 | (when ,(or force 'reusing-stream-p) 618 | (setf reusing-stream-p nil 619 | user-supplied-stream nil 620 | stream (make-new-connection uri)) 621 | (go retry)))) 622 | (try-again-without-reusing-stream () 623 | `(maybe-try-again-without-reusing-stream t)) 624 | (with-retrying (&body body) 625 | `(restart-case 626 | (handler-bind (((and error 627 | ;; We should not retry errors received from the server. 628 | ;; Only technical errors such as disconnection or some 629 | ;; problems with the protocol should be retried automatically. 630 | ;; This solves https://github.com/fukamachi/dexador/issues/137 issue. 631 | (not http-request-failed)) 632 | (lambda (e) 633 | (declare (ignorable e)) 634 | (maybe-try-again-without-reusing-stream)))) 635 | ,@body) 636 | (retry-request () :report "Retry the same request." 637 | (return-from request (apply #'request uri args))) 638 | (ignore-and-continue () :report "Ignore the error and continue.")))) 639 | (tagbody 640 | retry 641 | 642 | (unless (open-stream-p stream) 643 | (try-again-without-reusing-stream)) 644 | 645 | (with-retrying 646 | (write-sequence first-line-data stream) 647 | (write-sequence headers-data stream) 648 | (when cookie-headers 649 | (write-sequence cookie-headers stream)) 650 | (write-sequence +crlf+ stream) 651 | (force-output stream)) 652 | 653 | ;; Sending the content 654 | (when content 655 | (let ((encoding-stream (if chunkedp 656 | (chunga:make-chunked-stream stream) 657 | stream))) 658 | (when chunkedp 659 | (setf (chunga:chunked-stream-output-chunking-p encoding-stream) t)) 660 | (with-retrying 661 | (if (consp content) 662 | (dexador.body:write-multipart-content content boundary encoding-stream) 663 | (dexador.body:write-as-octets encoding-stream content)) 664 | (when chunkedp 665 | (setf (chunga:chunked-stream-output-chunking-p encoding-stream) nil)) 666 | (finish-output encoding-stream)))) 667 | 668 | start-reading 669 | (multiple-value-bind (http body response-headers-data transfer-encoding-p) 670 | (with-retrying 671 | (read-response stream (not (eq method :head)) verbose (not want-stream))) 672 | (let* ((status (http-status http)) 673 | (response-headers (http-headers http)) 674 | (content-length (gethash "content-length" response-headers)) 675 | (content-length (etypecase content-length 676 | (null content-length) 677 | (string (parse-integer content-length)) 678 | (integer content-length)))) 679 | (when (= status 0) 680 | (with-retrying 681 | (http-request-failed status 682 | :body body 683 | :headers headers 684 | :uri uri 685 | :method method))) 686 | (when verbose 687 | (print-verbose-data :outgoing first-line-data headers-data cookie-headers +crlf+) 688 | (print-verbose-data :incoming response-headers-data)) 689 | (when cookie-jar 690 | (when-let (set-cookies (append (gethash "set-cookie" response-headers) 691 | (ensure-list (gethash "set-cookie2" response-headers)))) 692 | (merge-cookies cookie-jar 693 | (remove nil (mapcar (lambda (cookie) 694 | (declare (type string cookie)) 695 | (unless (= (length cookie) 0) 696 | (parse-set-cookie-header cookie 697 | (uri-host uri) 698 | (uri-path uri)))) 699 | set-cookies))))) 700 | (when (and (member status '(301 302 303 307 308) :test #'=) 701 | (gethash "location" response-headers) 702 | (/= max-redirects 0)) 703 | ;; Need to read the response body 704 | (when (and want-stream 705 | (not (eq method :head))) 706 | (cond 707 | ((integerp content-length) 708 | (dotimes (i content-length) 709 | (loop until (read-byte body nil nil)))) 710 | (transfer-encoding-p 711 | (read-until-crlf*2 body)))) 712 | 713 | (let* ((location-uri (quri:uri (gethash "location" response-headers))) 714 | (same-server-p (or (null (uri-host location-uri)) 715 | (and (string= (uri-scheme location-uri) 716 | (uri-scheme uri)) 717 | (string= (uri-host location-uri) 718 | (uri-host uri)) 719 | (eql (uri-port location-uri) 720 | (uri-port uri)))))) 721 | (if (and same-server-p 722 | (or (= status 307) (= status 308) 723 | (member method '(:get :head) :test #'eq))) 724 | (progn ;; redirection to the same host 725 | (setq uri (merge-uris location-uri uri)) 726 | (setq first-line-data 727 | (with-fast-output (buffer) 728 | (write-first-line method uri version buffer))) 729 | (when cookie-jar 730 | ;; Rebuild cookie-headers. 731 | (setq cookie-headers (build-cookie-headers uri cookie-jar))) 732 | (decf max-redirects) 733 | (if (equalp (gethash "connection" response-headers) "close") 734 | (try-again-without-reusing-stream) 735 | (progn 736 | (setq reusing-stream-p t) 737 | (go retry)))) 738 | (progn ;; this is a redirection to a different host 739 | (setf location-uri (quri:merge-uris location-uri uri)) 740 | ;; Close connection if it isn't from our connection pool or from the user and we aren't going to 741 | ;; pass it to our new call. 742 | (when (not same-server-p) (return-stream-to-pool-or-close stream (gethash "connection" response-headers) uri)) 743 | (setf (getf args :headers) 744 | (nconc `((:host . ,(uri-host location-uri))) headers)) 745 | (setf (getf args :max-redirects) 746 | (1- max-redirects)) 747 | ;; Redirect as GET if it's 301, 302, 303 748 | (unless (or (= status 307) (= status 308) 749 | (member method '(:get :head) :test #'eq)) 750 | (setf (getf args :method) :get)) 751 | (return-from request 752 | (apply #'request location-uri (if same-server-p 753 | args 754 | (progn (remf args :stream) args)))))))) 755 | (unwind-protect 756 | (let* ((keep-connection-alive (connection-keep-alive-p 757 | (gethash "connection" response-headers))) 758 | (body (convert-body body 759 | (gethash "content-encoding" response-headers) 760 | (gethash "content-type" response-headers) 761 | content-length 762 | transfer-encoding-p 763 | force-binary 764 | force-string 765 | keep-connection-alive 766 | (if (and use-connection-pool keep-connection-alive (not user-supplied-stream) (streamp body)) 767 | (lambda (underlying-stream abort) 768 | (declare (ignore abort)) 769 | (when (and underlying-stream (open-stream-p underlying-stream)) 770 | ;; read any left overs the user may have not read (in case of errors on user side?) 771 | (loop while (ignore-errors (listen underlying-stream)) ;; ssl streams may close 772 | do (read-byte underlying-stream nil nil)) 773 | (when (open-stream-p underlying-stream) 774 | (push-connection (format nil "~A://~A" 775 | (uri-scheme uri) 776 | (uri-authority uri)) underlying-stream #'close)))) 777 | #'dexador.keep-alive-stream:keep-alive-stream-close-underlying-stream)))) 778 | ;; Raise an error when the HTTP response status code is 4xx or 50x. 779 | (when (<= 400 status) 780 | (with-retrying 781 | (http-request-failed status 782 | :body body 783 | :headers response-headers 784 | :uri uri 785 | :method method))) 786 | ;; Have to be a little careful with the fifth value stream we return -- 787 | ;; the user may be not aware that keep-alive t without use-connection-pool can leak 788 | ;; sockets, so we wrap the returned last value so when it is garbage 789 | ;; collected it gets closed. If the user is getting a stream back as BODY, 790 | ;; then we instead add a finalizer to that stream to close it when garbage collected 791 | (return-from request 792 | (values body 793 | status 794 | response-headers 795 | uri 796 | (when (and keep-alive 797 | (not (equalp (gethash "connection" response-headers) "close")) 798 | (or (not use-connection-pool) user-supplied-stream)) 799 | (or (and original-user-supplied-stream ;; user provided a stream 800 | (if (usocket-wrapped-stream-p original-user-supplied-stream) ;; but, it came from us 801 | (eql (usocket-wrapped-stream-stream original-user-supplied-stream) stream) ;; and we used it 802 | (eql original-user-supplied-stream stream)) ;; user provided a bare stream 803 | original-user-supplied-stream) ;; return what the user sent without wrapping it 804 | (if want-stream ;; add a finalizer to the body to close the stream 805 | (progn 806 | (trivial-garbage:finalize body (lambda () (close stream))) 807 | stream) 808 | (let ((wrapped-stream (make-usocket-wrapped-stream :stream stream))) 809 | (trivial-garbage:finalize wrapped-stream (lambda () (close stream))) 810 | wrapped-stream))))))) 811 | (finalize-connection stream (gethash "connection" response-headers) uri)))))))))) 812 | -------------------------------------------------------------------------------- /src/backend/winhttp.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:dexador.backend.winhttp 2 | (:nicknames :dex.winhttp) 3 | (:use #:cl 4 | #:dexador.restarts 5 | #:dexador.util 6 | #:winhttp) 7 | (:import-from #:dexador.body 8 | #:decode-body 9 | #:write-multipart-content 10 | #:decompress-body) 11 | (:import-from #:dexador.error 12 | #:http-request-failed) 13 | (:import-from #:winhttp 14 | #:set-ignore-certificates 15 | #:set-timeouts) 16 | (:import-from #:fast-io 17 | #:fast-output-stream 18 | #:with-fast-output 19 | #:fast-write-sequence 20 | #:finish-output-stream) 21 | (:import-from #:babel) 22 | (:import-from #:flexi-streams) 23 | (:import-from #:cl-cookie 24 | #:cookie-jar-host-cookies 25 | #:write-cookie-header 26 | #:parse-set-cookie-header 27 | #:merge-cookies) 28 | (:import-from #:alexandria 29 | #:read-file-into-byte-vector 30 | #:ensure-list 31 | #:when-let) 32 | (:import-from #:split-sequence 33 | #:split-sequence) 34 | (:export :request)) 35 | (in-package #:dexador.backend.winhttp) 36 | 37 | (defconstant +WINHTTP_OPTION_DISABLE_FEATURE+ 63) 38 | (defconstant +WINHTTP_DISABLE_COOKIES+ #x00000001) 39 | (defconstant +WINHTTP_DISABLE_REDIRECTS+ #x00000002) 40 | (defconstant +WINHTTP_DISABLE_KEEP_ALIVE+ #x00000008) 41 | 42 | (defun set-option (req var value &optional (type :uint32)) 43 | (cffi:with-foreign-object (buf type) 44 | (setf (cffi:mem-aref buf type) value) 45 | (let ((ret (winhttp::%set-option req 46 | var 47 | buf 48 | (cffi:foreign-type-size type)))) 49 | (unless ret 50 | (winhttp::get-last-error))))) 51 | 52 | (defun query-headers* (req) 53 | (loop with hash = (make-hash-table :test 'equal) 54 | for (name-camelcased value) in (query-headers req) 55 | for name = (string-downcase name-camelcased) 56 | if (gethash name hash) 57 | do (setf (gethash name hash) 58 | (format nil "~A, ~A" (gethash name hash) value)) 59 | else 60 | do (setf (gethash name hash) value) 61 | finally (return hash))) 62 | 63 | (defun convert-content (content multipart-p form-urlencoded-p preferred-content-type) 64 | (etypecase content 65 | (cons 66 | (cond (multipart-p 67 | (let ((boundary (make-random-string 12))) 68 | (values 69 | (let ((stream (make-instance 'fast-output-stream))) 70 | (write-multipart-content content boundary stream) 71 | (finish-output-stream stream)) 72 | (format nil "~A; boundary=~A" 73 | (or preferred-content-type "multipart/form-data") 74 | boundary)))) 75 | (form-urlencoded-p 76 | (values 77 | (babel:string-to-octets (quri:url-encode-params content)) 78 | "application/x-www-form-urlencoded")) 79 | (t 80 | (error "Can't convert a CONS content")))) 81 | (string 82 | (values (babel:string-to-octets content) 83 | (or preferred-content-type 84 | "text/plain"))) 85 | (pathname 86 | (values (read-file-into-byte-vector content) 87 | (or preferred-content-type 88 | (mimes:mime content)))) 89 | ((array (unsigned-byte 8) (*)) 90 | (values content 91 | (or preferred-content-type 92 | "application/octet-stream"))) 93 | (null 94 | (values (make-array 0 :element-type '(unsigned-byte 8)) 95 | preferred-content-type)))) 96 | 97 | ;; TODO: Try asynchronous 98 | (defun request (uri &rest args 99 | &key (method :get) (version 1.1) 100 | content headers 101 | basic-auth bearer-auth 102 | cookie-jar 103 | (connect-timeout *default-connect-timeout*) (read-timeout *default-read-timeout*) 104 | (keep-alive t) (use-connection-pool t) 105 | (max-redirects 5) 106 | ssl-key-file ssl-cert-file ssl-key-password 107 | stream (verbose *verbose*) 108 | force-binary force-string 109 | want-stream 110 | proxy 111 | (insecure *not-verify-ssl*) 112 | ca-path) 113 | (declare (ignore version use-connection-pool 114 | ssl-key-file ssl-cert-file ssl-key-password 115 | stream verbose 116 | proxy 117 | ca-path)) 118 | (let* ((uri (quri:uri uri)) 119 | (content-type 120 | (find :content-type headers :key #'car :test #'string-equal)) 121 | (multipart-p (or (and content-type 122 | (string= (cdr content-type) "multipart/" :end1 10)) 123 | (and (null (cdr content-type)) 124 | (consp content) 125 | (find-if #'pathnamep content :key #'cdr)))) 126 | (form-urlencoded-p (or (string= (cdr content-type) "application/x-www-form-urlencoded") 127 | (and (null (cdr content-type)) 128 | (consp content) 129 | (not multipart-p)))) 130 | (user-agent 131 | (cdr (find :user-agent headers :key #'car :test #'string-equal)))) 132 | (multiple-value-bind (content detected-content-type) 133 | (convert-content content multipart-p form-urlencoded-p (cdr content-type)) 134 | (when detected-content-type 135 | (if content-type 136 | (setf (cdr (assoc :content-type headers :test #'string-equal)) detected-content-type) 137 | (setf headers (append `(("Content-Type" . ,detected-content-type)) headers)))) 138 | 139 | (when cookie-jar 140 | (let ((cookies 141 | (cookie-jar-host-cookies cookie-jar (quri:uri-host uri) (or (quri:uri-path uri) "/") 142 | :securep (string= (quri:uri-scheme uri) "https")))) 143 | (when cookies 144 | (setf headers 145 | (append headers 146 | `(("Cookie" . ,(write-cookie-header cookies)))))))) 147 | (with-http (session (or user-agent *default-user-agent*)) 148 | (with-connect (conn session (quri:uri-host uri) (quri:uri-port uri)) 149 | (with-request (req conn :verb method 150 | :url (format nil "~@[~A~]~@[?~A~]" 151 | (quri:uri-path uri) 152 | (quri:uri-query uri)) 153 | :https-p (equalp (quri:uri-scheme uri) "https")) 154 | (cond 155 | ((quri:uri-userinfo uri) 156 | (destructuring-bind (user pass) (split-sequence #\: (quri:uri-userinfo uri)) 157 | (set-credentials req user pass))) 158 | ((and basic-auth bearer-auth) 159 | (error "You should only use one Authorization header.")) 160 | (bearer-auth 161 | (setf headers 162 | (append headers 163 | (list (cons "Authorization" (concatenate 'string "Bearer " bearer-auth)))))) 164 | (basic-auth 165 | (set-credentials req (car basic-auth) (cdr basic-auth)))) 166 | 167 | ;; TODO: SSL arguments 168 | ;; TODO: proxy support 169 | (set-option req 170 | +WINHTTP_OPTION_DISABLE_FEATURE+ 171 | (logior +WINHTTP_DISABLE_COOKIES+ 172 | +WINHTTP_DISABLE_REDIRECTS+ 173 | (if keep-alive 0 +WINHTTP_DISABLE_KEEP_ALIVE+))) 174 | 175 | (dolist (header headers) 176 | (add-request-headers req 177 | (format nil "~:(~A~): ~A" (car header) (cdr header)))) 178 | 179 | (when (and (equalp (quri:uri-scheme uri) "https") 180 | insecure) 181 | (set-ignore-certificates req)) 182 | 183 | (when connect-timeout 184 | (set-timeouts req 185 | :connect (* 1000 connect-timeout) 186 | :recv (* 1000 read-timeout))) 187 | 188 | (send-request req content) 189 | 190 | (receive-response req) 191 | 192 | (let ((status (query-status-code req)) 193 | (response-headers (query-headers* req))) 194 | (when cookie-jar 195 | (when-let (set-cookies (append (ensure-list (gethash "set-cookie" response-headers)) 196 | (ensure-list (gethash "set-cookie2" response-headers)))) 197 | (merge-cookies cookie-jar 198 | (remove nil (mapcar (lambda (cookie) 199 | (declare (type string cookie)) 200 | (unless (= (length cookie) 0) 201 | (parse-set-cookie-header cookie 202 | (quri:uri-host uri) 203 | (quri:uri-path uri)))) 204 | set-cookies))))) 205 | 206 | ;; Redirect 207 | (when (and (member status '(301 302 303 307 308)) 208 | (gethash "location" response-headers) 209 | (/= max-redirects 0)) 210 | (let ((location-uri (quri:uri (gethash "location" response-headers)))) 211 | (let ((method 212 | (if (and (or (null (quri:uri-host location-uri)) 213 | (and (string= (quri:uri-scheme location-uri) 214 | (quri:uri-scheme uri)) 215 | (string= (quri:uri-host location-uri) 216 | (quri:uri-host uri)) 217 | (eql (quri:uri-port location-uri) 218 | (quri:uri-port uri)))) 219 | (or (= status 307) (= status 308) 220 | (member method '(:get :head) :test #'eq))) 221 | method 222 | :get))) 223 | ;; TODO: slurp the body 224 | (return-from request 225 | (apply #'request (quri:merge-uris location-uri uri) 226 | :max-redirects (1- max-redirects) 227 | :method method 228 | args))))) 229 | 230 | (let ((body (with-fast-output (body :vector) 231 | (loop with buffer = (make-array 1024 :element-type '(unsigned-byte 8)) 232 | for bytes = (read-data req buffer) 233 | until (zerop bytes) 234 | do (fast-write-sequence buffer body 0 bytes))))) 235 | (when (gethash "content-encoding" response-headers) 236 | (setf body 237 | (decompress-body 238 | (gethash "content-encoding" response-headers) 239 | body))) 240 | 241 | (let ((body (if force-binary 242 | body 243 | (decode-body (gethash "content-type" response-headers) body 244 | :default-charset (if force-string 245 | babel:*default-character-encoding* 246 | nil))))) 247 | ;; Raise an error when the HTTP response status is 4xx or 5xx. 248 | (when (<= 400 status) 249 | (restart-case 250 | (http-request-failed status 251 | :body body 252 | :headers response-headers 253 | :uri uri 254 | :method method) 255 | (retry-request () 256 | :report "Retry the same request." 257 | (return-from request 258 | (apply #'request uri args))) 259 | (retry-insecure () 260 | :report "Retry the same request without checking for SSL certificate validity." 261 | (return-from request 262 | (apply #'request uri :insecure t args))) 263 | (ignore-and-continue () 264 | :report "Ignore the error and continue."))) 265 | 266 | ;; TODO: This obviously isn't streaming. 267 | ;; Wrapping 'req' object by gray streams would be better, 268 | ;; but freeing it could be a problem for the next. 269 | (when want-stream 270 | (setf body 271 | (etypecase body 272 | (string (make-string-input-stream body)) 273 | (vector (flex:make-in-memory-input-stream body))))) 274 | 275 | (values body 276 | status 277 | response-headers 278 | uri)))))))))) 279 | -------------------------------------------------------------------------------- /src/body.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:dexador.body 2 | (:use #:cl) 3 | (:import-from #:dexador.encoding 4 | #:detect-charset) 5 | (:import-from #:dexador.decoding-stream 6 | #:make-decoding-stream) 7 | (:import-from #:dexador.util 8 | #:ascii-string-to-octets 9 | #:+crlf+ 10 | #:octets) 11 | (:import-from #:alexandria #:copy-stream #:assoc-value) 12 | (:import-from #:babel 13 | #:octets-to-string 14 | #:character-decoding-error) 15 | (:import-from #:babel-encodings 16 | #:*suppress-character-coding-errors*) 17 | (:import-from :trivial-mimes 18 | :mime) 19 | (:import-from #:quri 20 | #:url-encode) 21 | (:import-from #:chipz 22 | #:make-decompressing-stream 23 | #:decompress 24 | #:make-dstate) 25 | (:export #:decode-body 26 | #:write-multipart-content 27 | #:multipart-value-content-type 28 | #:decompress-body 29 | #:write-as-octets 30 | #:multipart-content-length 31 | #:content-length 32 | #:with-content-caches 33 | #:content-type)) 34 | (in-package #:dexador.body) 35 | 36 | (defun decode-body (content-type body &key default-charset on-close) 37 | (let ((charset (or (and content-type 38 | (detect-charset content-type body)) 39 | default-charset)) 40 | (babel-encodings:*suppress-character-coding-errors* t)) 41 | (if charset 42 | (handler-case 43 | (if (streamp body) 44 | (make-decoding-stream body :encoding charset :on-close on-close) 45 | (babel:octets-to-string body :encoding charset)) 46 | (babel:character-decoding-error (e) 47 | (warn (format nil "Failed to decode the body to ~S due to the following error (falling back to binary):~% ~A" 48 | charset 49 | e)) 50 | (return-from decode-body body))) 51 | body))) 52 | 53 | (defun content-disposition (key val) 54 | (typecase val 55 | (cons (content-disposition key (first val))) 56 | (pathname 57 | (let* ((filename (file-namestring val)) 58 | (utf8-filename-p (find-if (lambda (char) 59 | (< 127 (char-code char))) 60 | filename))) 61 | (format nil "Content-Disposition: form-data; name=\"~A\"; ~:[filename=\"~A\"~;filename*=UTF-8''~A~]~C~C" 62 | key 63 | utf8-filename-p 64 | (if utf8-filename-p 65 | (url-encode filename :encoding :utf-8) 66 | filename) 67 | #\Return #\Newline))) 68 | (otherwise 69 | (format nil "Content-Disposition: form-data; name=\"~A\"~C~C" 70 | key 71 | #\Return #\Newline)))) 72 | 73 | (defmacro define-alist-cache (cache-name) 74 | (let ((var (intern (format nil "*~A*" cache-name)))) 75 | `(progn 76 | (defvar ,var) 77 | (defun ,(intern (format nil "LOOKUP-IN-~A" cache-name)) (elt) 78 | (when (boundp ',var) 79 | (alexandria:assoc-value ,var elt))) 80 | (defun (setf ,(intern (format nil "LOOKUP-IN-~A" cache-name))) (val elt) 81 | (when (boundp ',var) 82 | (setf (alexandria:assoc-value ,var elt) val)) 83 | val)))) 84 | 85 | ;; If bound, an alist mapping content to content-type, 86 | ;; used to avoid determining content type multiple times 87 | (define-alist-cache content-type-cache) 88 | ;; If bound, an alist mapping content to encoded content, to avoid 89 | ;; double converting content when we must calculate its length first 90 | (define-alist-cache content-encoding-cache) 91 | 92 | (defmacro with-content-caches (&body body) 93 | `(let ((*content-type-cache* nil) 94 | (*content-encoding-cache* nil)) 95 | ,@body)) 96 | 97 | (defun content-type (value) 98 | (typecase value 99 | (pathname (or (lookup-in-content-type-cache value) 100 | (setf (lookup-in-content-type-cache value) (mimes:mime value)))) 101 | (otherwise nil))) 102 | 103 | (defun multipart-value-content-type (value) 104 | (typecase value 105 | (cons 106 | (destructuring-bind (val &key content-type) 107 | value 108 | (or content-type (content-type val)))) 109 | (otherwise (content-type value)))) 110 | 111 | (defun convert-to-octets (val) 112 | (or (lookup-in-content-encoding-cache val) 113 | (setf (lookup-in-content-encoding-cache val) 114 | (typecase val 115 | (string (babel:string-to-octets val)) 116 | ((array (unsigned-byte 8) (*)) val) 117 | (symbol (babel:string-to-octets (princ-to-string val))) 118 | (cons (convert-to-octets (first val))) 119 | (otherwise (babel:string-to-octets (princ-to-string val))))))) 120 | 121 | (defun write-as-octets (stream val) 122 | (typecase val 123 | ((array (unsigned-byte 8) (*)) (write-sequence val stream)) 124 | (pathname 125 | (with-open-file (in val :element-type '(unsigned-byte 8)) 126 | (alexandria:copy-stream in stream))) 127 | (string 128 | (write-sequence (convert-to-octets val) stream)) 129 | (cons (write-as-octets stream (first val))) 130 | (otherwise (write-sequence (convert-to-octets val) stream)))) 131 | 132 | (defun content-length (val) 133 | (typecase val 134 | (pathname (with-open-file (in val) 135 | (file-length in))) 136 | (cons (content-length (first val))) 137 | (otherwise (length (convert-to-octets val))))) 138 | 139 | (defun multipart-content-length (content boundary) 140 | (declare (type simple-string boundary)) 141 | (let ((boundary-length (length boundary))) 142 | (+ (loop for (key . val) in content 143 | sum (+ 2 ;; -- 144 | boundary-length 145 | 2 ;; CR LF 146 | (length (the simple-string (content-disposition key val))) 147 | (let ((content-type (multipart-value-content-type val))) 148 | (if content-type 149 | (+ #.(length "Content-Type: ") (length content-type) 2) 150 | 0)) 151 | 2 152 | (content-length val) 153 | 2) 154 | into total-length 155 | finally (return total-length)) 156 | 2 boundary-length 2 2))) 157 | 158 | (defun write-multipart-content (content boundary stream) 159 | (let ((boundary (ascii-string-to-octets boundary))) 160 | (labels ((boundary-line (&optional endp) 161 | (write-sequence (ascii-string-to-octets "--") stream) 162 | (write-sequence boundary stream) 163 | (when endp 164 | (write-sequence (ascii-string-to-octets "--") stream)) 165 | (crlf)) 166 | (crlf () (write-sequence +crlf+ stream))) 167 | (loop for (key . val) in content 168 | do (boundary-line) 169 | (write-sequence (ascii-string-to-octets (content-disposition key val)) stream) 170 | (let ((content-type (multipart-value-content-type val))) 171 | (when content-type 172 | (write-sequence 173 | (ascii-string-to-octets 174 | (format nil "Content-Type: ~A~C~C" content-type #\Return #\Newline)) 175 | stream))) 176 | (crlf) 177 | (write-as-octets stream val) 178 | (crlf) 179 | finally 180 | (boundary-line t))))) 181 | 182 | (defun decompress-body (content-encoding body) 183 | (unless content-encoding 184 | (return-from decompress-body body)) 185 | 186 | (cond 187 | ((string= content-encoding "gzip") 188 | (if (streamp body) 189 | (chipz:make-decompressing-stream :gzip body) 190 | (chipz:decompress nil (chipz:make-dstate :gzip) body))) 191 | ((string= content-encoding "deflate") 192 | (if (streamp body) 193 | (chipz:make-decompressing-stream :zlib body) 194 | (chipz:decompress nil (chipz:make-dstate :zlib) body))) 195 | (t body))) 196 | -------------------------------------------------------------------------------- /src/connection-cache.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador.connection-cache 3 | (:use :cl) 4 | (:import-from :bordeaux-threads 5 | :make-lock 6 | :with-lock-held) 7 | (:export :*connection-pool* 8 | :*use-connection-pool* 9 | :*max-active-connections* 10 | :make-connection-pool 11 | :steal-connection 12 | :push-connection 13 | :clear-connection-pool)) 14 | (in-package :dexador.connection-cache) 15 | 16 | (defvar *use-connection-pool* t) 17 | (defvar *max-active-connections* 8 18 | "Allowed number of active connections to all hosts. If you change this, 19 | then call (make-new-connection-pool).") 20 | 21 | (defstruct lru-pool-elt 22 | (prev nil :type (or null lru-pool-elt)) 23 | (next nil :type (or null lru-pool-elt)) 24 | (elt nil :type t) 25 | (key nil :type t) 26 | (eviction-callback nil :type (or null function))) 27 | 28 | ;; An LRU-POOL can have multiple entries for the same key 29 | (defstruct lru-pool 30 | (lock #+thread-support (bt2:make-lock :name "connection pool lock") 31 | #-thread-support nil) 32 | (hash-table nil :type (or null hash-table)) ;; hash table entries are lists of elements 33 | (head nil :type (or null lru-pool-elt)) ;; most recently used is here and it's a doubly-linked-list 34 | (tail nil :type (or null lru-pool-elt)) ;; least recently used is here 35 | (num-elts 0 :type fixnum) 36 | (max-elts 8 :type fixnum)) 37 | 38 | (defun make-connection-pool (&optional (max-active-connections *max-active-connections*)) 39 | (make-lru-pool :hash-table (make-hash-table :test 'equal) :max-elts max-active-connections)) 40 | 41 | (defvar *connection-pool* nil) 42 | 43 | (defun make-new-connection-pool (&optional (max-active-connections *max-active-connections*)) 44 | (clear-connection-pool) 45 | (setf *connection-pool* (make-connection-pool max-active-connections))) 46 | 47 | (defun get-from-lru-pool (lru-pool key) 48 | "Takes an element from the LRU-POOL matching KEY. Must be called with LRU-POOL-LOCK held. 49 | The element is removed from the pool." 50 | (let* ((hash-table (lru-pool-hash-table lru-pool)) 51 | (possible-elts (gethash key (lru-pool-hash-table lru-pool)))) 52 | (when possible-elts 53 | (let ((remaining-elts (cdr possible-elts))) 54 | (if remaining-elts 55 | (setf (gethash key hash-table) remaining-elts) 56 | (remhash key hash-table))) 57 | (let ((elt (car possible-elts))) 58 | (let ((prev (lru-pool-elt-prev elt)) 59 | (next (lru-pool-elt-next elt))) 60 | (if prev 61 | (setf (lru-pool-elt-next prev) next) 62 | (setf (lru-pool-head lru-pool) next)) 63 | (if next 64 | (setf (lru-pool-elt-prev next) prev) 65 | (setf (lru-pool-tail lru-pool) prev))) 66 | (decf (lru-pool-num-elts lru-pool)) 67 | (lru-pool-elt-elt elt))))) 68 | 69 | (defun evict-tail (lru-pool) 70 | "Removes the least recently used element of the LRU-POOL and returns 71 | (values evicted-element eviction-callback t) if there was 72 | an element to remove, otherwise nil. Must be called with LRU-POOL-LOCK held. 73 | 74 | Outside the LRU-POOL-LOCK you must call the returned EVICTION-CALLBACK with the EVICTED-ELEMENT." 75 | ;; slightly different from get-from-lru-pool because we want to get rid of the 76 | ;; actual oldest element (one could in principle call get-from-lru-pool on 77 | ;; (lru-pool-elt-key (lru-pool-tail lru-pool)) if you didn't care 78 | (let* ((tail (lru-pool-tail lru-pool))) 79 | (when tail 80 | (let ((prev (lru-pool-elt-prev tail))) 81 | (if prev 82 | (setf (lru-pool-elt-next prev) nil) 83 | (setf (lru-pool-head lru-pool) nil)) 84 | (setf (lru-pool-tail lru-pool) prev) 85 | (let* ((hash-table (lru-pool-hash-table lru-pool)) 86 | (key (lru-pool-elt-key tail)) 87 | (remaining (delete tail (gethash key hash-table)))) 88 | (if remaining 89 | (setf (gethash key hash-table) remaining) 90 | (remhash key hash-table)))) 91 | (decf (lru-pool-num-elts lru-pool)) 92 | (values (lru-pool-elt-elt tail) (lru-pool-elt-eviction-callback tail) t)))) 93 | 94 | (defun add-to-lru-pool (lru-pool key elt eviction-callback) 95 | "Adds ELT to an LRU-POOL with potentially non-unique KEY, potentially evicting another element to 96 | make room. EVICTION-CALLBACK will be called with one parameter ELT, when ELT is evicted from the 97 | LRU-POOL. ADD-TO-LRU-POOL must be called with LRU-POOL-LOCK held. 98 | 99 | If an element was evicted to make space, returns (values evicted-elt eviction-callback t) 100 | otherwise nil. The EVICTION-CALLBACK should take one parameter, the evicted element." 101 | (declare (type lru-pool lru-pool)) 102 | (let* ((old-head (lru-pool-head lru-pool)) 103 | (lru-pool-elt (make-lru-pool-elt :prev nil :next old-head :elt elt :key key :eviction-callback eviction-callback)) 104 | (hash-table (lru-pool-hash-table lru-pool))) 105 | (setf (lru-pool-head lru-pool) lru-pool-elt) 106 | (push lru-pool-elt (gethash key hash-table)) 107 | (when old-head 108 | (setf (lru-pool-elt-prev old-head) lru-pool-elt)) 109 | (unless (lru-pool-tail lru-pool) 110 | (setf (lru-pool-tail lru-pool) lru-pool-elt)) 111 | (when (> (incf (lru-pool-num-elts lru-pool)) (lru-pool-max-elts lru-pool)) 112 | (evict-tail lru-pool)))) 113 | 114 | (defmethod print-object ((obj lru-pool-elt) str) ;; avoid printing loops 115 | (print-unreadable-object (obj str :type "LRU-POOL-ELT") 116 | (format str "~A NEXT ~A" (lru-pool-elt-key obj) (lru-pool-elt-next obj)))) 117 | 118 | (defmethod print-object ((obj lru-pool) str) ;; avoid printing loops 119 | (print-unreadable-object (obj str :type "LRU-POOL") 120 | (let (objs) 121 | (loop with lru-pool-elt = (lru-pool-head obj) 122 | while lru-pool-elt 123 | do (push (list (lru-pool-elt-key lru-pool-elt) (lru-pool-elt-elt lru-pool-elt)) objs) 124 | do (setf lru-pool-elt (lru-pool-elt-next lru-pool-elt))) 125 | (if objs 126 | (format str "~A/~A elts~%~{ ~{~A~^: ~}~^~%~}" (lru-pool-num-elts obj) (lru-pool-max-elts obj) objs) 127 | (format str "empty"))))) 128 | 129 | (defmacro with-lock (lock &body body) 130 | (declare (ignorable lock)) 131 | #+thread-support `(bt2:with-lock-held (,lock) 132 | ,@body) 133 | #-thread-support `(progn ,@body)) 134 | 135 | (defun push-connection (host-port stream &optional eviction-callback) 136 | "Add STREAM back to connection pool with key HOST-PORT. EVICTION-CALLBACK 137 | must be a function of a single parameter, and will be called with STREAM 138 | if the HOST-PORT/SOCKET pair is evicted from the connection pool." 139 | (when *use-connection-pool* 140 | (let ((pool *connection-pool*)) 141 | (multiple-value-bind (evicted-elt eviction-callback) 142 | (with-lock (lru-pool-lock pool) 143 | (add-to-lru-pool pool host-port stream eviction-callback)) 144 | (and eviction-callback (funcall eviction-callback evicted-elt)) 145 | (values))))) 146 | 147 | (defun steal-connection (host-port) 148 | "Return the STREAM associated with key HOST-PORT" 149 | (when *use-connection-pool* 150 | (let ((pool *connection-pool*)) 151 | (with-lock (lru-pool-lock pool) 152 | (get-from-lru-pool pool host-port))))) 153 | 154 | (defun clear-connection-pool () 155 | "Remove all elements from the connection pool, calling their eviction-callbacks." 156 | (when *use-connection-pool* 157 | (let ((pool *connection-pool*) 158 | evicted-element eviction-callback element-was-evicted) 159 | (when pool 160 | (loop for count from 0 161 | do (setf (values evicted-element eviction-callback element-was-evicted) 162 | (with-lock (lru-pool-lock pool) 163 | (evict-tail pool))) 164 | do (when eviction-callback (funcall eviction-callback evicted-element)) 165 | while element-was-evicted))))) 166 | 167 | (make-new-connection-pool) 168 | -------------------------------------------------------------------------------- /src/decoding-stream.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador.decoding-stream 3 | (:use :cl) 4 | (:import-from :trivial-gray-streams 5 | :fundamental-character-input-stream 6 | :stream-read-char 7 | :stream-unread-char 8 | :stream-read-byte 9 | :stream-read-sequence) 10 | (:import-from :babel 11 | :*string-vector-mappings* 12 | :unicode-char) 13 | (:import-from :babel-encodings 14 | :*default-character-encoding* 15 | :get-character-encoding 16 | :code-point-counter 17 | :enc-max-units-per-char 18 | :lookup-mapping) 19 | (:export :make-decoding-stream 20 | :decoding-stream) 21 | (:documentation "Provides character decoding stream. 22 | Similar to flexi-input-stream, except this uses Babel for decoding.")) 23 | (in-package :dexador.decoding-stream) 24 | 25 | (declaim (type fixnum +buffer-size+)) 26 | (eval-when (:compile-toplevel :load-toplevel :execute) 27 | (defconstant +buffer-size+ 128)) 28 | 29 | (defclass decoding-stream (fundamental-character-input-stream) 30 | ((stream :type stream 31 | :initarg :stream 32 | :initform (error ":stream is required") 33 | :accessor decoding-stream-stream) 34 | (encoding :initarg :encoding 35 | :initform (error ":encoding is required") 36 | :accessor decoding-stream-encoding) 37 | (buffer :type (simple-array (unsigned-byte 8) (#.+buffer-size+)) 38 | :initform (make-array +buffer-size+ :element-type '(unsigned-byte 8)) 39 | :accessor decoding-stream-buffer) 40 | (buffer-position :type fixnum 41 | :initform +buffer-size+ 42 | :accessor decoding-stream-buffer-position) 43 | (buffer-end-position :type fixnum 44 | :initform -1 45 | :accessor decoding-stream-buffer-end-position) 46 | (last-char :type character 47 | :initform #\Nul 48 | :accessor decoding-stream-last-char) 49 | (last-char-size :type fixnum 50 | :initform 0 51 | :accessor decoding-stream-last-char-size) 52 | (on-close :type (or null function) :initform nil :initarg :on-close))) 53 | 54 | (defmethod initialize-instance :after ((stream decoding-stream) &rest initargs) 55 | (declare (ignore initargs)) 56 | (with-slots (encoding) stream 57 | (when (keywordp encoding) 58 | (setf encoding (get-character-encoding encoding))))) 59 | 60 | (defun make-decoding-stream (stream &key (encoding babel-encodings:*default-character-encoding*) 61 | (on-close)) 62 | (let ((decoding-stream (make-instance 'decoding-stream 63 | :stream stream 64 | :encoding encoding 65 | :on-close on-close))) 66 | (fill-buffer decoding-stream) 67 | decoding-stream)) 68 | 69 | (defun fill-buffer (stream) 70 | (declare (optimize speed)) 71 | (with-slots (stream buffer buffer-position buffer-end-position) stream 72 | (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer) 73 | (type fixnum buffer-position)) 74 | (let ((to-read (- +buffer-size+ buffer-position))) 75 | (declare (type fixnum to-read)) 76 | (replace buffer buffer 77 | :start1 0 78 | :start2 buffer-position 79 | :end2 +buffer-size+) 80 | (setf buffer-position 0) 81 | (let ((n (read-sequence buffer stream :start to-read))) 82 | (declare (type fixnum n)) 83 | (unless (= n +buffer-size+) 84 | (setf buffer-end-position n)))))) 85 | 86 | (defun needs-to-fill-buffer-p (stream) 87 | (declare (optimize speed)) 88 | (when (/= -1 (the fixnum (decoding-stream-buffer-end-position stream))) 89 | (return-from needs-to-fill-buffer-p nil)) 90 | 91 | (with-slots (buffer-position encoding) stream 92 | (< (- +buffer-size+ (the fixnum buffer-position)) 93 | (the fixnum (enc-max-units-per-char encoding))))) 94 | 95 | (defmethod stream-read-char ((stream decoding-stream)) 96 | (declare (optimize speed)) 97 | (when (needs-to-fill-buffer-p stream) 98 | (fill-buffer stream)) 99 | 100 | (when (= (the fixnum (decoding-stream-buffer-end-position stream)) 101 | (the fixnum (decoding-stream-buffer-position stream))) 102 | (return-from stream-read-char :eof)) 103 | 104 | (with-slots (buffer buffer-position encoding last-char last-char-size) 105 | stream 106 | (declare (fixnum buffer-position)) 107 | (let* ((mapping (lookup-mapping *string-vector-mappings* encoding)) 108 | (counter (code-point-counter mapping))) 109 | (declare (type function counter)) 110 | (multiple-value-bind (chars new-end) 111 | (funcall counter buffer buffer-position +buffer-size+ 1) 112 | (declare (ignore chars) (fixnum new-end)) 113 | (let ((string (make-string 1 :element-type 'babel:unicode-char)) 114 | (size (the fixnum (- new-end buffer-position)))) 115 | (funcall (the function (babel-encodings:decoder mapping)) 116 | buffer buffer-position new-end string 0) 117 | (setf buffer-position new-end 118 | last-char (aref string 0) 119 | last-char-size size) 120 | (aref string 0)))))) 121 | 122 | (defmethod stream-unread-char ((stream decoding-stream) char) 123 | (let ((last-char (decoding-stream-last-char stream))) 124 | (when (char= last-char #\Nul) 125 | (error "No character to unread from this stream")) 126 | (unless (char= char last-char) 127 | (error "Last character read (~S) was different from ~S" 128 | last-char char)) 129 | (with-slots (buffer-position last-char-size) stream 130 | (decf buffer-position last-char-size)) 131 | (with-slots (last-char last-char-size) stream 132 | (setf last-char #\Nul 133 | last-char-size 0)) 134 | nil)) 135 | 136 | #+(or abcl clasp ecl) 137 | (defmethod stream-read-sequence ((stream decoding-stream) sequence start end &key) 138 | (loop for i from start to end 139 | for char = (stream-read-char stream) 140 | if (eq char :eof) 141 | do (return i) 142 | else do (setf (aref sequence i) char) 143 | finally (return end))) 144 | 145 | #+(or clasp ecl) 146 | (defmethod stream-read-byte ((stream decoding-stream)) 147 | (with-slots (last-char last-char-size) stream 148 | (setf last-char #\Nul 149 | last-char-size 0)) 150 | (read-byte (decoding-stream-stream stream) nil :eof)) 151 | 152 | (defmethod open-stream-p ((stream decoding-stream)) 153 | (open-stream-p (decoding-stream-stream stream))) 154 | 155 | (defmethod stream-element-type ((stream decoding-stream)) 156 | 'unicode-char) 157 | 158 | (defmethod close ((stream decoding-stream) &key abort) 159 | ;; TODO: modify me to return the connection to the connection pool 160 | (with-slots (stream) stream 161 | (when (open-stream-p stream) 162 | (close stream :abort abort)))) 163 | -------------------------------------------------------------------------------- /src/dexador.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (uiop:define-package dexador 3 | (:nicknames :dex) 4 | (:use :cl) 5 | (:shadow :get 6 | :delete) 7 | (:import-from :dexador.connection-cache 8 | :*connection-pool* 9 | :*use-connection-pool* 10 | :make-connection-pool 11 | :clear-connection-pool) 12 | (:import-from :dexador.util 13 | :*default-connect-timeout* 14 | :*default-read-timeout* 15 | :*default-proxy* 16 | :*verbose* 17 | :*not-verify-ssl*) 18 | (:import-from :alexandria 19 | :copy-stream 20 | :remove-from-plist) 21 | (:export :request 22 | :get 23 | :post 24 | :head 25 | :put 26 | :patch 27 | :delete 28 | :fetch 29 | :*default-connect-timeout* 30 | :*default-read-timeout* 31 | :*default-proxy* 32 | :*verbose* 33 | :*not-verify-ssl* 34 | :*connection-pool* 35 | :*use-connection-pool* 36 | :make-connection-pool 37 | :clear-connection-pool 38 | 39 | :*dexador-backend*) 40 | (:use-reexport :dexador.restarts 41 | :dexador.error)) 42 | (in-package :dexador) 43 | 44 | (defvar *dexador-backend* 45 | #+windows :winhttp 46 | #-windows :usocket) 47 | 48 | (defun request (uri &rest args 49 | &key method version 50 | content headers 51 | basic-auth bearer-auth 52 | cookie-jar 53 | connect-timeout read-timeout 54 | keep-alive use-connection-pool 55 | max-redirects 56 | ssl-key-file ssl-cert-file ssl-key-password 57 | stream verbose 58 | force-binary 59 | force-string 60 | want-stream 61 | proxy 62 | insecure 63 | ca-path) 64 | (declare (ignore method version 65 | content headers 66 | basic-auth bearer-auth 67 | cookie-jar 68 | connect-timeout read-timeout 69 | keep-alive use-connection-pool 70 | max-redirects 71 | ssl-key-file ssl-cert-file ssl-key-password 72 | stream verbose 73 | force-binary 74 | force-string 75 | want-stream 76 | proxy 77 | insecure 78 | ca-path)) 79 | (ecase *dexador-backend* 80 | (:usocket (apply #'uiop:symbol-call '#:dexador.backend.usocket '#:request uri args)) 81 | (:winhttp (apply #'uiop:symbol-call '#:dexador.backend.winhttp '#:request uri args)))) 82 | 83 | (defun get (uri &rest args 84 | &key (version 1.1) headers basic-auth cookie-jar (keep-alive t) 85 | (use-connection-pool dexador.connection-cache:*use-connection-pool*) 86 | (connect-timeout dexador.util:*default-connect-timeout*) 87 | (read-timeout dexador.util:*default-read-timeout*) 88 | (max-redirects 5) force-binary force-string want-stream content 89 | ssl-key-file ssl-cert-file ssl-key-password stream 90 | (verbose dexador.util:*verbose*) (proxy dexador.util:*default-proxy*) 91 | (insecure dexador.util:*not-verify-ssl*) ca-path) 92 | "Make a GET request to URI and return 93 | (values body-or-stream status response-headers uri &optional opaque-socket-stream) 94 | 95 | You may pass a real stream in as STREAM if you want us to communicate with the server via it -- 96 | though if any errors occur, we will open a new connection to the server. If you have a previous 97 | OPAQUE-SOCKET-STREAM you can pass that in as STREAM as well and we will re-use that connection. 98 | 99 | OPAQUE-SOCKET-STREAM is not returned if USE-CONNECTION-POOL is T, instead we keep track of it and 100 | re-use it when needed. 101 | 102 | If WANT-STREAM is T, then a STREAM is returned as the first value. You may read this as needed to 103 | get the body of the response. If KEEP-ALIVE and USE-CONNECTION-POOL are T, then the stream will be 104 | returned to the connection pool when you have read all the data or closed the stream. If KEEP-ALIVE 105 | is NIL then you are responsible for closing the stream when done. 106 | 107 | If KEEP-ALIVE is T and USE-CONNECTION-POOL is NIL, then the fifth value returned is a stream which 108 | you can then pass in again using the STREAM option to re-use the active connection. If you ignore 109 | the stream, it will get closed during garbage collection. 110 | 111 | If KEEP-ALIVE is T and USE-CONNECTION-POOL is T, then there is no fifth 112 | value (OPAQUE-SOCKET-STREAM) returned, but the active connection to the host/port may be reused in 113 | subsequent calls. This removes the need for the caller to keep track of the active socket-stream 114 | for subsequent calls. 115 | 116 | While CONTENT is allowed in a GET request the results are ill-defined and not advised." 117 | (declare (ignorable version headers basic-auth cookie-jar keep-alive use-connection-pool 118 | connect-timeout read-timeout max-redirects force-binary force-string 119 | want-stream ssl-key-file ssl-cert-file ssl-key-password stream 120 | verbose proxy insecure ca-path content)) 121 | (apply #'request uri :method :get args)) 122 | 123 | (defun post (uri &rest args 124 | &key (version 1.1) content headers basic-auth cookie-jar (keep-alive t) 125 | (use-connection-pool dexador.connection-cache:*use-connection-pool*) 126 | (connect-timeout dexador.util:*default-connect-timeout*) 127 | (read-timeout dexador.util:*default-read-timeout*) 128 | force-binary force-string want-stream ssl-key-file ssl-cert-file 129 | ssl-key-password stream (verbose dexador.util:*verbose*) 130 | (proxy dexador.util:*default-proxy*) 131 | (insecure dexador.util:*not-verify-ssl*) ca-path) 132 | (declare (ignorable version content headers basic-auth cookie-jar keep-alive 133 | use-connection-pool connect-timeout read-timeout force-binary 134 | force-string want-stream ssl-key-file ssl-cert-file ssl-key-password 135 | stream verbose proxy insecure ca-path)) 136 | (apply #'request uri :method :post args)) 137 | 138 | (defun head (uri &rest args 139 | &key (version 1.1) headers basic-auth cookie-jar 140 | (connect-timeout dexador.util:*default-connect-timeout*) 141 | (read-timeout dexador.util:*default-read-timeout*) 142 | (max-redirects 5) 143 | ssl-key-file ssl-cert-file ssl-key-password stream 144 | (verbose dexador.util:*verbose*) 145 | (proxy dexador.util:*default-proxy*) 146 | (insecure dexador.util:*not-verify-ssl*) ca-path) 147 | (declare (ignorable version headers basic-auth cookie-jar connect-timeout read-timeout 148 | max-redirects ssl-key-file ssl-cert-file ssl-key-password stream 149 | verbose proxy insecure ca-path)) 150 | (apply #'request uri :method :head :use-connection-pool nil args)) 151 | 152 | (defun put (uri &rest args 153 | &key (version 1.1) content headers basic-auth cookie-jar (keep-alive t) 154 | (use-connection-pool dexador.connection-cache:*use-connection-pool*) 155 | (connect-timeout dexador.util:*default-connect-timeout*) 156 | (read-timeout dexador.util:*default-read-timeout*) 157 | force-binary force-string want-stream ssl-key-file ssl-cert-file 158 | ssl-key-password stream 159 | (verbose dexador.util:*verbose*) 160 | (proxy dexador.util:*default-proxy*) 161 | (insecure dexador.util:*not-verify-ssl*) ca-path) 162 | (declare (ignorable version content headers basic-auth cookie-jar keep-alive 163 | use-connection-pool connect-timeout read-timeout force-binary 164 | force-string want-stream ssl-key-file ssl-cert-file ssl-key-password 165 | stream verbose proxy insecure ca-path)) 166 | (apply #'request uri :method :put args)) 167 | 168 | (defun patch (uri &rest args 169 | &key (version 1.1) content headers basic-auth cookie-jar (keep-alive t) 170 | (use-connection-pool dexador.connection-cache:*use-connection-pool*) 171 | (connect-timeout dexador.util:*default-connect-timeout*) 172 | (read-timeout dexador.util:*default-read-timeout*) 173 | force-binary force-string want-stream ssl-key-file ssl-cert-file 174 | ssl-key-password stream 175 | (verbose dexador.util:*verbose*) 176 | (proxy dexador.util:*default-proxy*) 177 | (insecure dexador.util:*not-verify-ssl*) ca-path) 178 | (declare (ignorable version content headers basic-auth cookie-jar keep-alive 179 | use-connection-pool connect-timeout read-timeout force-binary 180 | force-string want-stream ssl-key-file ssl-cert-file 181 | ssl-key-password stream verbose proxy insecure ca-path)) 182 | (apply #'request uri :method :patch args)) 183 | 184 | (defun delete (uri &rest args 185 | &key (version 1.1) headers basic-auth cookie-jar (keep-alive t) 186 | (use-connection-pool dexador.connection-cache:*use-connection-pool*) 187 | (connect-timeout dexador.util:*default-connect-timeout*) 188 | (read-timeout dexador.util:*default-read-timeout*) 189 | force-binary force-string want-stream content 190 | ssl-key-file ssl-cert-file ssl-key-password stream 191 | (verbose dexador.util:*verbose*) 192 | (proxy dexador.util:*default-proxy*) 193 | (insecure dexador.util:*not-verify-ssl*) ca-path) 194 | (declare (ignorable version headers basic-auth cookie-jar keep-alive use-connection-pool 195 | connect-timeout read-timeout force-binary force-string want-stream 196 | ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy 197 | insecure ca-path content)) 198 | (apply #'request uri :method :delete args)) 199 | 200 | (defun fetch (uri destination &rest args 201 | &key (if-exists :error) 202 | (version 1.1) headers basic-auth cookie-jar (keep-alive t) 203 | (use-connection-pool dexador.connection-cache:*use-connection-pool*) 204 | (connect-timeout dexador.util:*default-connect-timeout*) 205 | (read-timeout dexador.util:*default-read-timeout*) 206 | (max-redirects 5) ssl-key-file ssl-cert-file 207 | ssl-key-password stream 208 | (verbose dexador.util:*verbose*) 209 | (proxy dexador.util:*default-proxy*) 210 | (insecure dexador.util:*not-verify-ssl*) ca-path) 211 | (declare (ignorable version headers basic-auth cookie-jar keep-alive use-connection-pool 212 | connect-timeout read-timeout max-redirects ssl-key-file ssl-cert-file 213 | ssl-key-password stream verbose proxy insecure ca-path)) 214 | (unless (and (eql if-exists nil) 215 | (probe-file destination)) 216 | (with-open-file (out destination 217 | :direction :output :element-type '(unsigned-byte 8) 218 | :if-exists if-exists 219 | :if-does-not-exist :create) 220 | (let ((body (apply #'dex:get uri :want-stream t :force-binary t 221 | (remove-from-plist args :if-exists)))) 222 | (alexandria:copy-stream body out) 223 | ;; Nominally the body gets closed, but if keep-alive is nil we need to explicitly do it. 224 | (when (open-stream-p body) 225 | (close body)))))) 226 | -------------------------------------------------------------------------------- /src/encoding.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador.encoding 3 | (:use :cl) 4 | (:import-from :babel 5 | :list-character-encodings 6 | :*default-character-encoding*) 7 | (:import-from :ppcre 8 | :scan-to-strings) 9 | (:export :detect-charset)) 10 | (in-package :dexador.encoding) 11 | 12 | (defun parse-content-type (content-type) 13 | (let ((types 14 | (nth-value 1 15 | (ppcre:scan-to-strings "^\\s*?(\\w+)/([^;\\s]+)(?:\\s*;\\s*charset=([A-Za-z0-9_-]+))?" 16 | content-type)))) 17 | (when types 18 | (values (aref types 0) 19 | (aref types 1) 20 | (aref types 2))))) 21 | 22 | (defun charset-to-encoding (charset &optional 23 | (default babel:*default-character-encoding*)) 24 | (cond 25 | ((null charset) 26 | default) 27 | ((string-equal charset "utf-8") 28 | :utf-8) 29 | ((string-equal charset "euc-jp") 30 | :eucjp) 31 | ((or (string-equal charset "shift_jis") 32 | (string-equal charset "shift-jis")) 33 | :cp932) 34 | ((string-equal charset "windows-31j") 35 | :cp932) 36 | (t (or (find charset (babel:list-character-encodings) 37 | :test #'string-equal) 38 | default)))) 39 | 40 | (defun detect-charset (content-type body) 41 | (multiple-value-bind (type subtype charset) 42 | (parse-content-type content-type) 43 | (cond 44 | ((charset-to-encoding charset nil)) 45 | ((string-equal type "text") 46 | (or (charset-to-encoding charset nil) 47 | (if (and (string-equal subtype "html") 48 | (typep body '(array (unsigned-byte 8) (*)))) 49 | (charset-to-encoding (detect-charset-from-html body) nil) 50 | nil) 51 | :utf-8)) 52 | ((and (string-equal type "application") 53 | (or (string-equal subtype "json") 54 | (string-equal subtype "javascript"))) 55 | ;; According to RFC4627 (http://www.ietf.org/rfc/rfc4627.txt), 56 | ;; JSON text SHALL be encoded in Unicode. The default encoding is UTF-8. 57 | ;; It's possible to determine if the encoding is UTF-16 or UTF-36 58 | ;; by looking at the first four octets, however, I leave it to the future. 59 | ;; 60 | ;; According to RFC4329 (https://datatracker.ietf.org/doc/html/rfc4329), 61 | ;; javascript also is specified by charset, or defaults to UTF-8 62 | ;; It's also possible to specify in the first four octets, but 63 | ;; like application/json I leave it to the future. 64 | (charset-to-encoding charset :utf-8)) 65 | ((and (string-equal type "application") 66 | (ppcre:scan "(?:[^+]+\\+)?xml" subtype)) 67 | (charset-to-encoding charset))))) 68 | 69 | (defun detect-charset-from-html (body) 70 | "Detect the body's charset by (roughly) searching meta tags which has \"charset\" attribute." 71 | (labels ((find-meta (start) 72 | (search #.(babel:string-to-octets ") body :start start :test #'=))) 78 | (unless end 79 | (return-from main nil)) 80 | (incf end) 81 | (let ((match (nth-value 1 (ppcre:scan-to-strings 82 | "charset=[\"']?([^\\s\"'>]+)[\"']?" 83 | (babel:octets-to-string body :start start :end end :errorp nil))))) 84 | (if match 85 | (aref match 0) 86 | (main end))))))) 87 | (main 0))) 88 | -------------------------------------------------------------------------------- /src/error.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador.error 3 | (:use :cl) 4 | (:import-from :quri 5 | :render-uri) 6 | (:export :http-request-failed 7 | 8 | ;; 4xx 9 | :http-request-bad-request 10 | :http-request-unauthorized 11 | :http-request-payment-required 12 | :http-request-forbidden 13 | :http-request-not-found 14 | :http-request-method-not-allowed 15 | :http-request-not-acceptable 16 | :http-request-proxy-authentication-required 17 | :http-request-request-timeout 18 | :http-request-conflict 19 | :http-request-gone 20 | :http-request-length-required 21 | :http-request-precondition-failed 22 | :http-request-payload-too-large 23 | :http-request-uri-too-long 24 | :http-request-unsupported-media-type 25 | :http-request-range-not-satisfiable 26 | :http-request-expectation-failed 27 | :http-request-misdirected-request 28 | :http-request-upgrade-required 29 | :http-request-too-many-requests 30 | 31 | ;; 5xx 32 | :http-request-internal-server-error 33 | :http-request-not-implemented 34 | :http-request-bad-gateway 35 | :http-request-service-unavailable 36 | :http-request-gateway-timeout 37 | :http-request-http-version-not-supported 38 | 39 | ;; accessors 40 | :response-body 41 | :response-status 42 | :response-headers 43 | :request-uri 44 | :request-method 45 | 46 | ;; Proxy errors 47 | :socks5-proxy-request-failed)) 48 | (in-package :dexador.error) 49 | 50 | (define-condition http-request-failed (error) 51 | ((body :initarg :body 52 | :reader response-body) 53 | (status :initarg :status 54 | :reader response-status) 55 | (headers :initarg :headers 56 | :reader response-headers) 57 | (uri :initarg :uri 58 | :reader request-uri) 59 | (method :initarg :method 60 | :reader request-method)) 61 | (:report (lambda (condition stream) 62 | (with-slots (uri status) condition 63 | (format stream "An HTTP request to ~S has failed (status=~D)." 64 | (quri:render-uri uri) 65 | status))))) 66 | 67 | (defmacro define-request-failed-condition (name code) 68 | `(define-condition ,(intern (format nil "~A-~A" :http-request name)) (http-request-failed) 69 | () 70 | (:report (lambda (condition stream) 71 | (with-slots (body uri) condition 72 | (format stream ,(format nil "An HTTP request to ~~S returned ~D ~A.~~2%~~A" 73 | code 74 | (substitute #\Space #\- (string-downcase name))) 75 | (quri:render-uri uri) 76 | body)))))) 77 | 78 | 79 | (defvar *request-failed-error* (make-hash-table :test 'eql)) 80 | 81 | #.`(progn 82 | ,@(loop for (name . code) in '(;; 4xx (Client Errors) 83 | (bad-request . 400) 84 | (unauthorized . 401) 85 | (payment-required . 402) 86 | (forbidden . 403) 87 | (not-found . 404) 88 | (method-not-allowed . 405) 89 | (not-acceptable . 406) 90 | (proxy-authentication-required . 407) 91 | (request-timeout . 408) 92 | (conflict . 409) 93 | (gone . 410) 94 | (length-required . 411) 95 | (precondition-failed . 412) 96 | (payload-too-large . 413) 97 | (uri-too-long . 414) 98 | (unsupported-media-type . 415) 99 | (range-not-satisfiable . 416) 100 | (expectation-failed . 417) 101 | (misdirected-request . 421) 102 | (upgrade-required . 426) 103 | (too-many-requests . 429) 104 | 105 | ;; 5xx (Server Errors) 106 | (internal-server-error . 500) 107 | (not-implemented . 501) 108 | (bad-gateway . 502) 109 | (service-unavailable . 503) 110 | (gateway-timeout . 504) 111 | (http-version-not-supported . 505)) 112 | collect `(define-request-failed-condition ,name ,code) 113 | collect `(setf (gethash ,code *request-failed-error*) 114 | ',(intern (format nil "~A-~A" :http-request name))))) 115 | 116 | (defun http-request-failed (status &key body headers uri method) 117 | (cerror 118 | "Ignore and continue" 119 | (gethash status *request-failed-error* 'http-request-failed) 120 | :body body 121 | :status status 122 | :headers headers 123 | :uri uri 124 | :method method)) 125 | 126 | (define-condition socks5-proxy-request-failed (http-request-failed) 127 | ((reason :initarg :reason)) 128 | (:report (lambda (condition stream) 129 | (with-slots (uri reason) condition 130 | (format stream "An HTTP request to ~S via SOCKS5 has failed (reason=~S)." 131 | (quri:render-uri uri) 132 | reason))))) 133 | -------------------------------------------------------------------------------- /src/keep-alive-stream.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador.keep-alive-stream 3 | (:use :cl) 4 | (:import-from :trivial-gray-streams 5 | :fundamental-input-stream 6 | :stream-read-byte 7 | :stream-read-sequence 8 | :stream-element-type 9 | :open-stream-p) 10 | (:import-from :alexandria 11 | :xor) 12 | (:export :make-keep-alive-stream 13 | :keep-alive-stream 14 | :keep-alive-chunked-stream 15 | :keep-alive-stream-close-underlying-stream 16 | :keep-alive-stream-stream)) 17 | (in-package :dexador.keep-alive-stream) 18 | 19 | (defclass keep-alive-stream (fundamental-input-stream) 20 | ((stream :type (or null stream) 21 | :initarg :stream 22 | :initform (error ":stream is required") 23 | :accessor keep-alive-stream-stream 24 | :documentation "A stream; when we read END elements from it, we call CLOSE-ACTION on it and 25 | set this slot to nil.") 26 | (end :initarg :end 27 | :initform nil 28 | :accessor keep-alive-stream-end) 29 | (close-action :initarg :on-close-or-eof :reader close-action 30 | :documentation "A (lambda (stream abort)) which will be called with keep-alive-stream-stream 31 | when the stream is either closed or we hit end of file or we hit end"))) 32 | 33 | (defun keep-alive-stream-close-underlying-stream (underlying-stream abort) 34 | (when (and underlying-stream (open-stream-p underlying-stream)) 35 | (close underlying-stream :abort abort))) 36 | 37 | (defclass keep-alive-chunked-stream (keep-alive-stream) 38 | ((chunga-stream :initarg :chunga-stream :accessor chunga-stream))) 39 | 40 | (defun make-keep-alive-stream (stream &key end chunked-stream (on-close-or-eof #'keep-alive-stream-close-underlying-stream)) 41 | "ON-CLOSE-OR-EOF takes a single parameter, STREAM (the stream passed in here, not the 42 | keep-alive-stream), and should handle clean-up of it" 43 | (assert (xor end chunked-stream)) 44 | (if chunked-stream 45 | (make-instance 'keep-alive-chunked-stream :stream stream :chunga-stream chunked-stream :on-close-or-eof on-close-or-eof) 46 | (make-instance 'keep-alive-stream :stream stream :end end :on-close-or-eof on-close-or-eof))) 47 | 48 | (defun maybe-close (stream &optional (close-if nil)) 49 | "Will close the underlying stream if close-if is T (unless it is already closed). 50 | If the stream is already closed or we closed it returns :EOF otherwise NIL." 51 | (let ((underlying-stream (keep-alive-stream-stream stream))) 52 | (cond 53 | ((not underlying-stream) 54 | :eof) 55 | (close-if 56 | (funcall (close-action stream) underlying-stream nil) 57 | (setf (keep-alive-stream-stream stream) nil) 58 | :eof) 59 | (t nil)))) 60 | 61 | (defmethod stream-read-byte ((stream keep-alive-stream)) 62 | "Return :EOF or byte read. When we hit EOF or finish reading our allowed content, 63 | call the close-action on our underlying-stream and return EOF." 64 | (let ((byte :eof) 65 | (underlying-stream (keep-alive-stream-stream stream))) 66 | (or (maybe-close stream (<= (keep-alive-stream-end stream) 0)) 67 | (progn 68 | (setf byte (read-byte underlying-stream nil :eof)) 69 | (decf (keep-alive-stream-end stream) 1) 70 | (maybe-close stream (or (<= (keep-alive-stream-end stream) 0) (eql byte :eof))) 71 | byte)))) 72 | 73 | (defmethod stream-read-byte ((stream keep-alive-chunked-stream)) 74 | "Return :EOF or byte read. When we hit :EOF or finish reading our chunk, 75 | call the close-action on our underlying-stream and return :EOF" 76 | (or (maybe-close stream) 77 | (if (chunga:chunked-stream-input-chunking-p (chunga-stream stream)) 78 | (let ((byte (read-byte (chunga-stream stream) nil :eof))) 79 | (if (eql byte :eof) 80 | (prog1 81 | byte 82 | (maybe-close stream t)) 83 | byte)) 84 | (or (maybe-close stream t) :eof)))) 85 | 86 | (defmethod stream-read-sequence ((stream keep-alive-stream) sequence start end &key) 87 | (declare (optimize speed)) 88 | (if (null (keep-alive-stream-stream stream)) ;; we already closed it 89 | start 90 | (let* ((to-read (min (- end start) (keep-alive-stream-end stream))) 91 | (n (read-sequence sequence (keep-alive-stream-stream stream) 92 | :start start 93 | :end (+ start to-read)))) 94 | (decf (keep-alive-stream-end stream) (- n start)) 95 | (maybe-close stream (<= (keep-alive-stream-end stream) 0)) 96 | n))) 97 | 98 | (defmethod stream-read-sequence ((stream keep-alive-chunked-stream) sequence start end &key) 99 | (declare (optimize speed)) 100 | (if (null (keep-alive-stream-stream stream)) ;; we already closed it 101 | start 102 | (if (chunga:chunked-stream-input-chunking-p (chunga-stream stream)) 103 | (prog1 104 | (let ((num-read (read-sequence sequence (chunga-stream stream) :start start :end end))) 105 | num-read) 106 | (maybe-close stream (not (chunga:chunked-stream-input-chunking-p (chunga-stream stream))))) 107 | start))) 108 | 109 | (defmethod stream-element-type ((stream keep-alive-chunked-stream)) 110 | (stream-element-type (chunga-stream stream))) 111 | 112 | (defmethod stream-element-type ((stream keep-alive-stream)) 113 | '(unsigned-byte 8)) 114 | 115 | (defmethod open-stream-p ((stream keep-alive-stream)) 116 | (let ((underlying-stream (keep-alive-stream-stream stream))) 117 | (and underlying-stream (open-stream-p underlying-stream)))) 118 | 119 | (defmethod close ((stream keep-alive-stream) &key abort) 120 | (funcall (close-action stream) (keep-alive-stream-stream stream) abort) 121 | (setf (keep-alive-stream-stream stream) nil)) 122 | -------------------------------------------------------------------------------- /src/restarts.lisp: -------------------------------------------------------------------------------- 1 | (defpackage dexador.restarts 2 | (:use :cl) 3 | (:export :retry-request 4 | :ignore-and-continue)) 5 | (in-package :dexador.restarts) 6 | 7 | (defun ignore-and-continue (e) 8 | (let ((restart (find-restart 'ignore-and-continue e))) 9 | (when restart 10 | (invoke-restart restart)))) 11 | 12 | (defun retry-request (times &key (interval 3)) 13 | (declare (type (or function integer) interval)) 14 | (etypecase times 15 | (condition 16 | (let ((restart (find-restart 'retry-request times))) 17 | (when restart 18 | (invoke-restart restart)))) 19 | (integer 20 | (retry-request-ntimes times :interval interval)))) 21 | 22 | (defun retry-request-ntimes (n &key (interval 3)) 23 | (declare (type integer n) 24 | (type (or function integer) interval)) 25 | (let ((retries 0)) 26 | (declare (type integer retries)) 27 | (lambda (e) 28 | (declare (type condition e)) 29 | (let ((restart (find-restart 'retry-request e))) 30 | (when restart 31 | (when (< retries n) 32 | (incf retries) 33 | (etypecase interval 34 | (function (funcall interval retries)) 35 | (integer (sleep interval))) 36 | (invoke-restart restart))))))) 37 | -------------------------------------------------------------------------------- /src/util.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador.util 3 | (:use :cl) 4 | (:import-from :fast-io 5 | :with-fast-output 6 | :fast-write-byte 7 | :fast-write-sequence) 8 | (:import-from :quri 9 | :uri-path 10 | :uri-query 11 | :uri-host 12 | :uri-port 13 | :render-uri) 14 | (:export :*default-connect-timeout* 15 | :*default-read-timeout* 16 | :*verbose* 17 | :*default-proxy* 18 | :*not-verify-ssl* 19 | :defun-speedy 20 | :defun-careful 21 | :octets 22 | :ascii-string-to-octets 23 | :+crlf+ 24 | :*default-user-agent* 25 | :write-first-line 26 | :write-header 27 | :with-header-output 28 | :write-connect-header 29 | :make-random-string)) 30 | (in-package :dexador.util) 31 | 32 | (defvar *default-connect-timeout* 10) 33 | (defvar *default-read-timeout* 10) 34 | (defvar *verbose* nil) 35 | (defvar *not-verify-ssl* nil) 36 | (defvar *default-proxy* (or #-windows (uiop:getenv "HTTPS_PROXY") 37 | #-windows (uiop:getenv "HTTP_PROXY")) 38 | "If specified will be used as the default value of PROXY in calls to dexador. Defaults to 39 | the value of the environment variable HTTPS_PROXY or HTTP_PROXY if not on Windows.") 40 | 41 | (eval-when (:compile-toplevel :load-toplevel :execute) 42 | (defvar *speedy-declaration* '(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))) 43 | (defvar *careful-declaration* '(declare (optimize (speed 3) (safety 2))))) 44 | 45 | (defmacro defun-speedy (name lambda-list &body body) 46 | `(progn 47 | (declaim (notinline ,name)) 48 | (defun ,name ,lambda-list 49 | ,*speedy-declaration* 50 | ,@body))) 51 | 52 | (defmacro defun-careful (name lambda-list &body body) 53 | `(progn 54 | (declaim (notinline ,name)) 55 | (defun ,name ,lambda-list 56 | ,*careful-declaration* 57 | ,@body))) 58 | 59 | (deftype octets (&optional (len '*)) `(simple-array (unsigned-byte 8) (,len))) 60 | 61 | (declaim (ftype (function (simple-string) octets) ascii-string-to-octets)) 62 | (eval-when (:compile-toplevel :load-toplevel :execute) 63 | (defun-speedy %ascii-string-to-octets (string) 64 | (let ((result (make-array (length string) :element-type '(unsigned-byte 8)))) 65 | (declare (type octets result)) 66 | (dotimes (i (length string) result) 67 | (declare (type fixnum i)) 68 | (setf (aref result i) 69 | (char-code (aref string i)))))) 70 | 71 | (defun-speedy ascii-string-to-octets (string) 72 | (%ascii-string-to-octets string)) 73 | 74 | (define-compiler-macro ascii-string-to-octets (&whole form string) 75 | (if (constantp string) 76 | (%ascii-string-to-octets string) 77 | form)) 78 | 79 | (declaim (type octets +crlf+)) 80 | (defvar +crlf+ (ascii-string-to-octets (format nil "~C~C" #\Return #\Newline)))) 81 | 82 | (eval-when (:compile-toplevel :load-toplevel :execute) 83 | (defparameter *dexador-version* 84 | (asdf:component-version (asdf:find-system :dexador))) 85 | 86 | (defparameter *default-user-agent* 87 | (format nil "Dexador/~A (~A~@[ ~A~]); ~A;~@[ ~A~]" 88 | *dexador-version* 89 | (or (lisp-implementation-type) "Common Lisp") 90 | (or (lisp-implementation-version) "") 91 | (or #-clisp (software-type) 92 | #+(or win32 mswindows) "Windows" 93 | #-(or win32 mswindows) "Unix") 94 | (or #-clisp (software-version))))) 95 | 96 | (defparameter *header-buffer* nil) 97 | 98 | (defun write-first-line (method uri version &optional (buffer *header-buffer*)) 99 | (fast-write-sequence (ascii-string-to-octets (string method)) buffer) 100 | (fast-write-byte #.(char-code #\Space) buffer) 101 | (fast-write-sequence (ascii-string-to-octets 102 | (format nil "~A~:[~;~:*?~A~]" 103 | (or (uri-path uri) "/") 104 | (uri-query uri))) 105 | buffer) 106 | (fast-write-byte #.(char-code #\Space) buffer) 107 | (fast-write-sequence (ecase version 108 | (1.1 (ascii-string-to-octets "HTTP/1.1")) 109 | (1.0 (ascii-string-to-octets "HTTP/1.0"))) 110 | buffer) 111 | (fast-write-sequence +crlf+ buffer)) 112 | 113 | (defun write-header-field (name buffer) 114 | (fast-write-sequence (if (typep name 'octets) 115 | name 116 | (ascii-string-to-octets (string-capitalize name))) 117 | buffer)) 118 | 119 | (defun write-header-value (value buffer) 120 | (fast-write-sequence (if (typep value 'octets) 121 | value 122 | (ascii-string-to-octets (princ-to-string value))) 123 | buffer)) 124 | 125 | (defun write-header (name value &optional (buffer *header-buffer*)) 126 | (write-header-field name buffer) 127 | (fast-write-sequence (ascii-string-to-octets ": ") buffer) 128 | (write-header-value value buffer) 129 | (fast-write-sequence +crlf+ buffer)) 130 | 131 | (define-compiler-macro write-header (name value &optional (buffer '*header-buffer*)) 132 | `(progn 133 | ,(if (and (constantp name) 134 | (typep name '(or keyword string))) 135 | `(fast-write-sequence (ascii-string-to-octets ,(string-capitalize name)) ,buffer) 136 | `(write-header-field ,name ,buffer)) 137 | (fast-write-sequence (ascii-string-to-octets ": ") ,buffer) 138 | ,(if (constantp value) 139 | `(fast-write-sequence (ascii-string-to-octets ,(string value)) ,buffer) 140 | `(write-header-value ,value ,buffer)) 141 | (fast-write-sequence +crlf+ ,buffer))) 142 | 143 | (defmacro with-header-output ((buffer &optional output) &body body) 144 | `(with-fast-output (,buffer ,output) 145 | (declare (ignorable ,buffer)) 146 | (let ((*header-buffer* ,buffer)) 147 | ,@body))) 148 | 149 | (defun write-connect-header (uri version buffer &optional proxy-auth) 150 | (fast-write-sequence (ascii-string-to-octets "CONNECT") buffer) 151 | (fast-write-byte #.(char-code #\Space) buffer) 152 | (fast-write-sequence (ascii-string-to-octets (format nil "~A:~A" 153 | (uri-host uri) 154 | (uri-port uri))) 155 | buffer) 156 | (fast-write-byte #.(char-code #\Space) buffer) 157 | (fast-write-sequence (ecase version 158 | (1.1 (ascii-string-to-octets "HTTP/1.1")) 159 | (1.0 (ascii-string-to-octets "HTTP/1.0"))) 160 | buffer) 161 | (fast-write-sequence +crlf+ buffer) 162 | (fast-write-sequence (ascii-string-to-octets "Host:") buffer) 163 | (fast-write-byte #.(char-code #\Space) buffer) 164 | (fast-write-sequence (ascii-string-to-octets (format nil "~A:~A" 165 | (uri-host uri) 166 | (uri-port uri))) 167 | buffer) 168 | (when proxy-auth 169 | (fast-write-sequence +crlf+ buffer) 170 | (fast-write-sequence (ascii-string-to-octets "Proxy-Authorization:") buffer) 171 | (fast-write-byte #.(char-code #\Space) buffer) 172 | (fast-write-sequence (ascii-string-to-octets proxy-auth) buffer)) 173 | (fast-write-sequence +crlf+ buffer) 174 | (fast-write-sequence +crlf+ buffer)) 175 | 176 | (defun-speedy make-random-string (&optional (length 12)) 177 | (declare (type fixnum length)) 178 | (let ((result (make-string length))) 179 | (declare (type simple-string result)) 180 | (dotimes (i length result) 181 | (setf (aref result i) 182 | (ecase (random 5) 183 | ((0 1) (code-char (+ #.(char-code #\a) (random 26)))) 184 | ((2 3) (code-char (+ #.(char-code #\A) (random 26)))) 185 | ((4) (code-char (+ #.(char-code #\0) (random 10))))))))) 186 | -------------------------------------------------------------------------------- /t/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM clfoundation/sbcl 2 | 3 | WORKDIR /app 4 | 5 | ADD https://beta.quicklisp.org/quicklisp.lisp /root/quicklisp.lisp 6 | RUN set -x; \ 7 | sbcl --noinform --non-interactive --load /root/quicklisp.lisp \ 8 | --eval '(quicklisp-quickstart:install)' && \ 9 | echo '#-quicklisp (load #P"/root/quicklisp/setup.lisp")' > /root/.sbclrc && \ 10 | rm /root/quicklisp.lisp && \ 11 | sbcl --eval '(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)' --quit && \ 12 | mkdir -p "$HOME/.config/common-lisp/source-registry.conf.d/" && \ 13 | echo '(:tree "/app")' >> "$HOME/.config/common-lisp/source-registry.conf.d/ci.conf" 14 | 15 | ENTRYPOINT ["sbcl", "--noinform", "--non-interactive"] 16 | CMD ["--eval", "(ql:quickload :rove)", "--eval", "(rove:run :dexador-test)"] 17 | -------------------------------------------------------------------------------- /t/benchmark.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador-test.benchmark 3 | (:use :cl)) 4 | (in-package :dexador-test.benchmark) 5 | 6 | (defun run-benchmark () 7 | (clack:clackup 8 | (lambda (env) 9 | (declare (ignore env)) 10 | (list 200 ())))) 11 | -------------------------------------------------------------------------------- /t/data/bug139.txt: -------------------------------------------------------------------------------- 1 | This file needs to be exactly 253 bytes long which is (- (* 2 decoding-stream::+buffer-size+) 3). There was a bug in keep-alive-stream::read-sequence which did not return the correct value when hitting end of file. It should return start not zero.... 2 | -------------------------------------------------------------------------------- /t/data/quote.txt: -------------------------------------------------------------------------------- 1 | "Within a couple weeks of learning Lisp I found programming in any other language unbearably constraining." -- Paul Graham, Road to Lisp 2 | -------------------------------------------------------------------------------- /t/data/test.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/dexador/d7ac217819e9156abe10cd28ba7a2d548be03cad/t/data/test.gz -------------------------------------------------------------------------------- /t/data/test.zlib: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fukamachi/dexador/d7ac217819e9156abe10cd28ba7a2d548be03cad/t/data/test.zlib -------------------------------------------------------------------------------- /t/data/umb.bin: -------------------------------------------------------------------------------- 1 | ☂ 2 | -------------------------------------------------------------------------------- /t/dexador.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage dexador-test 3 | (:use :cl 4 | :rove) 5 | (:import-from :clack.test 6 | :*clack-test-port* 7 | :*clack-test-access-port* 8 | :port-available-p 9 | :localhost)) 10 | (in-package :dexador-test) 11 | 12 | (defun random-port () 13 | "Return a port number not in use from 50000 to 60000." 14 | (loop for port from (+ 50000 (random 1000)) upto 60000 15 | if (clack.test::port-available-p port) 16 | return port)) 17 | 18 | (defmacro testing-app ((desc &key use-connection-pool) app &body body) 19 | `(let ((*clack-test-port* (random-port))) 20 | (clack.test:testing-app ,desc ,app 21 | ;; Clack's TESTING-APP sets dex:*use-connection-pool* to NIL, 22 | ;; but we need to change it in some tests 23 | (let ((dex:*use-connection-pool* ,use-connection-pool)) 24 | (dex:clear-connection-pool) 25 | ,@body)))) 26 | 27 | (deftest normal-case-tests 28 | (testing-app ("normal case") 29 | (lambda (env) 30 | `(200 (:content-length ,(length (getf env :request-uri))) (,(getf env :request-uri)))) 31 | (testing "GET" 32 | (multiple-value-bind (body code headers) 33 | (dex:get (localhost "/foo") 34 | :headers '((:x-foo . "ppp"))) 35 | (ok (eql code 200)) 36 | (ok (equal body "/foo")) 37 | (ok (equal (gethash "content-length" headers) "4")))) 38 | (testing "HEAD" 39 | (multiple-value-bind (body code) 40 | (dex:head (localhost "/foo")) 41 | (ok (eql code 200)) 42 | (ok (equal body "")))) 43 | (testing "PUT" 44 | (multiple-value-bind (body code) 45 | (dex:put (localhost "/foo")) 46 | (ok (eql code 200)) 47 | (ok (equal body "/foo")))) 48 | (testing "DELETE" 49 | (multiple-value-bind (body code) 50 | (dex:delete (localhost "/foo")) 51 | (ok (eql code 200)) 52 | (ok (equal body "/foo")))))) 53 | 54 | (deftest proxy-http-tests 55 | #+windows 56 | (skip "Skipped proxy tests on Windows") 57 | #-windows 58 | (testing-app ("proxy (http) case") 59 | ; proxy behavior is same as direct connection if http 60 | (lambda (env) 61 | (let ((body (format nil "~A~%~A" 62 | (gethash "host" (getf env :headers)) 63 | (getf env :request-uri)))) 64 | `(200 (:content-length ,(length body)) (,body)))) 65 | (testing "GET" 66 | (multiple-value-bind (body code) 67 | (dex:get "http://lisp.org/foo" 68 | :headers '((:x-foo . "ppp")) 69 | :proxy (localhost)) 70 | (ok (eql code 200)) 71 | (ok (equal body (format nil "lisp.org~%/foo"))))) 72 | (testing "HEAD" 73 | (multiple-value-bind (body code) 74 | (dex:head "http://lisp.org/foo" 75 | :proxy (localhost)) 76 | (ok (eql code 200)) 77 | (ok (equal body "")))) 78 | (testing "PUT" 79 | (multiple-value-bind (body code) 80 | (dex:put "http://lisp.org/foo" 81 | :proxy (localhost)) 82 | (ok (eql code 200)) 83 | (ok (equal body (format nil "lisp.org~%/foo"))))) 84 | (testing "DELETE" 85 | (multiple-value-bind (body code) 86 | (dex:delete "http://lisp.org/foo" 87 | :proxy (localhost)) 88 | (ok (eql code 200)) 89 | (ok (equal body (format nil "lisp.org~%/foo"))))))) 90 | 91 | (deftest proxy-socks5-tests 92 | #+windows 93 | (skip "SOCKS5 proxy tests are skipped") 94 | #-windows 95 | (testing-app ("proxy (socks5) case") 96 | (flet ((check (uri in out) 97 | (flexi-streams:with-input-from-sequence (in in) 98 | (equalp 99 | (flexi-streams:with-output-to-sequence (out :element-type '(unsigned-byte 8)) 100 | (dexador.backend.usocket::ensure-socks5-connected in out (quri:uri uri) :get)) 101 | out)))) 102 | (ok (check "http://example.com/" 103 | #(5 0 104 | 5 0 0 1 0 0 0 0 0 0) 105 | #(5 1 0 106 | 5 1 0 3 11 101 120 97 109 112 108 101 46 99 111 109 0 80))) 107 | (ok (check "https://example.com/" 108 | #(5 0 109 | 5 0 0 1 0 0 0 0 0 0) 110 | #(5 1 0 111 | 5 1 0 3 11 101 120 97 109 112 108 101 46 99 111 109 1 187))) 112 | (ok (check "http://example.com:8080/" 113 | #(5 0 114 | 5 0 0 1 0 0 0 0 0 0) 115 | #(5 1 0 116 | 5 1 0 3 11 101 120 97 109 112 108 101 46 99 111 109 31 144))) 117 | (ok (check "https://example.com:8080/" 118 | #(5 0 119 | 5 0 0 1 0 0 0 0 0 0) 120 | #(5 1 0 121 | 5 1 0 3 11 101 120 97 109 112 108 101 46 99 111 109 31 144))) 122 | (ok (check "http://example.com/" 123 | #(5 0 124 | 5 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 125 | #(5 1 0 126 | 5 1 0 3 11 101 120 97 109 112 108 101 46 99 111 109 0 80))) 127 | (ok (check "http://example.com/" 128 | #(5 0 129 | 5 0 0 3 1 0 0 0) 130 | #(5 1 0 131 | 5 1 0 3 11 101 120 97 109 112 108 101 46 99 111 109 0 80))) 132 | (handler-case 133 | (check "http://example.com/" 134 | #(4) 135 | #()) 136 | (dex:socks5-proxy-request-failed () 137 | (ok t))) 138 | (handler-case 139 | (check "http://example.com/" 140 | #(5 255) 141 | #()) 142 | (dex:socks5-proxy-request-failed () 143 | (ok t)))) 144 | 145 | #+needs-Tor-running-on-localhost 146 | (let ((proxy "socks5://127.0.0.1:9150")) 147 | (testing "SOCKS5 GET" 148 | (multiple-value-bind (body code) 149 | (dex:get "http://duskgytldkxiuqc6.onion/" :proxy proxy) 150 | (declare (ignore body)) 151 | (ok (eql code 200)))) 152 | (testing "SOCKS5 GET with SSL" 153 | (multiple-value-bind (body code) 154 | (dex:get "https://www.facebookcorewwwi.onion/" :proxy proxy) 155 | (declare (ignore body)) 156 | (ok (eql code 200))))))) 157 | 158 | (deftest redirection-tests 159 | (testing-app ("redirection") 160 | (lambda (env) 161 | (let ((id (parse-integer (subseq (getf env :path-info) 1)))) 162 | (cond 163 | ((= id 3) 164 | '(200 (:content-length 2) ("OK"))) 165 | ((<= 300 id 399) 166 | `(,id (:location "/200") ())) 167 | ((= id 200) 168 | (let ((method (princ-to-string (getf env :request-method)))) 169 | `(200 (:content-length ,(length method)) 170 | (,method)))) 171 | (t 172 | `(302 (:location ,(format nil "/~D" (1+ id))) ()))))) 173 | (testing "redirect" 174 | (multiple-value-bind (body code headers) 175 | (dex:get (localhost "/1")) 176 | (ok (eql code 200)) 177 | (ok (equal body "OK")) 178 | (ok (equal (gethash "content-length" headers) 179 | (princ-to-string 2))))) 180 | (testing "not enough redirect" 181 | (multiple-value-bind (body code headers) 182 | (dex:get (localhost "/1") :max-redirects 0) 183 | (declare (ignore body)) 184 | (ok (eql code 302)) 185 | (ok (equal (gethash "location" headers) "/2")))) 186 | (testing "exceed max redirect" 187 | (multiple-value-bind (body code headers) 188 | (dex:get (localhost "/4") :max-redirects 7) 189 | (declare (ignore body)) 190 | (ok (eql code 302)) 191 | (ok (equal (gethash "location" headers) "/12")))) 192 | (testing "POST redirects as GET" 193 | (multiple-value-bind (body code headers uri) 194 | (dex:post (localhost "/301")) 195 | (declare (ignore headers)) 196 | (ok (eql code 200)) 197 | (ok (equal body "GET")) 198 | (ok (equal (quri:uri-path uri) "/200")))) 199 | (testing "POST redirects as POST for 307" 200 | (multiple-value-bind (body code headers uri) 201 | (dex:post (localhost "/307")) 202 | (declare (ignore headers)) 203 | (ok (eql code 200)) 204 | (ok (equal body "POST")) 205 | (ok (equal (quri:uri-path uri) "/200")))))) 206 | 207 | (deftest content-disposition-tests 208 | #+windows 209 | (skip "Content-Disposition tests are skipped") 210 | #-windows 211 | (testing "content-disposition" 212 | (ok (equal (dexador.backend.usocket::content-disposition "upload" #P"data/plain-file.txt") 213 | (format nil "Content-Disposition: form-data; name=\"upload\"; filename=\"plain-file.txt\"~C~C" 214 | #\Return #\Newline)) 215 | "ASCII file name") 216 | (ok (equal (dexador.backend.usocket::content-disposition "upload" #P"data/plain file.txt") 217 | (format nil "Content-Disposition: form-data; name=\"upload\"; filename=\"plain file.txt\"~C~C" 218 | #\Return #\Newline)) 219 | "ASCII file name with space") 220 | #+ecl 221 | (skip "Skipped because UTF-8 pathname is not allowed on ECL") 222 | #-ecl 223 | (ok (equal (dexador.backend.usocket::content-disposition "upload" #P"data/foo-あいうえお.txt") 224 | (format nil "Content-Disposition: form-data; name=\"upload\"; filename*=UTF-8''foo-%E3%81%82%E3%81%84%E3%81%86%E3%81%88%E3%81%8A.txt~C~C" 225 | #\Return #\Newline)) 226 | "UTF-8 file name") 227 | (ok (equal (dexador.backend.usocket::content-disposition "title" "ignore") 228 | (format nil "Content-Disposition: form-data; name=\"title\"~C~C" 229 | #\Return #\Newline)) 230 | "string value"))) 231 | 232 | ;; SBCL replaces LF with CRLF when reading from a stream on Windows 233 | (defun replace-crlf-to-lf (string) 234 | (ppcre:regex-replace-all (format nil "~C~C" #\Return #\Newline) 235 | string 236 | (format nil "~C" #\Newline))) 237 | 238 | (deftest post-request-tests 239 | (testing-app ("POST request") 240 | (lambda (env) 241 | (cond 242 | ((string= (getf env :path-info) "/upload") 243 | (let ((buf (make-array (getf env :content-length) 244 | :element-type '(unsigned-byte 8)))) 245 | (read-sequence buf (getf env :raw-body)) 246 | `(200 () 247 | (,(replace-crlf-to-lf (babel:octets-to-string buf)))))) 248 | (t 249 | (let ((req (lack.request:make-request env))) 250 | `(200 () 251 | (,(with-output-to-string (s) 252 | (loop for (k . v) in (lack.request:request-body-parameters req) 253 | do (format s "~&~A: ~A~%" 254 | k 255 | (cond 256 | ((and (consp v) 257 | (streamp (car v))) 258 | (let* ((buf (make-array 1024 :element-type '(unsigned-byte 8))) 259 | (n (read-sequence buf (car v)))) 260 | (replace-crlf-to-lf (babel:octets-to-string (subseq buf 0 n))))) 261 | ((consp v) 262 | (car v)) 263 | (t v))))))))))) 264 | (testing "content in alist" 265 | (multiple-value-bind (body code headers) 266 | (dex:post (localhost) 267 | :content '(("name" . "Eitaro") 268 | ("email" . "e.arrows@gmail.com"))) 269 | (declare (ignore headers)) 270 | (ok (eql code 200)) 271 | (ok (equal body (format nil "name: Eitaro~%email: e.arrows@gmail.com~%"))))) 272 | (testing "string content" 273 | (multiple-value-bind (body code headers) 274 | (dex:post (localhost "/upload") 275 | :content "this is string data") 276 | (declare (ignore headers)) 277 | (ok (eql code 200)) 278 | (ok (equal body "this is string data")))) 279 | (testing "octets content" 280 | (multiple-value-bind (body code headers) 281 | (dex:post (localhost "/upload") 282 | :content (babel:string-to-octets "this is octet data")) 283 | (declare (ignore headers)) 284 | (ok (eql code 200)) 285 | (ok (equal body "this is octet data")))) 286 | (testing "multipart" 287 | (multiple-value-bind (body code) 288 | (dex:post (localhost) 289 | :content `(("title" . "Road to Lisp") 290 | ("body" . ,(asdf:system-relative-pathname :dexador #P"t/data/quote.txt")))) 291 | (ok (eql code 200)) 292 | (ok (equal body 293 | (format nil "title: Road to Lisp~%body: \"Within a couple weeks of learning Lisp I found programming in any other language unbearably constraining.\" -- Paul Graham, Road to Lisp~2%"))))) 294 | (testing "multipart-boundary-added" 295 | (multiple-value-bind (body code) 296 | (dex:post (localhost) 297 | :content `(("title" . "Road to Lisp") 298 | ("body" . ,(asdf:system-relative-pathname :dexador #P"t/data/quote.txt")))) 299 | (ok (eql code 200)) 300 | (ok (equal body 301 | (format nil "title: Road to Lisp~%body: \"Within a couple weeks of learning Lisp I found programming in any other language unbearably constraining.\" -- Paul Graham, Road to Lisp~2%"))))) 302 | (testing "multipart-boundary-test-added-even-if-content-type-specified" 303 | (multiple-value-bind (body code) 304 | (dex:post (localhost) 305 | :headers '((:content-type . "multipart/form-data")) 306 | :content `(("title" . "Road to Lisp") 307 | ("body" . ,(asdf:system-relative-pathname :dexador #P"t/data/quote.txt")))) 308 | (ok (eql code 200)) 309 | (ok (equal body 310 | (format nil "title: Road to Lisp~%body: \"Within a couple weeks of learning Lisp I found programming in any other language unbearably constraining.\" -- Paul Graham, Road to Lisp~2%"))))) 311 | (testing "upload" 312 | (multiple-value-bind (body code) 313 | (dex:post (localhost "/upload") 314 | :content (asdf:system-relative-pathname :dexador #P"t/data/quote.txt")) 315 | (ok (eql code 200)) 316 | (ok (equal body 317 | (format nil "\"Within a couple weeks of learning Lisp I found programming in any other language unbearably constraining.\" -- Paul Graham, Road to Lisp~%"))))))) 318 | 319 | (deftest http-request-failed-tests 320 | (testing-app ("HTTP request failed") 321 | (lambda (env) 322 | (if (string= (getf env :path-info) "/404") 323 | '(404 (:x-foo 0) ("Not Found")) 324 | '(500 (:x-bar 1) ("Internal Server Error")))) 325 | (handler-case 326 | (progn 327 | (dex:get (localhost)) 328 | (fail "Must raise an error DEX:HTTP-REQUEST-FAILED")) 329 | (dex:http-request-failed (e) 330 | (pass "Raise DEX:HTTP-REQUEST-FAILED error") 331 | (ok (eql (dex:response-status e) 500) 332 | "response status is 500") 333 | (ok (equal (dex:response-body e) "Internal Server Error") 334 | "response body is \"Internal Server Error\"") 335 | (ok (equal (gethash "x-bar" (dex:response-headers e)) 336 | "1")))) 337 | (handler-case 338 | (progn 339 | (dex:get (localhost "/404")) 340 | (fail "Must raise an error DEX:HTTP-REQUEST-NOT-FOUND")) 341 | (dex:http-request-not-found (e) 342 | (pass "Raise DEX:HTTP-REQUEST-FAILED error") 343 | (ok (eql (dex:response-status e) 404) 344 | "response status is 404") 345 | (ok (equal (dex:response-body e) "Not Found") 346 | "response body is \"Not Found\"") 347 | (ok (equal (gethash "x-foo" (dex:response-headers e)) 348 | "0")))))) 349 | 350 | (deftest using-cookies-tests 351 | (testing-app ("Using cookies") 352 | (lambda (env) 353 | (list (if (string= (getf env :path-info) "/302") 354 | 302 355 | 200) 356 | ;; mixi.jp 357 | '(:set-cookie "_auid=a8acafbaef245a806f6a308506dc95c8; domain=localhost; path=/; expires=Mon, 10-Jul-2017 12:32:47 GMT" 358 | ;; sourceforge 359 | :set-cookie2 "VISITOR=55a11217d3179d198af1d003; expires=\"Tue, 08-Jul-2025 12:54:47 GMT\"; httponly; Max-Age=315360000; Path=/") 360 | '("ok"))) 361 | (let ((cookie-jar (cl-cookie:make-cookie-jar))) 362 | (ok (eql (length (cl-cookie:cookie-jar-cookies cookie-jar)) 0) "0 cookies") 363 | (dex:head (localhost) :cookie-jar cookie-jar) 364 | (ok (eql (length (cl-cookie:cookie-jar-cookies cookie-jar)) 2) "2 cookies") 365 | (dex:head (localhost) :cookie-jar cookie-jar)) 366 | 367 | ;; 302 368 | (let ((cookie-jar (cl-cookie:make-cookie-jar))) 369 | (ok (eql (length (cl-cookie:cookie-jar-cookies cookie-jar)) 0) "0 cookies") 370 | (dex:head (localhost "/302") :cookie-jar cookie-jar) 371 | (ok (eql (length (cl-cookie:cookie-jar-cookies cookie-jar)) 2) "2 cookies") 372 | (dex:head (localhost "/302") :cookie-jar cookie-jar)))) 373 | 374 | (deftest verbose-tests 375 | (testing-app ("verbose") 376 | (lambda (env) 377 | (declare (ignore env)) 378 | '(200 () ("ok"))) 379 | (ok (dex:get (localhost) :verbose t)))) 380 | 381 | (deftest want-stream-tests 382 | (testing-app ("want-stream") 383 | (lambda (env) 384 | (declare (ignore env)) 385 | '(200 (:content-type "text/plain") ("hi"))) 386 | ;; decoding stream 387 | (let ((body (dex:get (localhost) :want-stream t :keep-alive nil))) 388 | #+windows 389 | (ok (typep body 'stream)) 390 | #-windows 391 | (ok (typep body 'dexador.decoding-stream:decoding-stream) 392 | "body is a decoding stream") 393 | (ok (subtypep (stream-element-type body) 'babel:unicode-char) 394 | "body is a character stream") 395 | (let ((buf (make-string 2))) 396 | (read-sequence buf body) 397 | (ok (equal buf "hi")))) 398 | ;; binary stream 399 | (let ((body (dex:get (localhost) :want-stream t :force-binary t :keep-alive nil))) 400 | (ok (typep body 'stream) "body is a stream") 401 | (ok (open-stream-p body) "body is open") 402 | (ok (subtypep (stream-element-type body) '(unsigned-byte 8)) 403 | "body is a octets stream") 404 | (let ((buf (make-array 2 :element-type '(unsigned-byte 8)))) 405 | (read-sequence buf body) 406 | (ok (equal (babel:octets-to-string buf) "hi")))))) 407 | 408 | (deftest big-body-with-want-stream-tests 409 | (testing-app ("big body with want-stream") 410 | (lambda (env) 411 | (declare (ignore env)) 412 | `(200 (:content-type "application/json; charset=utf-8" 413 | :content-length 748) 414 | ("[{\"name\":\"allow-statement-in-has-a\",\"commit\":{\"sha\":\"d58b3c96503786c64eb2dba22980ebb14010bdbf\",\"url\":\"https://api.github.com/repos/fukamachi/datafly/commits/d58b3c96503786c64eb2dba22980ebb14010bdbf\"}},{\"name\":\"fix-has-a\",\"commit\":{\"sha\":\"4bcea61e84402317ab49605918972983a1511e6a\",\"url\":\"https://api.github.com/repos/fukamachi/datafly/commits/4bcea61e84402317ab49605918972983a1511e6a\"}},{\"name\":\"jojo\",\"commit\":{\"sha\":\"d2b753e7fdd0dbeada9721380cf410186a85535b\",\"url\":\"https://api.github.com/repos/fukamachi/datafly/commits/d2b753e7fdd0dbeada9721380cf410186a85535b\"}},{\"name\":\"master\",\"commit\":{\"sha\":\"d2b753e7fdd0dbeada9721380cf410186a85535b\",\"url\":\"https://api.github.com/repos/fukamachi/datafly/commits/d2b753e7fdd0dbeada9721380cf410186a85535b\"}}]"))) 415 | ;; decoding stream 416 | (let ((body (dex:get (localhost) :want-stream t))) 417 | #+windows 418 | (ok (typep body 'stream)) 419 | #-windows 420 | (ok (typep body 'dexador.decoding-stream:decoding-stream) 421 | "body is a decoding stream") 422 | (ok (subtypep (stream-element-type body) 'babel:unicode-char) 423 | "body is a character stream") 424 | (let ((buf (make-string 1024))) 425 | (ok (eql (read-sequence buf body) 748)))))) 426 | 427 | (deftest redirection-for-want-stream-tests 428 | (testing-app ("redirection for want-stream") 429 | (lambda (env) 430 | (if (string= (getf env :path-info) "/index.html") 431 | '(200 () ("ok")) 432 | '(307 (:location "/index.html" 433 | :transfer-encoding "chunked") ("")))) 434 | (let ((body (dex:get (localhost) :want-stream t))) 435 | (ok body)))) 436 | 437 | (deftest no-body-tests 438 | (testing-app ("no body") 439 | (lambda (env) 440 | (let ((path (getf env :path-info))) 441 | (if (string= path "/204") 442 | '(204 () ()) 443 | '(200 () ())))) 444 | ;; no Content-Length and no Transfer-Encoding 445 | (multiple-value-bind (body status headers) 446 | (dex:get (localhost)) 447 | (ok (equal body "")) 448 | (ok (eql status 200)) 449 | (ok (null (gethash "content-length" headers))) 450 | (ok (null (gethash "transfer-encoding" headers)))) 451 | ;; 204 No Content 452 | (multiple-value-bind (body status headers) 453 | (dex:get (localhost "/204")) 454 | (ok (eql status 204)) 455 | (ok (equal body "")) 456 | (ok (null (gethash "content-length" headers))) 457 | (ok (null (gethash "transfer-encoding" headers)))))) 458 | 459 | (defvar *json* "{\"name\":\"Eitaro Fukamachi\",\"name_ja\":\"深町英太郎\",\"login\":true}") 460 | (deftest json-tests 461 | (testing-app ("JSON") 462 | (lambda (env) 463 | (declare (ignore env)) 464 | `(200 (:content-type "application/json") (,*json*))) 465 | (multiple-value-bind (body status) 466 | (dex:get (localhost)) 467 | (ok (equal body *json*) 468 | "JSON is returned as a string") 469 | (ok (eql status 200))) 470 | (let ((babel:*default-character-encoding* :cp932)) 471 | ;; Test if the JSON encoding 472 | (multiple-value-bind (body status) 473 | (dex:get (localhost)) 474 | (ok (equal body *json*) 475 | "The default encoding is UTF-8 though babel:*default-character-encoding* is different") 476 | (ok (eql status 200)))))) 477 | 478 | (deftest keep-alive-tests 479 | (testing-app ("keep-alive") 480 | (lambda (env) 481 | (declare (ignore env)) 482 | '(200 () ("hi"))) 483 | (let ((headers (nth-value 2 (dex:get (localhost))))) 484 | (ok (or (null (gethash "connection" headers)) 485 | (string-equal (gethash "connection" headers) "keep-alive")))) 486 | (let ((headers (nth-value 2 (dex:get (localhost) :keep-alive nil)))) 487 | (ok (equalp (gethash "connection" headers) "close"))) 488 | (multiple-value-bind (b status response-headers uri opaque-socket-stream) 489 | (dex:get (localhost) :keep-alive t :use-connection-pool nil) 490 | (declare (ignorable b status response-headers uri opaque-socket-stream)) 491 | #+windows 492 | (ok (null opaque-socket-stream) "no socket stream") 493 | #-windows 494 | (ok (open-stream-p opaque-socket-stream) "stream is kept alive") 495 | (ok (= status 200) "success") 496 | #-windows 497 | (multiple-value-bind (b2 status2 response-headers2 uri2 opaque-socket-stream2) 498 | (dex:get (localhost) :keep-alive t :use-connection-pool nil :stream opaque-socket-stream) 499 | (declare (ignorable b2 response-headers2 uri2)) 500 | (ok (eql opaque-socket-stream opaque-socket-stream2) "stream is re-used") 501 | (ok (open-stream-p opaque-socket-stream2) "stream is kept alive") 502 | (ok (close opaque-socket-stream) "stream can be closed") 503 | (ok (= status2 200) "success") 504 | (multiple-value-bind (b3 status3 response-headers3 uri3 opaque-socket-stream3) 505 | (dex:get (localhost) :keep-alive t :use-connection-pool nil :stream opaque-socket-stream2) 506 | (declare (ignorable b3 uri3)) 507 | (member (gethash "connection" response-headers3) '(nil "keep-alive") :test #'equalp) 508 | (ok (= status3 200) "success") 509 | (ok (not (eql opaque-socket-stream3 opaque-socket-stream2)) "passing in closed stream works")))))) 510 | 511 | (defun assert-pool-items-count-is (expected-count) 512 | (let ((count (dexador.connection-cache::lru-pool-num-elts dexador:*connection-pool*))) 513 | (ok (= count 514 | expected-count) 515 | (format nil "Pool items count should be equal to ~A (real value is ~A)" 516 | expected-count 517 | count)))) 518 | 519 | (defun assert-connection-header-is (headers expected-value) 520 | (let ((value (gethash "connection" headers))) 521 | (ok (equalp value expected-value) 522 | (format nil "\"Connection\" header should be equal to ~S (real value is ~S)" 523 | expected-value 524 | value)))) 525 | 526 | 527 | (deftest connection-pool-and-errors 528 | ;; Here we are checking the situation when server returns 400 error and 529 | ;; in the second case also requests connection interruption. 530 | ;; Previously, this second case lead to an error when closed connection 531 | ;; was returned to the pool. 532 | #+windows 533 | (skip "Skipped because connection pool is not used on Windows.") 534 | #-windows 535 | (let ((success-count 0) 536 | (error-count 0) 537 | (error-and-close-count 0)) 538 | (flet ((assert-success-count (expected) 539 | (ok (= success-count expected) 540 | (format nil "Expected success-count to be ~S (real value is ~S)" 541 | expected success-count))) 542 | (assert-error-count (expected) 543 | (ok (= error-count expected) 544 | (format nil "Expected error-count to be ~S (real value is ~S)" 545 | expected error-count))) 546 | (assert-error-and-close-count (expected) 547 | (ok (= error-and-close-count expected) 548 | (format nil "Expected error-and-close-count to be ~S (real value is ~S)" 549 | expected error-and-close-count)))) 550 | (testing-app ("connection-pool-and-errors" :use-connection-pool t) 551 | (lambda (env) 552 | (let ((path (getf env :path-info))) 553 | (cond 554 | ((string= path "/error-and-close") 555 | (incf error-and-close-count) 556 | '(400 557 | (:connection "close") 558 | (""))) 559 | ((string= path "/error") 560 | (incf error-count) 561 | '(400 562 | nil 563 | (""))) 564 | (t 565 | (incf success-count) 566 | '(200 567 | nil 568 | ("")))))) 569 | (testing "Initial pool state" 570 | (assert-pool-items-count-is 0)) 571 | 572 | (testing "Successful requests leave one connect in the pool" 573 | (loop repeat 10 574 | do (dex:get (localhost "/"))) 575 | (assert-pool-items-count-is 1) 576 | (assert-success-count 10) 577 | (assert-error-count 0) 578 | (assert-error-and-close-count 0)) 579 | 580 | (testing "Repetitive success and error requests should not populate pool with connections" 581 | (loop repeat 10 582 | do (dex:get (localhost "/")) 583 | (ok (rove:signals (dex:get (localhost "/error")) 584 | 'dex:http-request-bad-request))) 585 | (assert-success-count 20) 586 | (assert-error-count 10) 587 | (assert-error-and-close-count 0) 588 | ;; Previously, because of the bug, connections count was 8 (maximum) 589 | (assert-pool-items-count-is 1)) 590 | 591 | (testing "If server requests connection close on error, connection should not be returned to the pool." 592 | (loop repeat 10 593 | do (dex:get (localhost "/")) 594 | ;; Previously, because of the another bug, other error was signaled, 595 | ;; because dexador retried and error with a new connection, 596 | ;; but closed it before the second attempt, because server response 597 | ;; has "Connection: close" header: 598 | (ok (rove:signals (dex:get (localhost "/error-and-close")) 599 | 'dex:http-request-bad-request))) 600 | 601 | (assert-success-count 30) 602 | (assert-error-count 10) 603 | (assert-error-and-close-count 10) 604 | (assert-pool-items-count-is 0)))))) 605 | 606 | 607 | (deftest deflate-compression-tests 608 | (testing-app ("deflate compression") 609 | (lambda (env) 610 | (declare (ignore env)) 611 | `(200 (:content-encoding "deflate" :content-type "text/plain") 612 | ,(asdf:system-relative-pathname :dexador #p"t/data/test.zlib"))) 613 | (let ((body (dex:get (localhost)))) 614 | (ok (equal body "Deflate test string."))))) 615 | 616 | (deftest gzip-compression-tests 617 | (testing-app ("gzip compression") 618 | (lambda (env) 619 | (declare (ignore env)) 620 | `(200 (:content-encoding "gzip" :content-type "text/plain") 621 | ,(asdf:system-relative-pathname :dexador #p"t/data/test.gz"))) 622 | (let ((body (dex:get (localhost)))) 623 | (ok (equal body "Gzip test string."))))) 624 | 625 | (deftest unread-character-tests 626 | (ok (eql #\u2602 627 | (with-open-file (stream (asdf:system-relative-pathname 628 | :dexador #p"t/data/umb.bin") 629 | :element-type '(unsigned-byte 8)) 630 | (let ((decoding-stream 631 | (dexador.decoding-stream:make-decoding-stream stream))) 632 | (peek-char nil decoding-stream) 633 | (read-char decoding-stream)))))) 634 | 635 | (deftest keep-alive-stream/decoding-stream 636 | (with-open-file (stream0 (asdf:system-relative-pathname 637 | :dexador #p"t/data/bug139.txt") 638 | :element-type '(unsigned-byte 8)) 639 | (let* ((len (file-length stream0)) 640 | (stream1 (dexador.keep-alive-stream:make-keep-alive-stream stream0 :end len 641 | :chunked-stream nil)) 642 | (stream2 (dexador.decoding-stream:make-decoding-stream stream1))) 643 | (ok (= (length 644 | (loop for c = (read-char stream2 nil :eof) 645 | until (eq c :eof) 646 | collect c)) len))))) 647 | 648 | (deftest connection-cache-test 649 | (let ((dexador.connection-cache:*connection-pool* (dexador.connection-cache:make-connection-pool 2))) 650 | ;; Make sure empty cache works 651 | (ok (null (dexador.connection-cache:steal-connection "some-host"))) 652 | (dexador.connection-cache:clear-connection-pool) 653 | ;; Make sure push / steal works 654 | (dexador.connection-cache:push-connection "host1" "host1-socket") 655 | (ok (string= (dexador.connection-cache:steal-connection "host1") "host1-socket")) 656 | ;; Make sure steal actually removed the connection 657 | (ok (null (dexador.connection-cache:steal-connection "host1"))) 658 | ;; Check to make sure multiple elements with the same key work 659 | (dexador.connection-cache:push-connection "host1" "host1-socket1") 660 | (dexador.connection-cache:push-connection "host1" "host1-socket2") 661 | (let ((result1 (dexador.connection-cache:steal-connection "host1")) 662 | (result2 (dexador.connection-cache:steal-connection "host1"))) 663 | (ok (and (stringp result1) (stringp result2) (not (string= result1 result2))))) 664 | ;; make sure hash table stays clean 665 | (ok (zerop (hash-table-count (dexador.connection-cache::lru-pool-hash-table dexador.connection-cache::*connection-pool*)))) 666 | ;; make sure maximum connections is obeyed and least recently used element is evicted 667 | (dexador.connection-cache:push-connection "host1" "host1-socket1") 668 | (dexador.connection-cache:push-connection "host2" "host2-socket") 669 | (dexador.connection-cache:push-connection "host2" "host2-socket") 670 | (ok (null (dexador.connection-cache:steal-connection "host1"))) 671 | (ok (string= (dexador.connection-cache:steal-connection "host2") "host2-socket")) 672 | (ok (string= (dexador.connection-cache:steal-connection "host2") "host2-socket")) 673 | (ok (null (dexador.connection-cache:steal-connection "host2"))) 674 | ;; Make sure clear-connection-pool works and callbacks are called 675 | (let ((called nil)) 676 | (dexador.connection-cache:push-connection "host1" "host1-socket1" (lambda (s) (declare (ignore s)) (setf called t))) 677 | (dexador.connection-cache:clear-connection-pool) 678 | (ok called) 679 | (setf called nil) 680 | (dexador.connection-cache:push-connection "host1" "host1-socket" (lambda (s) (declare (ignore s)) (setf called "host1"))) 681 | (dexador.connection-cache:push-connection "host2" "host2-socket" (lambda (s) (declare (ignore s)) (setf called "host2"))) 682 | (dexador.connection-cache:push-connection "host3" "host3-socket" (lambda (s) (declare (ignore s)) (setf called "host3"))) 683 | (ok (string= called "host1")) 684 | (dexador.connection-cache:push-connection "host4" "host4-socket" (lambda (s) (declare (ignore s)) (setf called "host4"))) 685 | (ok (string= called "host2"))))) 686 | 687 | (deftest keep-alive-stream-close 688 | "Issue #150, close on keep alive stream does" 689 | (with-open-file (stream0 (asdf:system-relative-pathname 690 | :dexador #p"t/data/bug139.txt") 691 | :element-type '(unsigned-byte 8)) 692 | (let* ((len (file-length stream0)) 693 | (fake-cache nil) 694 | (stream (dexador.keep-alive-stream:make-keep-alive-stream 695 | stream0 :end len :chunked-stream nil 696 | :on-close-or-eof (lambda (underlying-stream abort) 697 | (declare (ignorable abort)) 698 | (when underlying-stream 699 | (push underlying-stream fake-cache)))))) 700 | (ok (not (null (open-stream-p stream)))) 701 | (ok (null fake-cache)) 702 | (close stream) 703 | (ok (open-stream-p (car fake-cache))) 704 | (ok (null (open-stream-p stream)))))) 705 | 706 | (deftest multipart-content 707 | "When not using chunked encoding, multipart-content-length should be correct!" 708 | (let ((test `(("var" "hello") 709 | ("var2" ,(make-array 15 :element-type '(unsigned-byte 8)) 710 | :content-type "application/octet-stream")))) 711 | (ok (= (length 712 | (flexi-streams:with-output-to-sequence (str) 713 | (dexador.body:write-multipart-content test "BLARG" str))) 714 | (dexador.body:multipart-content-length test "BLARG"))))) 715 | 716 | (deftest restarts 717 | (let ((call 0)) 718 | (testing-app ("ok for every 5 times") 719 | (lambda (env) 720 | (cond 721 | ((equal (getf env :path-info) "/404") 722 | `(404 () ("not found"))) 723 | ((zerop (mod (incf call) 5)) 724 | `(200 () ("ok"))) 725 | (t `(422 () ("ng"))))) 726 | (testing "retry-request" 727 | (let ((retry (dex:retry-request 2 :interval 0))) 728 | (handler-case 729 | (handler-bind ((dex:http-request-failed retry)) 730 | (dex:get (localhost "/"))) 731 | (dex:http-request-failed () 732 | (ok (= call 3))))) 733 | (handler-bind ((dex:http-request-failed #'dex:retry-request)) 734 | (multiple-value-bind (body code headers) 735 | (dex:get (localhost "/")) 736 | (declare (ignore body headers)) 737 | (ok (eql code 200)) 738 | (ok (= call 5))))) 739 | (testing "ignore-and-continue" 740 | (handler-bind ((dex:http-request-not-found #'dex:ignore-and-continue)) 741 | (multiple-value-bind (body code headers) 742 | (dex:get (localhost "/404")) 743 | (declare (ignore body headers)) 744 | (ok (eql code 404)) 745 | (ok (= call 5))) 746 | (ok (signals (dex:get (localhost "/")) 747 | 'dex:http-request-failed))))))) 748 | -------------------------------------------------------------------------------- /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 5000; 11 | server_name localhost; 12 | location / { 13 | root /home/travis/build/fukamachi/dexador/benchmark/; 14 | } 15 | } 16 | } 17 | --------------------------------------------------------------------------------