ZelphirKaltstahl
/
guile-examples


			
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177
							(use-modules (fibers web server))
(use-modules (web request)
             (web response)
             (web uri))
(use-modules (sxml simple))
(use-modules
 ;; alist->hash-table
 (ice-9 hash-table)
 (ice-9 exceptions))

;; =========================
;; REQUEST/RESPONSE HANDLING
;; =========================
(define* (respond #: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 (request-path-components request)
  "Split a given request path up into its components. A request path is the
route after the domain and host part. For example for
http://localhost:8080/part1/part2/?blub=123 the result will be the list of
containing the string part1 and the string part2."
  ;; split the string that represents the uri and decode any url-endoced things
  ;; /part1/part2/ --> '("part1" "part2")
  (split-and-decode-uri-path
   ;; get the uri path as a string from the request struct
   ;; http://localhost:8080/part1/part2/?blub=123 --> /part1/part2/
   (uri-path
    ;; get the request-uri struct:
    ;; http://localhost:8080/abc/def/?abc=123 -->
    ;; #<<uri> scheme: #f userinfo: #f host: #f port: #f path: "/abc/def/"
    ;; query: "abc=123" fragment: #f>
    (request-uri request))))


;; ========
;; HANDLERS
;; ========

;; Next we define some handlers, which take care of handling specific routes.

(define (debug-handler request body)
  "The debug-handler will put all request headers into the rendered HTML, so
that we can see them on the page."
  (respond
   ;; Inside respond the SXML will be put into a template, so there is no need
   ;; to add html or body tags.
   `((h1 "hello world!")
     (table
      (tr (th "header") (th "value"))
      ;; splice in all request headers
      ,@(map (lambda (pair)
               `(tr (td (tt ,(with-output-to-string
                               (lambda () (display (car pair))))))
                    (td (tt ,(with-output-to-string
                               (lambda ()
                                 (write (cdr pair))))))))
             (request-headers request))))))


(define (hello-world-handler request request-body)
  "A handler for a route."
  ;; A handler must return 2 values: The header and body of the
  ;; response.
  (values
   ;; Return the headers as first value (the bare minimum).
   '((content-type . (text/plain)))
   ;; Then the response body. This is an example for returning a string as
   ;; second value, instead of a procedure, which takes an output port.
   "Hello World!"))


(define (blocking-wait-handler request request-body)
  "A handler for a route which waits blockingly for testing concurrent
connections."
  (sleep 10)
  (values
   ;; headers first (the bare minimum)
   '((content-type . (text/plain)))
   ;; then the response body
   "I've been waiting for you ..."))


;; =========
;; TEMPLATES
;; =========
(define (templatize title body)
  `(html (head (title ,title))
         (body ,@body)))

;; ======
;; 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
  (alist->hash-table
   ;; Using (quote ...) would not evaluate the handlers in the list
   ;; so we need quasiquote unquote.
   `((("hello" "world") . ,hello-world-handler)
     (("debug") . ,debug-handler)
     (("wait") . ,blocking-wait-handler))))


(define (logging-middleware request body)
  "The logging middleware takes care of logging to stdout whenever a request
comes in. We can imagine all sorts of logging here."
  (display
   (simple-format
    #f "responding for request-path-components: ~s\n"
    (request-path-components request))))


(define* (make-routes-dispatcher 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 the one 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)
    ;; 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 (hash-ref routes-config route-parts default-handler)])
      ;; Hand the handler the request and the body of the request.
      (handler request body))))

;; 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 everything inside this
;; dispatcher, but that would be less clean.
(run-server
 (make-routes-dispatcher routes-config #:default-handler debug-handler))