json-spec-elm-servant (empty) → 0.1.0.0
raw patch · 6 files changed
+1240/−0 lines, 6 filesdep +aesondep +basedep +binary
Dependencies added: aeson, base, binary, bound, bytestring, containers, cookie, directory, elm-syntax, hspec, http-types, json-spec, json-spec-elm, json-spec-elm-servant, mtl, prettyprinter, process, servant, text, time, unordered-containers, uuid
Files
- LICENSE +21/−0
- README.md +8/−0
- json-spec-elm-servant.cabal +75/−0
- src/Data/JsonSpec/Elm/Servant.hs +443/−0
- test/Api.hs +619/−0
- test/test.hs +74/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2023 Rick Owens++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,8 @@+# json-spec-elm-servant++Generate Elm encoders, decoders, and API requests for an Servant API,+where the shape of the data going over the API is described using+`json-spec`.++See the `/test/test.hs` and `/test/Api.hs` for an example.+
+ json-spec-elm-servant.cabal view
@@ -0,0 +1,75 @@+cabal-version: 3.0+name: json-spec-elm-servant+version: 0.1.0.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+ going over the API is described using `json-spec`.++ See the `/test/test.hs` and `/test/Api.hs` for+ an example.++homepage: https://github.com/owensmurray/json-spec-elm-servant+license: MIT+license-file: LICENSE+author: Rick Owens+maintainer: rick@owensmurray.com+copyright: 2022 Rick Owens+category: JSON, Elm, Servant, Web+build-type: Simple+extra-source-files:+ README.md+ LICENSE++common dependencies+ build-depends:+ , base >= 4.17.1.0 && < 4.18+ , bound >= 2.0.7 && < 2.1+ , containers >= 0.6.7 && < 0.7+ , directory >= 1.3.7.1 && < 1.4+ , elm-syntax >= 0.3.2.0 && < 0.4+ , http-types >= 0.12.3 && < 0.13+ , json-spec >= 0.2.1.1 && < 0.3+ , json-spec-elm >= 0.1.0.1 && < 0.2+ , mtl >= 2.2.2 && < 2.3+ , prettyprinter >= 1.7.1 && < 1.8+ , process >= 1.6.16.0 && < 1.7+ , servant >= 0.20 && < 0.21+ , text >= 2.0.2 && < 2.1+ , unordered-containers >= 0.2.19.1 && < 0.3++common warnings+ ghc-options:+ -Wmissing-deriving-strategies+ -Wmissing-export-lists+ -Wmissing-import-lists+ -Wredundant-constraints+ -Wall++library+ import: dependencies, warnings+ exposed-modules: + Data.JsonSpec.Elm.Servant+ -- other-modules: + -- other-extensions: + hs-source-dirs: src+ default-language: Haskell2010++test-suite test+ import: dependencies, warnings+ main-is: test.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ other-modules:+ Api+ build-depends:+ , json-spec-elm-servant+ , aeson >= 2.1.2.1 && < 2.2+ , binary >= 0.8.9.1 && < 0.9+ , bytestring >= 0.11.4.0 && < 0.12+ , cookie >= 0.4.6 && < 0.5+ , hspec >= 2.11.1 && < 2.12+ , time >= 1.12.2 && < 1.13+ , uuid >= 1.3.15 && < 1.4+
+ src/Data/JsonSpec/Elm/Servant.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Data.JsonSpec.Elm.Servant (+ servantDefs,+) 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,+ 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+++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"+ , "Json.Decode.Decoder" `Type.App` Type.Var (B 0)+ )+ ]+ )+ , 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+ (+ Expr.apps+ "Json.Decode.decodeString"+ [ F . F <$>+ p req "decoder"+ , 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 Elmable e where+ 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))+ 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))+ (g "Json.Decode.succeed" `Expr.App` "Basics.()")+ )+ pure ()+++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+ typ <- typeOf @(DecodingSpec a)+ encoder <- encoderOf @(DecodingSpec a)+ pure $ BodyEncoder typ 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))+++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 segment+ PathParam (Capture name) -> Just name+ _ -> Nothing+ )+ params+++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+ 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.List []+ ]++ 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+ | BodyEncoder (Type Void) (Expression Void)+ 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)++
+ test/Api.hs view
@@ -0,0 +1,619 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- swiped from an incomplete personal project to use for testing. -}+module Api (+ -- * Api structure+ Api(..),+ ProtectedApi(..),+ UnprotectedApi(..),++ -- * Api data+ ProposalId(..),+ AvailabilityInterval(..),+ NewProposalReq(..),+ Name(..),+ Invite(..),+ Interval(..),+ Token(..),+ Email(..),+ Availability(..),+ DiscordAccessToken(..),+ DiscordUser(..),+ Guild(..),+ GuildId(..),+ AvailableCredits(..),+ DashboardData(..),+ Proposal(..),+ Cookie(..),+ SetMetadataReq(..),+ KV(..),+ FEConfig(..),+) where+++import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)+import Data.Binary (Binary)+import Data.ByteString (ByteString)+import Data.JsonSpec (Field(Field), HasJsonDecodingSpec(DecodingSpec,+ fromJSONStructure), HasJsonEncodingSpec(EncodingSpec, toJSONStructure),+ SpecJSON(SpecJSON), Specification(JsonArray, JsonDateTime, JsonEither,+ JsonInt, JsonLet, JsonObject, JsonRef, JsonString, JsonTag), Tag(Tag))+import Data.Map (Map)+import Data.Set (Set)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import GHC.Generics (Generic)+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)+import Web.Cookie (SetCookie)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.UUID as UUID+++data Api mode = Api+ { protectedApi :: mode+ :- "api"+ :> Header' '[Optional, Strict] "Authorization" Token+ :> Header' '[Optional, Strict] "Cookie" Cookie+ :> NamedRoutes ProtectedApi+ , unprotectedApi :: mode+ :- "api"+ :> NamedRoutes UnprotectedApi+ }+ deriving stock (Generic)+++newtype Cookie = Cookie ByteString+instance FromHttpApiData Cookie where+ parseHeader = Right . Cookie+ parseQueryParam = Right . Cookie . encodeUtf8+++data ProtectedApi mode = ProtectedApi+ { makeProposal :: mode+ :- "proposal"+ :> ReqBody' '[Required, Strict] '[JSON] NewProposalReq+ :> Post '[JSON] (KV ProposalId Proposal)++ , deleteProposal :: mode+ :- "proposal"+ :> Capture "proposalId" ProposalId+ :> DeleteNoContent++ , setAvailability :: mode+ :- "proposal"+ :> Capture "proposalId" ProposalId+ :> "availability"+ :> ReqBody' '[Required, Strict] '[JSON] Availability+ :> PostNoContent++ , setMetadata :: mode+ :- "proposal"+ :> Capture "proposalId" ProposalId+ :> "metadata"+ :> ReqBody' '[Required, Strict] '[JSON] SetMetadataReq+ :> PostNoContent++ , dashboard :: mode+ :- "dashboard"+ :> Get '[JSON] DashboardData++ , addInvite :: mode+ :- "proposal"+ :> Capture "proposalId" ProposalId+ :> "invites"+ :> "add"+ :> ReqBody' '[Required, Strict] '[JSON] Invite+ :> PostNoContent++ , deleteInvite :: mode+ :- "proposal"+ :> Capture "proposalId" ProposalId+ :> "invites"+ :> "delete"+ :> ReqBody' '[Required, Strict] '[JSON] Invite+ :> PostNoContent++ , getGuilds :: mode+ :- "guilds"+ :> Get '[JSON] (Set Guild)++ }+ deriving stock (Generic)+++data SetMetadataReq = SetMetadataReq+ { name :: Name+ , description :: Text+ , venue :: Text+ }+ deriving FromJSON via (SpecJSON SetMetadataReq)+instance HasJsonDecodingSpec SetMetadataReq where+ type DecodingSpec SetMetadataReq =+ JsonObject+ '[ '("name", DecodingSpec Name)+ , '("description", JsonString)+ , '("venue", JsonString)+ ]+ fromJSONStructure+ (Field @"name" name_,+ (Field @"description" description,+ (Field @"venue" venue,+ ())))+ = do+ name <- fromJSONStructure name_+ pure+ SetMetadataReq+ { name+ , description+ , venue+ }+++data DashboardData = DashboardData+ { proposals :: Map ProposalId Proposal+ , credits :: AvailableCredits+ , user :: DiscordUser+ }+ deriving ToJSON via (SpecJSON DashboardData)+instance HasJsonEncodingSpec DashboardData where+ type EncodingSpec DashboardData =+ JsonLet+ '[ '("DashboardData"+ , JsonObject+ '[ '("proposals",+ JsonArray+ ( JsonObject+ '[ '("key", EncodingSpec ProposalId)+ , '("value", EncodingSpec Proposal)+ ]+ )+ )+ , '("credits", EncodingSpec AvailableCredits)+ , '("user", EncodingSpec DiscordUser)+ ]+ )+ ]+ (JsonRef "DashboardData")+ toJSONStructure DashboardData {proposals, credits, user} =+ (Field @"proposals"+ [ (Field @"key" (toJSONStructure k),+ (Field @"value" (toJSONStructure v),+ ()))+ | (k, v) <- Map.toAscList proposals+ ],+ (Field @"credits" (toJSONStructure credits),+ (Field @"user" (toJSONStructure user),+ ())))+++data Proposal = Proposal+ { name :: Name+ , owner :: DiscordUser+ , description :: Text+ , venue :: Text+ , availability :: [AvailabilityInterval]+ , invites :: Set Invite+ , createdAt :: UTCTime+ }+ deriving stock (Generic)+ deriving (ToJSON, FromJSON) via (SpecJSON Proposal)+instance HasJsonEncodingSpec Proposal where+ type EncodingSpec Proposal =+ JsonObject+ '[ '("name", EncodingSpec Name)+ , '("owner", EncodingSpec DiscordUser)+ , '("availability", JsonArray (EncodingSpec AvailabilityInterval))+ , '("description", JsonString)+ , '("venue", JsonString)+ , '("invites", JsonArray (EncodingSpec Invite))+ , '("created-at", JsonDateTime)+ ]+ toJSONStructure+ Proposal+ { name+ , owner+ , availability+ , description+ , invites+ , venue+ , createdAt+ }+ =+ (Field @"name" (toJSONStructure name),+ (Field @"owner" (toJSONStructure owner),+ (Field @"availability" (toJSONStructure <$> availability),+ (Field @"description" description,+ (Field @"venue" venue,+ (Field @"invites" (toJSONStructure <$> Set.toList invites),+ (Field @"created-at" createdAt,+ ())))))))+instance HasJsonDecodingSpec Proposal where+ type DecodingSpec Proposal = EncodingSpec Proposal+ fromJSONStructure+ (Field @"name" name,+ (Field @"owner" user,+ (Field @"availability" rawAvailability,+ (Field @"description" description,+ (Field @"venue" venue,+ (Field @"invites" rawInvites,+ (Field @"created-at" createdAt,+ ())))))))+ = do+ availability <- traverse fromJSONStructure rawAvailability+ invites <- traverse fromJSONStructure rawInvites+ pure+ Proposal+ { name = Name name+ , owner = DiscordUser user+ , description+ , availability+ , invites = Set.fromList invites+ , venue+ , createdAt+ }+++data Invite+ = InviteUser DiscordUser+ | InviteGuild Guild+ deriving stock (Eq, Ord)+ deriving (ToJSON, FromJSON) via (SpecJSON Invite)+instance HasJsonEncodingSpec Invite where+ type EncodingSpec Invite =+ JsonLet+ '[ '( "Invite"+ , JsonEither+ ( JsonObject+ '[ '("type", JsonTag "discord-user")+ , '("username", EncodingSpec DiscordUser)+ ]+ )+ ( JsonObject+ '[ '("type", JsonTag "discord-server")+ , '("guild", EncodingSpec Guild)+ ]+ )+ )+ ]+ (JsonRef "Invite")+ toJSONStructure = \case+ InviteUser user ->+ Left+ (Field @"type" (Tag @"discord-user"),+ (Field @"username" (toJSONStructure user),+ ()))+ InviteGuild guild ->+ Right+ (Field @"type" (Tag @"discord-server"),+ (Field @"guild" (toJSONStructure guild),+ ()))+instance HasJsonDecodingSpec Invite where+ type DecodingSpec Invite = EncodingSpec Invite+ fromJSONStructure = \case+ Left+ (Field @"type" (Tag @"discord-user"),+ (Field @"username" user,+ ()))+ ->+ InviteUser <$> fromJSONStructure user++ Right+ (Field @"type" (Tag @"discord-server"),+ (Field @"guild" guild,+ ()))+ ->+ InviteGuild <$> fromJSONStructure guild+++data Guild = Guild+ { guildId :: GuildId+ , name :: Text+ }+ deriving stock (Eq, Ord)+ deriving (ToJSON, FromJSON) via (SpecJSON Guild)+instance HasJsonEncodingSpec Guild where+ type EncodingSpec Guild =+ JsonObject+ '[ '("id", EncodingSpec GuildId)+ , '("name", JsonString)+ ]+ toJSONStructure Guild { guildId , name } =+ (Field @"id" (toJSONStructure guildId),+ (Field @"name" name,+ ()))+instance HasJsonDecodingSpec Guild where+ type DecodingSpec Guild = EncodingSpec Guild+ fromJSONStructure+ (Field @"id" id_,+ (Field @"name" name,+ ()))+ = do+ guildId <- fromJSONStructure id_+ pure Guild { guildId , name }+++newtype GuildId = GuildId+ { unGuildId :: Text+ }+ deriving newtype (ToHttpApiData, Eq, Ord)+ deriving FromJSON via (SpecJSON GuildId)+instance HasJsonEncodingSpec GuildId where+ type EncodingSpec GuildId = JsonString+ toJSONStructure = unGuildId+instance HasJsonDecodingSpec GuildId where+ type DecodingSpec GuildId = EncodingSpec GuildId+ fromJSONStructure = pure . GuildId+++data AvailabilityInterval = AvailabilityInterval+ { interval :: Interval+ , users :: Set DiscordUser+ }+ deriving ToJSON via (SpecJSON AvailabilityInterval)+instance HasJsonDecodingSpec AvailabilityInterval where+ type DecodingSpec AvailabilityInterval = EncodingSpec AvailabilityInterval+ fromJSONStructure+ (Field @"interval" rawInterval,+ (Field @"users" rawUsers,+ ()))+ = do+ interval <- fromJSONStructure rawInterval+ pure+ AvailabilityInterval+ { interval+ , users = Set.fromList (DiscordUser <$> rawUsers)+ }+instance HasJsonEncodingSpec AvailabilityInterval where+ type EncodingSpec AvailabilityInterval =+ JsonObject '[+ '("interval", EncodingSpec Interval),+ '("users", JsonArray (EncodingSpec DiscordUser))+ ]+ toJSONStructure AvailabilityInterval { interval , users } =+ (Field @"interval" (toJSONStructure interval),+ (Field @"users" (toJSONStructure <$> Set.toList users),+ ()))+++newtype AvailableCredits = AvailableCredits+ { unAvailableCredits :: Int+ }+ deriving ToJSON via (SpecJSON AvailableCredits)+instance HasJsonEncodingSpec AvailableCredits where+ type EncodingSpec AvailableCredits = JsonInt+ toJSONStructure = unAvailableCredits+++data UnprotectedApi mode = UnprotectedApi+ { login :: mode+ :- "login"+ :> ReqBody '[JSON] DiscordAccessToken+ :> Post+ '[JSON]+ (+ Headers+ '[ Header "Set-Cookie" SetCookie+ , Header "Set-Cookie" SetCookie+ ]+ DiscordUser+ )+ , logout :: mode+ :- "logout"+ :> Verb 'GET 204 '[JSON]+ (+ Headers+ '[ Header "Set-Cookie" SetCookie+ , Header "Set-Cookie" SetCookie+ ]+ NoContent+ )+ , config :: mode+ :- "config"+ :> Get '[JSON] FEConfig+ }+ deriving stock (Generic)+++newtype FEConfig = FEConfig+ { discordRedirect :: Text+ }+ deriving (ToJSON) via (SpecJSON FEConfig)+instance HasJsonEncodingSpec FEConfig where+ type EncodingSpec FEConfig =+ JsonObject+ '[ '( "redirectUrl", JsonString) ]+ toJSONStructure FEConfig { discordRedirect } =+ (Field @"redirectUrl" discordRedirect,+ ())++newtype Email = Email+ { unEmail :: Text+ }+ deriving newtype (FromJSON)+++newtype DiscordAccessToken = DiscordAccessToken+ { unDiscordAccessToken :: Text+ }+ deriving newtype (Binary)+ deriving (FromJSON) via (SpecJSON DiscordAccessToken)+instance HasJsonDecodingSpec DiscordAccessToken where+ type DecodingSpec DiscordAccessToken = JsonString+ fromJSONStructure = pure . DiscordAccessToken+++newtype Token = Token+ { unToken :: Text+ }+ deriving newtype+ ( Eq+ , FromHttpApiData+ , Ord+ )+++newtype ProposalId = ProposalId+ { unProposalId :: UUID+ }+ deriving newtype+ ( Eq+ , FromHttpApiData+ , Ord+ , ToJSONKey+ , FromJSONKey+ )+ deriving ToJSON via (SpecJSON ProposalId)+instance HasJsonEncodingSpec ProposalId where+ type EncodingSpec ProposalId = JsonString+ toJSONStructure = UUID.toText . unProposalId+++data NewProposalReq = NewProposalReq+ { name :: Name+ , availability :: Availability+ , description :: Text+ , venue :: Text+ }+ deriving (FromJSON) via (SpecJSON NewProposalReq)+instance HasJsonDecodingSpec NewProposalReq where+ type DecodingSpec NewProposalReq =+ JsonObject+ '[ '("name", DecodingSpec Name)+ , '("availability", DecodingSpec Availability)+ , '("description", JsonString)+ , '("venue", JsonString)+ ]+ fromJSONStructure+ (Field @"name" rawName,+ (Field @"availability" rawAvailability,+ (Field @"description" description,+ (Field @"venue" venue,+ ()))))+ = do+ name <- fromJSONStructure rawName+ availability <- fromJSONStructure rawAvailability+ pure+ NewProposalReq+ { name+ , availability+ , description+ , venue+ }+++newtype Availability = Availability+ { unAvailability :: Set Interval+ }+ deriving FromJSON via (SpecJSON Availability)+instance HasJsonDecodingSpec Availability where+ type DecodingSpec Availability = JsonArray (DecodingSpec Interval)+ fromJSONStructure =+ fmap (Availability . Set.fromList)+ . traverse fromJSONStructure+++newtype Name = Name+ { unName :: Text+ }+ deriving (ToJSON, FromJSON) via (SpecJSON Name)+instance HasJsonEncodingSpec Name where+ type EncodingSpec Name = JsonString+ toJSONStructure = unName+instance HasJsonDecodingSpec Name where+ type DecodingSpec Name = EncodingSpec Name+ fromJSONStructure = pure . Name+++data Interval = Interval+ { startInclusive :: UTCTime+ , endExclusive :: UTCTime+ }+ deriving stock (Eq, Ord)+ deriving (ToJSON, FromJSON) via (SpecJSON Interval)+instance HasJsonEncodingSpec Interval where+ type EncodingSpec Interval =+ JsonObject '[+ '("startInclusive", JsonDateTime),+ '("endExclusive", JsonDateTime)+ ]+ toJSONStructure+ Interval+ { startInclusive+ , endExclusive+ }+ =+ (Field @"startInclusive" startInclusive,+ (Field @"endExclusive" endExclusive,+ ()))+instance HasJsonDecodingSpec Interval where+ type DecodingSpec Interval = EncodingSpec Interval+ fromJSONStructure+ (Field @"startInclusive" startInclusive,+ (Field @"endExclusive" endExclusive,+ ()))+ = do+ pure+ Interval+ { startInclusive+ , endExclusive+ }+++newtype DiscordUser = DiscordUser+ { unDiscordUser :: Text+ }+ deriving newtype ( Eq , FromJSON , Ord, Binary)+ deriving ToJSON via (SpecJSON DiscordUser)+instance HasJsonEncodingSpec DiscordUser where+ type EncodingSpec DiscordUser = JsonString+ toJSONStructure = unDiscordUser+instance HasJsonDecodingSpec DiscordUser where+ type DecodingSpec DiscordUser = EncodingSpec DiscordUser+ fromJSONStructure = pure . DiscordUser+++data KV k v = KV+ { key :: k+ , value :: v+ }+deriving via (SpecJSON (KV ProposalId Proposal)) instance+ ToJSON (KV ProposalId Proposal)+instance+ (HasJsonEncodingSpec k, HasJsonEncodingSpec v)+ =>+ HasJsonEncodingSpec (KV k v)+ where+ type EncodingSpec (KV k v) =+ JsonObject+ '[ '("key", EncodingSpec k)+ , '("value", EncodingSpec v)+ ]++ toJSONStructure KV { key , value } =+ (Field @"key" (toJSONStructure key),+ (Field @"value" (toJSONStructure value),+ ()))++
+ test/test.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main (main) where++import Api (Api)+import Data.Foldable (traverse_)+import Data.HashMap.Strict (HashMap)+import Data.JsonSpec.Elm.Servant (servantDefs)+import Data.Proxy (Proxy(Proxy))+import Data.Text (Text)+import Language.Elm.Name (Module)+import Language.Elm.Pretty (modules)+import Prelude (Bool(True), Functor(fmap), Semigroup((<>)), ($), (.),+ FilePath, IO, init)+import Prettyprinter (defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Servant.API (ToServantApi)+import System.Directory (createDirectoryIfMissing)+import System.Process (callCommand)+import Test.Hspec (describe, hspec, it)+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.IO as TIO++main :: IO ()+main =+ hspec $ do+ describe "thing" $ do+ it "works" $+ let+ actual :: HashMap Module Text+ actual =+ fmap ((<> "\n") . renderStrict . layoutPretty defaultLayoutOptions)+ . modules+ . Set.toList+ $ servantDefs (Proxy @(ToServantApi Api))++ in do+ traverse_ writeModule (HM.toList actual)+ callCommand "(cd elm-test; elm-format src/ --yes)"+ callCommand+ "(\+ \cd elm-test; \+ \yes Y | (\+ \elm init; \+ \elm install rtfeldman/elm-iso8601-date-strings; \+ \elm install elm/json; \+ \elm install elm/url; \+ \elm install elm/time; \+ \elm install elm/http\+ \); \+ \elm make src/Api/Req.elm\+ \)"+ callCommand "rm -rf elm-test"+++writeModule :: (Module, Text) -> IO ()+writeModule (module_, content) = do+ createDirectoryIfMissing True dirname+ TIO.writeFile filename content+ where+ pathName :: [Text] -> FilePath+ pathName = ("elm-test/src/" <>) . Text.unpack . Text.intercalate "/"++ filename :: FilePath+ filename = pathName module_ <> ".elm"++ dirname :: FilePath+ dirname = pathName (init module_)++