;; Run this code in DrScheme's `(module ...)' language.

(module server mzscheme
  (require (lib "thread.ss")
           (lib "string.ss")
           (lib "etc.ss")
           (lib "xml.ss" "xml")
           (lib "uri-codec.ss" "net"))
  
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  A basic web server
  
  ;; An args is
  ;;  list-of-(cons string string)
  
  ;; dispatch-table : list-of-(cons regexp (args -> ))
  (define dispatch-table null)
  
  ;; add-handler : regexp (args -> ) -> void
  ;;  Adds a handler to the dispatch table. The handler
  ;;  is called for a request that matches the given regexp.
  (define (add-handler rx handler)
    (set! dispatch-table (cons (cons rx handler)
                               dispatch-table)))
  
  (define rx:request
    #rx"^([A-Z]*) (.+) HTTP/[0-9]+\\.[0-9]+[\r\n]")

  ;; serve:  ->
  ;;  Runs a web server to handle GET requests through
  ;;  dispatch-table
  (define (serve)
    ;; The `run-server' function is about 55 lines in
    ;;   plt/collects/mzlib/thread.ss
    ;; It starts a TCP listener, farms each accepted
    ;; connection to a new thread, and terminates the
    ;; thread if it runs too long.
    (run-server
     ;; Port number:
     8080
     ;; Handler:
     (lambda (in out)
       (let ([m (regexp-match rx:request (read-line in))])
         (when (and m (string=? (cadr m) "GET"))
           ;; Set ports:
	   (current-input-port in)
	   (current-output-port out)
	   ;; Dispatch
	   (return-page (dispatch (caddr m))))))
     ;; Timeout in msec:
     60000
     void
     (lambda (port five true)
       (tcp-listen port five true "::"))))
  
  ;; dispatch : string -> 
  ;;  Handles the given path, sending a reply back through
  ;;  the current output port, then exits
  (define (dispatch path)
    (let-values ([(base args) (parse-path path)])
      (or
       (ormap (lambda (d)
                (let ([m (regexp-match (car d) base)])
                  (and m
                       ;; Call handler
                       ((cdr d) base args))))
              dispatch-table)
       ;; If we get here, it means that no dispatch-table
       ;;  match was found
       (error-page `("Unknown page: " ,path)))))
  
  ;; parse-path : string -> (values string args)
  ;;  Parses a request path into a base part and arguments
  (define (parse-path s)
    (cond
      [(regexp-match #rx"^(.*)[?](.*)$" s)
       => (lambda (m)
            ;; A path with arguments...
            (values (uri-decode (cadr m))
                    ;; Split out the list of arguments X=Y, then
                    ;;  split each into (cons X Y)
                    (map (lambda (a)
                           (cond
                             [(regexp-match #rx"^(.*)=(.*)$" a)
                              => (lambda (am)
                                   (cons (uri-decode (cadr am))
                                         (uri-decode (caddr am))))]
                             [else
                              (cons (uri-decode a) "")]))
                         (regexp-split #rx"&" (caddr m)))))]
      [else 
       ;; A path without arguments
       (values (uri-decode s) null)]))

  ;; Tests for parse-path (relatively easy!):
  (parse-path "") "should be" (values "" '())
  (parse-path "foo") "should be" (values "foo" '())
  (parse-path "foo?x=y&z=2") 
  "should be" (values "foo" '(("x" . "y") ("z" . "2")))
  (parse-path "foo?x=y&ack&more=0") 
  "should be" (values "foo" '(("x" . "y") 
                              ("ack" . "")
                              ("more" . "0")))
  
  ;; return-page : xexpr -> 
  ;;  Doesn't return; it prints the given page to the current out
  ;;  port, then terminates the thread
  (define (return-page xexpr)
    ;; Send response
    (printf "HTTP/1.0 200 Okay\r\n")
    (printf "Server: k\r\nContent-Type: text/html\r\n\r\n")
    (display (xexpr->string xexpr))
    (newline)
    ;; Clean up
    (drain-input)
    (close-input-port (current-input-port))
    (close-output-port (current-output-port)))
  
  ;; error-page : list-of-xexpr -> expr
  ;;  Like return-page, but takes only error content
  (define (error-page body)
    `(html (head (title "Error"))
           (body
            (font ((color "red"))
                  ,@body))))
  
  ;; drain-input : -> void
  ;;  Reads all input and throws it away. Otherwise,
  ;;  the client may think we weren't listening at all.
  (define (drain-input)
    (let ([l (read-line (current-input-port) 'any)])
      (unless (or (eof-object? l)
                  (string=? "" l))
        (drain-input))))
  
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  Running-total servlet using state

  (define total 0)

  ;; a-handler : string args ->
  (define (a-handler base args)
    `(html 
      (head (title "Running total"))
      (body
       (p "Current value: " ,(number->string total))
       (p (a ((href "/a2")) "+2"))
       (p (a ((href "/a3")) "+3")))))

  ;; a2-handler : string args ->
  (define (a2-handler base args)
    (set! total (+ total 2))
    (a-handler base args))

  ;; a3-handler : string args ->
  (define (a3-handler base args)
    (set! total (+ total 3))
    (a-handler base args))

  (add-handler #rx"/a" a-handler)
  (add-handler #rx"/a2" a2-handler)
  (add-handler #rx"/a3" a3-handler)
  
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  Clone-friendly running-total servlet

  ;; b-handler : string args ->
  (define (b-handler base args)
    (do-b 0))
    
  (define (do-b total)
    `(html 
      (head (title "Running total"))
      (body
       (p "Current value: " ,(number->string total))
       (p (a ((href ,(format "/b2?val=~a" total))) "+2"))
       (p (a ((href ,(format "/b3?val=~a" total))) "+3")))))

  ;; b2-handler : string args ->
  (define (b2-handler base args)
    (do-b (+ 2 (string->number (cdr (assoc "val" args))))))
    
  ;; b3-handler : string args ->
  (define (b3-handler base args)
    (do-b (+ 2 (string->number (cdr (assoc "val" args))))))

  (add-handler #rx"/b" b-handler)
  (add-handler #rx"/b2" b2-handler)
  (add-handler #rx"/b3" b3-handler)

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;  web-read/k
  
  (define table (make-hash-table 'equal))
  
  (define (remember v)
    (let ([key (symbol->string (gensym))])
      (hash-table-put! table key v)
      key))

  (define (lookup key)
    (hash-table-get table key))

  
  (define (web-read/k prompt cont)
    (let ([key (remember cont)])
      `(html 
        (head (title "Web Read"))
        (body ,prompt
              (form ([action "/resume-k"] [method "get"])
                    (input ([type "text"] [name "value"]
                                          [value ""]))
                    (input ([type "submit"] [name "enter"] 
                                            [value "Enter"]))
                    (input ([type "hidden"] [name "key"]
                                            [value ,key])))))))
  
  (define (resume-k-handler base args)
    ((lookup (cdr (assoc "key" args)))
     (read (open-input-string (cdr (assoc "value" args))))))
  
  (add-handler #rx"/resume-k" resume-k-handler)
  
  (define (web-pause/k prompt cont)
    (let ([key (remember cont)])
      `(html 
        (head (title "Web Pause"))
        (body ,prompt
              (p (a ((href ,(format "/p-resume-k?key=~a" key)))
                    "continue"))))))
  
  (define (p-resume-k-handler base args)
    ((lookup (cdr (assoc "key" args)))))

  (add-handler #rx"/p-resume-k" p-resume-k-handler)

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Servlet that uses web-read/k
  
  (define (g-handler base args)
    (do-g 0))
  
  (define (do-g total)
    (web-read/k (format "Total is ~a" total)
		(lambda (val)
		  (do-g (+ val total)))))
  
  (add-handler #rx"/g" g-handler)

  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; More servlets
  
  (define (h-handler base args)
    (do-h identity))
  
  (define (do-h cont)
    (web-read/k "First number"
		(lambda (v1)
		  (web-read/k "Second number"
			      (lambda (v2)
				(cont (number->string (+ v1 v2))))))))
  
  (add-handler #rx"/h" h-handler)

  
  (define (i-handler base args)
    (do-i identity))
  
  (define (do-i cont)
    (do-h (lambda (h-result)
            (web-pause/k h-result
			 (lambda ()
			   (do-h cont))))))
  
  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  ;; Start the server; this call doesn't return
  (serve))