Created
October 1, 2018 02:42
-
-
Save DanBurton/f0a1472daa8bfdeb21fbbaca783a943c to your computer and use it in GitHub Desktop.
A typed version of https://docs.racket-lang.org/more/index.html
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#lang typed/racket | |
(require (for-syntax syntax/parse)) | |
(require typed/net/url) | |
(require racket/control) | |
(require/typed xml | |
[xexpr->string (Xexpr -> String)]) | |
;; Simplified types from typed/net/url | |
(define-type PathFrag (U 'same 'up String)) | |
;; Simplified types from xml | |
(define-type Query (Listof (Pairof Symbol (U False String)))) | |
(define-type Xexpr (Listof (U String Symbol Xexpr))) | |
;; Type synonyms specific to this code | |
(define-type Handler (Query -> Xexpr)) | |
(define-type PTX (Prompt-Tagof Xexpr ((-> Xexpr) -> Xexpr))) | |
(define-type PHandler (PTX Query -> Xexpr)) | |
;; Helper macros a la Clojure | |
(define-syntax (some->> stx) | |
(syntax-parse stx | |
[(_ x:expr) | |
#'x] | |
[(_ x:expr f:id fs ...) | |
#'(some->> x (f) fs ...)] | |
[(_ x:expr (e:expr ...) fs ...) | |
#'(let ([x* x]) | |
(and x* (some->> (e ... x*) fs ...)))])) | |
(define-syntax (when-let stx) | |
(syntax-parse stx | |
[(_ () body:expr ...) | |
#'(begin | |
body ...)] | |
[(_ ([x:id e:expr] bs ...) body:expr ...) | |
#'(let ([x e]) | |
(when x | |
(when-let (bs ...) | |
body ...)))])) | |
(define-syntax (guard stx) | |
(syntax-parse stx | |
[(_ p x) | |
#'(let ([x* x]) | |
(and (p x) x))])) | |
(: serve (Integer -> (-> Void))) | |
(define (serve port-no) | |
(define main-cust (make-custodian)) | |
(parameterize ([current-custodian main-cust]) | |
(define listener (tcp-listen port-no 5 #t)) | |
(: loop (-> Void)) | |
(define (loop) | |
(accept-and-handle listener) | |
(loop)) | |
(thread loop)) | |
(λ () | |
(custodian-shutdown-all main-cust))) | |
(: accept-and-handle (TCP-Listener -> Thread)) | |
(define (accept-and-handle listener) | |
(define cust (make-custodian)) | |
(custodian-limit-memory cust (* 50 1024 1024)) | |
(parameterize ([current-custodian cust]) | |
(define-values (in out) (tcp-accept listener)) | |
(thread | |
(λ () | |
(handle in out) | |
(close-input-port in) | |
(close-output-port out)))) | |
; Watcher thread: | |
(thread (λ () | |
(sleep 10) | |
(custodian-shutdown-all cust)))) | |
(: handle (Input-Port Output-Port -> Void)) | |
(define (handle in out) | |
(when-let ([str-path | |
(some->> (read-line in) | |
(guard string?) | |
(regexp-match #rx"^GET (.+) HTTP/[0-9]+\\.[0-9]+") | |
second)]) | |
; Discard the rest of the header (up to blank line): | |
(regexp-match #rx"(\r\n|^)\r\n" in) | |
; Dispatch: | |
(define xexpr (dispatch str-path)) | |
; Send reply: | |
(display "HTTP/1.0 200 Okay\r\n" out) | |
(display "Server: dan-rkt-demo\r\n" out) | |
(display "Content-Type: text/html\r\n" out) | |
(display "\r\n" out) | |
(display (xexpr->string xexpr) out))) | |
(: dispatch (String -> Xexpr)) | |
(define (dispatch str-path) | |
; Parse the request as a URL: | |
(define url (string->url str-path)) | |
; Extract the path part: | |
(: path (Listof PathFrag)) | |
(define path (map path/param-path (url-path url))) | |
; Find a handler based on the path's first element | |
(define h (hash-ref dispatch-table (car path) #f)) | |
(if h | |
; Call a handler: | |
(h (url-query url)) | |
; No handler found: | |
(not-found str-path))) | |
(: dispatch-table (Mutable-HashTable PathFrag Handler)) | |
(define dispatch-table (make-hash)) | |
(: not-found (-> String Xexpr)) | |
(define (not-found str-path) | |
`(html (head (title "Error")) | |
(body | |
(font ((color "red")) | |
"Unknown page: " | |
,str-path) | |
,common-links))) | |
(hash-set! dispatch-table "hello" | |
(λ (query) | |
`(html (body "Hello, World!") | |
,common-links))) | |
(: build-request-page (String String String -> Xexpr)) | |
(define (build-request-page label next-url hidden) | |
`(html | |
(head (title "Enter a Number to Add")) | |
(body ([bgcolor "white"]) | |
(form ([action ,next-url] | |
[method "get"]) | |
,label | |
(input ([type "text"] | |
[name "number"] | |
[value ""])) | |
(input ([type "hidden"] | |
[name "hidden"] | |
[value ,hidden])) | |
(input ([type "submit"] | |
[name "enter"] | |
[value "Enter"]))) | |
,common-links))) | |
(: common-links Xexpr) | |
(define common-links | |
`(p | |
(a ([href "/sum2"]) "/sum2") | |
" " | |
(a ([href "/hello"]) "/hello") | |
" " | |
(a ([href "/many"]) "/many"))) | |
(: many Handler) | |
(define (many query) | |
(build-request-page "Number of greetings:" "/reply" "")) | |
(: reply Handler) | |
(define (reply query) | |
(define n (number-from-query query)) | |
`(html (body ,@(for/list : (Listof String) ([i (in-range n)]) | |
" hello") | |
,common-links))) | |
(hash-set! dispatch-table "many" many) | |
(hash-set! dispatch-table "reply" reply) | |
(: number-from-query (Query -> Integer)) | |
(define (number-from-query query) | |
(or (some->> query (assq 'number) cdr string->number (guard natural?)) | |
1)) | |
(: with-new-prompt-tag (Symbol PHandler -> Handler)) | |
(define ((with-new-prompt-tag sym h) query) | |
(: ptx PTX) | |
(define ptx (make-continuation-prompt-tag sym)) | |
(prompt-at ptx (h ptx query))) | |
(: send/suspend (PTX (String -> Xexpr) -> (values PTX Query))) | |
(define (send/suspend ptx mk-page) | |
(: the-suspend (PHandler -> Nothing)) | |
(define (the-suspend k) | |
(define tag (format "k~a" (current-inexact-milliseconds))) | |
(hash-set! dispatch-table tag (with-new-prompt-tag 'send/suspend k)) | |
(abort-current-continuation ptx (λ () (mk-page (string-append "/" tag))))) | |
(call-with-composable-continuation the-suspend ptx)) | |
(: get-number (PTX String -> (values PTX Integer))) | |
(define (get-number ptx label) | |
; Receive the computation-as-URL here | |
(: get-number-cont (String -> Xexpr)) | |
(define (get-number-cont k-url) | |
; Generate the query-page result for this connection. | |
; Send the query result to the saved-computation URL: | |
(build-request-page label k-url "")) | |
(define-values (ptx* query) | |
; Generate a URL for the current computation: | |
(send/suspend ptx get-number-cont)) | |
; We arrive here later, in a new connection | |
(values ptx* (number-from-query query))) | |
(: sum2 PHandler) | |
(define (sum2 ptx query) | |
(define-values (ptx* m) (get-number ptx "First number:")) | |
(define-values (_ptx n) (get-number ptx* "Second number:")) | |
`(html (body "The sum is " ,(number->string (+ m n)) | |
,common-links))) | |
(hash-set! dispatch-table "sum2" (with-new-prompt-tag 'sum2 sum2)) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment