| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127 |
- (library (response-utils)
- (export respond
- respond-static-asset
- make-respond-static-asset-handler)
- (import
- (except (rnrs base) let-values)
- (only (guile) lambda* λ error when display sleep)
- ;; Guile modules
- ;; alist->hash-table
- (prefix (ice-9 hash-table) ice9-hash-table:)
- ;; Guile exception handling
- (ice-9 exceptions)
- (ice-9 session)
- ;; for bytevector operations
- (ice-9 binary-ports)
- ;; SRFIs
- ;; hash tables
- (prefix (srfi srfi-69) srfi-69:)
- ;; receive form
- (prefix (srfi srfi-8) srfi-8:)
- ;; let-values
- (prefix (srfi srfi-11) srfi-11:)
- ;; list utils
- (prefix (srfi srfi-1) srfi-1:)
- ;; web server, concurrent
- (fibers web server)
- ;; standard web library
- (web request)
- (web response)
- (web uri)
- (sxml simple)
- ;; custom modules
- (path-handling)
- (web-path-handling)
- (file-reader)
- (mime-types)
- (prefix (logging) log:)
- (templates)))
- (define respond
- (lambda* (#:optional body
- #:key
- (status 200)
- (title "This is my title!")
- (doctype "<!DOCTYPE html>\n")
- (content-type-params '((charset . "utf-8")))
- (content-type 'text/html)
- ;; Usually we have no exra headers by default.
- (extra-headers '())
- ;; If a body is provided use its templatized
- ;; form. and returns its last argument, if
- ;; previous arguments are #t.
- (sxml (and body (templatize title body))))
- "Respond to a request with the given SXML body. The SXML
- is put into the HTML template, which adds html, head, title,
- and body tag."
- ;; as before, answer in two parts, headers and body
- (values (build-response #:code status
- ;; headers are an alist
- #:headers
- `((content-type . (,content-type ,@content-type-params))
- ,@extra-headers))
- ;; Instead of returning the body as a string,
- ;; respond can be given a procedure, which will
- ;; be called by the web server to write out the
- ;; response to the client. This procedure gets
- ;; an output port as an argument. So you have 2
- ;; options: return string or return procedure
- ;; which takes a port.
- (λ (port)
- (when doctype (display doctype port))
- (cond
- [sxml
- (sxml->xml sxml port)]
- [else
- (sxml->xml '(p "no HTML body in response") port)])))))
- (define respond-static-asset
- (lambda* (static-asset-path
- #:key
- ;; By default assume the asset to exist in the file system.
- (status 200)
- (content-type-params '())
- (extra-headers '()))
- "Serve a static asset."
- (log:debug "serving a static asset for path:" static-asset-path)
- (let* ([file-ext (file-extension static-asset-path)]
- [mime-type (srfi-69:hash-table-ref file-extension-mime-types file-ext)]
- [content-type mime-type])
- (log:debug "responding with MIME type:" mime-type)
- (values (build-response
- #:code status
- #:headers
- `((content-type . (,content-type ,@content-type-params))
- ,@extra-headers))
- (λ (port)
- (let ([static-asset-data (read-file-to-bytevector static-asset-path)])
- (cond
- [static-asset-data
- (put-bytevector port static-asset-data)]
- [else
- (raise-exception
- (make-exception
- (make-non-continuable-error)
- (make-exception-with-message "no data read from file")
- (make-exception-with-irritants (list static-asset-path))
- (make-exception-with-origin 'respond-static-asset)))])))))))
- ;; (define make-respond-static-asset-handler
- ;; ;; take a static asset path
- ;; (λ (static-asset-path)
- ;; (log:debug "creating static asset handler, which takes 2 arguments")
- ;; ;; and return a procedure, which takes 2 arguments
- ;; (λ (request body)
- ;; (log:debug "inside static asset response handler")
- ;; ;; TODO: do we need to check for existence of the asset at the point?
- ;; (srfi-11:let-values
- ;; ([(resp-headers resp-body)
- ;; ;; TODO: does there need to be a lambda here?
- ;; (respond-static-asset static-asset-path)])
- ;; ;; return 2 values
- ;; (values resp-headers resp-body)))))
|
