#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
         in-http-body-chunks)

(require racket/match
         racket/port
         racket/stream
         "./util.rkt")

(module+ test
  (require rackunit))

;; ---------------------------------------------------------------------------------------
;; 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)
      (stream? x)))

(define empty-http-body #f)

;; (write-http-body bdy [port]) -> void?
;; bdy : http-body?
;; port : output-port?
(define (write-http-body bdy [port (current-output-port)])
  (match bdy
    [#f (void)]
    [(? bytes? bs) (write-bytes bs port)]
    [(? stream? bss) (error 'write-http-body "chunked is not implemented sorry. ;(")]))

;; (in-http-body-chunks bdy) -> (streamof bytes)
;; bdy : http-body?
(define (in-http-body-chunks bdy)
  (match bdy
    [#f '()]
    [(? bytes? bs) (list bs)]
    [(? stream? bss) bss]))

(define (http-body-additional-headers bdy)
  (match bdy
    [#f '()]
    [(? bytes? bs) `([content-length . ,(bytes-length bs)])]
    [(? stream?) '([transfer-encoding . #"chunked"])]))

;; ---------------------------------------------------------------------------------------
;; Parsing

(struct exn:fail:read-http exn:fail [] #:transparent)

(define (raise-read-http-error . fmt)
  (raise (exn:fail:read-http (string-append "read-http-msg: " (apply format fmt))
                             (current-continuation-marks))))

(define (string->start-line s)
  (match (regexp-match #px"^(HTTP/1\\.1 (\\d+) .*)|(([A-Z]+) ([^ ]+) HTTP/1\\.1)$" s)
    [(list _ _ code #f #f #f)
     (http-start-line:res (string->number code))]
    [(list _ #f #f _ method path)
     (http-start-line:req (string->symbol method) (build-path path))]
    [_ #f]))

(define (string->header-kv s)
  (match (regexp-match #px"^([^:]+):\\s*(.*)$" s)
    [(list _ k v) (cons (string->symbol (string-downcase k))
                          (->bytes v))]
    [_ #f]))

(define (read-crlf-line port)
  (match (regexp-match #px"^([^\r]*)\r\n" port)
    [(list _ line) (bytes->string/utf-8 line)]
    [_ (port->string port)]))

;; (read-http-msg [port]) -> http-msg?
;; port : input-port?
(define (read-http-msg [port (current-input-port)])
  (define sln/str
    (read-crlf-line port))
  (define sln
    (or (string->start-line sln/str)
        (raise-read-http-error "invalid start line: ~s" sln/str)))
  (define hdrs
    (for/list ([hln (in-port read-crlf-line port)])
      #:break (string=? hln "")
      (or (string->header-kv hln)
          (raise-read-http-error "read-http-msg: invalid header line: ~s" hln))))
  (define msg (make-msg sln hdrs))
  (define bdy (read-http-body (hash-ref (http-msg-headers msg) 'transfer-encoding #f)
                              (hash-ref (http-msg-headers msg) 'content-length #f)
                              port))
  (http-set-body msg bdy))

;; (http-body-reader tenc clen [port]) -> http-body?
;; tenc, clen : (or/c #f bytes?)
;; port : input-port?
(define (read-http-body tenc clen [port (current-input-port)])
  (define len (and clen (string->int (bytes->string/utf-8 clen))))
  (cond
    [(equal? tenc #"chunked") (read-chunked-stream port)]
    [(number? len) (read-bytes len port)]
    [(and (not tenc) (not len)) #f]
    [else (raise-read-http-error "read-http-body: not sure how to read HTTP body")]))

;; input-port? -> [streamof bytes?]
(define (read-chunked-stream port)
  (define len (string->number (read-crlf-line port)))
  (define data (read-bytes len port))
  (match-define #"\r\n" (read-bytes 2 port))
  (if (zero? len)
      empty-stream
      (stream-cons data (read-chunked-stream port))))

;; ==========================================

(module+ test
  (define-syntax-rule (check-bytes->http-msg bs ... msg-expr)
    (let ([p (open-input-bytes (bytes-append bs ...))])
      (check-equal? (read-http-msg p) msg-expr)
      (check-eq? (read-char p) eof)))

  (check-bytes->http-msg #"GET /foo?a=z HTTP/1.1\r\n"
                         #"host: foobar\r\n"
                         #"\r\n"
                         (make-http-req 'GET "/foo?a=z" '([host . "foobar"])))

  (check-bytes->http-msg #"HTTP/1.1 200 OK\r\n"
                         #"Content-Type: text/html\r\n"
                         #"Content-Length: 5\r\n"
                         #"\r\n"
                         #"hello"
                         (http-set-body (make-http-res 200 '([content-type . "text/html"]
                                                             [content-length . 5]))
                                        #"hello"))

  (let ([msg (read-http-msg
              (open-input-bytes (bytes-append #"HTTP/1.1 200 OK\r\n"
                                              #"Transfer-Encoding: chunked\r\n"
                                              #"\r\n"
                                              #"5\r\nhello\r\n"
                                              #"2\r\n, \r\n"
                                              #"6\r\nworld!\r\n"
                                              #"0\r\n\r\n")))])
    (check-equal? (for/list ([bs (in-http-body-chunks (http-msg-body msg))]) bs)
                  '(#"hello" #", " #"world!")))

  ;; "write --> read" works
  (let-values ([(in out) (make-pipe)])
    (thread (λ () (write-http-msg ex-req-/ out)))
    (check-equal? (read-http-msg in) ex-req-/)))