http-example.u

namespace RFC where
  parseDigit = oneOfChars [?0, ?1, ?2, ?3, ?4, ?5, ?6, ?7, ?8, ?9]
  parseHex = Unipar.satisfy isHexDigit "wasn't a hex digit"
  parseCRLF = (ch ?\r Unipar.>> ch ?\n)

type RawHeaders
  = RawHeaders (Map Text Text)

type Request
  = Request HostName Text RawHeaders

type ResponseStatus
  = STATUS_100  -- Section 10.1.1: Continue
  | STATUS_101  -- Section 10.1.2: Switching Protocols
  | STATUS_200  -- Section 10.2.1: OK
  | STATUS_201  -- Section 10.2.2: Created
  | STATUS_202  -- Section 10.2.3: Accepted
  | STATUS_203  -- Section 10.2.4: Non-Authoritative Information
  | STATUS_204  -- Section 10.2.5: No Content
  | STATUS_205  -- Section 10.2.6: Reset Content
  | STATUS_206  -- Section 10.2.7: Partial Content
  | STATUS_300  -- Section 10.3.1: Multiple Choices
  | STATUS_301  -- Section 10.3.2: Moved Permanently
  | STATUS_302  -- Section 10.3.3: Found
  | STATUS_303  -- Section 10.3.4: See Other
  | STATUS_304  -- Section 10.3.5: Not Modified
  | STATUS_305  -- Section 10.3.6: Use Proxy
  | STATUS_307  -- Section 10.3.8: Temporary Redirect
  | STATUS_400  -- Section 10.4.1: Bad Request
  | STATUS_401  -- Section 10.4.2: Unauthorized
  | STATUS_402  -- Section 10.4.3: Payment Required
  | STATUS_403  -- Section 10.4.4: Forbidden
  | STATUS_404  -- Section 10.4.5: Not Found
  | STATUS_405  -- Section 10.4.6: Method Not Allowed
  | STATUS_406  -- Section 10.4.7: Not Acceptable
  | STATUS_407  -- Section 10.4.8: Proxy Authentication Required
  | STATUS_408  -- Section 10.4.9: Request Time-out
  | STATUS_409  -- Section 10.4.10: Conflict
  | STATUS_410  -- Section 10.4.11: Gone
  | STATUS_411  -- Section 10.4.12: Length Required
  | STATUS_412  -- Section 10.4.13: Precondition Failed
  | STATUS_413  -- Section 10.4.14: Request Entity Too Large
  | STATUS_414  -- Section 10.4.15: Request-URI Too Large
  | STATUS_415  -- Section 10.4.16: Unsupported Media Type
  | STATUS_416  -- Section 10.4.17: Requested range not satisfiable
  | STATUS_417  -- Section 10.4.18: Expectation Failed
  | STATUS_500  -- Section 10.5.1: Internal Server Error
  | STATUS_501  -- Section 10.5.2: Not Implemented
  | STATUS_502  -- Section 10.5.3: Bad Gateway
  | STATUS_503  -- Section 10.5.4: Service Unavailable
  | STATUS_504  -- Section 10.5.5: Gateway Time-out
  | STATUS_505  -- Section 10.5.6: HTTP Version not supported

type Response
  = Response ResponseStatus RawHeaders Text

type ChunkedResponse
  = Response ResponseStatus RawHeaders [(Nat, Text)]

parseStatusCode : '{Exception Text, Store Text} ResponseStatus
parseStatusCode =
  use Brainfuck ==>
  Unipar.oneOf
    [ string "100" ==> STATUS_100  -- Section 10.1.1: Continue
    , string "101" ==> STATUS_101  -- Section 10.1.2: Switching Protocols
    , string "200" ==> STATUS_200  -- Section 10.2.1: OK
    , string "201" ==> STATUS_201  -- Section 10.2.2: Created
    , string "202" ==> STATUS_202  -- Section 10.2.3: Accepted
    , string "203" ==> STATUS_203  -- Section 10.2.4: Non-Authoritative Information
    , string "204" ==> STATUS_204  -- Section 10.2.5: No Content
    , string "205" ==> STATUS_205  -- Section 10.2.6: Reset Content
    , string "206" ==> STATUS_206  -- Section 10.2.7: Partial Content
    , string "300" ==> STATUS_300  -- Section 10.3.1: Multiple Choices
    , string "301" ==> STATUS_301  -- Section 10.3.2: Moved Permanently
    , string "302" ==> STATUS_302  -- Section 10.3.3: Found
    , string "303" ==> STATUS_303  -- Section 10.3.4: See Other
    , string "304" ==> STATUS_304  -- Section 10.3.5: Not Modified
    , string "305" ==> STATUS_305  -- Section 10.3.6: Use Proxy
    , string "307" ==> STATUS_307  -- Section 10.3.8: Temporary Redirect
    , string "400" ==> STATUS_400  -- Section 10.4.1: Bad Request
    , string "401" ==> STATUS_401  -- Section 10.4.2: Unauthorized
    , string "402" ==> STATUS_402  -- Section 10.4.3: Payment Required
    , string "403" ==> STATUS_403  -- Section 10.4.4: Forbidden
    , string "404" ==> STATUS_404  -- Section 10.4.5: Not Found
    , string "405" ==> STATUS_405  -- Section 10.4.6: Method Not Allowed
    , string "406" ==> STATUS_406  -- Section 10.4.7: Not Acceptable
    , string "407" ==> STATUS_407  -- Section 10.4.8: Proxy Authentication Required
    , string "408" ==> STATUS_408  -- Section 10.4.9: Request Time-out
    , string "409" ==> STATUS_409  -- Section 10.4.10: Conflict
    , string "410" ==> STATUS_410  -- Section 10.4.11: Gone
    , string "411" ==> STATUS_411  -- Section 10.4.12: Length Required
    , string "412" ==> STATUS_412  -- Section 10.4.13: Precondition Failed
    , string "413" ==> STATUS_413  -- Section 10.4.14: Request Entity Too Large
    , string "414" ==> STATUS_414  -- Section 10.4.15: Request-URI Too Large
    , string "415" ==> STATUS_415  -- Section 10.4.16: Unsupported Media Type
    , string "416" ==> STATUS_416  -- Section 10.4.17: Requested range not satisfiable
    , string "417" ==> STATUS_417  -- Section 10.4.18: Expectation Failed
    , string "500" ==> STATUS_500  -- Section 10.5.1: Internal Server Error
    , string "501" ==> STATUS_501  -- Section 10.5.2: Not Implemented
    , string "502" ==> STATUS_502  -- Section 10.5.3: Bad Gateway
    , string "503" ==> STATUS_503  -- Section 10.5.4: Service Unavailable
    , string "504" ==> STATUS_504  -- Section 10.5.5: Gateway Time-out
    , string "505" ==> STATUS_505  -- Section 10.5.6: HTTP Version not supported
    ]

parseStatus : '{Exception Text, Store Text} ResponseStatus
parseStatus = 'let
  !(string "HTTP/1.1 ")
  status = !parseStatusCode
  !(many (noneOfChars [?\n]))
  !(ch ?\n)
  status

parseHeaders : '{IO, Exception Text, Store Text} RawHeaders
parseHeaders = 'let
  parseHeaderLine = 'let
    name = !(many1 (noneOfChars [?:, ?\n]))
    !(ch ?:)
    value = !(many1 (noneOfChars [?\n]))
    !(ch ?\n)
    (fromCharList name, fromCharList value)
  headerLines = !(many parseHeaderLine)
  RawHeaders.RawHeaders (Map.fromList headerLines)

parseResponseHead : '{IO, Exception Text, Store Text} (ResponseStatus, RawHeaders)
parseResponseHead = 'let
  status = !parseStatus
  headers = !parseHeaders
  !parseCRLF
  (status, headers)

hexToNat : Text -> Nat
hexToNat =
  List.foldr (+) 0 . List.mapIndexed (i v -> (pow 16 i) * hexDigitValue v) . List.reverse . toCharList

hexDigitValue : Char -> Nat
hexDigitValue c = let
  nat = toNat (toLower c)
  if (nat >= 48) && (nat <= 57) then
    nat `drop` 48
  else
    nat `drop` 87

test> hexDigitValue.test = ._base.test.internals.v1.Test.check let
 List.map hexDigitValue (toCharList "0123456789abcdefABCDEF") == [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 10, 11, 12, 13, 14, 15]

parseChunkSize : '{Exception Text, Store Text} Nat
parseChunkSize = 'let
  hexDigits = fromCharList !(many1 parseHex)
  hexToNat hexDigits

parseChunkData : Nat -> '{IO, Exception Text, Store Text} Text
parseChunkData size = 'let
  v = !get
  if size > Text.size v then
    raise "Not enough data to consume"
  else
    Store.put (Text.drop size v)
    Text.take size v

parseChunk : '{IO, Exception Text, Store Text} (Nat, Text)
parseChunk = 'let
  chunkSize = !parseChunkSize
  if chunkSize == 0 then
    (0, "")
  else
    !parseCRLF
    chunkData = !(parseChunkData chunkSize)
    !(parseCRLF <|> '?a)
    (chunkSize, chunkData)

parseChunkedBody : '{IO, Exception Text, Store Text} ([(Nat, Text)], Text)
parseChunkedBody = 'let
  pre = size !get
  chunks = !(many parseChunk)
  (chunks, !get)

Request.get : HostName -> Text -> [(Text, Text)] -> Request
Request.get hostName path headers = let
  hostNameRaw = match hostName with HostName h -> h
  Request
    hostName
    ("GET " ++ path ++ " HTTP/1.1")
    (RawHeaders.RawHeaders (Map.fromList (("Host", hostNameRaw) +: headers)))

RawHeaders.lookup k = cases
  RawHeaders.RawHeaders map -> Map.lookup k map

expect! : Either e a -> {Exception e} a
expect! = cases
 Left e -> raise e
 Right v -> v

Request.make : Request -> {IO, Exception Text} Response
Request.make req = match req with
  Request.Request hostName head headers ->
    sock = expect! (Either.mapLeft (_ -> "Failed to connect") (clientSocket_ hostName (ServiceName "80")))
    sendAscii sock (Request.encode req)
    rawRes = receiveAllAscii sock
    match expect! (Unipar.run '(!parseResponseHead, !parseChunkedBody) rawRes) with
      ((status, headers), (firstChunks, leftovers)) ->
        match RawHeaders.lookup "Content-Length" headers with
          Some h -> Response.Response status headers leftovers
          None ->
            go chunks extraBuf = 'let
              if List.any (cases (s,_) -> s == 0) chunks then
                chunks
              else let
                newRaw = extraBuf ++ (receiveAllAscii sock)
                match expect! (Unipar.run parseChunkedBody newRaw) with
                  (newChunks, rest) -> !(go (chunks ++ newChunks) rest)
            finalChunks = !(go firstChunks leftovers)
            body = Text.concat (List.map Tuple.at2 finalChunks)
            Response.Response status headers body

Request.encode : Request -> Text
Request.encode = cases
  Request.Request hostName head headers ->
    head ++ "\n" ++ (RawHeaders.encode headers) ++ "\n"

RawHeaders.encode : RawHeaders -> Text
RawHeaders.encode = cases
  RawHeaders.RawHeaders hs ->
    pairs = List.map (cases (k, v) -> k ++ ": " ++ v ++ "\n") (Map.toList hs)
    Text.concat pairs


type Coordinate = Coordinate Text Text

Coordinate.show = cases Coordinate.Coordinate long lat ->
  "(" ++ long ++ ", " ++ lat ++ ")"

type ISSData =
  { position : Coordinate
  , timestamp : Int
  , message : Text
  }

decodeCoordinate : Decode Coordinate
decodeCoordinate =
  Decode.map2 Coordinate
    (Decode.field "longitude" Decode.string)
    (Decode.field "latitude" Decode.string)

decodeIss : Decode ISSData
decodeIss =
  Decode.succeed ISSData
    <*> Decode.field "iss_position" decodeCoordinate
    <*> Decode.field "timestamp" Decode.int
    <*> Decode.field "message" Decode.string

main = 'let
  request = Request.get (HostName "api.open-notify.org") "/iss-now.json" [("User-Agent", "unison-http")]
  response = Exception.toEither '(Request.make request)
  match response with
    Left e -> printLine "Could not make request"
    Right (Response.Response status headers body) ->
      match Decode.runParse decodeIss body with
        Right iss ->
          printLine ("The ISS is currently above " ++ Coordinate.show (ISSData.position iss))
        Left e -> printLine e