http.carp

(load "git@github.com:carpentry-org/uri@0.0.11")
(load "git@github.com:carpentry-org/time@0.1.0")

(deftype SameSite
  (Lax [])
  (Strict [])
  (None [])
)

(defmodule SameSite
  (defn zero [] (Lax))
  (implements zero SameSite.zero)
)

(doc Cookie "is a simple cookie data type. You usually shouldn’t need to build
the type yourself, instead you can [parse](#parse) it.")

(deftype Cookie [name String,
                 value String,
                 path String,
                 expires (Maybe Datetime),
                 domain (Maybe String),
                 secure Bool,
                 httponly Bool,
                 samesite SameSite])

(defmodule Cookie
  (doc expired? "checks if a cookie is expired now.")
  (defn expired? [c]
    (match @(expires c)
      (Maybe.Just d) (> &(Datetime.now) &d)
      (Maybe.Nothing) false))

  (doc parse "parses a cookie.")
  (defn parse [s]
    (let [splt (split-by s &[\=])]
      (if (= (Array.length &splt) 2)
        (Result.Success
          (init
            (trim (Array.unsafe-first &splt))
            (trim (Array.unsafe-nth &splt 1)) @"/"
            (Maybe.Nothing) (Maybe.Nothing) false false (zero)))
        (Result.Error @"cookie malformed: expected key=value pair"))))

  (doc parse-many "parses multiple cookies.")
  (defn parse-many [s]
      (Array.reduce
        &(fn [a s]
          (match a
            (Result.Error err) (Result.Error err)
            (Result.Success arr)
              (match (parse s)
                (Result.Error err) (Result.Error err)
                (Result.Success c) (Result.Success (Array.push-back arr c)))))
        (Result.Success []) &(split-by s &[\;])))

  (doc kv "makes a `name=value` pair from a cookie.")
  (defn kv [c] (fmt "%s=%s" (name c) (value c)))

  (doc set "makes a proper set cookie string from a cookie.")
  (defn set [c]
    (let-do [s (fmt "%s; Path=%s" &(kv c) (path c))]
      (match @(expires c)
        (Maybe.Nothing) ()
        (Maybe.Just xp)
          (set! s (fmt "%s; Expires=%s" &s &(Datetime.strftime &xp "%a, %d %b %Y %H:%M:%S GMT"))))
      (match @(domain c)
        (Maybe.Nothing) ()
        (Maybe.Just d) (set! s (fmt "%s; Domain=%s" &s &d)))
      (when @(secure c) (set! s (fmt "%s; Secure" &s)))
      (when @(httponly c) (set! s (fmt "%s; HttpOnly" &s)))
      (match @(samesite c)
        (SameSite.Lax)    (set! s (fmt "%s; SameSite=Lax" &s))
        (SameSite.Strict) (set! s (fmt "%s; SameSite=Strict" &s))
        (SameSite.None)   (set! s (fmt "%s; SameSite=None" &s)))
      s))

  (private parse-set-prop)
  (hidden parse-set-prop)
  (defn parse-set-prop [a p]
    (match a
      (Result.Error err) (Result.Error err)
      (Result.Success c)
        (let [prop &(trim p)
              splt &(split-by prop &[\=])
              l<2 (< (Array.length splt) 2)]
          (cond
            (= prop "Secure") (Result.Success (set-secure c true))
            (= prop "HttpOnly") (Result.Success (set-httponly c true))
            (starts-with? prop "Path")
              (if l<2
                (Result.Error @"malformed path property in set-cookie, no value")
                (Result.Success (set-path c (join "=" &(Array.suffix splt 1)))))
            (starts-with? prop "Domain")
              (if l<2
                (Result.Error @"malformed domain property in set-cookie, no value")
                (Result.Success
                  (set-domain c (Maybe.Just (join "=" &(Array.suffix splt 1))))))
            (starts-with? prop "Expires")
              (if l<2
                (Result.Error @"malformed expires property in set-cookie, no value")
                (Result.Error @"TODO: parse date"))
            (starts-with? prop "Max-Age")
              (if l<2
                (Result.Error @"malformed max-age property in set-cookie, no value")
                (let [mi (Int.from-string &(join "=" &(Array.suffix splt 1)))]
                  (match mi
                    (Maybe.Nothing)
                      (Result.Error @"malformed max-age value in set-cookie")
                    (Maybe.Just i)
                      (Result.Success
                        (set-expires c
                          (Maybe.Just (Datetime.add-seconds &(Datetime.now) i)))))))
            (starts-with? prop "SameSite")
              (if l<2
                (Result.Error @"malformed samesite property in set-cookie, no value")
                (let [s (join "=" &(Array.suffix splt 1))]
                  (case &s
                    "Lax"    (Result.Success (set-samesite c (SameSite.Lax)))
                    "Strict" (Result.Success (set-samesite c (SameSite.Strict)))
                    "None"   (Result.Success (set-samesite c (SameSite.None)))
                    (Result.Error
                      (fmt "malformed samesite property in set-cookie, unknown value: %s" &s)))))
            (Result.Error (fmt "Unknown set-cookie property: %s" prop))))))

  (doc parse-set "parses a `Set-Cookie` form.")
  (defn parse-set [s]
    (let [splt (split-by s &[\;])]
      (Array.reduce &parse-set-prop (parse (Array.unsafe-first &splt))
                    &(Array.suffix &splt 1))))
)

(doc Request "is a request data type. It holds the `verb` of the request, the
`version`, the `uri`, the `cookies`, the `headers`, and the `body`.")
(deftype Request [verb String,
                  version String,
                  uri URI,
                  cookies (Array Cookie),
                  headers (Map String (Array String)),
                  body String])

(defmodule Request
  (doc ignore-body? "checks whether the body of the request should be ignored.")
  (defn ignore-body? [r] (= (verb r) "HEAD"))

  (private str-headers)
  (hidden str-headers)
  (defn str-headers [r]
    (Map.kv-reduce
      &(fn [acc k v]
        (fmt "%s\r\n%s"
             &acc
             &(join "\r\n" &(Array.copy-map &(fn [x] (fmt "%s: %s" k x)) v))
        ))
      @""
      (headers r)))

  (private str-cookies)
  (hidden str-cookies)
  (defn str-cookies [r]
    (if (empty? (cookies r))
      @""
      (fmt "Cookie: %s" &(join ";" &(Array.copy-map &Cookie.kv (cookies r))))))

  (doc str "stringifies the request. It should be stringified exactly as it
looks on the wire.")
  (defn str [r]
    (fmt "%s %s %s%s\r\n%s\r\n\r\n%s"
         (verb r)
         &(str (uri r))
         (version r)
         &(str-headers r)
         &(str-cookies r)
         (body r)))
  (implements str Request.str)

  (doc request "builds a HTTP `1.1` request.")
  (defn request [verb uri cookies headers body]
    (init verb @"HTTP/1.1" uri cookies headers body))

  (doc get "builds a HTTP GET request (version `1.1`).")
  (defn get [uri cookies headers body]
    (request @"GET" uri cookies headers body))

  (doc post "builds a HTTP POST request (version `1.1`).")
  (defn post [uri cookies headers body]
    (request @"POST" uri cookies headers body))

  (doc put "builds a HTTP PUT request (version `1.1`).")
  (defn put [uri cookies headers body]
    (request @"PUT" uri cookies headers body))

  (doc del "builds a HTTP DELETE request (version `1.1`).")
  (defn del [uri cookies headers body]
    (request @"DELETE" uri cookies headers body))

  (doc patch "builds a HTTP PATCH request (version `1.1`).")
  (defn patch [uri cookies headers body]
    (request @"PATCH" uri cookies headers body))

  (doc parse "parses a HTTP request from a string `txt`.

Returns an `(Error String)` holding the error message if it fails, otherwise
it will return a `(Success Request)`.")
  (defn parse [txt]
    (let [ls &(Pattern.split #"\r\n" txt)
          fst (Array.first ls)]
      (match fst
        (Maybe.Nothing) (Result.Error @"Malformed request: empty")
        (Maybe.Just s)
          (let [splt (words &s)]
            (if (/= (Array.length &splt) 3)
              (Result.Error (fmt "Malformed request: found first line '%s'" &s))
              (let-do [headers {}
                       cookies []
                       body @""
                       failed @""]
                (for [i 1 (Array.length ls)]
                  (let [l (Array.unsafe-nth ls i)]
                    (if (= l "")
                      (do
                        (when (> (Array.length ls) (Int.inc i))
                          (set! body
                            (join "\n" &(Array.suffix ls (Int.inc i)))))
                        (break))
                      (let [splt (split-by l &[\:])]
                        (if (< (Array.length &splt) 2)
                          (do
                            (set! failed @l)
                            (break))
                          (let [k (Array.unsafe-nth &splt 0)
                                v &(trim &(join ":" &(Array.suffix &splt 1)))]
                            (if (= k "Cookie")
                              (match (Cookie.parse-many v)
                                (Result.Error err)
                                  (do
                                    (set! failed err)
                                    (break))
                                (Result.Success arr)
                                  (set! cookies (Array.concat &[cookies arr])))
                              (set! headers
                                (Map.update-with-default
                                  headers
                                  k
                                  &(fn [h] (Array.push-back h @v))
                                  [])))))))))
                (if (/= &failed "")
                  (Result.Error (fmt "Malformed request: found header '%s'" &failed))
                  (let [uri (URI.parse (Array.unsafe-nth &splt 1))]
                    (match uri
                      (Result.Success uri)
                        (Result.Success
                          (init
                            @(Array.unsafe-nth &splt 0)
                            @(Array.unsafe-nth &splt 2)
                            uri
                            cookies
                            headers
                            body))
                      (Result.Error err)
                        (Result.Error
                          (fmt "Malformed request: uri decoding error: '%s'" &err)))))))))))
)

(doc Response "is a response data type. It holds the `code` of the request, the
`version`, the `message`, the `cookies`, the `headers`, and the `body`.")
(deftype Response [code Int,
                   message String,
                   version String,
                   cookies (Array Cookie),
                   headers (Map String (Array String)),
                   body String])

(defmodule Response
  (private str-headers)
  (hidden str-headers)
  (defn str-headers [r]
    (Map.kv-reduce
      &(fn [acc k v]
        (fmt "%s\r\n%s"
             &acc
             &(join "\r\n" &(Array.copy-map &(fn [x] (fmt "%s: %s" k x)) v))
        ))
      @""
      (headers r)))

  (private str-cookies)
  (hidden str-cookies)
  (defn str-cookies [r]
    (Array.reduce
      &(fn [acc c]
        (fmt "%s\r\nSet-Cookie: %s"
             &acc
             &(Cookie.set c)))
      @""
      (cookies r)))

  (doc str "stringifies the request. It should be stringified exactly as it
looks on the wire.")
  (defn str [r]
    (fmt "%s %d %s%s%s\r\n\r\n%s"
         (version r)
         @(code r)
         (message r)
         &(str-headers r)
         &(str-cookies r)
         (body r)))
  (implements str Response.str)

  (doc ok? "checks whether the status code is less than 400.")
  (defn ok? [r] (< @(code r) 400))

  (doc client-error? "checks whether the status code is between 400 and 500.")
  (defn client-error? [r] (let [c @(code r)] (and (<= 400 c) (< c 500))))

  (doc server-error? "checks whether the status code is between 500 and 600.")
  (defn server-error? [r] (let [c @(code r)] (and (<= 500 c) (< c 600))))

  (doc parse "parses a HTTP response from a string `txt`.

Returns a `(Error String)` holding the error message if it fails, otherwise
it will return a `(Success Response)`.")
  (defn parse [txt]
    (let [ls &(Pattern.split #"\r\n" txt)
          fst (Array.first ls)]
      (match fst
        (Maybe.Nothing) (Result.Error @"Malformed response: empty")
        (Maybe.Just s)
          (let [splt (words &s)]
            (if (< (Array.length &splt) 3)
              (Result.Error (fmt "Malformed response: found first line '%s'" &s))
              (let-do [headers {}
                       cookies []
                       body @""
                       failed @""]
                (for [i 1 (Array.length ls)]
                  (let [l (Array.unsafe-nth ls i)]
                    (if (= l "")
                      (do
                        (when (> (Array.length ls) (Int.inc i))
                          (set! body
                            (join "\n" &(Array.suffix ls (Int.inc i)))))
                        (break))
                      (let [splt (split-by l &[\:])]
                        (if (< (Array.length &splt) 2)
                          (do
                            (set! failed @l)
                            (break))
                          (let [k (Array.unsafe-nth &splt 0)
                                v &(trim &(join ":" &(Array.suffix &splt 1)))]
                            (if (= k "Set-Cookie")
                              (match (Cookie.parse-set v)
                                (Result.Error err)
                                  (do
                                    (set! failed err)
                                    (break))
                                (Result.Success c) (Array.push-back! &cookies c))
                              (set! headers
                                (Map.update-with-default
                                  headers
                                  k
                                  &(fn [h] (Array.push-back h @v))
                                  [])))))))))
                (if (/= &failed "")
                  (Result.Error (fmt "Malformed response: found header '%s'" &failed))
                  (let [msc (Int.from-string (Array.unsafe-nth &splt 1))]
                    (match msc
                      (Maybe.Just status-code)
                        (Result.Success
                          (init
                            status-code
                            (join " " &(Array.suffix &splt 2))
                            @(Array.unsafe-nth &splt 0)
                            cookies
                            headers
                            body))
                      (Maybe.Nothing)
                        (Result.Error
                          (fmt "Malformed request: status code decoding error: '%s'"
                            (Array.unsafe-nth &splt 1))))))))))))
)