(module server mzscheme (require (lib "thread.ss") (lib "string.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]") ;; Needed to end a connection: (define current-done-k (make-parameter #f)) ;; Needed to keep sessions single-threaded: (define current-lock (make-parameter #f)) ;; serve: -> ;; Runs a web server to handle GET requests through ;; dispatch-table (define (serve) (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")) ;; done-k is used in return-page (let/cc done-k ;; Set ports and remember done-k (current-input-port in) (current-output-port out) (current-done-k done-k) ;; Set current-lock with `parameterize' so ;; it sticks to the continuation (parameterize ([current-lock (make-semaphore)]) ;; Dispatch (dispatch (caddr m))))))) ;; Timeout in msec: 60000)) ;; dispatch : string -> ;; Handles the given path, sending a reply back through ;; the current output port, then jumping to (current-done-k) (define (dispatch path) (let-values ([(base args) (parse-path path)]) (for-each (lambda (d) (let ([m (regexp-match (car d) base)]) (when m ;; The handler shouldn't return... ((cdr d) base args)))) dispatch-table) ;; If we get here, it means that no dispatch-table ;; match was found (return-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"))) ;; real-return-page : xexpr -> ;; Doesn't return; it prints the given page to the current out ;; port, then terminates the thread (define (return-page xexpr) ;; Release session lock (semaphore-post (current-lock)) ;; 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)) ;; End thread ((current-done-k))) ;; return-error-page : list-of-xexpr -> ;; Like return-page, but takes only error content (define (return-error-page body) (return-page `(html (head (title "Error")) (body (font ((color "red")) ,@body))))) ;; drain-input : -> void ;; Reads all input and throws it away. Otherwise, ;; the server 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)))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; General utilities for sum sessions ;; return-request-page : string string -> ;; Sends a page with a form for filling in a number. ;; The first string is used for the prompt, and the ;; second string determines the URL to continue the ;; session with the user-supplied number (define (return-request-page which-number next-url) (return-page `(html (head (title "Enter a Number to Add")) (body ([bgcolor "white"]) (form ([action ,next-url] [method "get"]) "Enter the " ,which-number " number to add: " (input ([type "text"] [name "number"] [value ""])) (input ([type "submit"] [name "enter"] [value "Enter"]))))))) ;; return-answer-page : string string -> ;; Sends a page with a sum result, given the two ;; user-supplied number strings (define (return-answer-page first second) (return-page `(html (head (title "Sum")) (body ([bgcolor "white"]) (p "The sum is " ,(number->string (+ (string->number first) (string->number second)))))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Sum implementation #1 ;; The state of the computation is embedded in the URL ;; (i.e., the popular but clumsy way) (define rx:a #rx"/a(.*)") ;; a-handler : string args -> (define (a-handler base args) ;; Parse past the "/a" part to see which mode we're in (let ([mode (cadr (regexp-match rx:a base))]) (cond [(string=? mode "") ;; Initial request. Send a form for the first ;; argument, which will be sent to the URL ;; /a/gotfirst (return-request-page "first" "/a/gotfirst")] [(string=? mode "/gotfirst") ;; Got an initial respose --- extract it from ;; the args (let ([first (cdr (assoc "number" args))]) ;; Issue the second request; this time, the ;; next URL us /a/gotsecond/, where ;; remembers the string we just received (return-request-page "second" (format "/a/gotsecond/~a" first)))] [(regexp-match #rx"/gotsecond/(.*)" mode) ;; Got second response, and first response has ;; been matched out of mode => (lambda (m) (let ([first (cadr m)] [second (cdr (assoc "number" args))]) ;; Produce the answer page (return-answer-page first second)))]))) (add-handler rx:a a-handler) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; General-purpose continuation handler (define rx:continue #rx"^/continue/(.*)$") ;; k-table : hash-table(string -> continuation) (define k-table (make-hash-table 'equal)) ;; call-with-continue : (string -> ) -> args ;; Takes a procedure that wants a URL string and ;; that sends a page. If this function ever ;; returns, it returns the args generated by ;; the sent page (define (call-with-continue proc) (let ([result (let/cc finish (let ([name (symbol->string (gensym))]) (hash-table-put! k-table name finish) ;; proc should send a result (which includes releasing ;; the session lock) (proc (format "/continue/~a" name)) ;; Shouldn't get here (return-error-page `("A send/suspend proc returned, and it shouldn't."))))]) ;; Wait for session lock (semaphore-wait (current-lock)) ;; Return result from continuation result)) ;; continue-handler : string args -> ;; Re-dispatch to the named continuation (define (continue-handler base args) (let ([name (cadr (regexp-match rx:continue base))]) (let ([k (hash-table-get k-table name (lambda () (return-error-page `("No such continuation: " ,name))))]) (k args)))) (add-handler rx:continue continue-handler) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Sum implementation #2 ;; The state is implicit in the continuation ;; (i.e., the nice way --- just like having the user here) ;; request-number : string -> string ;; Send a page requsting a number, using the given string in ;; the prompt. Report back the user's answer. (define (request-number which-number) (let ([args (call-with-continue (lambda (k-url) ;; Send a request for a number, using ;; k-url as the next URL (return-request-page which-number k-url)))]) ;; The request number is in args; extract it and ;; return it (cdr (assoc "number" args)))) ;; b-handler : string args -> (define (b-handler base args) ;; Get two numbers and add them (return-answer-page (request-number "first") (request-number "second"))) (add-handler #rx"/b/?" b-handler) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Start the server (serve))