smol-http package, with http-msg implementation

Makefile

@@ -1,6 +1,11 @@
 
 all: .setup
+	raco setup smol-http
 	raco make webcrawler
 
+test: .setup
+	raco test -p smol-http
+
 .setup:
+	raco pkg install smol-http/
 	@touch $@

smol-http/http-msg.rkt

@@ -0,0 +1,138 @@
+#lang racket/base
+(provide http-msg?
+         http-msg-headers
+         http-msg-body
+         write-http-msg
+
+         http-req? make-http-req
+         http-res? make-http-res
+
+         http-body?
+         empty-http-body
+         write-http-body)
+
+(require racket/match
+         "./util.rkt")
+
+(module+ test
+  (require rackunit racket/port))
+
+;; ---------------------------------------------------------------------------------------
+;; HTTP messages
+
+(struct http-msg [start-line headers body] #:transparent)
+(struct http-start-line:req [method path] #:transparent)
+(struct http-start-line:res [code] #:transparent)
+
+;; any? -> boolean?
+(define (http-req? h)
+  (and (http-msg? h) (http-start-line:req? (http-msg-start-line h))))
+(define (http-res? h)
+  (and (http-msg? h) (http-start-line:res? (http-msg-start-line h))))
+
+(define (make-msg sln hdrs)
+  (http-set-headers (http-msg sln (hasheq) empty-http-body) hdrs))
+
+;; (make-http-req method path [hdrs]) -> http-req?
+;; method : http-request-method?
+;; path : path-string?
+;; hdrs : (listof (cons/c symbol? any?))
+(define (make-http-req method path [hdrs '()])
+  (make-msg (http-start-line:req method (build-path path)) hdrs))
+
+;; (make-http-res code [hdrs]) -> http-res?
+;; code : http-response-code?
+;; hdrs : (listof (cons/c symbol? any?))
+(define (make-http-res code [hdrs '()])
+  (make-msg (http-start-line:res code) hdrs))
+
+;; (http-set-headers msg hdrs) -> http-msg?
+;; msg : http-msg?
+;; hdrs : (listof (cons/c symbol? any?))
+(define (http-set-headers msg hdrs)
+  (struct-copy http-msg msg
+               [headers (for/fold ([hdrs (http-msg-headers msg)])
+                                  ([kv (in-list hdrs)])
+                          (if (cdr kv)
+                              (hash-set hdrs (car kv) (->bytes (cdr kv)))
+                              (hash-remove hdrs (car kv))))]))
+
+;; (http-set-body msg how) -> http-msg?
+;; msg : http-msg?
+;; how : (or/c http-body? (http-body? . -> . http-body?))
+(define (http-set-body msg how)
+  (define remove-old-headers
+    (for/list ([kv (in-list (http-body-additional-headers (http-msg-body msg)))])
+      (cons (car kv) #f)))
+  (define bdy*
+    (match how
+      [(? http-body? bdy*) bdy*]
+      [(? procedure? f) (f (http-msg-body msg))]))
+  (http-set-headers (struct-copy http-msg msg [body bdy*])
+                    (append remove-old-headers
+                            (http-body-additional-headers bdy*))))
+
+;; (write-http-msg msg [port]) -> void?
+;; msg : http-msg?
+;; port : output-port?
+(define (write-http-msg msg [port (current-output-port)])
+  (match-define (http-msg sln hdrs body) msg)
+  (match sln
+    [(http-start-line:req mthd path)
+     (fprintf port "~a ~a HTTP/1.1\r\n" mthd path)]
+    [(http-start-line:res code)
+     (fprintf port "HTTP/1.1 ~a ~a\r\n" code (http-response-code-name code))])
+  (for ([k (in-list (sort (hash-keys hdrs) symbol<?))])
+    (fprintf port "~a: ~a\r\n" k (hash-ref hdrs k)))
+  (write-bytes #"\r\n" port)
+  (write-http-body body port))
+
+;; ==========================================
+
+(module+ test
+  (define ex-req-/ (make-http-req 'GET "/" '([Host . "localhost"])))
+  (define ex-res-ok (http-set-body (make-http-res 200) #"Hello world"))
+
+  (check-pred http-req? ex-req-/)
+  (check-pred http-res? ex-res-ok)
+
+  (check-equal? (hash-ref (http-msg-headers ex-req-/) 'Host) #"localhost")
+  (check-equal? (hash-ref (http-msg-headers ex-res-ok) 'Content-Length) #"11")
+
+  (define-syntax-rule (check-http-msg->bytes msg bs ...)
+    (check-equal? (let ([p (open-output-bytes)])
+                    (write-http-msg msg p)
+                    (get-output-bytes p))
+                  (bytes-append bs ...)))
+
+  (check-http-msg->bytes ex-req-/
+                         #"GET / HTTP/1.1\r\n"
+                         #"Host: localhost\r\n"
+                         #"\r\n")
+
+  (check-http-msg->bytes ex-res-ok
+                         #"HTTP/1.1 200 OK\r\n"
+                         #"Content-Length: 11\r\n"
+                         #"\r\n"
+                         #"Hello world")
+
+  (check-http-msg->bytes (http-set-body ex-res-ok empty-http-body)
+                         #"HTTP/1.1 200 OK\r\n"
+                         #"\r\n"))
+
+;; ---------------------------------------------------------------------------------------
+;; Message bodies
+
+(define (http-body? x)
+  (or (eq? x #f)
+      (bytes? x)))
+
+(define empty-http-body #f)
+
+(define (http-body-additional-headers bdy)
+  (match bdy
+    [#f '()]
+    [(? bytes? bs) `([Content-Length . ,(bytes-length bs)])]))
+
+(define (write-http-body bdy [port (current-output-port)])
+  (when bdy (write-bytes bdy port)))

smol-http/info.rkt

@@ -0,0 +1,4 @@
+#lang info
+(define collection "smol-http")
+(define deps '("base"))
+(define test-omit-paths '("info.rkt"))

smol-http/main.rkt

@@ -0,0 +1,7 @@
+#lang racket/base
+(require "./util.rkt"
+         "./http-msg.rkt")
+(provide (all-from-out "./http-msg.rkt")
+         (except-out (all-from-out "./util.rkt") ->bytes))
+
+(module+ test)

smol-http/util.rkt

@@ -0,0 +1,38 @@
+#lang racket/base
+(provide http-request-method?
+         http-response-code?
+         http-response-code-name
+         ->bytes)
+
+(module+ test (require rackunit))
+
+;; ---------------------------------------------------------------------------------------
+
+;; any? -> boolean?
+(define (http-request-method? x)
+  (memq x '(GET POST)))
+
+(define http-status-codes
+  #hasheqv([200 . "OK"]
+           [301 . "Moved Permanently"]
+           [403 . "Forbidden"]
+           [404 . "Not Found"]
+           [500 . "Internal Server Error"]))
+
+;; any? -> boolean?
+(define (http-response-code? x)
+  (hash-has-key? http-status-codes x))
+
+;; http-status-code? -> string?
+(define (http-response-code-name c)
+  (hash-ref http-status-codes c))
+
+;; any? -> bytes?
+(define (->bytes x)
+  (if (bytes? x)
+      x
+      (string->bytes/latin-1 (format "~a" x))))
+
+(module+ test
+  (let ([b #"hello"]) (check-eq? (->bytes b) b))
+  (check-equal? (->bytes 5) #"5"))

webcrawler

@@ -1,5 +1,9 @@
 #!/usr/bin/env racket
 #lang racket/base
+(require smol-http)
+
+(define req
+  (make-http-req 'GET "/hello-world"))
 
 (module+ main
-  (displayln "Hello world."))
+  (write-http-msg req))