guile-website-example/app/main.scm

(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
  ;; model
  (model handler-config)

  ;; handlers
  (handlers index)
  (handlers schedule)
  (handlers resources)
  (handlers about)
  (handlers static-asset)

  (handlers debug)
  (handlers not-found-404)

  (middleware middleware)
  (lib utils response-utils)
  (lib utils request-utils)
  (lib utils list-utils)
  ;; (path-handling)
  (lib web-location-handling)
  (file-reader)
  (lib mime-types)
  (prefix (logging) log:)
  (templates helpers)
  (prefix (fslib) fslib:))


;;;
;;; 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
   (list (cons '() (make-handler-config index-handler))
         (cons '("home") (make-handler-config index-handler))
         (cons '("schedule") (make-handler-config schedule-handler))
         (cons '("resources") (make-handler-config resources-handler))
         (cons '("about") (make-handler-config about-handler))
         (cons '("debug") (make-handler-config debug-handler))
         (cons '("static")
               (make-handler-config static-asset-handler
                                    #:handles-children #t)))))


(define make-routes-dispatcher
  (lambda* (routes-config #:key (default-handler debug-handler))
    "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)
      ;; 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.
      (logging-middleware request body)

      (define req-path-components (request-path-components request))
      (log:debug "request path components:" req-path-components)

      ;; Try to find the request path in the routes. If it is not in the routes,
      ;; try to find each prefix of the request path in the routes. If a prefix
      ;; is in the routes, check, whether the handler of that route is
      ;; configured to match all requests starting with that request path
      ;; prefix.
      (let ([handler-conf
             (srfi-69:hash-table-ref routes-config
                                     req-path-components
                                     (λ () #f))])
      (cond
       [handler-conf
        ;; The request path has been found in the routes. Let the request be
        ;; handled by the corresponding handler.
        (log:debug "handler found for" req-path-components)
        ((handler-config-handler handler-conf) request body)]
       [else
        ;; Try to find request path prefixes in the routes. Reverse the prefixes
        ;; list, to check for longest prefixes first.
        (let ([req-path-prefixes (list-prefixes-long-to-short req-path-components)])
          (let ([prefix-request-path-handler
                 (srfi-1:fold (λ (req-path-prefix acc)
                                ;; Try to get a handler config for the request path
                                ;; prefix.
                                (let ([maybe-handler-conf
                                       (srfi-69:hash-table-ref routes-config
                                                               req-path-prefix
                                                               (λ () #f))])
                                  ;; If already a handler has been found, use
                                  ;; that one. This ensures to use the handler
                                  ;; for the longest matched prefix.
                                  (or acc
                                      ;; To actually match the request path, the
                                      ;; handler config must specify, that the handler
                                      ;; matches children of the route it is set for.
                                      (and (handler-config? maybe-handler-conf)
                                           (handler-config-handles-children? maybe-handler-conf)
                                           (handler-config-handler maybe-handler-conf)))))
                              #f
                              req-path-prefixes)])
            (cond
             [prefix-request-path-handler
              (log:debug "prefix handler found for" req-path-components)
              (prefix-request-path-handler request body)]
             ;; If even a handler for a prefix of the request path could not be
             ;; found, answer with a 404 response.
             [else
              (log:debug "no handler found for" req-path-components)
              (not-found-404-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 debug-handler))
    (log:debug "Stopped web server.")))


(main)