#lang scheme

(require (prefix-in log: (planet synx/log)))

(require srfi/19)
(require net/url)

; it's important to be able to reconstruct the headers perfectly
; so retain the raw string value, in case that ever matters.
(define-struct header (value raw) #:mutable)
(define-struct headers (dict) #:transparent)

(define parse-header
  (let ([splitter #px"([^:]+)\\s*:\\s*(.*)"])
    (λ (line headers)
;      (log:log "Got header ~s" line)
      (let ([match (cdr (regexp-match splitter line))])
        (let ([name (car match)]
              [raw (cadr match)])
          (set-header headers name raw #t))))))

(define (join-header name raw)
  (format "~a: ~a" name raw))


(define (make-headers-dict [pairs null])
  (make-immutable-custom-hash (λ (a b) (equal? (string-downcase a) (string-downcase b)))
                              (λ (a) (equal-hash-code (string-downcase a)))
                              (λ (a) (equal-secondary-hash-code (string-downcase a)))))

; headers hash as caseless, but still have case eh.
; need to keep their case for re-transmission.

(define token-headers
  '("Transfer-Encoding" "Connection" "Accept-Ranges"))

(define number-headers
  '("Content-Length" "Keep-alive"))

(define date-headers
  '("Date" "Last-Modified" "If-Modified-Since" "If-Not-Modified-Since"))

(define uri-headers
  '("Location" "Referer" "Referrer"))

(define (decode-date raw)
  (string->date raw "~a, ~d ~b ~Y ~H:~M:~S GMT"))
(define (encode-date value)
  (date->string value "~a, ~d ~b ~Y ~H:~M:~S GMT"))

(define (is-in? l a)
  (foldl (λ (i rest) (or rest (equal? i a))) #f l))

(define (decode name raw)
  (cond
    [(is-in? token-headers name) (regexp-split #rx" " raw)]
    [(is-in? number-headers name) (string->number raw)]
    [(is-in? date-headers name) (decode-date raw)]
    [(is-in? uri-headers name) (string->url raw)]
    [else raw]))

(define (encode name value)
  (cond
    [(is-in? token-headers name) (string-join value " ")]
    [(is-in? number-headers name) (number->string value)]
    [(is-in? date-headers name) (encode-date value)]
    [(is-in? uri-headers name) (url->string value)]
    [else value]))

(define (get-header headers name)
  (if headers
      (let ([header (dict-ref (headers-dict headers) name (λ () #f))])
        (if header
            (or (header-value header)
                (begin
                  (set-header-value! header (decode name (header-raw header)))
                  (header-value header)))
            #f))
      #f))
  
(define (set-header headerses name value [raw #f])
  (let ([header 
         (if raw
             (make-header #f value)
             (make-header value #f))])
    (if headerses
        (struct-copy headers headerses (dict (dict-set (headers-dict headerses) name header)))
        (make-headers (dict-set (make-headers-dict) name header)))))

(define (set-headers headers [pairs null])
  (foldl (λ (i headers) (set-header headers (car i) (cdr i)))
         headers
         pairs))

(define (for-each-raw-header headers proc)
  (dict-for-each
   (headers-dict headers)
   (λ (name header)
     (proc
      name
      (or (header-raw header)
          (begin
            (set-header-raw! header (encode name (header-value header)))
            (header-raw header)))))))

(define status-line 
  (let ([split #rx" "]
        [front #rx"HTTP/([0-9]\\.[0-9])"])
    (λ (line)
      (let ([bits (regexp-split split line)])
        (when (not (>= (length bits) 3))
          (raise-user-error (format "Bad status line ~s must have at least 3 bits!" line)))
        (let ([version (regexp-match front (car bits))])
          (when (not version)
            (raise-user-error "Bad version ~s" (car bits)))
          (let ([version (string->number (cadr version))]
                [code (string->number (cadr bits))])
            (values version code (string-join (cddr bits) " "))))))))

(define headers/c (or/c headers? false?))

(provide/contract
 [get-header (-> headers/c string? any/c)]
 [set-header (->* (headers/c string? any/c) (boolean?) headers?)]
 [set-headers (->* (headers/c) ((listof pair?)) headers?)]
 [is-in? (-> (listof string?) string? boolean?)]
 
; all for session.ss:
 [status-line (-> string? (values number? integer? string?))]
 [for-each-raw-header (-> headers? (-> string? string? any) void?)]
 [parse-header (-> string? headers/c headers?)]
 [join-header (-> string? string? string?)])

(provide headers/c headers?)