A typed version of https://docs.racket-lang.org/more/index.html

serve.rkt

#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))