diff --git a/json-spec-elm-servant.cabal b/json-spec-elm-servant.cabal --- a/json-spec-elm-servant.cabal +++ b/json-spec-elm-servant.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: json-spec-elm-servant -version: 0.3.0.0 +version: 0.3.1.0 synopsis: Generated elm code for servant APIs. description: Generate Elm encoders, decoders, and API requests for an Servant API, where the shape of the data diff --git a/src/Data/JsonSpec/Elm/Servant.hs b/src/Data/JsonSpec/Elm/Servant.hs --- a/src/Data/JsonSpec/Elm/Servant.hs +++ b/src/Data/JsonSpec/Elm/Servant.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -14,7 +15,22 @@ {-# 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 @@ -41,7 +57,7 @@ Nothing), Semigroup((<>)), ($), (.), (<$>), Eq, Int, error, reverse) import Servant.API (ReflectMethod(reflectMethod), (:<|>), (:>), Capture, Header', Headers, JSON, NamedRoutes, NoContent, NoContentVerb, Optional, - ReqBody', Required, ToServantApi, Verb) + QueryParam', ReqBody', Required, ToServantApi, Verb) import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as TE @@ -52,6 +68,14 @@ 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 @@ -162,7 +186,7 @@ ( 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] $ + , pat "Api.Req.Right" [Pat.Var 0] $ Expr.Case ( Expr.apps @@ -189,7 +213,15 @@ ] +{-| 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 'Capture', '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 @@ -248,6 +280,10 @@ 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 @@ -268,9 +304,9 @@ IsParam (ReqBody' (Required : mods) (JSON : accept) a) where param = do - typ <- typeOf @(DecodingSpec a) + elmType <- typeOf @(DecodingSpec a) encoder <- encoderOf @(DecodingSpec a) - pure $ BodyEncoder typ encoder + pure $ BodyEncoder {elmType, encoder} instance {- IsParam (ReqBody' (other : mods) (JSON : accept) a) -} {-# overlaps #-} (IsParam (ReqBody' mods '[JSON] a)) => @@ -285,6 +321,24 @@ 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 @@ -332,6 +386,9 @@ (\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") @@ -398,7 +455,29 @@ Capture _ -> Expr.Var param_ | param_@(PathParam pp) <- params ] - , Expr.List [] + , 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 @@ -429,7 +508,17 @@ data Param = PathParam PathParam | HeaderParam HeaderParam - | BodyEncoder (Type Void) (Expression Void) + | QueryParam QP + | BodyEncoder + { elmType :: Type Void + , encoder :: Expression Void + } + deriving stock (Eq) + + +data QP + = RequiredQP Text + | OptionalQP Text deriving stock (Eq) diff --git a/test/Api.hs b/test/Api.hs --- a/test/Api.hs +++ b/test/Api.hs @@ -62,9 +62,10 @@ import Prelude (Applicative(pure), Either(Left, Right), Functor(fmap), Traversable(traverse), (.), (<$>), Eq, Int, Ord) import Servant.API (FromHttpApiData(parseHeader, parseQueryParam), - GenericMode((:-)), StdMethod(GET), (:>), Capture, DeleteNoContent, Get, - Header, Header', Headers, JSON, NamedRoutes, NoContent, Optional, Post, - PostNoContent, ReqBody, ReqBody', Required, Strict, ToHttpApiData, Verb) + GenericMode((:-)), StdMethod(GET), (:>), Capture, DeleteNoContent, + Get, Header, Header', Headers, JSON, NamedRoutes, NoContent, Optional, + Post, PostNoContent, QueryParam', ReqBody, ReqBody', Required, Strict, + ToHttpApiData, Verb) import Web.Cookie (SetCookie) import qualified Data.Map as Map import qualified Data.Set as Set @@ -117,6 +118,8 @@ , dashboard :: mode :- "dashboard" + :> QueryParam' '[Required, Strict] "foo" Text + :> QueryParam' '[Optional, Strict] "bar" Text :> Get '[JSON] DashboardData , addInvite :: mode