guile-vocabulary-trainer-web/main.scm

(library (example-web-server (0 0 1))
  (export main)
  (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
    (prefix (handlers) handlers:)
    (middleware)
    (response-utils)
    (request-utils)
    (path-handling)
    (web-path-handling)
    (file-reader)
    (mime-types)
    (prefix (logging) log:)))


;;;
;;; SERVER
;;;


;; Here we define the routes and other server specific
;; stuff.

;; A routes-config is a hash that contains associations
;; between route parts and handlers.
(define routes-config
  (srfi-69:alist->hash-table
   ;; Using (quote ...) would not evaluate the handlers in
   ;; the list so we need quasiquote unquote.
   `((() . ,handlers:index)
     (("debug") . ,handlers:debug))))


(define make-routes-dispatcher
  (lambda* (routes-config #:key (default-handler handlers:debug))
    "make-routes-dispatcher returns a procedure, which, for
each request, looks up the appropriate handler inside the
given routes-config. As a fallback, a default-handler is
given. In this case it is the debug-handler, which will
render all headers."
    ;; NOTE: make-routes-dispatcher itself is not
    ;; responsible for answering to requests. The Guile web
    ;; server leaves the implementation details completely
    ;; to us and thus offers maximum flexibility in this
    ;; matter. We made the decision ourselves, that we want
    ;; to look at the request URI parts, to determin the
    ;; appropriate handler.
    (λ (request body)
      (log:debug "-----------------------------------------------")
      (log:debug "(request-path-components request):" (request-path-components request))
      (let* ([req-path-comp (request-path-components request)]
             [req-path (if (null? req-path-comp)
                           "/"
                           (apply path-join req-path-comp))])
        (log:debug "request path is:" req-path)
        (cond
         ;; NOTE/TODO: Perhaps we have to translate the
         ;; request path to a file system path first.
         [(static-asset-path? req-path)
          (log:debug "request path is a static asset path:" req-path)
          ;; Check, whether the static asset route is OK to
          ;; access. If static asset is OK to access, then
          ;; serve it.
          (cond
           ;; All security hinges on
           ;; safe/existing/static-asset-path?, so it better
           ;; be secure!
           [(safe/existing/static-asset-path? req-path)
            (respond-static-asset req-path)]
           ;; If the path is not safe, refuse, by answering
           ;; with a 404 HTTP status code.
           [else
            (log:debug "using 404 handler for" req-path-comp)
            (handlers:not-found-404 request body)])]
         [else
          ;; Here we can have sequential actions. The first
          ;; action in this example is a logging
          ;; middleware. We could make a middleware return a
          ;; result, which is then handed to the next
          ;; middleware which might in turn manipulate the
          ;; result of the first one or create a new result
          ;; or whatever else we want to implement.
          (log:debug "not a static asset path" req-path-comp)
          (logging-middleware request body)
          ;; Only after logging the real request handling
          ;; begins.  First we get the appropriate handler
          ;; and then we hand it the request.
          (let* ([route-parts (request-path-components request)]
                 [handler
                  (srfi-69:hash-table-ref routes-config
                                          route-parts
                                          ;; SRFI-69 wants a
                                          ;; thunk, which is
                                          ;; more flexible
                                          ;; than a simple
                                          ;; default value.
                                          (λ () default-handler))])
            ;; Hand the handler the request and the body of
            ;; the request.
            (handler request body))])))))


(define main
  (λ ()
    (log:debug "Starting the web server ...")
    ;; Start the server. The run-server procedure expects to
    ;; be given a procedure, which will dispatch requests to
    ;; whatever is responsible for handling the
    ;; requests. Theoretically one could implement all
    ;; inside this dispatcher, but that would be less clean.
    (run-server
     (make-routes-dispatcher routes-config #:default-handler handlers:debug))
    (log:debug "Stopped web server.")))


(main)