Skip to content

Instantly share code, notes, and snippets.

@ijp
Created November 20, 2011 22:59
Show Gist options
  • Save ijp/1381107 to your computer and use it in GitHub Desktop.
Save ijp/1381107 to your computer and use it in GitHub Desktop.
(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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment