demos/hello-web.scm

   1 #!/usr/bin/guile \
   2 -e main -s
   3 !#
   4
   5 ;;; 8sync --- Asynchronous programming for Guile
   6 ;;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
   7 ;;;
   8 ;;; This file is part of 8sync.
   9 ;;;
  10 ;;; 8sync is free software: you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU Lesser General Public License as
  12 ;;; published by the Free Software Foundation, either version 3 of the
  13 ;;; License, or (at your option) any later version.
  14 ;;;
  15 ;;; 8sync is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU Lesser General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU Lesser General Public
  21 ;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (use-modules (8sync systems web)
  24              (8sync agenda)
  25              (web request)
  26              (web response)
  27              (web uri)
  28              (ice-9 match))
  29
  30 \f
  31 ;;; Utilities
  32 ;;; =========
  33
  34 (define (simple-404 request request-body)
  35   (values (build-response
  36            #:code 404
  37            #:headers '((content-type . (text/plain))))
  38           "Not found.  Dag, yo."))
  39
  40
  41 \f
  42 ;;; Views
  43 ;;; =====
  44
  45 (define (hello-world-view request request-body)
  46   (values '((content-type . (text/plain)))
  47           "Hello world!"))
  48
  49
  50 \f
  51 ;;; Dispatch / routing
  52 ;;; ==================
  53
  54 (define (web-dispatch request request-body)
  55   (define (call-view view)
  56     (view request request-body))
  57   ;; URI routing here
  58   (match (split-and-decode-uri-path (uri-path (request-uri request)))
  59     ;; This is for the `/' root
  60     (() (call-view hello-world-view))
  61     ;; An example of an inline view at `/pants/'
  62     (("pants")
  63      (values '((content-type . (text/plain)))
  64              "Hello pants!"))
  65     (_
  66      (call-view simple-404))))
  67
  68
  69 \f
  70 ;;; CLI
  71 ;;; ===
  72
  73 (define main (make-web-demo-cli #:handler (wrap-apply web-dispatch)))