Add HTTP module for Matrix API requests

src/Internal/Api/Api.elm

@@ -0,0 +1,57 @@
+module Internal.Api.Api exposing (..)
+
+{-|
+
+
+# API
+
+The API module is a front-end for implementing API endpoints according to spec.
+
+-}
+
+import Internal.Api.Chain as C
+import Internal.Api.Request as R
+import Internal.Config.Log exposing (log)
+import Internal.Tools.Json as Json
+import Internal.Values.Context exposing (APIContext)
+import Internal.Values.Vault as V
+
+
+{-| A TaskChain helps create a chain of HTTP requests.
+-}
+type alias TaskChain ph1 ph2 =
+    C.TaskChain R.Error V.VaultUpdate { ph1 | baseUrl : () } { ph2 | baseUrl : () }
+
+
+request :
+    { attributes : List (R.Attribute { ph1 | baseUrl : () })
+    , coder : Json.Coder V.VaultUpdate
+    , contextChange : V.VaultUpdate -> (APIContext { ph1 | baseUrl : () } -> APIContext { ph2 | baseUrl : () })
+    , method : String
+    , path : List String
+    }
+    -> TaskChain ph1 ph2
+request data =
+    R.toChain
+        { logHttp =
+            \r ->
+                ( V.HttpRequest r
+                , String.concat
+                    -- TODO: Move this to Internal.Config.Text module
+                    [ "Matrix HTTP: "
+                    , r.method
+                    , " "
+                    , r.url
+                    ]
+                    |> log.info
+                    |> List.singleton
+                )
+        , coder = data.coder
+        , request =
+            R.callAPI
+                { method = data.method
+                , path = data.path
+                }
+                |> R.withAttributes data.attributes
+        , toContextChange = data.contextChange
+        }

src/Internal/Api/Chain.elm

@@ -1,4 +1,7 @@
-module Internal.Api.Chain exposing (TaskChain, IdemChain, CompleteChain)
+module Internal.Api.Chain exposing
+    ( TaskChain, CompleteChain
+    , IdemChain, toTask
+    )
 
 {-|
 
@@ -13,7 +16,12 @@ that all information is stored and values are dealt with appropriately.
 Elm's type checking system helps making this system sufficiently rigorous to
 avoid leaking values passing through the API in unexpected ways.
 
-@docs TaskChain, IdemChain, CompleteChain
+@docs TaskChain, CompleteChain
+
+
+## Finished chain
+
+@docs IdemChain, toTask
 
 -}
 
@@ -173,3 +181,17 @@ onError onErr f =
 succeed : TaskChainPiece u a b -> TaskChain err u a b
 succeed piece _ =
     Task.succeed piece
+
+
+{-| Once the chain is complete, turn it into a valid task.
+-}
+toTask : IdemChain Never u a -> APIContext a -> Task.Task Never (Backpacked u {})
+toTask chain context =
+    chain context
+        |> Task.onError (\e -> Task.succeed <| never e.error)
+        |> Task.map
+            (\backpack ->
+                { messages = backpack.messages
+                , logs = backpack.logs
+                }
+            )

src/Internal/Api/Request.elm

@@ -1,6 +1,7 @@
 module Internal.Api.Request exposing
-    ( ApiCall, ApiPlan, callAPI, withAttributes
+    ( ApiCall, ApiPlan, Attribute, callAPI, withAttributes, toChain
-    , accessToken, withTransactionId
+    , Request, Error(..)
+    , accessToken, withTransactionId, timeout
     , fullBody, bodyBool, bodyInt, bodyString, bodyValue, bodyOpBool, bodyOpInt, bodyOpString, bodyOpValue
     , queryBool, queryInt, queryString, queryOpBool, queryOpInt, queryOpString
     )
@@ -15,7 +16,11 @@ This module helps describe API requests.
 
 ## Plan
 
-@docs ApiCall, ApiPlan, callAPI, withAttributes
+@docs ApiCall, ApiPlan, Attribute, callAPI, withAttributes, toChain
+
+Sometimes, APIs might fail. As a result, you may receive an error.
+
+@docs Request, Error
 
 
 ## API attributes
@@ -23,7 +28,7 @@ This module helps describe API requests.
 
 ### General attributes
 
-@docs accessToken, withTransactionId
+@docs accessToken, withTransactionId, timeout
 
 
 ### Body
@@ -37,9 +42,16 @@ This module helps describe API requests.
 
 -}
 
+import Dict
 import Http
+import Internal.Api.Chain as C
+import Internal.Config.Log exposing (Log, log)
+import Internal.Config.Text as Text
 import Internal.Tools.Json as Json
 import Internal.Values.Context as Context exposing (APIContext)
+import Json.Decode as D
+import Json.Encode as E
+import Task
 import Url
 import Url.Builder as UrlBuilder
 
@@ -52,6 +64,7 @@ type alias ApiCall ph =
     , baseUrl : String
     , context : APIContext ph
     , method : String
+    , path : List String
     }
 
 
@@ -77,8 +90,27 @@ type ContextAttr
     | NoAttr
     | QueryParam UrlBuilder.QueryParameter
     | ReplaceInUrl String String
+    | StatusCodeResponse Int ( Error, List Log )
     | Timeout Float
-    | UrlPath String
+
+
+{-| Error indicating that something went wrong.
+-}
+type Error
+    = InternetException Http.Error
+    | ServerReturnsBadJSON String
+
+
+{-| Ordinary shape of an HTTP request.
+-}
+type alias Request x a =
+    { headers : List Http.Header
+    , body : Http.Body
+    , method : String
+    , url : String
+    , resolver : Http.Resolver x a
+    , timeout : Maybe Float
+    }
 
 
 {-| Attribute that requires an access token to be present
@@ -171,19 +203,73 @@ bodyValue key value _ =
 -}
 callAPI : { method : String, path : List String } -> ApiPlan { a | baseUrl : () }
 callAPI { method, path } context =
-    { attributes =
+    { attributes = []
-        path
-            |> List.map Url.percentEncode
-            |> String.join "/"
-            |> (++) "/"
-            |> UrlPath
-            |> List.singleton
     , baseUrl = Context.getBaseUrl context
     , context = context
     , method = method
+    , path = path
     }
 
 
+{-| Decode the server's response into (hopefully) something meaningful.
+-}
+decodeServerResponse : D.Decoder ( a, List Log ) -> String -> Maybe ( Error, List Log ) -> Result ( Error, List Log ) ( a, List Log )
+decodeServerResponse decoder body statusCodeError =
+    case D.decodeString D.value body of
+        Err e ->
+            let
+                description : String
+                description =
+                    D.errorToString e
+            in
+            Err
+                ( ServerReturnsBadJSON description
+                , description
+                    |> Text.logs.serverReturnedInvalidJSON
+                    |> log.error
+                    |> List.singleton
+                )
+
+        Ok v ->
+            decodeServerValue decoder v statusCodeError
+
+
+{-| Decode the server's response, assuming that it parses correctly to
+a JSON value.
+-}
+decodeServerValue : D.Decoder ( a, List Log ) -> Json.Value -> Maybe ( Error, List Log ) -> Result ( Error, List Log ) ( a, List Log )
+decodeServerValue decoder value statusCodeError =
+    value
+        |> D.decodeValue decoder
+        |> Result.mapError
+            (\err ->
+                let
+                    description : String
+                    description =
+                        D.errorToString err
+
+                    -- TODO: Parse errors returned by Matrix API
+                    error : Maybe ( Error, List Log )
+                    error =
+                        Nothing
+                in
+                case ( error, statusCodeError ) of
+                    ( Just e, _ ) ->
+                        e
+
+                    ( Nothing, Just e ) ->
+                        e
+
+                    ( Nothing, Nothing ) ->
+                        ( ServerReturnsBadJSON description
+                        , description
+                            |> Text.logs.serverReturnedUnknownJSON
+                            |> log.error
+                            |> List.singleton
+                        )
+            )
+
+
 {-| Add an empty attribute that does nothing.
 -}
 empty : Attribute a
@@ -198,6 +284,158 @@ fullBody value _ =
     FullBody value
 
 
+getBody : List ContextAttr -> Json.Value
+getBody attributes =
+    attributes
+        |> List.filterMap
+            (\attr ->
+                case attr of
+                    FullBody v ->
+                        Just v
+
+                    _ ->
+                        Nothing
+            )
+        |> List.reverse
+        |> List.head
+        |> Maybe.withDefault
+            (List.filterMap
+                (\attr ->
+                    case attr of
+                        BodyParam key value ->
+                            Just ( key, value )
+
+                        _ ->
+                            Nothing
+                )
+                attributes
+                |> E.object
+            )
+
+
+getHeaders : List ContextAttr -> List Http.Header
+getHeaders =
+    List.filterMap
+        (\attr ->
+            case attr of
+                Header h ->
+                    Just h
+
+                _ ->
+                    Nothing
+        )
+
+
+getQueryParams : List ContextAttr -> List UrlBuilder.QueryParameter
+getQueryParams =
+    List.filterMap
+        (\attr ->
+            case attr of
+                QueryParam q ->
+                    Just q
+
+                _ ->
+                    Nothing
+        )
+
+
+getStatusCodes : List ContextAttr -> Dict.Dict Int ( Error, List Log )
+getStatusCodes =
+    List.filterMap
+        (\attr ->
+            case attr of
+                StatusCodeResponse code err ->
+                    Just ( code, err )
+
+                _ ->
+                    Nothing
+        )
+        >> Dict.fromList
+
+
+getTimeout : List ContextAttr -> Maybe Float
+getTimeout =
+    List.filterMap
+        (\attr ->
+            case attr of
+                Timeout f ->
+                    Just f
+
+                _ ->
+                    Nothing
+        )
+        >> List.reverse
+        >> List.head
+
+
+getUrl : ApiCall a -> String
+getUrl { attributes, baseUrl, path } =
+    UrlBuilder.crossOrigin
+        baseUrl
+        (path
+            |> List.map
+                (\p ->
+                    List.foldl
+                        (\attr cp ->
+                            case attr of
+                                ReplaceInUrl from to ->
+                                    if from == cp then
+                                        to
+
+                                    else
+                                        cp
+
+                                _ ->
+                                    cp
+                        )
+                        p
+                        attributes
+                )
+            |> List.map Url.percentEncode
+        )
+        (getQueryParams attributes)
+
+
+{-| Resolve the response of a Matrix API call.
+-}
+rawApiCallResolver : Json.Coder a -> Dict.Dict Int ( Error, List Log ) -> Http.Resolver ( Error, List Log ) ( a, List Log )
+rawApiCallResolver coder statusCodeErrors =
+    Http.stringResolver
+        (\response ->
+            case response of
+                Http.BadUrl_ s ->
+                    Http.BadUrl s
+                        |> InternetException
+                        |> Tuple.pair
+                        |> (|>) []
+                        |> Err
+
+                Http.Timeout_ ->
+                    Http.Timeout
+                        |> InternetException
+                        |> Tuple.pair
+                        |> (|>) []
+                        |> Err
+
+                Http.NetworkError_ ->
+                    Http.NetworkError
+                        |> InternetException
+                        |> Tuple.pair
+                        |> (|>) []
+                        |> Err
+
+                Http.BadStatus_ metadata body ->
+                    statusCodeErrors
+                        |> Dict.get metadata.statusCode
+                        |> decodeServerResponse (Json.decode coder) body
+
+                Http.GoodStatus_ metadata body ->
+                    statusCodeErrors
+                        |> Dict.get metadata.statusCode
+                        |> decodeServerResponse (Json.decode coder) body
+        )
+
+
 {-| Add a boolean value as a query parameter to the URL.
 -}
 queryBool : String -> Bool -> Attribute a
@@ -262,6 +500,54 @@ queryString key value _ =
     QueryParam <| UrlBuilder.string key value
 
 
+timeout : Float -> Attribute a
+timeout f _ =
+    Timeout f
+
+
+{-| Transform an APICall to a TaskChain.
+-}
+toChain :
+    { logHttp : Request ( Error, List Log ) ( update, List Log ) -> ( update, List Log )
+    , coder : Json.Coder update
+    , request : ApiPlan ph1
+    , toContextChange : update -> (APIContext ph1 -> APIContext ph2)
+    }
+    -> C.TaskChain Error update ph1 ph2
+toChain data apiContext =
+    data.request apiContext
+        |> (\call ->
+                let
+                    r : Request ( Error, List Log ) ( update, List Log )
+                    r =
+                        { method = call.method
+                        , headers = getHeaders call.attributes
+                        , url = getUrl call
+                        , body = Http.jsonBody (getBody call.attributes)
+                        , resolver = rawApiCallResolver data.coder (getStatusCodes call.attributes)
+                        , timeout = getTimeout call.attributes
+                        }
+                in
+                case data.logHttp r of
+                    ( httpU, httpLogs ) ->
+                        Http.task r
+                            |> Task.map
+                                (\( u, logs ) ->
+                                    { contextChange = data.toContextChange u
+                                    , logs = List.append httpLogs logs
+                                    , messages = [ httpU, u ]
+                                    }
+                                )
+                            |> Task.mapError
+                                (\( err, logs ) ->
+                                    { error = err
+                                    , logs = List.append httpLogs logs
+                                    , messages = [ httpU ]
+                                    }
+                                )
+           )
+
+
 {-| Add more attributes to the API plan.
 -}
 withAttributes : List (Attribute a) -> ApiPlan a -> ApiPlan a

src/Internal/Api/Task.elm

@@ -0,0 +1,39 @@
+module Internal.Api.Task exposing (..)
+
+import Internal.Api.Chain as C
+import Internal.Api.Request as Request
+import Internal.Config.Log exposing (Log)
+import Internal.Values.Context exposing (APIContext)
+import Internal.Values.Envelope exposing (EnvelopeUpdate(..))
+import Internal.Values.Room exposing (RoomUpdate(..))
+import Internal.Values.Vault exposing (VaultUpdate(..))
+import Task
+
+
+{-| A Backpack is the ultimate message type that gets sent back by the Elm
+runtime, which can be accessed, viewed and inspected.
+-}
+type alias Backpack =
+    { messages : List (EnvelopeUpdate VaultUpdate), logs : List Log }
+
+
+{-| A Task is a task that is ready to be sent to the outside world.
+-}
+type alias Task =
+    C.TaskChain Never (EnvelopeUpdate VaultUpdate) {} {}
+
+
+{-| An UnFinished Task that is used somewhere else in this module to write a
+complete Task type.
+-}
+type alias UFTask a b =
+    C.TaskChain Request.Error (EnvelopeUpdate VaultUpdate) a b
+
+
+{-| Transform a completed task into a Cmd.
+-}
+run : (Backpack -> msg) -> Task -> APIContext {} -> Cmd msg
+run toMsg task context =
+    context
+        |> C.toTask task
+        |> Task.perform toMsg

src/Internal/Config/Text.elm

@@ -535,7 +535,11 @@ leakingValueFound leaking_value =
 happened. Most of these unexpected results, are taken account of by the Elm SDK,
 but logged so that the programmer can do something about it.
 -}
-logs : { keyIsNotAnInt : String -> String }
+logs :
+    { keyIsNotAnInt : String -> String
+    , serverReturnedInvalidJSON : String -> String
+    , serverReturnedUnknownJSON : String -> String
+    }
 logs =
     { keyIsNotAnInt =
         \key ->
@@ -544,6 +548,8 @@ logs =
                 , key
                 , "` that cannot be converted to an Int"
                 ]
+    , serverReturnedInvalidJSON = (++) "The server returned invalid JSON: "
+    , serverReturnedUnknownJSON = (++) "The server returned JSON that doesn't seem to live up to spec rules: "
     }
 
 

src/Internal/Values/Vault.elm

@@ -33,6 +33,8 @@ Rooms are environments where people can have a conversation with each other.
 -}
 
 import FastDict as Dict exposing (Dict)
+import Internal.Api.Request as Request
+import Internal.Config.Log exposing (Log)
 import Internal.Config.Text as Text
 import Internal.Tools.Hashdict as Hashdict exposing (Hashdict)
 import Internal.Tools.Json as Json
@@ -52,6 +54,7 @@ based on new information provided by the Matrix API.
 -}
 type VaultUpdate
     = CreateRoomIfNotExists String
+    | HttpRequest (Request.Request ( Request.Error, List Log ) ( VaultUpdate, List Log ))
     | MapRoom String Room.RoomUpdate
     | More (List VaultUpdate)
     | SetAccountData String Json.Value
@@ -126,6 +129,11 @@ update vu vault =
                 (Maybe.withDefault (Room.init roomId) >> Maybe.Just)
                 vault
 
+        -- The HTTP request currently isn't used anywhere other than for
+        -- auditing the requests that the Vault is making
+        HttpRequest _ ->
+            vault
+
         MapRoom roomId ru ->
             mapRoom roomId (Room.update ru) vault