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