{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Data.JsonSpec.Elm.Servant (
-- * Generating Elm Clients
servantDefs,
-- * Extensions
{-|
The symbols in this section are mainly exposed in case you are using
some extensions to the standard servant types and need to build some
companion extensions to generate proper Elm types for them. For most
normal usage you will probably just use 'servantDefs'.
-}
Elmable(..),
IsParam(..),
Param(..),
PathParam(..),
HeaderParam(..),
QP(..),
) where
import Bound (Var(B, F), Scope, abstract1, closed, toScope)
import Control.Monad.Writer (MonadTrans(lift), MonadWriter(tell),
execWriter)
import Data.Foldable (Foldable(fold))
import Data.JsonSpec (HasJsonDecodingSpec(DecodingSpec),
HasJsonEncodingSpec(EncodingSpec))
import Data.JsonSpec.Elm (HasType(decoderOf, encoderOf, typeOf),
Definitions)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Proxy (Proxy(Proxy))
import Data.Set (Set)
import Data.String (IsString(fromString))
import Data.Text (Text)
import Data.Void (Void, absurd)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Elm.Definition (Definition)
import Language.Elm.Expression ((<|), Expression)
import Language.Elm.Type (Type)
import Network.HTTP.Types (Method)
import Prelude (Applicative(pure), Foldable(foldr, length), Maybe(Just,
Nothing), Semigroup((<>)), ($), (.), (<$>), Eq, Int, error, reverse)
import Servant.API (ReflectMethod(reflectMethod), (:<|>), (:>), Capture,
Header', Headers, JSON, NamedRoutes, NoContent, NoContentVerb, Optional,
QueryParam', ReqBody', Required, ToServantApi, Verb)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
import qualified Language.Elm.Definition as Def
import qualified Language.Elm.Expression as Expr
import qualified Language.Elm.Name as Name
import qualified Language.Elm.Pattern as Pat
import qualified Language.Elm.Type as Type
{-|
This function will traverse the @api@ type, generating elm definitions for:
* Http requests for each endpoint, including encoders and decoders for
anonymous elm types.
* Named Elm types (i.e. Any 'Specification' that is bound to a name using
'JsonLet'
* Decoders and Encoders for named elm types.
-}
servantDefs :: forall api. (Elmable api) => Proxy api -> Set Definition
servantDefs _ =
builtins
<> execWriter (endpoints @api [])
builtins :: Set Definition
builtins =
Set.fromList
[ Def.Alias
"Api.Req.Request"
1
(
toScope $
Type.Record
[ (Name.Field "method", "Basics.String")
, (Name.Field "headers", "Basics.List" `Type.App` "Http.Header")
, (Name.Field "url", "Basics.String")
, (Name.Field "body", "Http.Body")
, ( Name.Field "decoder"
, "Api.Req.Either"
`Type.App` Type.Var (B 0)
`Type.App` ("Json.Decode.Decoder" `Type.App` Type.Var (B 0))
)
]
)
, Def.Type
"Api.Req.Either"
2
[ ( Name.Constructor "Left"
, [toScope (Type.Var (B 0))]
)
, ( Name.Constructor "Right"
, [toScope (Type.Var (B 1))]
)
]
, Def.Constant
"Api.Req.task"
1
(
toScope $
let
var :: Type (Bound.Var Int a)
var = Type.Var (B 0)
in
Type.Fun
("Api.Req.Request" `Type.App` var)
(Type.apps "Task.Task" ["Http.Error", var])
)
(
Expr.Lam . toScope $
let
req :: Expression (Bound.Var () a)
req = Expr.Var (B ())
f :: Text -> b -> (Name.Field, b)
f name expr = (Name.Field name, expr)
p :: Expression v -> Text -> Expression v
p v name = Expr.Proj (Name.Field name) `Expr.App` v
in
"Http.task" <|
Expr.Record
[ f "method" $ p req "method"
, f "headers" $ p req "headers"
, f "url" $ p req "url"
, f "body" $ p req "body"
, f "timeout" "Maybe.Nothing"
, f "resolver" $
"Http.stringResolver" `Expr.App`
(
Expr.Lam . toScope $
let
var :: Expression (Bound.Var () a)
var = Expr.Var (B ())
pat
:: Name.Qualified
-> [Pat.Pattern v]
-> Expression (Bound.Var b a)
-> (Pat.Pattern v, Scope b Expression a)
pat con vars expr =
(Pat.Con con vars, toScope expr)
patVar :: Int -> Expression (Bound.Var Int a)
patVar n = Expr.Var (B n)
in
Expr.Case
var
[ pat "Http.BadUrl_" [Pat.Var 0] $
"Result.Err" `Expr.App`
("Http.BadUrl" `Expr.App` patVar 0)
, pat "Http.Timeout_" [] $
"Result.Err" `Expr.App` "Http.Timeout"
, pat "Http.NetworkError_" [] $
"Result.Err" `Expr.App` "Http.NetworkError"
, pat "Http.BadStatus_" [Pat.Var 0, Pat.Var 1] $
"Result.Err" `Expr.App`
(
"Http.BadStatus" `Expr.App`
p (patVar 0) "statusCode"
)
, pat
"Http.GoodStatus_"
[Pat.Var 0, Pat.Var 1]
(
Expr.Case
( F . F <$> p req "decoder")
[ pat "Api.Req.Left" [Pat.Var 0] $
"Result.Ok" `Expr.App` patVar 0
, pat "Api.Req.Right" [Pat.Var 0] $
Expr.Case
(
Expr.apps
"Json.Decode.decodeString"
[ patVar 0
, F <$> patVar 1
]
)
[ pat "Result.Err" [Pat.Var 0] $
"Result.Err"
<| "Http.BadBody"
<| "Json.Decode.errorToString"
<| patVar 0
, pat "Result.Ok" [Pat.Var 0] $
"Result.Ok" <| patVar 0
]
]
)
]
)
]
)
]
{-| Class of servant APIs for which Elm client code can be generated. -}
class Elmable e where
{-|
Collect all the Elm definitions needed to implement a client for
the API. This is called recursively on our walk down the API tree,
and the @['Param']@ argument contains all the request parameters
(like 'Servant.API.Capture', 'Servant.API.ReqBody'', etc) that have been encountered so far on
whatever particular branch . It will start out empty at the API root.
-}
endpoints :: [Param] -> Definitions ()
instance (Elmable a, Elmable b) => Elmable (a :<|> b) where
endpoints params = do
endpoints @a params
endpoints @b params
instance (Elmable (ToServantApi api)) => Elmable (NamedRoutes api) where
endpoints = endpoints @(ToServantApi api)
instance (IsParam a, Elmable b) => Elmable (a :> b) where
endpoints params = do
p <- param @a
endpoints @b (p : params)
instance (Elmable (Verb m c t r)) => Elmable (Verb m c t (Headers h r)) where
endpoints = endpoints @(Verb m c t r)
instance {- Elmable (Verb m c t NoContent) -}
(Elmable (NoContentVerb m))
=>
Elmable (Verb m c t NoContent)
where
endpoints = endpoints @(NoContentVerb m)
instance {- Elmable (Verb method code types response) -}
{-# overlaps #-}
( HasType (EncodingSpec response)
, ReflectMethod method
)
=>
Elmable (Verb method code types response)
where
endpoints (reverse -> params) = do
responseType <- typeOf @(EncodingSpec response)
decoder <- decoderOf @(EncodingSpec response)
tell . Set.singleton $
Def.Constant
(requestFunctionName @method params)
(length params)
(requestFunctionType params responseType)
(
requestFunctionBody
params
(reflectMethod (Proxy @method))
("Api.Req.Right" `Expr.App` decoder)
)
pure ()
instance (ReflectMethod method) => Elmable (NoContentVerb method) where
endpoints (reverse -> params) = do
tell . Set.singleton $
Def.Constant
(requestFunctionName @method params)
(length params)
(requestFunctionType params "Basics.()")
(
requestFunctionBody
params
(reflectMethod (Proxy @method))
("Api.Req.Left" `Expr.App` "Basics.()")
)
pure ()
{-|
Obtain a value-level request parameter type from the type-level servant
parameter type.
-}
class IsParam a where
param :: Definitions Param
instance (KnownSymbol name) => IsParam (Capture name tpy) where
param = pure $ PathParam (Capture (sym @name))
instance (KnownSymbol name) => IsParam (Header' (Optional : mods) name a) where
param = pure $ HeaderParam (OptionalHeader (sym @name))
instance (KnownSymbol name) => IsParam (Header' (Required : mods) name a) where
param = pure $ HeaderParam (RequiredHeader (sym @name))
instance {- IsParam (Header' (other : mods) name a) -}
{-# OVERLAPS #-} (IsParam (Header' mods name a))
=>
IsParam (Header' (other : mods) name a)
where
param = param @(Header' mods name a)
instance {- IsParam (ReqBody' (Required : mods) (JSON : accept) a) -}
(HasType (DecodingSpec a))
=>
IsParam (ReqBody' (Required : mods) (JSON : accept) a)
where
param = do
elmType <- typeOf @(DecodingSpec a)
encoder <- encoderOf @(DecodingSpec a)
pure $ BodyEncoder {elmType, encoder}
instance {- IsParam (ReqBody' (other : mods) (JSON : accept) a) -}
{-# overlaps #-} (IsParam (ReqBody' mods '[JSON] a))
=>
IsParam (ReqBody' (other : mods) (JSON : accept) a)
where
param = param @(ReqBody' mods '[JSON] a)
instance {- IsParam (ReqBody' mods (other : accept) a) -}
{-# overlaps #-} (IsParam (ReqBody' mods accept a))
=>
IsParam (ReqBody' mods (other : accept) a)
where
param = param @(ReqBody' mods accept a)
instance (KnownSymbol segment) => IsParam (segment :: Symbol) where
param = pure $ PathParam (Static (sym @segment))
instance {- IsParam (QueryParam' (Optional : more) name typ) -}
(KnownSymbol name)
=>
IsParam (QueryParam' (Optional : more) name typ)
where
param = pure $ QueryParam (OptionalQP (sym @name))
instance {- IsParam (QueryParam' (Required : more) name typ) -}
(KnownSymbol name)
=>
IsParam (QueryParam' (Required : more) name typ)
where
param = pure $ QueryParam (RequiredQP (sym @name))
instance {- IsParam (QueryParam' (other : more) name typ) -}
{-# overlaps #-} (IsParam (QueryParam' more name typ))
=>
IsParam (QueryParam' (other : more) name typ)
where
param = param @(QueryParam' more name typ)
requestFunctionName
:: forall method. (ReflectMethod method)
=> [Param]
-> Name.Qualified
requestFunctionName params =
Name.Qualified
["Api", "Req"]
(fold (methodName : pathParts))
where
methodName :: Text
methodName =
Text.toLower
. TE.decodeUtf8
. reflectMethod
$ Proxy @method
pathParts :: [Text]
pathParts =
Text.toTitle <$>
mapMaybe
(\case
PathParam (Static segment) -> Just (munge segment)
PathParam (Capture name) -> Just (munge name)
_ -> Nothing
)
params
{-
Try to generate valid names in the face of common api path
idioms. It isn't really worth it for this to be complete, but we
at least want to cover the basics
-}
munge :: Text -> Text
munge = Text.replace "-" "_"
requestFunctionType
:: [Param]
-> Type Void
-> Scope Int Type Void
requestFunctionType params responseType =
lift funType
where
funType :: Type Void
funType =
foldr
Type.Fun
("Api.Req.Request" `Type.App` responseType)
(
mapMaybe
(\case
PathParam (Capture _) -> Just "Basics.String"
PathParam (Static _) -> Nothing
QueryParam (RequiredQP _) -> Just "Basics.String"
QueryParam (OptionalQP _) ->
Just ("Basics.Maybe" `Type.App` "Basics.String")
HeaderParam (RequiredHeader _) -> Just "Basics.String"
HeaderParam (OptionalHeader _) ->
Just ("Basics.Maybe" `Type.App` "Basics.String")
BodyEncoder typ _ -> Just typ
)
params
)
requestFunctionBody
:: [Param]
-> Method
-> Expression Void
-> Expression Void
requestFunctionBody params method decoder =
buildLambda
(reverse params)
(
Expr.Record
[ (Name.Field "method", Expr.String (TE.decodeUtf8 method))
, (Name.Field "headers", headers)
, (Name.Field "url", url)
, (Name.Field "body", body)
, (Name.Field "decoder", Expr.bind g absurd decoder)
]
)
where
headers :: Expression Param
headers =
Expr.apps
"List.filterMap"
[ "Basics.identity"
, Expr.List
[ headerExpr header
| HeaderParam header <- params
]
]
where
headerExpr :: HeaderParam -> Expression Param
headerExpr header =
Expr.apps
"Maybe.map"
[ "Http.header" `Expr.App` Expr.String name
, case header of
RequiredHeader _ ->
"Maybe.Just" `Expr.App` Expr.Var (HeaderParam header)
OptionalHeader _ -> Expr.Var (HeaderParam header)
]
where
name :: Text
name =
case header of
RequiredHeader n -> n
OptionalHeader n -> n
url :: Expression Param
url =
Expr.apps
"Url.Builder.absolute"
[
Expr.List
[ case pp of
Static part -> Expr.String part
Capture _ -> Expr.Var param_
| param_@(PathParam pp) <- params
]
, Expr.apps
"List.filterMap"
[ "Basics.identity"
, Expr.List
[ let
name :: Text
name = case qp of { RequiredQP n -> n; OptionalQP n -> n}
queryExpr :: Expression Param
queryExpr =
Expr.apps
"Maybe.map"
[ "Url.Builder.string" `Expr.App` Expr.String name
, case qp of
RequiredQP _ ->
"Maybe.Just" `Expr.App` Expr.Var param_
OptionalQP _ -> Expr.Var param_
]
in
queryExpr
| param_@(QueryParam qp) <- params
]
]
]
body :: Expression Param
body =
case
[ g "Http.jsonBody" `Expr.App`
((absurd <$> encoder) `Expr.App` Expr.Var param_)
| param_@(BodyEncoder _ encoder) <- params
]
of
[] -> g "Http.emptyBody"
(encoder : _) -> encoder
buildLambda :: [Param] -> Expression Param -> Expression Void
buildLambda = \cases
[] e ->
fromMaybe
(error "Paramaters in expression to not match the parameter list.")
(Bound.closed e)
(PathParam (Static _) : more) e ->
buildLambda more e
(p : more) e ->
buildLambda
more
(Expr.Lam (abstract1 p e))
data Param
= PathParam PathParam
| HeaderParam HeaderParam
| QueryParam QP
| BodyEncoder
{ elmType :: Type Void
, encoder :: Expression Void
}
deriving stock (Eq)
data QP
= RequiredQP Text
| OptionalQP Text
deriving stock (Eq)
data PathParam
= Static Text
| Capture Text
deriving stock (Eq)
data HeaderParam
= RequiredHeader Text
| OptionalHeader Text
deriving stock (Eq)
g :: Name.Qualified -> Expression any
g = Expr.Global
sym
:: forall a b.
( IsString b
, KnownSymbol a
)
=> b
sym = fromString $ symbolVal (Proxy @a)