diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/json-spec-elm-servant.cabal b/json-spec-elm-servant.cabal new file mode 100644 --- /dev/null +++ b/json-spec-elm-servant.cabal @@ -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 + diff --git a/src/Data/JsonSpec/Elm/Servant.hs b/src/Data/JsonSpec/Elm/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonSpec/Elm/Servant.hs @@ -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) + + diff --git a/test/Api.hs b/test/Api.hs new file mode 100644 --- /dev/null +++ b/test/Api.hs @@ -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), + ())) + + diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -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_) + +