ZelphirKaltstahl
/
guile-examples


			
				
					
						
						
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137
							#|

Note: This is an attempt of using a tree structure to manage routes,
where sub routes can have different handlers than super routes. It is
experimental and might not cover many edge cases. The workings of the
lookup of routes inside the tree and how it is decided whether or not
to look up sub routes in the tree, is described in ~simple-tree.scm~.

|#

(add-to-load-path (dirname (current-filename)))
(use-modules (web server))
(use-modules (web request)
             (web response)
             (web uri))
(use-modules (sxml simple))
(use-modules (ice-9 hash-table))
(use-modules ((simple-tree) #:prefix simtree:))

;; =========================
;; 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)
                  (extra-headers '())
                  ;; if a body is provided use its templatized form
                  (sxml (and body (templatize title body))))
  ;; 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 gives
          ;; a procedure, which will be called by the web server to
          ;; write out the response to the client.
          ;; So you have 2 options: return string or return procedure which takes a port.
          (λ (port)
            (if sxml
                (begin
                  (if doctype (display doctype port))
                  (sxml->xml sxml port))))))

(define (request-path-components request)
  ;; just for showing what the functions do
  ;; (display (simple-format #f "(request-uri request): ~a\n"
  ;;                         (request-uri request)))
  ;; (display (simple-format #f "(uri-path ...): ~a\n"
  ;;                         (uri-path (request-uri request))))
  ;; (display (simple-format #f "(split-and-decode-uri-path ...): ~a\n"
  ;;                         (split-and-decode-uri-path (uri-path (request-uri request)))))
  ;; actual logic
  ;; split the string that represents the uri and decode any url-endoced things
  (split-and-decode-uri-path
   ;; get the uri path as a string from the request struct
   (uri-path
    ;; get the request struct
    (request-uri request))))

(define (debug-handler request body)
  ;; use respond helper
  (respond
   ;; will be templatized
   `((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)
  (values
   ;; headers first
   '((content-type . (text/plain)))
   ;; then the response body
   "Hello World!"))

(define (index-handler request request-body)
  (values
   ;; headers first
   '((content-type . (text/plain)))
   ;; then the response body
   "Welcome to the index page"))

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

;; ======
;; SERVER
;; ======
;; A tree that contains routes to handler associations
(define routes-config
  (simtree:list->tree
   `(root ,index-handler
      (("hello" ,debug-handler
        (("world" ,hello-world-handler ())))
       ("debug" ,debug-handler ()))))
  #;(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))))

(define (logging-middleware request body)
  (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))
  "return a procedure, which, for each request, looks up the
appropriate handler inside the given routes-config"
  (λ (request body)
    (logging-middleware request body)
    (let* ([route-parts (request-path-components request)]
           [handler
            (simtree:node-val
             (simtree:get-node-by-path routes-config
                                       (cons 'root route-parts)
                                       default-handler
                                       #:use-longest-prefix #t))])
      #;(display (simple-format #f "handler: ~s\n" handler))
      (handler request body))))

(run-server (make-routes-dispatcher routes-config
                                    #:default-handler debug-handler))