#lang racket
(require web-server/servlet
web-server/servlet-env
web-server/http/bindings
web-server/http/request-structs
net/url-structs)
(provide get post put patch delete
default-response-maker
status->message
define-handler
params
header
run)
(define (get path handler) (define-handler "GET" path handler))
(define (post path handler) (define-handler "POST" path handler))
(define (put path handler) (define-handler "PUT" path handler))
(define (patch path handler) (define-handler "PATCH" path handler))
(define (delete path handler) (define-handler "DELETE" path handler))
(define (default-response-maker status headers body)
(response/full status
(status->message status)
(current-seconds)
TEXT/HTML-MIME-TYPE
headers
(list (string->bytes/utf-8 body))))
(define run
(make-keyword-procedure
(lambda (kws kw-args . etc)
(cond
[(not (empty? etc))
(error 'run
"expected kw args (for serve/servlet) only; found ~a non-kw args"
(length etc))]
[(ormap (curryr memq '(#:servlet-regexp #:command-line?)) kws)
(error 'run
"kw args may not include #:servlet-regexp or #:command-line?")]
[else
(let* ([kw-pairs (append '((#:servlet-regexp #rx"")
(#:command-line? #t))
(filter (lambda (kw-pair)
(not (eq? '#:response-maker (car kw-pair))))
(map list kws kw-args)))]
[sorted-pairs (sort kw-pairs keyword<? #:key first)]
[response-maker (let ([response-maker-pair
(findf (lambda (p) (eq? (car p) '#:response-maker))
(map list kws kw-args))])
(if response-maker-pair
(cadr response-maker-pair)
default-response-maker))])
(keyword-apply serve/servlet
(map first sorted-pairs)
(map second sorted-pairs)
(list (lambda (req)
(request->handler req response-maker)))))]))))
(define (params request key)
(define query-pairs (url-query (request-uri request)))
(define body-pairs
(match (request-post-data/raw request)
[#f empty]
[body (url-query (string->url (string-append "?" (bytes->string/utf-8 body))))]))
(define url-pairs
(let ([keys (cadr (request->handler/keys/response-maker request))])
(request->key-bindings request keys)))
(hash-ref (make-hash (append query-pairs body-pairs url-pairs)) key ""))
(define request-handlers (make-hash))
(define (define-handler method path handler [response-maker default-response-maker])
(define keys (path->keys path))
(define path-regexp (compile-path path))
(define handler/keys/response-maker (list handler keys response-maker))
(hash-set! request-handlers
(string-append method " " path-regexp)
handler/keys/response-maker))
(define (path->keys path)
(map (lambda (match) (string->symbol (substring match 2)))
(regexp-match* #rx"/:([^\\/]+)" path)))
(define (compile-path path)
(string-append
"^"
(regexp-replace* #rx":[^\\/]+" path "([^/?]+)")
"(?:$|\\?)"))
(define (request->handler request
response-maker)
(define handler/keys/response-maker (request->handler/keys/response-maker request))
(begin
(printf (url->string (request-uri request)))
(cond
[handler/keys/response-maker (render/handler (car handler/keys/response-maker)
request
(caddr handler/keys/response-maker))]
[else (render/404 response-maker)])))
(define (request->handler/keys/response-maker request)
(define handler-key (request->matching-key request))
(case handler-key
[(#f) #f]
[else (hash-ref request-handlers handler-key #f)]))
(define (request->key-bindings request keys)
(define path-regexp
(second (regexp-split #rx" " (request->matching-key request))))
(define bindings (cdr (regexp-match path-regexp (url->string (request-uri request)))))
(for/list ([key keys] [binding bindings])
(cons key binding)))
(define (request->matching-key request)
(define (key-matches-route? key)
(match-define (list _ method path-regexp)
(regexp-match #rx"([^ ]+) ([^ ]+)" key))
(and (equal? (request-method request) (string->bytes/utf-8 method))
(regexp-match (regexp path-regexp)
(url->string (request-uri request)))))
(findf key-matches-route? (hash-keys request-handlers)))
(define (render/handler handler request response-maker)
(define content
(case (procedure-arity handler)
[(1) (handler request)]
[else (handler)]))
(define status
(cond [(list? content) (first content)]
[else 200]))
(define headers
(cond [(list? content) (second content)]
[else '()]))
(define body
(cond [(list? content) (third content)]
[else content]))
(response-maker status headers body))
(define (render/404 response-maker)
(response-maker 404
'()
"Not Found"))
(define (status->message status)
(case status
[(100) #"Continue"]
[(101) #"Switching Protocols"]
[(200) #"OK"]
[(201) #"Created"]
[(202) #"Accepted"]
[(203) #"Non-Authoritative Information"]
[(204) #"No Content"]
[(205) #"Reset Content"]
[(206) #"Partial Content"]
[(300) #"Multiple Choices"]
[(301) #"Moved Permanently"]
[(302) #"Found"]
[(303) #"See Other"]
[(304) #"Not Modified"]
[(305) #"Use Proxy"]
[(307) #"Temporary Redirect"]
[(400) #"Bad Request"]
[(401) #"Unauthorized"]
[(402) #"Payment Required"]
[(403) #"Forbidden"]
[(404) #"Not Found"]
[(405) #"Method Not Allowed"]
[(406) #"Not Acceptable"]
[(407) #"Proxy Authentication Required"]
[(408) #"Request Timeout"]
[(409) #"Conflict"]
[(410) #"Gone"]
[(411) #"Length Required"]
[(412) #"Precondition Failed"]
[(413) #"Request Entity Too Large"]
[(414) #"Request-URI Too Long"]
[(415) #"Unsupported Media Type"]
[(416) #"Requested Range Not Satisfiable"]
[(417) #"Expectation Failed"]
[(500) #"Internal Server Error"]
[(501) #"Not Implemented"]
[(502) #"Bad Gateway"]
[(503) #"Service Unavailable"]
[(504) #"Gateway Timeout"]
[(505) #"HTTP Version Not Supported"]
[else #""]))