Add HTTP module for Matrix API requests

4-compiler-bug
Bram 2024-05-17 14:28:06 +02:00
parent 7935e112ed
commit 2e8185841a
6 changed files with 433 additions and 15 deletions

57
src/Internal/Api/Api.elm Normal file
View File

@ -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
}

View File

@ -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
}
)

View File

@ -1,6 +1,7 @@
module Internal.Api.Request exposing
( ApiCall, ApiPlan, callAPI, withAttributes
, accessToken, withTransactionId
( ApiCall, ApiPlan, Attribute, callAPI, withAttributes, toChain
, 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 =
path
|> List.map Url.percentEncode
|> String.join "/"
|> (++) "/"
|> UrlPath
|> List.singleton
{ attributes = []
, 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

39
src/Internal/Api/Task.elm Normal file
View File

@ -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

View File

@ -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: "
}

View File

@ -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