continuation-web-server.scm

(use-modules (ice-9 control)
             (rnrs hashtables)
             (web server)
             (sxml simple)
             (web response)
             (web request)
             (web uri)
             (ice-9 match))

;; utilities
(define-syntax if-let
  (syntax-rules ()
    ((if-let (val predicate) consequent alternative)
     (let ((val predicate))
       (if val
           consequent
           alternative)))
    ((if-let (val predicate) consequent)
     (let ((val predicate))
       (if val
           consequent)))))

;; web utilities

(define (request-path-components request)
  (split-and-decode-uri-path (uri-path (request-uri request))))

(define (not-found request)
  (values (build-response #:code 404)
          (string-append "Resource not found: "
                         (uri->string (request-uri request)))))

(define (ok value)
  (values (build-response #:code 200 #:headers '((content-type . (text/html))))
          value))

(define (query-parameters request)
  ;; TODO: doesn't handle #\; or do any error handling
  (let ((query-string (uri-query (request-uri request))))
    (map (lambda (fv-pair)
           (let ((decoded (map uri-decode (string-split fv-pair #\=))))
             (cons (string->symbol (car decoded))
                   (cadr decoded))))
         (string-split query-string #\&))))

;; continuation based runner

(define *cont-table* (make-hashtable string-hash string=?))

(define *web-prompt* (make-prompt-tag))

(define (lookup k)
  (format #t "Looking up ~s" k)
  (hashtable-ref *cont-table* k #f))

(define (store! k v)
  (format #t "Storing ~s:~s~%" k v)
  (hashtable-set! *cont-table* k v))

(define (continuation-uri key)
  (build-uri 'http #:path (string-append "/cont/" key)))

(define (with-web-prompt thunk)
  (call-with-prompt
   *web-prompt*
   thunk
   (lambda (k tag response)
     (case tag
       ((send/back)
        (ok response))
       ((send/suspend)
        (let* ((key (object->string k))
               (uri (continuation-uri (uri-encode key))))
          (store! key k)
          (ok (response uri))))
       (else
        (error "Unknown tag" tag))))))

(define (resume cont request)
  (cont request))

(define (send/back response)
  (abort-to-prompt *web-prompt* 'send/back response))

(define (send/suspend k-url->response)
  (abort-to-prompt *web-prompt* 'send/suspend k-url->response))

(define (run start)
  (define (handle request body)
    (match (request-path-components request)
      [("start")
       (with-web-prompt
        (lambda ()
          (start request)))]
      [("cont" k)
       (if-let (cont (lookup (uri-decode k)))
               (with-web-prompt
                (lambda ()
                  (resume cont request)))
               (not-found request))]
      [else
       (format #t "bad components ~s~%" (request-path-components request))
       (not-found request)]))
  (run-server handle))

;; application
(define (sxml->string* sxml)
  (call-with-output-string
   (lambda (out)
     (sxml->xml sxml out))))

(define (get-number)
  (let ((req (send/suspend
              (lambda (k-url)
                (sxml->string*
                 `(html
                   (head (title "Please enter a number"))
                   (body
                    (form (@ (action ,(uri->string k-url)))
                          "Please enter a number:"
                          (input (@ (type "text")
                                    (name "value")))
                          (input (@ (type "submit") (value "Submit")))))))))))
    (string->number (cdr (assq 'value (query-parameters req))))))

(define (print-total total)
  (send/back (sxml->string*
              `(html
                (head (title "The total"))
                (body (p "The total you entered was "
                         ,(number->string total)))))))

(define (main request)
  (let loop ((total 0))
    (let ((val (get-number)))
      (if (zero? val)
          (print-total (+ total val))
          (loop (+ total val))))))

(run main)