domaindriven (empty) → 0.5.0
raw patch · 21 files changed
+3906/−0 lines, 21 filesdep +QuickCheckdep +aesondep +async
Dependencies added: QuickCheck, aeson, async, base, bytestring, containers, deepseq, domaindriven, domaindriven-core, exceptions, generic-lens, hspec, http-client, http-types, microlens, mtl, openapi3, postgresql-simple, quickcheck-arbitrary-adt, quickcheck-classes, random, servant-client, servant-server, streamly, template-haskell, text, time, transformers, unliftio, unliftio-pool, unordered-containers, uuid, vector, warp
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +128/−0
- domaindriven.cabal +174/−0
- src/DomainDriven.hs +39/−0
- src/DomainDriven/Internal/HasFieldName.hs +71/−0
- src/DomainDriven/Internal/NamedFields.hs +867/−0
- src/DomainDriven/Internal/NamedJsonFields.hs +299/−0
- src/DomainDriven/Internal/Text.hs +31/−0
- src/DomainDriven/Server/Class.hs +163/−0
- src/DomainDriven/Server/Config.hs +85/−0
- src/DomainDriven/Server/Helpers.hs +122/−0
- src/DomainDriven/Server/TH.hs +995/−0
- src/DomainDriven/Server/Types.hs +151/−0
- test/Action/Counter.hs +54/−0
- test/Action/ExtraParam.hs +65/−0
- test/Action/ServerTest.hs +40/−0
- test/Action/Store.hs +204/−0
- test/DomainDriven/Internal/NamedJsonFieldsSpec.hs +101/−0
- test/DomainDriven/ServerSpec.hs +281/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for domaindriven++## 0.5.0++First release published on hackage.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tommy Engström (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tommy Engström nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,128 @@+# DomainDriven++DomainDriven is a batteries included synchronous event sourcing and CQRS library. The goal of this library is to allow you to implement DDD principles without focusing on the boilerplate. ++It uses `Template Haskell` we generate a Servant server from the specification and we aim to keep the specification as succinct as we can.++## The idea++- Use a GADT to specify the actions, what will be translated into `GET`s and `POST`s.+- Make each event update run in a transaction, thereby avoiding the eventual consistency issues commonly associated with event sourcing.++## How it works++In order to implement a model in `domaindriven` you have to define:+- The model (current state)+- The events+- How to update the model when new events come in+- The actions (queries and commands)+- How to handle actions ++### Model++The model is the current state of the system. This is what you normally would keep in a database, but as this is an event sourced system the state is not fundamental as it can be recalculated.++Currently all implemented persistence strategies all keep the state in memory.++### Events++Events are things that happened in the past. The event you define represent all the changes that can occur in the system.++Events should be specified in past tens.+```haskell++data Event+ = IncreasedCounter+ | DecreasedCounter+```++### Event handler++The model is calculated as a fold over the stream of events. As events happened in the past we can never refuse to handle them. This means the event handler is simply:++``` haskell+applyEvent :: Model -> Stored Event -> Model+```++where Stored is defined as:+``` haskell+data Stored a = Stored+ { storedEvent :: a+ , storedTimestamp :: UTCTime+ , storedUUID :: UUID+ }+```++### Commands++Commands are defined using a GADT with one type parameter representing the return type. For example:++``` haskell+-- Same as: data StorageAction (x :: ParamPart) method a where+data StorageAction :: Action where+ GetFile+ :: P x "fileId" UUID + -> StorageAction x Query ByteString+ AddFile+ :: P x "fileContent" ByteString + -> StorageAction Cmd UUID+ RemoveFile + :: P x "fileId" UUID + -> StorageAction Cmd ()+```++### Action handler++Actions, in contrast to events, are allowed to fail. If an action succeeds we need to return a value of the type specified by the constructor and, if it was a command, a list of events. The action handler do not update the state.++In addition you may need to make requests, read from disk, or perform other side effects in order to calculate the result.++`ActionHandler` is defined as:++``` haskell+type ActionHandler model event m c =+ forall method a. c 'ParamType method a -> HandlerType method model event m a+```++In practice this means you specify actions as++```haskell++data CounterAction x method return where+ GetCounter ::CounterAction x Query Int+ IncreaseCounter ::CounterAction x Cmd Int+ DecreaseCounter ::CounterAction x Cmd Int+```++and the corresponding handler as++```haskell+handleAction :: ActionHandler CounterAction CounterEvent IO a +handleAction = \case+ GetCounter -> Query $ pure -- Query is just `model -> IO a`+ IncreaseCounter -> Cmd $ \_ -> `model -> IO (model -> a, [CounterEvent])`+ pure (id -- return state as is, after the event is applied+ , [CounterIncreased])+ DecreaseCounter -> Cmd $ \counter -> do+ when (counter < 1) (throwM NegativeNotSupported)+ pure (id, [CounterDecreased])+```++A `Query` takes a `model -> m a`, i.e. you get access to the model and the ability to run monadic efficts. `Query`s will be translates into `GET` in the generated API.++A `Cmd` has the additional ability of emitting events. It takes a `model -> m (model -> a, [event])`. The return value is specified as a function from the updated model to the return type. This way we can, in the Counter example, return the new value after the event handler has run.+++### Generating the server+++Now we have defined the core parts of our service. We can now generate the server using the template-haskell function `mkServer`. It takes two arguments: The server config and the name of the GADT representing the actions. E.g. `$(mkServer counterActionConfig ''CounterAction)`.++The `ServerConfig`, `storeActionConfig` in this example, contains the API options for the for the Action and all it's sub actions, as well as a all parameter names. This can be tenerated with `$(mkServerConfig "counterActionConfig")`, but due to TemplateHaskell's stage restrictions it cannot run in the same file as `mkServer`.+++### Simple example++Minimal example can be found in [examples/simple/Main.hs](examples/simple/Main.hs), this uses the model defined in [models/Models/Counter.hs](models/Models/Counter.hs)++
+ domaindriven.cabal view
@@ -0,0 +1,174 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.1.+--+-- see: https://github.com/sol/hpack++name: domaindriven+version: 0.5.0+synopsis: Batteries included event sourcing and CQRS+description: Please see the README on GitHub at <https://github.com/tommyengstrom/domaindriven/tree/master/domaindriven#readme>+category: Web+homepage: https://github.com/tommyengstrom/domaindriven#readme+bug-reports: https://github.com/tommyengstrom/domaindriven/issues+author: Tommy Engström+maintainer: tommy@tommyengstrom.com+copyright: 2023 Tommy Engström+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/tommyengstrom/domaindriven++library+ exposed-modules:+ DomainDriven+ DomainDriven.Internal.HasFieldName+ DomainDriven.Internal.NamedFields+ DomainDriven.Internal.NamedJsonFields+ DomainDriven.Internal.Text+ DomainDriven.Server.Class+ DomainDriven.Server.Config+ DomainDriven.Server.Helpers+ DomainDriven.Server.TH+ DomainDriven.Server.Types+ other-modules:+ Paths_domaindriven+ hs-source-dirs:+ src+ default-extensions:+ Arrows+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DuplicateRecordFields+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedLabels+ OverloadedStrings+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeFamilyDependencies+ TypeOperators+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns+ build-depends:+ aeson >=2.0.3 && <2.2+ , async >=2.2.4 && <2.3+ , base >=4.7 && <5+ , bytestring >=0.11.3 && <0.12+ , containers >=0.6.5.1 && <0.7+ , deepseq >=1.4.6.1 && <1.5+ , domaindriven-core >=0.5.0 && <0.6+ , exceptions >=0.10.4 && <0.11+ , generic-lens >=2.2.1.0 && <2.3+ , http-types >=0.12.3 && <0.13+ , microlens >=0.4.12.0 && <0.5+ , mtl >=2.2.2 && <2.3+ , openapi3 >=3.2.2 && <3.3+ , postgresql-simple >=0.6.4 && <0.7+ , random >=1.2.1.1 && <1.3+ , servant-server >=0.19.2 && <0.20+ , streamly >=0.8.1.1 && <0.9+ , template-haskell >=2.18.0.0 && <2.19+ , text >=1.2.5.0 && <1.3+ , time >=1.11.1.1 && <1.12+ , transformers >=0.5.6.2 && <0.6+ , unliftio >=0.2.0.1 && <0.3+ , unliftio-pool >=0.2.2.0 && <0.3+ , unordered-containers >=0.2.19.1 && <0.3+ , uuid >=1.3.15 && <1.4+ , vector >=0.12.3.1 && <0.13+ default-language: Haskell2010++test-suite domaindriven-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Action.Counter+ Action.ExtraParam+ Action.ServerTest+ Action.Store+ DomainDriven.Internal.NamedJsonFieldsSpec+ DomainDriven.ServerSpec+ Paths_domaindriven+ hs-source-dirs:+ test+ default-extensions:+ Arrows+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DuplicateRecordFields+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ LambdaCase+ MultiParamTypeClasses+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedLabels+ OverloadedStrings+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeFamilyDependencies+ TypeOperators+ TypeSynonymInstances+ ViewPatterns+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-patterns -threaded -rtsopts -with-rtsopts=-N -Wall -Wunused-packages+ build-depends:+ QuickCheck >=2.14.2 && <2.15+ , aeson >=2.0.3 && <2.2+ , async >=2.2.4 && <2.3+ , base >=4.7 && <5+ , containers >=0.6.5.1 && <0.7+ , deepseq >=1.4.6.1 && <1.5+ , domaindriven >=0.5.0 && <0.6+ , domaindriven-core >=0.5.0 && <0.6+ , exceptions >=0.10.4 && <0.11+ , hspec >=2.9.7 && <2.10+ , http-client >=0.7.13.1 && <0.8+ , mtl >=2.2.2 && <2.3+ , openapi3 >=3.2.2 && <3.3+ , quickcheck-arbitrary-adt >=0.3.1.0 && <0.4+ , quickcheck-classes >=0.6.5.0 && <0.7+ , servant-client ==0.19.*+ , servant-server >=0.19.2 && <0.20+ , text >=1.2.5.0 && <1.3+ , warp >=3.3.23 && <3.4+ default-language: Haskell2010
+ src/DomainDriven.hs view
@@ -0,0 +1,39 @@+module DomainDriven (module X) where++import Data.UUID as X (UUID)++import DomainDriven.Internal.NamedFields as X+import DomainDriven.Persistance.Class as X+ ( ReadModel (..)+ , Stored (..)+ , WriteModel (..)+ , mkId+ )+import DomainDriven.Server.Class as X+ ( Action+ , ActionHandler+ , ActionRunner+ , CanMutate+ , CbCmd+ , Cmd+ , HandlerType (..)+ , ModelAccess (..)+ , P+ , ParamPart (..)+ , Query+ , RequestType+ , mapEvent+ , mapModel+ , mapResult+ , runAction+ )+import DomainDriven.Server.Config as X+ ( HasApiOptions (..)+ , ServerConfig+ , mkServerConfig+ )+import DomainDriven.Server.TH as X (mkServer)+import DomainDriven.Server.Types as X+ ( ApiOptions (..)+ , defaultApiOptions+ )
+ src/DomainDriven/Internal/HasFieldName.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}++module DomainDriven.Internal.HasFieldName where++import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Data.Vector (Vector)+import DomainDriven.Internal.Text+import GHC.Generics+import Prelude++class HasFieldName t where+ fieldName :: Text+ default fieldName :: (Generic t, GHasFieldName (Rep t)) => Text+ fieldName = gfieldName $ from (undefined :: t)++instance HasFieldName Int where+ fieldName = "int"++instance HasFieldName Double where+ fieldName = "double"++instance HasFieldName Text where+ fieldName = "text"++instance HasFieldName Bool where+ fieldName = "bool"++instance HasFieldName Day where+ fieldName = "day"++instance HasFieldName UTCTime where+ fieldName = "utcTime"++instance+ HasFieldName v+ => HasFieldName (M.Map k v)+ where+ fieldName = "mapOf" `camelAppendT` fieldName @v++instance+ HasFieldName v+ => HasFieldName (HM.HashMap k v)+ where+ fieldName = "mapOf" `camelAppendT` fieldName @v++instance HasFieldName v => HasFieldName (Set v) where+ fieldName = "setOf" `camelAppendT` fieldName @v++instance {-# OVERLAPPABLE #-} HasFieldName v => HasFieldName [v] where+ fieldName = "listOf" `camelAppendT` fieldName @v++instance {-# OVERLAPPING #-} HasFieldName String where+ fieldName = "string"++instance HasFieldName v => HasFieldName (Vector v) where+ fieldName = "vectorOf" `camelAppendT` fieldName @v++instance HasFieldName v => HasFieldName (Maybe v) where+ fieldName = fieldName @v++class GHasFieldName t where+ gfieldName :: t x -> Text++instance Datatype c => GHasFieldName (M1 i c f) where+ gfieldName = T.pack . lowerFirst . datatypeName
+ src/DomainDriven/Internal/NamedFields.hs view
@@ -0,0 +1,867 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-}++module DomainDriven.Internal.NamedFields+ ( NF1 (..)+ , NF2 (..)+ , NF3 (..)+ , NF4 (..)+ , NF5 (..)+ , NF6 (..)+ , NF7 (..)+ , NF8 (..)+ , NF9 (..)+ )+where++import Data.Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+import Data.OpenApi+import Data.Proxy+import qualified Data.Text as T+import GHC.Generics (Generic)+import GHC.TypeLits+import Prelude++data NF1 (name :: Symbol) (f1 :: Symbol) ty = NF1 ty+ deriving (Show, Generic)++data NF2 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 = NF2 a1 a2+ deriving (Show, Generic)++data NF3 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 (f3 :: Symbol) a3 = NF3 a1 a2 a3+ deriving (Show, Generic)++data NF4 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 (f3 :: Symbol) a3 (f4 :: Symbol) a4 = NF4 a1 a2 a3 a4+ deriving (Show, Generic)++data NF5 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 (f3 :: Symbol) a3 (f4 :: Symbol) a4 (f5 :: Symbol) a5 = NF5 a1 a2 a3 a4 a5+ deriving (Show, Generic)++data NF6 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 (f3 :: Symbol) a3 (f4 :: Symbol) a4 (f5 :: Symbol) a5 (f6 :: Symbol) a6 = NF6 a1 a2 a3 a4 a5 a6+ deriving (Show, Generic)++data NF7 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 (f3 :: Symbol) a3 (f4 :: Symbol) a4 (f5 :: Symbol) a5 (f6 :: Symbol) a6 (f7 :: Symbol) a7 = NF7 a1 a2 a3 a4 a5 a6 a7+ deriving (Show, Generic)++data NF8 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 (f3 :: Symbol) a3 (f4 :: Symbol) a4 (f5 :: Symbol) a5 (f6 :: Symbol) a6 (f7 :: Symbol) a7 (f8 :: Symbol) a8 = NF8 a1 a2 a3 a4 a5 a6 a7 a8+ deriving (Show, Generic)++data NF9 (name :: Symbol) (f1 :: Symbol) a1 (f2 :: Symbol) a2 (f3 :: Symbol) a3 (f4 :: Symbol) a4 (f5 :: Symbol) a5 (f6 :: Symbol) a6 (f7 :: Symbol) a7 (f8 :: Symbol) a8 (f9 :: Symbol) a9 = NF9 a1 a2 a3 a4 a5 a6 a7 a8 a9+ deriving (Show, Generic)++symbolKey :: forall n. KnownSymbol n => Key+symbolKey = Key.fromString . symbolVal $ Proxy @n++instance (KnownSymbol f1, ToJSON a1) => ToJSON (NF1 name f1 a1) where+ toJSON (NF1 a1) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ ]++instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ )+ => ToJSON (NF2 name f1 a1 f2 a2)+ where+ toJSON (NF2 a1 a2) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ ]++instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ , KnownSymbol f3+ , ToJSON a3+ )+ => ToJSON (NF3 name f1 a1 f2 a2 f3 a3)+ where+ toJSON (NF3 a1 a2 a3) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ , (symbolKey @f3, toJSON a3)+ ]+instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ , KnownSymbol f3+ , ToJSON a3+ , KnownSymbol f4+ , ToJSON a4+ )+ => ToJSON (NF4 name f1 a1 f2 a2 f3 a3 f4 a4)+ where+ toJSON (NF4 a1 a2 a3 a4) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ , (symbolKey @f3, toJSON a3)+ , (symbolKey @f4, toJSON a4)+ ]+instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ , KnownSymbol f3+ , ToJSON a3+ , KnownSymbol f4+ , ToJSON a4+ , KnownSymbol f5+ , ToJSON a5+ )+ => ToJSON (NF5 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5)+ where+ toJSON (NF5 a1 a2 a3 a4 a5) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ , (symbolKey @f3, toJSON a3)+ , (symbolKey @f4, toJSON a4)+ , (symbolKey @f5, toJSON a5)+ ]+instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ , KnownSymbol f3+ , ToJSON a3+ , KnownSymbol f4+ , ToJSON a4+ , KnownSymbol f5+ , ToJSON a5+ , KnownSymbol f6+ , ToJSON a6+ )+ => ToJSON (NF6 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6)+ where+ toJSON (NF6 a1 a2 a3 a4 a5 a6) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ , (symbolKey @f3, toJSON a3)+ , (symbolKey @f4, toJSON a4)+ , (symbolKey @f5, toJSON a5)+ , (symbolKey @f6, toJSON a6)+ ]+instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ , KnownSymbol f3+ , ToJSON a3+ , KnownSymbol f4+ , ToJSON a4+ , KnownSymbol f5+ , ToJSON a5+ , KnownSymbol f6+ , ToJSON a6+ , KnownSymbol f7+ , ToJSON a7+ )+ => ToJSON (NF7 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7)+ where+ toJSON (NF7 a1 a2 a3 a4 a5 a6 a7) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ , (symbolKey @f3, toJSON a3)+ , (symbolKey @f4, toJSON a4)+ , (symbolKey @f5, toJSON a5)+ , (symbolKey @f6, toJSON a6)+ , (symbolKey @f7, toJSON a7)+ ]+instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ , KnownSymbol f3+ , ToJSON a3+ , KnownSymbol f4+ , ToJSON a4+ , KnownSymbol f5+ , ToJSON a5+ , KnownSymbol f6+ , ToJSON a6+ , KnownSymbol f7+ , ToJSON a7+ , KnownSymbol f8+ , ToJSON a8+ )+ => ToJSON (NF8 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7 f8 a8)+ where+ toJSON (NF8 a1 a2 a3 a4 a5 a6 a7 a8) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ , (symbolKey @f3, toJSON a3)+ , (symbolKey @f4, toJSON a4)+ , (symbolKey @f5, toJSON a5)+ , (symbolKey @f6, toJSON a6)+ , (symbolKey @f7, toJSON a7)+ , (symbolKey @f8, toJSON a8)+ ]+instance+ ( KnownSymbol f1+ , ToJSON a1+ , KnownSymbol f2+ , ToJSON a2+ , KnownSymbol f3+ , ToJSON a3+ , KnownSymbol f4+ , ToJSON a4+ , KnownSymbol f5+ , ToJSON a5+ , KnownSymbol f6+ , ToJSON a6+ , KnownSymbol f7+ , ToJSON a7+ , KnownSymbol f8+ , ToJSON a8+ , KnownSymbol f9+ , ToJSON a9+ )+ => ToJSON (NF9 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7 f8 a8 f9 a9)+ where+ toJSON (NF9 a1 a2 a3 a4 a5 a6 a7 a8 a9) =+ Object $+ KM.fromList+ [ (symbolKey @f1, toJSON a1)+ , (symbolKey @f2, toJSON a2)+ , (symbolKey @f3, toJSON a3)+ , (symbolKey @f4, toJSON a4)+ , (symbolKey @f5, toJSON a5)+ , (symbolKey @f6, toJSON a6)+ , (symbolKey @f7, toJSON a7)+ , (symbolKey @f8, toJSON a8)+ , (symbolKey @f9, toJSON a9)+ ]++instance+ (KnownSymbol name, KnownSymbol f1, FromJSON a1)+ => FromJSON (NF1 name f1 a1)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ pure $ NF1 a1++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ )+ => FromJSON (NF2 name f1 a1 f2 a2)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ pure $ NF2 a1 a2++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ , KnownSymbol f3+ , FromJSON a3+ )+ => FromJSON (NF3 name f1 a1 f2 a2 f3 a3)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ a3 <- o .: symbolKey @f3+ pure $ NF3 a1 a2 a3++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ , KnownSymbol f3+ , FromJSON a3+ , KnownSymbol f4+ , FromJSON a4+ )+ => FromJSON (NF4 name f1 a1 f2 a2 f3 a3 f4 a4)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ a3 <- o .: symbolKey @f3+ a4 <- o .: symbolKey @f4+ pure $ NF4 a1 a2 a3 a4++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ , KnownSymbol f3+ , FromJSON a3+ , KnownSymbol f4+ , FromJSON a4+ , KnownSymbol f5+ , FromJSON a5+ )+ => FromJSON (NF5 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ a3 <- o .: symbolKey @f3+ a4 <- o .: symbolKey @f4+ a5 <- o .: symbolKey @f5+ pure $ NF5 a1 a2 a3 a4 a5++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ , KnownSymbol f3+ , FromJSON a3+ , KnownSymbol f4+ , FromJSON a4+ , KnownSymbol f5+ , FromJSON a5+ , KnownSymbol f6+ , FromJSON a6+ )+ => FromJSON (NF6 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ a3 <- o .: symbolKey @f3+ a4 <- o .: symbolKey @f4+ a5 <- o .: symbolKey @f5+ a6 <- o .: symbolKey @f6+ pure $ NF6 a1 a2 a3 a4 a5 a6++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ , KnownSymbol f3+ , FromJSON a3+ , KnownSymbol f4+ , FromJSON a4+ , KnownSymbol f5+ , FromJSON a5+ , KnownSymbol f6+ , FromJSON a6+ , KnownSymbol f7+ , FromJSON a7+ )+ => FromJSON (NF7 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ a3 <- o .: symbolKey @f3+ a4 <- o .: symbolKey @f4+ a5 <- o .: symbolKey @f5+ a6 <- o .: symbolKey @f6+ a7 <- o .: symbolKey @f7+ pure $ NF7 a1 a2 a3 a4 a5 a6 a7++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ , KnownSymbol f3+ , FromJSON a3+ , KnownSymbol f4+ , FromJSON a4+ , KnownSymbol f5+ , FromJSON a5+ , KnownSymbol f6+ , FromJSON a6+ , KnownSymbol f7+ , FromJSON a7+ , KnownSymbol f8+ , FromJSON a8+ )+ => FromJSON (NF8 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7 f8 a8)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ a3 <- o .: symbolKey @f3+ a4 <- o .: symbolKey @f4+ a5 <- o .: symbolKey @f5+ a6 <- o .: symbolKey @f6+ a7 <- o .: symbolKey @f7+ a8 <- o .: symbolKey @f8+ pure $ NF8 a1 a2 a3 a4 a5 a6 a7 a8++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , FromJSON a1+ , KnownSymbol f2+ , FromJSON a2+ , KnownSymbol f3+ , FromJSON a3+ , KnownSymbol f4+ , FromJSON a4+ , KnownSymbol f5+ , FromJSON a5+ , KnownSymbol f6+ , FromJSON a6+ , KnownSymbol f7+ , FromJSON a7+ , KnownSymbol f8+ , FromJSON a8+ , KnownSymbol f9+ , FromJSON a9+ )+ => FromJSON (NF9 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7 f8 a8 f9 a9)+ where+ parseJSON = withObject (symbolVal $ Proxy @name) $ \o -> do+ a1 <- o .: symbolKey @f1+ a2 <- o .: symbolKey @f2+ a3 <- o .: symbolKey @f3+ a4 <- o .: symbolKey @f4+ a5 <- o .: symbolKey @f5+ a6 <- o .: symbolKey @f6+ a7 <- o .: symbolKey @f7+ a8 <- o .: symbolKey @f8+ a9 <- o .: symbolKey @f9+ pure $ NF9 a1 a2 a3 a4 a5 a6 a7 a8 a9++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ )+ => ToSchema (NF1 name f1 a1)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ let f1 = T.pack . symbolVal $ Proxy @f1+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1]+ , _schemaProperties = [(f1, Inline f1Dec)]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ )+ => ToSchema (NF2 name f1 a1 f2 a2)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ , KnownSymbol f3+ , ToSchema a3+ )+ => ToSchema (NF3 name f1 a1 f2 a2 f3 a3)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ f3Dec <- declareSchema $ Proxy @a3+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ let f3 = T.pack . symbolVal $ Proxy @f3+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2, f3]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ , (f3, Inline f3Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ , KnownSymbol f3+ , ToSchema a3+ , KnownSymbol f4+ , ToSchema a4+ )+ => ToSchema (NF4 name f1 a1 f2 a2 f3 a3 f4 a4)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ f3Dec <- declareSchema $ Proxy @a3+ f4Dec <- declareSchema $ Proxy @a4+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ let f3 = T.pack . symbolVal $ Proxy @f3+ let f4 = T.pack . symbolVal $ Proxy @f4+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2, f3, f4]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ , (f3, Inline f3Dec)+ , (f4, Inline f4Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ , KnownSymbol f3+ , ToSchema a3+ , KnownSymbol f4+ , ToSchema a4+ , KnownSymbol f5+ , ToSchema a5+ )+ => ToSchema (NF5 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ f3Dec <- declareSchema $ Proxy @a3+ f4Dec <- declareSchema $ Proxy @a4+ f5Dec <- declareSchema $ Proxy @a5+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ let f3 = T.pack . symbolVal $ Proxy @f3+ let f4 = T.pack . symbolVal $ Proxy @f4+ let f5 = T.pack . symbolVal $ Proxy @f5+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2, f3, f4, f5]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ , (f3, Inline f3Dec)+ , (f4, Inline f4Dec)+ , (f5, Inline f5Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ , KnownSymbol f3+ , ToSchema a3+ , KnownSymbol f4+ , ToSchema a4+ , KnownSymbol f5+ , ToSchema a5+ , KnownSymbol f6+ , ToSchema a6+ )+ => ToSchema (NF6 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ f3Dec <- declareSchema $ Proxy @a3+ f4Dec <- declareSchema $ Proxy @a4+ f5Dec <- declareSchema $ Proxy @a5+ f6Dec <- declareSchema $ Proxy @a6+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ let f3 = T.pack . symbolVal $ Proxy @f3+ let f4 = T.pack . symbolVal $ Proxy @f4+ let f5 = T.pack . symbolVal $ Proxy @f5+ let f6 = T.pack . symbolVal $ Proxy @f6+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2, f3, f4, f5, f6]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ , (f3, Inline f3Dec)+ , (f4, Inline f4Dec)+ , (f5, Inline f5Dec)+ , (f6, Inline f6Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ , KnownSymbol f3+ , ToSchema a3+ , KnownSymbol f4+ , ToSchema a4+ , KnownSymbol f5+ , ToSchema a5+ , KnownSymbol f6+ , ToSchema a6+ , KnownSymbol f7+ , ToSchema a7+ )+ => ToSchema (NF7 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ f3Dec <- declareSchema $ Proxy @a3+ f4Dec <- declareSchema $ Proxy @a4+ f5Dec <- declareSchema $ Proxy @a5+ f6Dec <- declareSchema $ Proxy @a6+ f7Dec <- declareSchema $ Proxy @a7+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ let f3 = T.pack . symbolVal $ Proxy @f3+ let f4 = T.pack . symbolVal $ Proxy @f4+ let f5 = T.pack . symbolVal $ Proxy @f5+ let f6 = T.pack . symbolVal $ Proxy @f6+ let f7 = T.pack . symbolVal $ Proxy @f7+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2, f3, f4, f5, f6, f7]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ , (f3, Inline f3Dec)+ , (f4, Inline f4Dec)+ , (f5, Inline f5Dec)+ , (f6, Inline f6Dec)+ , (f7, Inline f7Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ , KnownSymbol f3+ , ToSchema a3+ , KnownSymbol f4+ , ToSchema a4+ , KnownSymbol f5+ , ToSchema a5+ , KnownSymbol f6+ , ToSchema a6+ , KnownSymbol f7+ , ToSchema a7+ , KnownSymbol f8+ , ToSchema a8+ )+ => ToSchema (NF8 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7 f8 a8)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ f3Dec <- declareSchema $ Proxy @a3+ f4Dec <- declareSchema $ Proxy @a4+ f5Dec <- declareSchema $ Proxy @a5+ f6Dec <- declareSchema $ Proxy @a6+ f7Dec <- declareSchema $ Proxy @a7+ f8Dec <- declareSchema $ Proxy @a8+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ let f3 = T.pack . symbolVal $ Proxy @f3+ let f4 = T.pack . symbolVal $ Proxy @f4+ let f5 = T.pack . symbolVal $ Proxy @f5+ let f6 = T.pack . symbolVal $ Proxy @f6+ let f7 = T.pack . symbolVal $ Proxy @f7+ let f8 = T.pack . symbolVal $ Proxy @f8+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2, f3, f4, f5, f6, f7, f8]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ , (f3, Inline f3Dec)+ , (f4, Inline f4Dec)+ , (f5, Inline f5Dec)+ , (f6, Inline f6Dec)+ , (f7, Inline f7Dec)+ , (f8, Inline f8Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }++instance+ ( KnownSymbol name+ , KnownSymbol f1+ , ToSchema a1+ , KnownSymbol f2+ , ToSchema a2+ , KnownSymbol f3+ , ToSchema a3+ , KnownSymbol f4+ , ToSchema a4+ , KnownSymbol f5+ , ToSchema a5+ , KnownSymbol f6+ , ToSchema a6+ , KnownSymbol f7+ , ToSchema a7+ , KnownSymbol f8+ , ToSchema a8+ , KnownSymbol f9+ , ToSchema a9+ )+ => ToSchema (NF9 name f1 a1 f2 a2 f3 a3 f4 a4 f5 a5 f6 a6 f7 a7 f8 a8 f9 a9)+ where+ declareNamedSchema _ = do+ f1Dec <- declareSchema $ Proxy @a1+ f2Dec <- declareSchema $ Proxy @a2+ f3Dec <- declareSchema $ Proxy @a3+ f4Dec <- declareSchema $ Proxy @a4+ f5Dec <- declareSchema $ Proxy @a5+ f6Dec <- declareSchema $ Proxy @a6+ f7Dec <- declareSchema $ Proxy @a7+ f8Dec <- declareSchema $ Proxy @a8+ f9Dec <- declareSchema $ Proxy @a9+ let f1 = T.pack . symbolVal $ Proxy @f1+ let f2 = T.pack . symbolVal $ Proxy @f2+ let f3 = T.pack . symbolVal $ Proxy @f3+ let f4 = T.pack . symbolVal $ Proxy @f4+ let f5 = T.pack . symbolVal $ Proxy @f5+ let f6 = T.pack . symbolVal $ Proxy @f6+ let f7 = T.pack . symbolVal $ Proxy @f7+ let f8 = T.pack . symbolVal $ Proxy @f8+ let f9 = T.pack . symbolVal $ Proxy @f9+ -- Not sure we should be inlining the schema. Let+ let nfSchema :: Schema+ nfSchema =+ mempty+ { _schemaRequired = [f1, f2, f3, f4, f5, f6, f7, f8, f9]+ , _schemaProperties =+ [ (f1, Inline f1Dec)+ , (f2, Inline f2Dec)+ , (f3, Inline f3Dec)+ , (f4, Inline f4Dec)+ , (f5, Inline f5Dec)+ , (f6, Inline f6Dec)+ , (f7, Inline f7Dec)+ , (f8, Inline f8Dec)+ , (f9, Inline f9Dec)+ ]+ }+ pure+ NamedSchema+ { _namedSchemaName = Just . T.pack . symbolVal $ Proxy @name+ , _namedSchemaSchema = nfSchema+ }
+ src/DomainDriven/Internal/NamedJsonFields.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE UndecidableInstances #-}++module DomainDriven.Internal.NamedJsonFields where++import Control.Applicative+import Control.Monad.State+import Data.Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+import Data.Aeson.Types+import Data.Generics.Product+import Data.Kind (Type)+import Data.Maybe (fromMaybe)+import qualified Data.OpenApi as O+import Data.OpenApi.Declare+import Data.Proxy+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import DomainDriven.Internal.HasFieldName+import GHC.Generics+import Lens.Micro hiding (to)+import Prelude++import qualified Lens.Micro as Lens++packed :: Getting r String Text+packed = Lens.to T.pack++newtype NamedJsonFields a = NamedJsonFields a++instance (GNamedToJSON (Rep a), Generic a) => ToJSON (NamedJsonFields a) where+ toJSON (NamedJsonFields a) = gNamedToJson defaultNamedJsonOptions a++instance (GNamedFromJSON (Rep a), Generic a) => FromJSON (NamedJsonFields a) where+ parseJSON = fmap NamedJsonFields . gNamedParseJson defaultNamedJsonOptions++instance (Typeable a, GNamedToSchema (Rep a)) => O.ToSchema (NamedJsonFields a) where+ declareNamedSchema _ = gNamedDeclareNamedSchema defaultNamedJsonOptions (Proxy @a)++-- evalStateT (gDeclareNamedSchema defaultNamedJsonOptions $ Proxy @(Rep a)) []++gNamedToJson :: (GNamedToJSON (Rep a), Generic a) => NamedJsonOptions -> a -> Value+gNamedToJson opts a = Object . KM.fromList $ evalState (gToTupleList opts $ from a) []++gNamedParseJson+ :: (GNamedFromJSON (Rep a), Generic a) => NamedJsonOptions -> Value -> Parser a+gNamedParseJson opts v = to <$> evalStateT (gNamedFromJSON opts v) []++gNamedDeclareNamedSchema+ :: forall a+ . (GNamedToSchema (Rep a))+ => NamedJsonOptions+ -> Proxy a+ -> Declare (O.Definitions O.Schema) O.NamedSchema+gNamedDeclareNamedSchema opts _ =+ evalStateT (gDeclareNamedSchema opts (Proxy @(Rep a))) []++-----------------------------------------Options------------------------------------------++data NamedJsonOptions = NamedJsonOptions+ { constructorTagModifier :: String -> String+ , tagFieldName :: String+ , skipTagField :: Bool+ , datatypeNameModifier :: String -> String+ }+ deriving (Generic)++defaultNamedJsonOptions :: NamedJsonOptions+defaultNamedJsonOptions =+ NamedJsonOptions+ { constructorTagModifier = id+ , tagFieldName = "tag"+ , skipTagField = False+ , datatypeNameModifier = id+ }++-----------------------------------------O.ToSchema-----------------------------------------+data Proxy3 a b c = Proxy3++class GNamedToSchema (f :: Type -> Type) where+ gDeclareNamedSchema+ :: NamedJsonOptions+ -> Proxy f+ -> StateT [UsedName] (Declare (O.Definitions O.Schema)) O.NamedSchema++-- Grab the name of the datatype+instance (Datatype d, GNamedToSchema f) => GNamedToSchema (D1 d f) where+ gDeclareNamedSchema opts _ = do+ let dtName :: String+ dtName = opts ^. field @"datatypeNameModifier" $ datatypeName (Proxy3 @d @f)+ O.NamedSchema _ rest <- gDeclareNamedSchema opts (Proxy @f)+ pure $ O.NamedSchema (Just $ T.pack dtName) rest++-- Grab the name of the constructor to use for the `tag` field content.+instance (GNamedToSchema f, Constructor c) => GNamedToSchema (C1 c f) where+ gDeclareNamedSchema opts _ = do+ O.NamedSchema _ s <- gDeclareNamedSchema opts (Proxy @f)+ if opts ^. field @"skipTagField"+ then pure $ O.NamedSchema Nothing s+ else do+ let tagName :: Key+ tagName = Key.fromText $ opts ^. field @"tagFieldName" . packed+ state $ \ss -> ((), tagName : ss)+ let constructorName :: Text+ constructorName =+ T.pack+ . (opts ^. field @"constructorTagModifier")+ . conName+ $ Proxy3 @c @f++ tagFieldSchema :: O.Schema+ tagFieldSchema =+ mempty+ & O.properties+ <>~ [+ ( Key.toText tagName+ , O.Inline $+ mempty+ & O.type_+ ?~ O.OpenApiString+ & O.enum_+ ?~ [String constructorName]+ )+ ]+ & O.required+ <>~ [Key.toText tagName]+ pure $ O.NamedSchema Nothing $ tagFieldSchema <> s++-- Grab the name of the field, but not not set it as O.required+instance+ {-# OVERLAPPING #-}+ (O.ToSchema f, HasFieldName f)+ => GNamedToSchema (S1 s (Rec0 (Maybe f)))+ where+ gDeclareNamedSchema _opts _ = do+ let fName = Key.fromText $ fieldName @(Maybe f)+ usedNames <- state (\used -> (used, fName : used))+ _ <- lift $ O.declareSchemaRef $ Proxy @f+ pure+ . O.NamedSchema Nothing+ $ mempty+ & O.properties+ <>~ [+ ( Key.toText $ actualFieldName usedNames fName+ , O.Inline $ O.toSchema $ Proxy @f+ )+ ]++-- Grab the name of the field and set it as O.required+instance+ {-# OVERLAPPABLE #-}+ (O.ToSchema f, HasFieldName f)+ => GNamedToSchema (S1 s (Rec0 f))+ where+ gDeclareNamedSchema _opts _ = do+ let fName = Key.fromText $ fieldName @f+ usedNames <- state (\used -> (used, fName : used))+ _ <- lift $ O.declareSchemaRef $ Proxy @f+ pure+ . O.NamedSchema Nothing+ $ mempty+ & O.properties+ <>~ [+ ( Key.toText $ actualFieldName usedNames fName+ , O.Inline $ O.toSchema $ Proxy @f+ )+ ]+ & O.required+ <>~ [Key.toText $ actualFieldName usedNames fName]++instance GNamedToSchema U1 where+ gDeclareNamedSchema _opts _ = pure $ O.NamedSchema Nothing mempty++instance (GNamedToSchema f, GNamedToSchema g) => GNamedToSchema (f :*: g) where+ gDeclareNamedSchema opts _ = do+ O.NamedSchema _ a <- gDeclareNamedSchema opts (Proxy @f)+ O.NamedSchema _ b <- gDeclareNamedSchema opts (Proxy @g)+ pure (O.NamedSchema Nothing $ a <> b)++instance (GNamedToSchema f, GNamedToSchema g) => GNamedToSchema (f :+: g) where+ gDeclareNamedSchema opts _ = do+ -- Sum types do not share fields, thus we do not need to adjust the names+ O.NamedSchema _ a <- lift $ evalStateT (gDeclareNamedSchema opts (Proxy @f)) []+ O.NamedSchema _ b <- lift $ evalStateT (gDeclareNamedSchema opts (Proxy @g)) []+ let unwrapOneOf :: O.Schema -> [O.Referenced O.Schema]+ unwrapOneOf x = fromMaybe [O.Inline x] $ x ^. O.oneOf+ pure $+ O.NamedSchema Nothing $+ mempty+ & O.oneOf+ ?~ unwrapOneOf a <> unwrapOneOf b++------------------------------------------ToJSON------------------------------------------+type UsedName = Key++class GNamedToJSON a where+ gToTupleList :: NamedJsonOptions -> a x -> State [UsedName] [(Key, Value)]++instance (GNamedToJSON f) => GNamedToJSON (M1 D d f) where+ gToTupleList opts = gToTupleList opts . unM1++instance (GNamedToJSON f, Constructor c) => GNamedToJSON (M1 C c f) where+ gToTupleList opts a = do+ tag <-+ if opts ^. field @"skipTagField"+ then pure []+ else do+ usedNames <- get+ put $ usedNames <> [Key.fromText $ opts ^. field @"tagFieldName" . packed]+ pure+ [+ ( Key.fromText $ opts ^. field @"tagFieldName" . packed+ , String+ . T.pack+ . (opts ^. field @"constructorTagModifier")+ $ conName a+ )+ ]+ rest <- gToTupleList opts $ unM1 a+ pure $ tag <> rest++instance (ToJSON t, HasFieldName t) => GNamedToJSON (M1 S c (Rec0 t)) where+ gToTupleList _opts a = do+ usedNames <- get+ let fName = Key.fromText $ fieldName @t+ put $ usedNames <> [fName]+ pure [(actualFieldName usedNames fName, toJSON . unK1 $ unM1 a)]++instance GNamedToJSON U1 where+ gToTupleList _opts U1 = pure []++instance (GNamedToJSON a, GNamedToJSON b) => GNamedToJSON (a :*: b) where+ gToTupleList opts (a :*: b) = do+ p1 <- gToTupleList opts a+ p2 <- gToTupleList opts b+ pure $ p1 <> p2++instance (GNamedToJSON a, GNamedToJSON b) => GNamedToJSON (a :+: b) where+ gToTupleList opts = \case+ L1 a -> gToTupleList opts a+ R1 a -> gToTupleList opts a++actualFieldName :: [UsedName] -> Key -> Key+actualFieldName usedNames fName =+ fName <> case length (filter (== fName) usedNames) of+ 0 -> Key.fromText ""+ i -> Key.fromText $ "_" <> T.pack (show (i + 1))++-----------------------------------------FromJSON-----------------------------------------++lookupKey :: Key -> Value -> StateT [UsedName] Parser Value+lookupKey k = \case+ Object o -> do+ usedNames <- get+ put $ usedNames <> [k]+ maybe (fail $ "No key " <> show k) pure $ KM.lookup k o+ _ -> fail $ "Expected " <> show k <> " to be an object."++class GNamedFromJSON a where+ gNamedFromJSON :: NamedJsonOptions -> Value -> StateT [UsedName] Parser (a x)++instance GNamedFromJSON p => GNamedFromJSON (M1 D f p) where+ gNamedFromJSON opts v = M1 <$> gNamedFromJSON opts v++instance (Constructor f, GNamedFromJSON p) => GNamedFromJSON (M1 C f p) where+ gNamedFromJSON opts v =+ if opts ^. field @"skipTagField"+ then M1 <$> gNamedFromJSON opts v+ else do+ tag <- lookupKey (Key.fromText $ opts ^. field @"tagFieldName" . packed) v+ c <- M1 <$> gNamedFromJSON opts v+ let constructorName =+ T.pack . (opts ^. field @"constructorTagModifier") $ conName c+ case tag of+ String t | t == constructorName -> pure c+ _ -> fail "Unknown tag"++instance GNamedFromJSON U1 where+ gNamedFromJSON _opts _ = pure U1++instance (GNamedFromJSON a, GNamedFromJSON b) => GNamedFromJSON (a :+: b) where+ gNamedFromJSON opts vals =+ L1 <$> gNamedFromJSON opts vals <|> R1 <$> gNamedFromJSON opts vals++instance (GNamedFromJSON a, GNamedFromJSON b) => GNamedFromJSON (a :*: b) where+ gNamedFromJSON opts vals = do+ p1 <- gNamedFromJSON opts vals+ p2 <- gNamedFromJSON opts vals+ pure $ p1 :*: p2++instance (FromJSON t, HasFieldName t) => GNamedFromJSON (M1 S c (Rec0 t)) where+ gNamedFromJSON _opts vals = do+ usedNames <- get+ let fName = Key.fromText $ fieldName @t+ v <- lookupKey (actualFieldName usedNames fName) vals+ put $ usedNames <> [fName]+ lift $ M1 . K1 <$> (parseJSON @t) v
+ src/DomainDriven/Internal/Text.hs view
@@ -0,0 +1,31 @@+module DomainDriven.Internal.Text where++import Data.Char+ ( toLower+ , toUpper+ )+import Data.Text (Text)+import qualified Data.Text as T+import Prelude++lowerFirst :: String -> String+lowerFirst = \case+ [] -> []+ c : cs -> toLower c : cs++lowerFirstT :: Text -> Text+lowerFirstT = T.pack . lowerFirst . T.unpack++upperFirst :: String -> String+upperFirst = \case+ [] -> []+ c : cs -> toUpper c : cs++upperFirstT :: Text -> Text+upperFirstT = T.pack . upperFirst . T.unpack++camelAppend :: String -> String -> String+camelAppend a b = a <> upperFirst b++camelAppendT :: Text -> Text -> Text+camelAppendT a b = a <> upperFirstT b
+ src/DomainDriven/Server/Class.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module DomainDriven.Server.Class where++import Control.Monad.Reader+import Data.Kind+import DomainDriven.Persistance.Class+import GHC.TypeLits+import Servant+import UnliftIO+import Prelude++data+ RequestType+ (accessType :: ModelAccess)+ (contentTypes :: [Type])+ (verb :: Type -> Type)++data ModelAccess+ = Direct+ | Callback++type Cmd = RequestType 'Direct '[JSON] (Verb 'POST 200 '[JSON])+type CbCmd = RequestType 'Callback '[JSON] (Verb 'POST 200 '[JSON])+type Query = RequestType 'Direct '[JSON] (Verb 'GET 200 '[JSON])+type CbQuery = RequestType 'Callback '[JSON] (Verb 'GET 200 '[JSON])++-- | The kind of an Action, defined with a GADT as:+-- data MyAction :: Action where+-- ThisAction :: P x "count" Int -> MyAction x 'Cmd Int+-- ThatAction :: P x "description" Text -> MyAction x 'Cmd ()+type Action = ParamPart -> Type -> Type -> Type++type family CanMutate method :: Bool where+ CanMutate (RequestType a c (Verb 'GET code cts)) = 'False+ CanMutate (RequestType a c (Verb 'POST code cts)) = 'True+ CanMutate (RequestType a c (Verb 'PUT code cts)) = 'True+ CanMutate (RequestType a c (Verb 'PATCH code cts)) = 'True+ CanMutate (RequestType a c (Verb 'DELETE code cts)) = 'True++-- | Used as a parameter to the `P` type family on order to determine the focus.+data ParamPart+ = ParamName+ | ParamType+ deriving (Show)++-- | P is used for specifying the parameters of the model.+-- The name will be used as the name in the JSON encoding or the query parameter of the+-- generated server.+type family P (x :: ParamPart) (name :: Symbol) (a :: Type) where+ P 'ParamName name ty = Proxy name+ P 'ParamType name ty = ty++type family GetModelAccess method :: ModelAccess where+ GetModelAccess (RequestType a b c) = a++data HandlerType method model event m a where+ Query+ :: (CanMutate method ~ 'False, GetModelAccess method ~ 'Direct)+ => (model -> m a)+ -> HandlerType method model event m a+ CbQuery+ :: (CanMutate method ~ 'False, GetModelAccess method ~ 'Callback)+ => ((m model) -> m a)+ -> HandlerType method model event m a+ Cmd+ :: (CanMutate method ~ 'True, GetModelAccess method ~ 'Direct)+ => (model -> m (model -> a, [event]))+ -> HandlerType method model event m a+ CbCmd+ :: (CanMutate method ~ 'True, GetModelAccess method ~ 'Callback)+ => ((forall x. (model -> m (model -> x, [event])) -> m x) -> m a)+ -> HandlerType method model event m a++type CmdCallback model event (m :: Type -> Type) =+ (forall a. model -> m (a, [event]))++mapModel+ :: forall m event model0 model1 method a+ . Monad m+ => (model0 -> model1)+ -> HandlerType method model1 event m a+ -> HandlerType method model0 event m a+mapModel f = \case+ Query h -> Query (h . f)+ CbQuery withModel -> CbQuery \fetchModel ->+ withModel (fmap f fetchModel)+ Cmd h -> Cmd $ \m -> do+ (fm, evs) <- h $ f m+ pure (fm . f, evs)+ CbCmd withTrans -> CbCmd $ \runTrans ->+ withTrans $ \(trans :: model -> m (x, [e0])) -> do+ runTrans $ \model -> do+ (r, evs) <- trans (f model)+ pure (r . f, evs)++mapEvent+ :: forall m e0 e1 a method model+ . Monad m+ => (e0 -> e1)+ -> HandlerType method model e0 m a+ -> HandlerType method model e1 m a+mapEvent f = \case+ Query h -> Query h+ CbQuery h -> CbQuery h+ Cmd h -> Cmd $ \m -> do+ (ret, evs) <- h m+ pure (ret, fmap f evs)+ CbCmd withTrans -> CbCmd $ \runTrans ->+ withTrans $ \(trans :: model -> m (x, [e0])) -> do+ runTrans $ \model -> do+ (r, evs) <- trans model+ pure (r, fmap f evs)++mapResult+ :: Monad m+ => (r0 -> r1)+ -> HandlerType method model e m r0+ -> HandlerType method model e m r1+mapResult f = \case+ Query h -> Query $ fmap f . h+ CbQuery h -> CbQuery $ fmap f . h+ Cmd h -> Cmd $ \m -> do+ (ret, evs) <- h m+ pure (f . ret, evs)+ CbCmd withTrans -> CbCmd $ \transact -> f <$> withTrans transact++-- | Action handler+--+-- Expects a command, specified using a one-parameter GADT where the parameter specifies+-- the return type.+--+-- When implementing the handler you have access to IO, but in order for the library to+-- ensure thread safety of state updates you do not have direct access to the current+-- state. Instead the handler returns a continuation, telling the library how to perform+-- the evaluations on the model.+--+-- The resulting events will be applied to the current state so that no other command can+-- run and generate events on the same state.+type ActionHandler model event m c =+ forall method a. c 'ParamType method a -> HandlerType method model event m a++type ActionRunner m c =+ forall method a+ . MonadUnliftIO m+ => c 'ParamType method a+ -> m a++runAction+ :: (MonadUnliftIO m, WriteModel p, model ~ Model p, event ~ Event p)+ => p+ -> ActionHandler model event m cmd+ -> cmd 'ParamType method ret+ -> m ret+runAction p handleCmd cmd = case handleCmd cmd of+ Query m -> m =<< liftIO (getModel p)+ CbQuery m -> m (liftIO (getModel p))+ Cmd m -> transactionalUpdate p m+ CbCmd withTrans -> withTrans $ \runTrans -> do+ transactionalUpdate p runTrans
+ src/DomainDriven/Server/Config.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use newtype instead of data" #-}++module DomainDriven.Server.Config+ ( module DomainDriven.Server.Config+ , Name+ )+where++import Data.Char (isLower)+import qualified Data.List as L+import qualified Data.Map as M+import DomainDriven.Server.Class+import DomainDriven.Server.Types+import GHC.Generics (Generic)+import Language.Haskell.TH+import Lens.Micro ((%~), _2)+import Prelude++-- | Configuration used to generate server+-- This is expected to be generated by `mkServerConfig`. It is only explicit due to+-- the GHC stage restrictions.+data ServerConfig = ServerConfig+ { allApiOptions :: M.Map String ApiOptions+ -- ^ Map of API options for all action GADTs used in the API+ }+ deriving (Show, Generic)++class HasApiOptions (action :: Action) where+ apiOptions :: ApiOptions+ apiOptions = defaultApiOptions++defaultServerConfig :: ServerConfig+defaultServerConfig = ServerConfig M.empty++-- | Generate a server configuration and give it the specified name+mkServerConfig :: String -> Q [Dec]+mkServerConfig (mkName -> cfgName) = do+ sig' <- sigD cfgName (conT ''ServerConfig)+ body' <-+ [d|$(varP cfgName) = ServerConfig $(getApiOptionsMap)|]+ pure $ sig' : body'++-- | Generates `Map String ApiOptions`+-- Containing the ApiOptions of all types with an ApiOpts instance+getApiOptionsMap :: Q Exp+getApiOptionsMap =+ reify ''HasApiOptions >>= \case+ ClassI _ instances -> do+ cfgs <- traverse nameAndCfg instances+ [e|M.fromList $(pure $ ListE cfgs)|]+ i -> fail $ "Expected ClassI but got: " <> show i+ where+ nameAndCfg :: Dec -> Q Exp+ nameAndCfg = \case+ InstanceD _ _ (AppT klass ty') _ | klass == ConT ''HasApiOptions -> do+ (name, ty) <- getNameAndTypePattern ty'+ [e|+ ( $(stringE $ show name)+ , apiOptions @($(pure ty))+ )+ |]+ d -> fail $ "Expected instance InstanceD but got: " <> show d++ getNameAndTypePattern :: Type -> Q (Name, Type)+ getNameAndTypePattern = \case+ ty@(ConT n) -> pure (n, ty)+ AppT ty _ -> (_2 %~ (`AppT` WildCardT)) <$> getNameAndTypePattern ty+ ty -> fail $ "stipExtraParams: Expected to find constructor, got: " <> show ty++------------------------------------------------------------------------------------------+-- Some utility functions that can be useful when remapping names+------------------------------------------------------------------------------------------+dropPrefix :: String -> String -> String+dropPrefix pre s = if pre `L.isPrefixOf` s then drop (length pre) s else s++dropSuffix :: String -> String -> String+dropSuffix pre s = if pre `L.isSuffixOf` s then take (length s - length pre) s else s++dropFirstWord :: String -> String+dropFirstWord = L.dropWhile isLower . drop 1
+ src/DomainDriven/Server/Helpers.hs view
@@ -0,0 +1,122 @@+module DomainDriven.Server.Helpers where++import Control.Monad+import Control.Monad.State+import Data.Generics.Product+import qualified Data.List as L+import DomainDriven.Internal.Text+import DomainDriven.Server.Types+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (OccName (..))+import Lens.Micro+import Prelude++runServerGenM :: ServerGenState -> ServerGenM a -> Q a+runServerGenM s m = evalStateT (unServerGenM m) s++liftQ :: Q a -> ServerGenM a+liftQ m = ServerGenM $ lift m++withLocalState :: (ServerGenState -> ServerGenState) -> ServerGenM a -> ServerGenM a+withLocalState fs m = ServerGenM $ do+ startState <- get+ modify fs+ a <- unServerGenM m+ put startState+ pure a++mkUrlSegment :: ConstructorName -> ServerGenM UrlSegment+mkUrlSegment n = do+ opts <- gets (^. field @"info" . field @"options")+ pure $+ n+ ^. typed+ . unqualifiedString+ . to (opts ^. field @"renameConstructor")+ . to UrlSegment++unqualifiedString :: Lens' Name String+unqualifiedString = typed @OccName . typed++askTypeName :: ServerGenM Name+askTypeName = do+ si <- get+ let baseName :: String+ baseName =+ si ^. field @"info" . field @"baseGadt" . typed @Name . unqualifiedString++ cNames :: [String]+ cNames =+ si+ ^.. field @"info"+ . typed @[ConstructorName]+ . folded+ . typed @Name+ . unqualifiedString+ separator :: String+ separator = si ^. field @"info" . typed @ApiOptions . field @"typenameSeparator"++ pure . mkName . L.intercalate separator $ baseName : cNames++askApiTypeName :: ServerGenM Name+askApiTypeName = (unqualifiedString <>~ "Api") <$> askTypeName++askEndpointTypeName :: ServerGenM Name+askEndpointTypeName = (unqualifiedString <>~ "Endpoint") <$> askTypeName++askServerName :: ServerGenM Name+askServerName =+ (\n -> n & unqualifiedString %~ lowerFirst & unqualifiedString <>~ "Server")+ <$> askTypeName++askHandlerName :: ServerGenM Name+askHandlerName =+ (\n -> n & unqualifiedString %~ lowerFirst & unqualifiedString <>~ "Handler")+ <$> askTypeName++askBodyTag :: ConstructorName -> ServerGenM TyLit+askBodyTag cName = do+ constructorSegment <- mkUrlSegment cName+ gadtSegment <-+ gets (^. field @"info" . field @"options" . field @"bodyNameBase") >>= \case+ Just n -> pure $ UrlSegment n+ Nothing ->+ gets+ ( ^.+ field @"info"+ . field @"currentGadt"+ . typed+ . to nameBase+ . to UrlSegment+ )++ separator <- gets (^. field @"info" . typed @ApiOptions . field @"typenameSeparator")+ pure+ . StrTyLit+ . L.intercalate separator+ $ (gadtSegment : [constructorSegment])+ ^.. folded+ . typed++enterApi :: ApiSpec -> ServerGenM a -> ServerGenM a+enterApi spec m = withLocalState (field @"info" %~ extendServerInfo) m+ where+ extendServerInfo :: ServerInfo -> ServerInfo+ extendServerInfo i =+ i & typed .~ spec ^. typed @ApiOptions & field @"currentGadt" .~ spec ^. typed++enterApiPiece :: ApiPiece -> ServerGenM a -> ServerGenM a+enterApiPiece p m = do+ newSegment <- mkUrlSegment (p ^. typed @ConstructorName)+ let extendServerInfo :: ServerInfo -> ServerInfo+ extendServerInfo i =+ i+ & (typed @[UrlSegment] <>~ [newSegment])+ & (typed @[ConstructorName] <>~ p ^. typed . to pure)+ withLocalState (field @"info" %~ extendServerInfo) m++hasJsonContentType :: HandlerSettings -> Bool+hasJsonContentType hs = case hs ^. field @"contentTypes" of+ AppT (AppT PromotedConsT (ConT n)) (SigT PromotedNilT (AppT ListT StarT)) ->+ nameBase n == "JSON"+ _ -> False
+ src/DomainDriven/Server/TH.hs view
@@ -0,0 +1,995 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module DomainDriven.Server.TH where++import Control.Monad++import Control.Monad.State+import Data.Foldable+import Data.Function (on)+import Data.Generics.Product+import Data.List qualified as L+import Data.Map qualified as M+import Data.Maybe+import Data.Set qualified as S+import Data.Traversable+import DomainDriven.Server.Class+import DomainDriven.Server.Config+import DomainDriven.Server.Helpers+import DomainDriven.Server.Types+import Language.Haskell.TH+import Lens.Micro+import Servant+import UnliftIO (MonadUnliftIO (..))+import Prelude++-- import Debug.Trace+-- import GHC.Generics (Generic)+-- import Data.Bifunctor++-- | Generate a server with granular configuration+--+-- Expects a Map of ApiOptions generated by `DomainDriven.Config.getApiOptionsMap`+-- Due to GHC stage restrictions this cannot be generated in the same module.+--+-- Using this require you to enable template haskell+-- {\-# LANGUAGE TemplateHaskell #-\}++-- $(mkServer config ''MyAction)++mkServer :: ServerConfig -> Name -> Q [Dec]+mkServer cfg (GadtName -> gadtName) = do+ spec <- mkServerSpec cfg gadtName+ opts <- getApiOptions cfg gadtName+ let si :: ServerInfo+ si =+ ServerInfo+ { baseGadt = spec ^. typed+ , currentGadt = spec ^. typed+ , parentConstructors = []+ , prefixSegments = []+ , options = opts+ }+ runServerGenM+ ServerGenState{info = si, usedParamNames = mempty}+ (mkServerFromSpec spec)++getApiOptions :: ServerConfig -> GadtName -> Q ApiOptions+getApiOptions cfg (GadtName n) = case M.lookup (show n) (allApiOptions cfg) of+ Just o -> pure o+ Nothing ->+ fail $+ "Cannot find ApiOptions for "+ <> show n+ <> ". "+ <> "\nProbable reasons:"+ <> "\n - It does not implement `HasApiOptions`."+ <> "\n - The instance is not visible from where `mkServerConfig` is run."+ <> "\n - The `ServerConfig` instance was manually defined and not complete."++getActionDec :: GadtName -> Q (Dec, VarBindings)+getActionDec (GadtName n) = do+ cmdType <- reify n+ let errMsg = fail $ "Expected " <> show n <> "to be a GADT"+ case cmdType of+ TyConI dec@(DataD _ctx _name params _ _ _) ->+ case mkVarBindings params of+ Right b -> pure (dec, b)+ Left err -> fail $ "getActionDec: " <> err+ TyConI{} -> errMsg+ ClassI{} -> errMsg+ ClassOpI{} -> errMsg+ FamilyI{} -> errMsg+ PrimTyConI{} -> errMsg+ DataConI{} -> errMsg+ PatSynI{} -> errMsg+ VarI{} -> errMsg+ TyVarI{} -> errMsg++getSubActionDec :: VarBindings -> SubActionMatch -> Q (Dec, VarBindings)+getSubActionDec tyVars subAction = do+ -- We have to do a `reify` on the subaction to get the constructors. When we do this+ -- we get new [TyVarBndr ()]. These needs to be unified with what we have from the+ -- parent.++ cmdType <- reify $ subAction ^. field @"subActionName"+ case cmdType of+ TyConI (DataD ctx name params mKind constructors deriv) -> do+ let parentParams :: [TyVarBndr ()]+ parentParams =+ getUsedTyVars+ (toTyVarBndr tyVars)+ (subAction ^. field @"subActionType")++ unless+ (on (==) length parentParams params)+ ( fail $+ "getSubActionDec: Different number of parameters. Parent: "+ <> show parentParams+ <> ", child: "+ <> show params+ )+ let tyVarMap :: M.Map Name Name+ tyVarMap =+ M.fromList $+ on zip (^.. folded . typed @Name) params parentParams++ case mkVarBindings parentParams of+ Right b -> do+ let rename :: Type -> Type+ rename ty = either (const ty) id $ replaceVarT tyVarMap ty++ constructorDec :: Dec+ constructorDec =+ DataD+ (fmap rename ctx)+ name+ parentParams+ mKind+ (fmap (updateConstructorTypes rename) constructors)+ deriv+ pure (constructorDec, b)+ Left err -> fail $ "getSubActionDec: " <> err <> " --------- " <> show parentParams+ TyConI{} -> errorOut+ ClassI{} -> errorOut+ ClassOpI{} -> errorOut+ FamilyI{} -> errorOut+ PrimTyConI{} -> errorOut+ DataConI{} -> errorOut+ PatSynI{} -> errorOut+ VarI{} -> errorOut+ TyVarI{} -> errorOut+ where+ errorOut =+ fail $+ "Expected "+ <> show (subAction ^. field @"subActionName")+ <> "to be a GADT"++replaceVarT :: M.Map Name Name -> Type -> Either String Type+replaceVarT m = \case+ AppT ty1 ty2 -> AppT <$> replaceVarT m ty1 <*> replaceVarT m ty2+ VarT oldName -> case M.lookup oldName m of+ Just n -> Right (VarT n)+ Nothing -> Left $ "replaceVarT: No match for variable \"" <> show oldName <> "\""+ ty -> Right ty -- Don't think I need to match on other constructors. *lazy*++guardMethodVar :: TyVarBndr flag -> Q ()+guardMethodVar = \case+ KindedTV _ _ k -> check k+ PlainTV _ _ -> check StarT+ where+ check :: Type -> Q ()+ check _ = pure ()++getMutabilityOf :: Type -> Q Mutability+getMutabilityOf = \case+ AppT (AppT (AppT _ (PromotedT verbName)) _) _ -> checkVerb verbName+ ConT n ->+ reify n >>= \case+ TyConI (TySynD _ _ (AppT (AppT (AppT _ (PromotedT verbName)) _) _)) ->+ checkVerb verbName+ info ->+ fail $+ "Expected method to be a Verb of a type synonym for a Verb. Got:\n"+ <> show info+ ty -> fail $ "Expected a Verb without return type applied, got: " <> show ty+ where+ checkVerb :: Name -> Q Mutability+ checkVerb n = case show n of+ "Network.HTTP.Types.Method.GET" -> pure Immutable+ _ -> pure Mutable++guardReturnVar :: Show flag => TyVarBndr flag -> Q ()+guardReturnVar = \case+ KindedTV _ _ StarT -> pure ()+ PlainTV _ _ -> pure ()+ ty -> fail $ "Return type must be a concrete type. Got: " <> show ty++getConstructors :: Dec -> Q [Con]+getConstructors = \case+ DataD _ _ (last3 -> Just (_x, method, ret)) _ cs _ -> do+ guardMethodVar method+ guardReturnVar ret+ pure cs+ d@DataD{} -> fail $ "Unexpected Action data type: " <> show d+ d -> fail $ "Expected a GADT with two parameters but got: " <> show d+ where+ last3 :: [a] -> Maybe (a, a, a)+ last3 = \case+ [a, b, c] -> Just (a, b, c)+ [_, _] -> Nothing+ [_] -> Nothing+ [] -> Nothing+ l -> last3 $ tail l++toTyVarBndr :: VarBindings -> [TyVarBndr ()]+toTyVarBndr VarBindings{paramPart, method, return, extra} =+ extra <> [KindedTV paramPart () (ConT ''ParamPart), PlainTV method (), PlainTV return ()]++mkVarBindings :: Show flag => [TyVarBndr flag] -> Either String VarBindings+mkVarBindings varBinds = case varBinds of+ [KindedTV x _ kind, method, ret]+ | kind == ConT ''ParamPart ->+ Right+ VarBindings+ { paramPart = x+ , method = method ^. to noFlag . typed @Name+ , return = ret ^. to noFlag . typed @Name+ , extra = []+ }+ | otherwise ->+ Left $+ "mkVarBindings: Expected parameter of kind ParamPart, got: "+ <> show varBinds+ [_, _] -> Left errMsg+ [_] -> Left errMsg+ [] -> Left errMsg+ p : l -> over (field @"extra") (noFlag p :) <$> mkVarBindings l+ where+ noFlag :: TyVarBndr flag -> TyVarBndr ()+ noFlag = \case+ KindedTV x _ kind -> KindedTV x () kind+ PlainTV x _ -> PlainTV x ()++ errMsg =+ "mkVarBindings: Expected parameters `(x :: ParamPart) method return`, got: "+ <> show varBinds++matchNormalConstructor :: Con -> Either String ConstructorMatch+matchNormalConstructor con = do+ (x, gadtCon) <- unconsForall con+ (conName, params, constructorType) <- unconsGadt gadtCon+ finalType <- matchFinalConstructorType constructorType+ pure+ ConstructorMatch+ { xParam = x+ , constructorName = conName+ , parameters = params+ , finalType = finalType+ }+ where+ getParamPartVar :: Show a => [TyVarBndr a] -> Either String Name+ getParamPartVar = \case+ KindedTV x _spec kind : _ | kind == ConT ''ParamPart -> Right x+ a : l -> case getParamPartVar l of+ r@Right{} -> r+ Left e -> Left $ e <> show a+ [] -> Left "Expected a constrctor parameterized by `(x :: ParamPart)`, got: "++ unconsForall :: Con -> Either String (Name, Con)+ unconsForall = \case+ ForallC bindings _ctx con' -> do+ x <- getParamPartVar bindings+ Right (x, con')+ con' ->+ Left $+ "Expected a constrctor parameterized by `(x :: ParamPart)`, got: "+ <> show con'++ unconsGadt :: Con -> Either String (Name, [Pmatch], Type)+ unconsGadt = \case+ GadtC [conName] bangArgs ty -> do+ params <- traverse (matchP . snd) bangArgs+ pure (conName, params, ty)+ con' -> Left $ "Expected Gadt constrctor, got: " <> show con'++matchSubActionConstructor :: Con -> Either String SubActionMatch+matchSubActionConstructor con = do+ gadtCon <- unconsForall con+ -- Left $ show gadtCon+ (conName, normalParams, (subActionName, subActionType), _constructorType) <-+ unconsGadt gadtCon+ pure+ SubActionMatch+ { constructorName = conName+ , parameters = normalParams+ , subActionName = subActionName+ , subActionType = subActionType+ }+ where+ unconsForall :: Con -> Either String Con+ unconsForall = \case+ ForallC _params _ctx con' -> pure con'+ con' ->+ Left $+ "Expected a higher order constrctor parameterized by `(x :: ParamPart)`, got: "+ <> show con'++ unconsGadt :: Con -> Either String (Name, [Pmatch], (Name, Type), Type)+ unconsGadt = \case+ con'@(GadtC [actionName] bangArgs ty) -> do+ (normalArgs, subActionType) <- do+ let (normalArgs, subActions) =+ L.splitAt (length bangArgs - 1) (snd <$> bangArgs)+ case subActions of+ [] -> Left "No arguments"+ a : _ -> Right (normalArgs, a)+ normalParams <- traverse matchP normalArgs+ let getActionName :: Type -> Either String Name+ getActionName = \case+ ConT subAction -> Right subAction+ (AppT a _) -> getActionName a+ ty' ->+ Left $+ "getActionName: Expected `ConT [action name]` got: "+ <> show ty'+ <> " from constructor: "+ <> show con'+ subActionName <- getActionName subActionType+ pure (actionName, normalParams, (subActionName, subActionType), ty)+ con' -> Left $ "Expected Gadt constrctor, got: " <> show con'++matchFinalConstructorType :: Type -> Either String FinalConstructorTypeMatch+matchFinalConstructorType = \case+ AppT (AppT _typeName a) retTy -> do+ reqTy <- matchRequestType a+ Right FinalConstructorTypeMatch{requestType = reqTy, returnType = retTy}+ ty -> Left $ "Expected constructor like `GetCount x Query Int`, got: " <> show ty++matchRequestType :: Type -> Either String RequestTypeMatch+matchRequestType = \case+ AppT (AppT (AppT (ConT _reqTy) accessType) ct) verb ->+ Right RequestTypeMatch{accessType = accessType, contentTypes = ct, verb = verb}+ ty -> Left $ "Expected `RequestType`, got: " <> show ty++-- | Tries to match a Type to a more easily readable Pmatch.+-- Successful match means the type is representing the type family `P`+matchP :: Type -> Either String Pmatch+matchP = \case+ AppT (AppT (AppT (ConT p) (VarT x)) (LitT (StrTyLit pName))) ty -> do+ unless+ (on (==) show p ''P)+ (Left $ "Expected " <> show ''P <> ", got: " <> show p)+ Right Pmatch{paramPart = x, paramName = pName, paramType = ty}+ ty -> Left $ "Expected type family `P`, got: " <> show ty++mkApiPiece :: ServerConfig -> VarBindings -> Con -> Q ApiPiece+mkApiPiece cfg varBindings con = do+ case (matchNormalConstructor con, matchSubActionConstructor con) of+ (Right c, _) -> do+ actionType <-+ getMutabilityOf $+ c+ ^. field @"finalType"+ . field @"requestType"+ . field @"verb"+ pure $+ Endpoint+ (ConstructorName $ c ^. field @"constructorName")+ ( ConstructorArgs $+ c+ ^.. field @"parameters"+ . folded+ . to+ (\p -> (p ^. field @"paramName", p ^. field @"paramType"))+ )+ varBindings+ HandlerSettings+ { contentTypes =+ c+ ^. field @"finalType"+ . field @"requestType"+ . field @"contentTypes"+ , verb =+ c+ ^. field @"finalType"+ . field @"requestType"+ . field @"verb"+ }+ actionType+ (EpReturnType $ c ^. field @"finalType" . field @"returnType")+ (_, Right c) -> do+ subServerSpec <- mkSubServerSpec cfg varBindings c+ pure $+ SubApi+ (c ^. field @"constructorName" . to ConstructorName)+ ( ConstructorArgs $+ c+ ^.. field @"parameters"+ . folded+ . to+ (\p -> (p ^. field @"paramName", p ^. field @"paramType"))+ )+ subServerSpec+ (Left err1, Left err2) ->+ fail $+ "mkApiPiece - "+ <> "\n---------------------mkApiPiece: Expected ------------------------"+ <> show err1+ <> "\n---------------------or-------------------------------------------"+ <> "\n"+ <> show err2+ <> "\n------------------------------------------------------------------"++-- | Create a ApiSpec from a GADT+-- The GADT must have one parameter representing the return type+mkServerSpec :: ServerConfig -> GadtName -> Q ApiSpec+mkServerSpec cfg n = do+ (dec, varBindings) <- getActionDec n --- AHA, THis is the fucker fucking with me!+ eps <- traverse (mkApiPiece cfg varBindings) =<< getConstructors dec+ opts <- getApiOptions cfg n+ pure+ ApiSpec+ { gadtName = n+ , gadtType =+ GadtType $+ L.foldl'+ AppT+ (ConT $ n ^. typed @Name)+ ( varBindings+ ^.. field @"extra"+ . folded+ . typed @Name+ . to VarT+ )+ , allVarBindings = varBindings+ , endpoints = eps+ , options = opts+ }++gadtToAction :: GadtType -> Either String Type+gadtToAction (GadtType ty) = case ty of+ AppT (AppT (AppT ty' (VarT _x)) (VarT _method)) (VarT _return) -> Right ty'+ _ -> Left $ "Expected `GADT` with final kind `Action`, got: " <> show ty++mkSubServerSpec :: ServerConfig -> VarBindings -> SubActionMatch -> Q ApiSpec+mkSubServerSpec cfg varBindings subAction = do+ (dec, bindings) <- getSubActionDec varBindings subAction -- We must not use the bindings or we'd end up with different names+ eps <- traverse (mkApiPiece cfg bindings) =<< getConstructors dec+ opts <- getApiOptions cfg name++ actionTy <-+ either fail pure $+ subAction+ ^. field @"subActionType"+ . to GadtType+ . to gadtToAction+ pure+ ApiSpec+ { gadtName = name+ , gadtType = GadtType actionTy+ , allVarBindings = varBindings+ , endpoints = eps+ , options = opts+ }+ where+ name :: GadtName+ name = subAction ^. field @"subActionName" . to GadtName++-- | Name and type variables used by API+askApiNameAndParams :: ApiSpec -> ServerGenM (Name, [TyVarBndr ()])+askApiNameAndParams spec = do+ apiTypeName <- askApiTypeName+ pure (apiTypeName, apiSpecTyVars spec)++apiPieceTyVars :: ApiPiece -> [TyVarBndr ()]+apiPieceTyVars = \case+ Endpoint _ args bindings _ _ ret ->+ L.nub $+ foldMap+ (getUsedTyVars $ bindings ^. field @"extra")+ (ret ^. typed @Type : args ^.. typed @[(String, Type)] . folded . typed @Type)+ SubApi _ _ spec -> apiSpecTyVars spec++apiSpecTyVars :: ApiSpec -> [TyVarBndr ()]+apiSpecTyVars spec =+ filter+ (`elem` usedTyVars)+ (spec ^. field @"allVarBindings" . field @"extra")+ where+ usedTyVars = L.nub $ foldMap apiPieceTyVars $ spec ^. field @"endpoints"++mkApiTypeDecs :: ApiSpec -> ServerGenM [Dec]+mkApiTypeDecs spec = do+ (apiTypeName, tyVars) <- askApiNameAndParams spec+ epTypes <- traverse mkEndpointApiType (spec ^. typed @[ApiPiece])+ topLevelDec <- case reverse epTypes of -- :<|> is right associative+ [] -> fail "Server contains no endpoints"+ (ty, _tyVars) : ts -> do+ let fish :: Type -> Type -> Q Type+ fish b a = [t|$(pure a) :<|> $(pure b)|]+ apiType <- liftQ (foldM fish ty (fmap fst ts))+ pure $ TySynD apiTypeName tyVars apiType+ handlerDecs <- mconcat <$> traverse mkHandlerTypeDec (spec ^. typed @[ApiPiece])+ pure $ topLevelDec : handlerDecs++applyTyVars :: Type -> [TyVarBndr ()] -> Type+applyTyVars ty tyVars = foldl AppT ty (tyVars ^.. folded . typed @Name . to VarT)++-- | Create endpoint types to be referenced in the API+-- * For Endpoint this is just a reference to the handler type+-- * For SubApi we apply the path parameters before referencing the SubApi+mkEndpointApiType :: ApiPiece -> ServerGenM (Type, [TyVarBndr ()])+mkEndpointApiType p = enterApiPiece p $ case p of+ Endpoint _n args bindings _ _ ret -> do+ epName <- askEndpointTypeName+ let usedTyVars :: [TyVarBndr ()]+ usedTyVars =+ L.nub $+ foldMap+ (getUsedTyVars $ bindings ^. field @"extra")+ (ret ^. typed @Type : args ^.. typed @[(String, Type)] . folded . typed @Type)+ pure+ ( applyTyVars (ConT epName) usedTyVars+ , filter (`elem` usedTyVars) (bindings ^. field @"extra") -- Make sure we get type vars in the right order+ )+ SubApi cName cArgs spec -> do+ urlSegment <- mkUrlSegment cName+ (n, tyVars) <- askApiNameAndParams spec+ finalType <- liftQ $ prependServerEndpointName urlSegment (applyTyVars (ConT n) tyVars)++ params <- mkQueryParams cArgs+ bird <- liftQ [t|(:>)|]+ let ep = foldr (\a b -> bird `AppT` a `AppT` b) finalType params+ pure (ep, tyVars)++-- | Defines the servant types for the endpoints+-- For SubApi it will trigger the full creating of the sub server with types and all+--+-- Result will be something like:+-- ```+-- type Customer_CreateEndpoint+-- = "Create"+-- :> ReqBody '[JSON] (NamedField1 "Customer_Create" Name Email)+-- :> Post '[JSON] CustomerKey+mkHandlerTypeDec :: ApiPiece -> ServerGenM [Dec]+mkHandlerTypeDec p = enterApiPiece p $ do+ case p of+ Endpoint name args varBindings hs Immutable retType -> do+ -- Get endpoint will use query parameters+ ty <- do+ queryParams <- mkQueryParams args+ let reqReturn = mkVerb hs $ mkReturnType retType+ bird <- liftQ [t|(:>)|]+ let stuff = foldr1 joinUrlParts $ queryParams <> [reqReturn]+ joinUrlParts :: Type -> Type -> Type+ joinUrlParts a b = bird `AppT` a `AppT` b+ urlSegment <- mkUrlSegment name+ liftQ $ prependServerEndpointName urlSegment stuff+ epTypeName <- askEndpointTypeName+ pure [TySynD epTypeName (getUsedTyVars (toTyVarBndr varBindings) ty) ty]+ Endpoint name args varBindings hs Mutable retType -> do+ -- Non-get endpoints use a request body+ ty <- do+ reqBody <- mkReqBody hs name args+ let reqReturn = mkReturnType retType+ middle <- case reqBody of+ Nothing -> pure $ mkVerb hs reqReturn+ Just b -> liftQ [t|$(pure b) :> $(pure $ mkVerb hs reqReturn)|]+ urlSegment <- mkUrlSegment name+ liftQ $ prependServerEndpointName urlSegment middle+ epTypeName <- askEndpointTypeName+ pure [TySynD epTypeName (getUsedTyVars (toTyVarBndr varBindings) ty) ty]+ SubApi _name args spec' -> enterApi spec' $ do+ _ <- mkQueryParams args+ -- Make sure we take into account what parameters have already been used.+ -- Skip this and we could end up generating APIs with multiple+ -- QueryParams with the same name, which servant will accept and use one+ -- one the values for both parameters.+ mkServerFromSpec spec'++guardUniqueParamName :: String -> ServerGenM ()+guardUniqueParamName paramName = do+ existingNames <- gets (^. field @"usedParamNames")+ when (paramName `elem` existingNames) $ do+ info <- gets (^. field @"info")+ let problematicConstructor = info ^. field @"currentGadt" . typed @Name . to show+ problematicParentConstructors =+ L.intercalate "->" $+ info+ ^.. field @"parentConstructors"+ . folded+ . typed @Name+ . to show+ fail $+ "Duplicate query parameters with name "+ <> show paramName+ <> " in Action "+ <> show problematicConstructor+ <> " with constructor hierarcy "+ <> show problematicParentConstructors+ modify $ over (field @"usedParamNames") (S.insert paramName)++mkQueryParams :: ConstructorArgs -> ServerGenM [QueryParamType]+mkQueryParams (ConstructorArgs args) = do+ may <- liftQ [t|Maybe|] -- Maybe parameters are optional, others required+ for args $ \case+ (name, AppT may' ty)+ | may' == may -> do+ guardUniqueParamName name+ liftQ+ [t|+ QueryParam'+ '[Optional, Servant.Strict]+ $(pure . LitT . StrTyLit $ name)+ $(pure ty)+ |]+ (name, ty) -> do+ guardUniqueParamName name+ liftQ+ [t|+ QueryParam'+ '[Required, Servant.Strict]+ $(pure . LitT . StrTyLit $ name)+ $(pure ty)+ |]++type QueryParamType = Type++updateConstructorTypes :: (Type -> Type) -> Con -> Con+updateConstructorTypes f = \case+ NormalC n bts -> NormalC n (fmap (fmap f) bts)+ RecC n vbt -> RecC n (fmap (fmap f) vbt)+ InfixC bt1 n bt2 -> InfixC bt1 n bt2+ ForallC b cxt' c -> ForallC b cxt' (updateConstructorTypes f c)+ GadtC n bts ty -> GadtC n (fmap (fmap f) bts) (f ty)+ RecGadtC n vbt ty -> RecGadtC n (fmap (fmap f) vbt) (f ty)++mkVerb :: HandlerSettings -> Type -> Type+mkVerb (HandlerSettings _ verb) ret = verb `AppT` ret++-- | Declare then handlers for the API+mkServerDec :: ApiSpec -> ServerGenM [Dec]+mkServerDec spec = do+ (apiTypeName, apiParams) <- askApiNameAndParams spec+ serverName <- askServerName++ let runnerName :: Name+ runnerName = mkName "runner"++ actionRunner' :: Type+ actionRunner' =+ ConT ''ActionRunner+ `AppT` VarT runnerMonadName+ `AppT` ( spec+ ^. field @"gadtType"+ . typed+ )++ server :: Type+ server =+ ConT ''ServerT+ `AppT` applyTyVars (ConT apiTypeName) apiParams+ `AppT` VarT runnerMonadName++ serverType :: Type+ serverType =+ withForall+ (spec ^. field' @"allVarBindings" . field @"extra")+ (ArrowT `AppT` actionRunner' `AppT` server)++ let serverSigDec :: Dec+ serverSigDec = SigD serverName serverType++ mkHandlerExp :: ApiPiece -> ServerGenM Exp+ mkHandlerExp p = enterApiPiece p $ do+ n <- askHandlerName+ pure $ VarE n `AppE` VarE runnerName+ handlers <- traverse mkHandlerExp (spec ^. typed @[ApiPiece])+ body <- case reverse handlers of -- :<|> is right associative+ [] -> fail "Server contains no endpoints"+ e : es -> liftQ $ foldM (\b a -> [|$(pure a) :<|> $(pure b)|]) e es+ let serverFunDec :: Dec+ serverFunDec = FunD serverName [Clause [VarP runnerName] (NormalB body) []]+ serverHandlerDecs <-+ mconcat+ <$> traverse (mkApiPieceHandler (gadtType spec)) (spec ^. typed @[ApiPiece])++ pure $ serverSigDec : serverFunDec : serverHandlerDecs++-- | Get the subset of type varaibes used ty a type, in the roder they're applied+-- Used to avoid rendundant type variables in the forall statement of sub-servers+getUsedTyVars :: forall flag. [TyVarBndr flag] -> Type -> [TyVarBndr flag]+getUsedTyVars bindings ty = getUsedTyVarNames ty ^.. folded . to (`M.lookup` m) . _Just+ where+ m :: M.Map Name (TyVarBndr flag)+ m = M.fromList $ zip (fmap getName bindings) bindings++ getName :: TyVarBndr flag -> Name+ getName = \case+ PlainTV n _ -> n+ KindedTV n _ _ -> n++-- | Get the type variables (VarT) used in a type, returned in the order they're+-- referenced+getUsedTyVarNames :: Type -> [Name]+getUsedTyVarNames ty' = L.nub $ case ty' of+ (AppT a b) -> on (<>) getUsedTyVarNames a b+ (ConT _) -> []+ (VarT n) -> [n]+ ForallT _ _ ty -> getUsedTyVarNames ty+ ForallVisT _ ty -> getUsedTyVarNames ty+ AppKindT ty _ -> getUsedTyVarNames ty+ SigT ty _ -> getUsedTyVarNames ty+ PromotedT _ -> []+ InfixT ty1 _ ty2 -> getUsedTyVarNames ty1 <> getUsedTyVarNames ty2+ UInfixT ty1 _ ty2 -> getUsedTyVarNames ty1 <> getUsedTyVarNames ty2+ ParensT ty -> getUsedTyVarNames ty+ TupleT _ -> []+ UnboxedTupleT _ -> []+ UnboxedSumT _ -> []+ ArrowT -> []+ MulArrowT -> []+ EqualityT -> []+ ListT -> []+ PromotedTupleT _ -> []+ PromotedNilT -> []+ PromotedConsT -> []+ StarT -> []+ ConstraintT -> []+ LitT _ -> []+ WildCardT -> []+ ImplicitParamT _ ty -> getUsedTyVarNames ty++withForall :: [TyVarBndr ()] -> Type -> Type+withForall extra ty =+ ForallT+ bindings+ varConstraints+ ty+ where+ bindings :: [TyVarBndr Specificity]+ bindings =+ KindedTV runnerMonadName SpecifiedSpec (ArrowT `AppT` StarT `AppT` StarT)+ : ( getUsedTyVars extra ty+ & traversed %~ \case+ PlainTV n _ -> PlainTV n SpecifiedSpec+ KindedTV n _ k -> KindedTV n SpecifiedSpec k+ )++ varConstraints :: [Type]+ varConstraints = [ConT ''MonadUnliftIO `AppT` VarT runnerMonadName]++actionRunner :: Type -> Type+actionRunner runnerGADT =+ ConT ''ActionRunner+ `AppT` VarT runnerMonadName+ `AppT` runnerGADT++runnerMonadName :: Name+runnerMonadName = mkName "m"++mkNamedFieldsType :: ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)+mkNamedFieldsType cName = \case+ ConstructorArgs [] -> pure Nothing+ ConstructorArgs args -> do+ bodyTag <- askBodyTag cName++ let nfType :: Type+ nfType = AppT (ConT nfName) (LitT bodyTag)++ nfName :: Name+ nfName = mkName $ "NF" <> show (length args)++ addNFxParam :: Type -> (String, Type) -> Type+ addNFxParam nfx (name, ty) = AppT (AppT nfx (LitT $ StrTyLit name)) ty+ pure . Just $ foldl addNFxParam nfType args++mkQueryHandlerSignature :: GadtType -> ConstructorArgs -> EpReturnType -> Type+mkQueryHandlerSignature+ gadt@(GadtType actionType)+ (ConstructorArgs args)+ (EpReturnType retType) =+ withForall (either (const []) id $ gadtTypeParams gadt) $+ mkFunction $+ actionRunner actionType : fmap snd args <> [ret]+ where+ ret :: Type+ ret = AppT (VarT runnerMonadName) retType++-- | Makes command handler, e.g.+-- counterCmd_AddToCounterHandler ::+-- ActionRunner m CounterCmd -> NamedFields1 "CounterCmd_AddToCounter" Int -> m Int+mkCmdHandlerSignature+ :: GadtType -> ConstructorName -> ConstructorArgs -> EpReturnType -> ServerGenM Type+mkCmdHandlerSignature gadt cName cArgs (EpReturnType retType) = do+ nfArgs <- mkNamedFieldsType cName cArgs+ pure $+ withForall (either (const []) id $ gadtTypeParams gadt) $+ mkFunction $+ [actionRunner (gadt ^. typed)]+ <> maybe [] pure nfArgs+ <> [ret]+ where+ ret :: Type+ ret = AppT (VarT runnerMonadName) $ case retType of+ TupleT 0 -> ConT ''NoContent+ ty -> ty++mkFunction :: [Type] -> Type+mkFunction = foldr1 (\a b -> ArrowT `AppT` a `AppT` b)++sortAndExcludeBindings :: [TyVarBndr Specificity] -> Type -> Either String [TyVarBndr Specificity]+sortAndExcludeBindings bindings ty = do+ varOrder <- varNameOrder ty+ let m :: M.Map Name Int+ m = M.fromList $ zip varOrder [1 ..]++ Right $ fmap fst . catMaybes $ bindings ^.. folded . to (\a -> (a,) <$> M.lookup (a ^. typed) m)++varNameOrder :: Type -> Either String [Name]+varNameOrder = \case+ ConT _ -> Right []+ VarT n -> Right [n]+ (AppT a b) -> (<>) <$> varNameOrder a <*> varNameOrder b+ crap -> Left $ "sortAndExcludeBindings: " <> show crap++gadtTypeParams :: GadtType -> Either String [TyVarBndr ()]+gadtTypeParams = fmap (fmap (`PlainTV` ())) . varNameOrder . (^. typed)++-- | Define the servant handler for an enpoint or referens the subapi with path+-- parameters applied+mkApiPieceHandler :: GadtType -> ApiPiece -> ServerGenM [Dec]+mkApiPieceHandler gadt apiPiece =+ enterApiPiece apiPiece $ do+ case apiPiece of+ Endpoint _cName cArgs _ _hs Immutable ty -> do+ let nrArgs :: Int+ nrArgs = length $ cArgs ^. typed @[(String, Type)]+ varNames <- liftQ $ replicateM nrArgs (newName "arg")+ handlerName <- askHandlerName+ runnerName <- liftQ $ newName "runner"++ let funSig :: Dec+ funSig = SigD handlerName $ mkQueryHandlerSignature gadt cArgs ty++ funBodyBase =+ AppE (VarE runnerName) $+ foldl+ AppE+ (ConE $ apiPiece ^. typed @ConstructorName . typed)+ (fmap VarE varNames)++ funBody = case ty ^. typed of+ TupleT 0 -> [|fmap (const NoContent) $(pure funBodyBase)|]+ _ -> pure $ funBodyBase+ funClause <-+ liftQ $+ clause+ (fmap (pure . VarP) (runnerName : varNames))+ (normalB [|$(funBody)|])+ []+ pure [funSig, FunD handlerName [funClause]]+ Endpoint cName cArgs _ hs Mutable ty | hasJsonContentType hs -> do+ let nrArgs :: Int+ nrArgs = length $ cArgs ^. typed @[(String, Type)]+ varNames <- liftQ $ replicateM nrArgs (newName "arg")+ handlerName <- askHandlerName+ runnerName <- liftQ $ newName "runner"+ let varPat :: Pat+ varPat = ConP nfName [] (fmap VarP varNames)++ nfName :: Name+ nfName = mkName $ "NF" <> show nrArgs++ funSig <- SigD handlerName <$> mkCmdHandlerSignature gadt cName cArgs ty++ let funBodyBase =+ AppE (VarE runnerName) $+ foldl+ AppE+ (ConE $ apiPiece ^. typed @ConstructorName . typed)+ (fmap VarE varNames)++ funBody = case ty ^. typed of+ TupleT 0 -> [|fmap (const NoContent) $(pure funBodyBase)|]+ _ -> pure $ funBodyBase+ funClause <-+ liftQ $+ clause+ (pure (VarP runnerName) : [pure varPat | nrArgs > 0])+ (normalB [|$(funBody)|])+ []+ pure [funSig, FunD handlerName [funClause]]+ Endpoint _cName cArgs _ _hs Mutable ty -> do+ let nrArgs :: Int+ nrArgs = length $ cArgs ^. typed @[(String, Type)]+ unless (nrArgs < 2) $+ fail "Only one argument is supported for non-JSON request bodies"+ varName <- liftQ $ newName "arg"+ handlerName <- askHandlerName+ runnerName <- liftQ $ newName "runner"+ let varPat :: Pat+ varPat = VarP varName++ let funSig :: Dec+ funSig = SigD handlerName $ mkQueryHandlerSignature gadt cArgs ty++ funBodyBase =+ AppE (VarE runnerName) $+ AppE+ (ConE $ apiPiece ^. typed @ConstructorName . typed)+ (VarE varName)++ funBody = case ty ^. typed of+ TupleT 0 -> [|fmap (const NoContent) $(pure funBodyBase)|]+ _ -> pure $ funBodyBase+ funClause <-+ liftQ $+ clause+ (pure (VarP runnerName) : [pure varPat | nrArgs > 0])+ (normalB [|$(funBody)|])+ []+ pure [funSig, FunD handlerName [funClause]]+ SubApi cName cArgs spec -> do+ -- Apply the arguments to the constructor before referencing the subserver+ varNames <- liftQ $ replicateM (length (cArgs ^. typed @[(String, Type)])) (newName "arg")+ handlerName <- askHandlerName+ (targetApiTypeName, targetApiParams) <- enterApi spec (askApiNameAndParams spec)+ targetServer <- enterApi spec askServerName+ runnerName <- liftQ $ newName "runner"++ funSig <- liftQ $ do+ let params =+ withForall (spec ^. field @"allVarBindings" . field @"extra") $+ mkFunction $+ [actionRunner (gadt ^. typed)]+ <> cArgs ^.. typed @[(String, Type)] . folded . _2+ <> [ ConT ''ServerT+ `AppT` applyTyVars (ConT targetApiTypeName) targetApiParams+ `AppT` VarT runnerMonadName+ ]+ pure (SigD handlerName params)++ funClause <- liftQ $ do+ let cmd =+ foldl+ AppE+ (ConE $ cName ^. typed)+ (fmap VarE varNames)+ in clause+ (varP <$> runnerName : varNames)+ ( fmap+ NormalB+ [e|+ $(varE targetServer)+ ($(varE runnerName) . $(pure cmd))+ |]+ )+ []+ let funDef = FunD handlerName [funClause]+ pure [funSig, funDef]++---- | This is the only layer of the ReaderT stack where we do not use `local` to update the+---- url segments.+mkServerFromSpec :: ApiSpec -> ServerGenM [Dec]+mkServerFromSpec spec = enterApi spec $ do+ apiTypeDecs <- mkApiTypeDecs spec+ serverDecs <- mkServerDec spec+ pure $ apiTypeDecs <> serverDecs++-- | Handles the special case of `()` being transformed into `NoContent`+mkReturnType :: EpReturnType -> Type+mkReturnType (EpReturnType ty) = case ty of+ TupleT 0 -> ConT ''NoContent+ _ -> ty++prependServerEndpointName :: UrlSegment -> Type -> Q Type+prependServerEndpointName prefix rest =+ [t|$(pure $ LitT . StrTyLit $ prefix ^. typed) :> $(pure $ rest)|]++mkReqBody+ :: HandlerSettings -> ConstructorName -> ConstructorArgs -> ServerGenM (Maybe Type)+mkReqBody hs name args =+ if hasJsonContentType hs+ then do+ body <- mkNamedFieldsType name args+ case body of+ Nothing -> pure Nothing+ Just b -> Just <$> liftQ [t|ReqBody '[JSON] $(pure b)|]+ else do+ let body = case args of+ ConstructorArgs [] -> Nothing+ ConstructorArgs [(_, t)] -> Just t+ ConstructorArgs _ ->+ fail "Multiple arguments are only supported for JSON content"+ case body of+ Nothing -> pure Nothing+ Just b ->+ Just+ <$> liftQ+ [t|ReqBody $(pure $ hs ^. field @"contentTypes") $(pure b)|]
+ src/DomainDriven/Server/Types.hs view
@@ -0,0 +1,151 @@+module DomainDriven.Server.Types where++import Control.Monad.State+import Data.Function (on)+import Data.Generics.Product+import Data.List qualified as L+import Data.Set (Set)+import GHC.Generics (Generic)+import Language.Haskell.TH+import Lens.Micro ((^.))+import Prelude++-- Contains infromatiotion of how the API should look, gathered from the Action GADT.+data ApiSpec = ApiSpec+ { gadtName :: GadtName+ , gadtType :: GadtType+ -- ^ Name of the GADT representing the command+ , allVarBindings :: VarBindings+ , endpoints :: [ApiPiece]+ -- ^ Endpoints created from the constructors of the GADT+ , options :: ApiOptions+ -- ^ The setting to use when generating part of the API+ }+ deriving (Show, Generic)++data VarBindings = VarBindings+ { paramPart :: Name+ , method :: Name+ , return :: Name+ , extra :: [TyVarBndr ()]+ }+ deriving (Show, Generic, Eq)++data ApiOptions = ApiOptions+ { renameConstructor :: String -> String+ , typenameSeparator :: String+ , bodyNameBase :: Maybe String+ }+ deriving (Generic)++defaultApiOptions :: ApiOptions+defaultApiOptions =+ ApiOptions+ { renameConstructor =+ \s -> case L.splitAt (on (-) L.length s "Action") s of+ (x, "Action") -> x+ _ -> s+ , typenameSeparator = "_"+ , bodyNameBase = Nothing+ }++instance Show ApiOptions where+ show o =+ "ApiOptions {renameConstructor = ***, typenameSeparator = \""+ <> o+ ^. field @"typenameSeparator"+ <> "\"}"++data Mutability+ = Mutable+ | Immutable+ deriving (Show, Eq)++data ApiPiece+ = Endpoint+ ConstructorName+ ConstructorArgs+ VarBindings+ HandlerSettings+ Mutability+ EpReturnType+ | SubApi ConstructorName ConstructorArgs ApiSpec+ deriving (Show, Generic)++data HandlerSettings = HandlerSettings+ { contentTypes :: Type+ , verb :: Type+ }+ deriving (Show, Generic, Eq)++newtype ConstructorName = ConstructorName Name deriving (Show, Generic, Eq)+newtype EpReturnType = EpReturnType Type deriving (Show, Generic, Eq)+newtype GadtName = GadtName Name deriving (Show, Generic, Eq)+newtype GadtType = GadtType Type deriving (Show, Generic, Eq)++newtype UrlSegment = UrlSegment String deriving (Show, Generic, Eq)+newtype ConstructorArgs = ConstructorArgs [(String, Type)] deriving (Show, Generic, Eq)+newtype Runner = Runner Type deriving (Show, Generic, Eq)++-- | Carries information regarding how the API looks at the place we're currently at.+data ServerInfo = ServerInfo+ { baseGadt :: GadtName+ -- ^ Use as a prefix of all types+ , currentGadt :: GadtName+ , parentConstructors :: [ConstructorName]+ -- ^ To create good names without conflict+ , prefixSegments :: [UrlSegment]+ -- ^ Used to give a good name to the request body+ , options :: ApiOptions+ -- ^ The current options+ }+ deriving (Show, Generic)++data ServerGenState = ServerGenState+ { info :: ServerInfo+ , usedParamNames :: Set String+ }+ deriving (Show, Generic)++newtype ServerGenM a = ServerGenM {unServerGenM :: StateT ServerGenState Q a}+ deriving newtype (Functor, Applicative, Monad, MonadState ServerGenState, MonadFail)++data Pmatch = Pmatch+ { paramPart :: Name+ , paramName :: String+ , paramType :: Type+ }+ deriving (Show, Generic)++data ConstructorMatch = ConstructorMatch+ { xParam :: Name+ -- ^ Of kind ParamPart+ , constructorName :: Name+ , parameters :: [Pmatch]+ , finalType :: FinalConstructorTypeMatch+ }+ deriving (Show, Generic)++data SubActionMatch = SubActionMatch+ { constructorName :: Name+ , parameters :: [Pmatch]+ , subActionName :: Name+ , subActionType :: Type+ }+ deriving (Show, Generic)++data SubActionTypeMatch = SubActionTypeMatch+ deriving (Show, Generic)++data FinalConstructorTypeMatch = FinalConstructorTypeMatch+ { requestType :: RequestTypeMatch+ , returnType :: Type+ }+ deriving (Show, Generic)++data RequestTypeMatch = RequestTypeMatch+ { accessType :: Type+ , contentTypes :: Type+ , verb :: Type+ }+ deriving (Show, Generic)
+ test/Action/Counter.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Action.Counter where++import Control.DeepSeq+import Control.Monad (when)+import Control.Monad.Catch+import Data.Aeson+import Data.Typeable (Typeable)+import DomainDriven+import GHC.Generics (Generic)+import Prelude++-- | The model, representing the current state+type CounterModel = Int++data CounterEvent+ = CounterIncreased+ | CounterDecreased+ deriving (Show, Generic, ToJSON, FromJSON, NFData)++data CounterAction :: Action where+ GetCounter :: CounterAction x Query Int+ IncreaseCounter :: CounterAction x Cmd Int+ DecreaseCounter :: CounterAction x Cmd Int+ AddToCounter+ :: P x "numberToAdd" Int+ -> CounterAction x Cmd Int+ -- ^ Add a positive number to the counter+ deriving (HasApiOptions)++handleAction+ :: CounterAction 'ParamType method a+ -> HandlerType method CounterModel CounterEvent IO a+handleAction = \case+ GetCounter -> Query $ pure+ IncreaseCounter -> Cmd $ \_ -> pure (id, [CounterIncreased])+ DecreaseCounter -> Cmd $ \counter -> do+ when (counter < 1) (throwM NegativeNotSupported)+ pure (id, [CounterDecreased])+ AddToCounter a -> Cmd $ \_ -> do+ when (a < 0) (throwM NegativeNotSupported)+ pure (id, replicate a CounterIncreased)++data CounterError = NegativeNotSupported+ deriving (Show, Eq, Typeable, Exception)++applyCounterEvent :: CounterModel -> Stored CounterEvent -> CounterModel+applyCounterEvent m (Stored event _timestamp _uuid) = case event of+ CounterIncreased -> m + 1+ CounterDecreased -> m - 1++$(mkServerConfig "serverConfig")
+ test/Action/ExtraParam.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}++module Action.ExtraParam where++import Control.Monad.Catch+import Data.Aeson (FromJSON, ToJSON)+import Data.Text (Text)+import Data.Text qualified as T+import DomainDriven+import GHC.Generics (Generic)+import Prelude++data ExtraP = This | That++newtype MyInt (ep :: ExtraP) = MyInt Int+ deriving (Show, Generic)+ deriving newtype (FromJSON, ToJSON)++data ExtraParamAction (bool :: Bool) (ep :: ExtraP) :: Action where+ ReverseText+ :: P x "text" Text+ -> ExtraParamAction bool ep x CbCmd Text+ Sub1 :: Sub1Action ep x a r -> ExtraParamAction bool ep x a r+ Sub2 :: Sub2Action x a r -> ExtraParamAction bool ep x a r+ Sub3 :: Sub3Action ep bool x a r -> ExtraParamAction bool ep x a r+ deriving (HasApiOptions)++data Sub1Action (ep :: ExtraP) :: Action where+ TalkToMe :: Sub1Action ep x Query Text+ SayMyNumber :: P x "int" (MyInt ep) -> Sub1Action ep x Cmd String+ SayMyMaybeNumber :: P x "int" (Maybe (MyInt ep)) -> Sub1Action ep x Query String+ deriving (HasApiOptions)++data Sub2Action :: Action where+ SaySomething+ :: P x "number" Int+ -> Sub2Action x Query String+ deriving (HasApiOptions)++data Sub3Action (ep :: ExtraP) (bool :: Bool) :: Action where+ SayHello :: Sub3Action ep bool x Query Text+ deriving (HasApiOptions)++handleExtraParamAction :: MonadThrow m => ActionHandler () () m (ExtraParamAction bool ep)+handleExtraParamAction = \case+ ReverseText t -> CbCmd $ \_runTransaction -> pure (T.reverse t)+ Sub1 a -> handleSub1Action a+ Sub2 a -> handleSub2Action a+ Sub3 a -> handleSub3Action a++handleSub1Action :: MonadThrow m => ActionHandler () () m (Sub1Action ep)+handleSub1Action = \case+ TalkToMe -> Query $ \_ -> pure "Hello!"+ SayMyNumber (MyInt i) -> Cmd $ \_ -> pure (const $ show i, [])+ SayMyMaybeNumber i -> Query $ \_ -> pure (show i)++handleSub2Action :: MonadThrow m => ActionHandler () () m Sub2Action+handleSub2Action = \case+ SaySomething i -> Query $ \_ -> pure $ "Something " <> show i++handleSub3Action :: MonadThrow m => ActionHandler () () m (Sub3Action ep bool)+handleSub3Action = \case+ SayHello -> Query $ \_ -> pure "Hello"++$(mkServerConfig "extraParamConfig")
+ test/Action/ServerTest.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}++module Action.ServerTest where++import Control.Monad.Catch+import qualified Data.List as L+import Data.Text (Text)+import qualified Data.Text as T+import DomainDriven+import Prelude++data ServerTestAction :: Action where+ ReverseText+ :: P x "text" Text+ -> ServerTestAction x CbCmd Text+ ConcatText+ :: P x "text" Text+ -> P x "string" String+ -> ServerTestAction x Query Text+ SubAction+ :: P x "text" Text+ -> SubAction x method a+ -> ServerTestAction x method a+ deriving (HasApiOptions)++handleAction :: MonadThrow m => ActionHandler () () m ServerTestAction+handleAction = \case+ ReverseText t -> CbCmd $ \_runTransaction -> pure (T.reverse t)+ ConcatText a b -> Query $ \() -> pure $ a <> T.pack b+ SubAction t action -> handleSubAction t action++data SubAction x method a where+ Intersperse :: P x "intersperse_text" Text -> SubAction x Query Text+ deriving (HasApiOptions)++handleSubAction :: MonadThrow m => Text -> ActionHandler () () m SubAction+handleSubAction t1 = \case+ Intersperse c -> Query $ \() -> pure $ L.foldl' (flip T.intersperse) t1 (T.unpack c)++$(mkServerConfig "testActionConfig")
+ test/Action/Store.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE TemplateHaskell #-}++module Action.Store where++import Control.Concurrent (threadDelay)+import Control.Monad (when)+import Control.Monad.Catch+ ( MonadThrow+ , throwM+ )+import Control.Monad.IO.Class+import Data.Aeson+ ( FromJSON+ , FromJSONKey+ , ToJSON+ , ToJSONKey+ )+import qualified Data.Map as M+import Data.OpenApi+ ( ToParamSchema+ , ToSchema+ )+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import DomainDriven+import GHC.Generics (Generic)+import Servant+import Prelude++newtype ItemKey = ItemKey UUID+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass+ ( FromJSONKey+ , ToJSONKey+ , FromJSON+ , ToJSON+ , ToSchema+ , ToParamSchema+ )+ deriving newtype (FromHttpApiData, ToHttpApiData)+newtype Quantity = Quantity Int+ deriving (Show, Eq, Ord, Generic)+ deriving newtype (Num)+ deriving anyclass (FromJSON, ToJSON, ToSchema)+newtype ItemName = ItemName Text+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (FromJSON, ToJSON, ToSchema)+ deriving newtype (IsString)+newtype Price = Price Int+ deriving (Show, Eq, Ord, Generic)+ deriving newtype (Num)+ deriving anyclass (FromJSON, ToJSON, ToSchema)++data ItemInfo = ItemInfo+ { key :: ItemKey+ , name :: ItemName+ , quantity :: Quantity+ , orderedQuantity :: Quantity+ -- ^ Ordered from supplier+ , price :: Price+ }+ deriving (Show, Eq, Generic, ToJSON, FromJSON, ToSchema)++-- | The store actions+-- `method` is `Verb` from servant without the returntype, `a`, applied+data StoreAction :: Action where+ ListItems :: StoreAction x (RequestType 'Direct '[JSON] (Verb 'GET 200 '[JSON])) [ItemInfo]+ Search+ :: P x "searchPhrase" Text+ -> StoreAction x Query [ItemInfo]+ ItemAction+ :: P x "item" ItemKey+ -> ItemAction x method a+ -> StoreAction x method a+ AdminAction+ :: AdminAction x method a+ -> StoreAction x method a+ deriving (HasApiOptions)++data ItemAction :: Action where+ ItemBuy :: P x "quantity" Quantity -> ItemAction x Cmd ()+ ItemStockQuantity :: ItemAction x Query Quantity+ ItemPrice :: ItemAction x Query Price++instance HasApiOptions ItemAction where+ apiOptions = defaultApiOptions{renameConstructor = drop (length @[] "Item")}++data AdminAction x method a where+ Order+ :: P x "item" ItemKey+ -> P x "quantity" Quantity+ -> AdminAction x CbCmd ()+ Restock+ :: P x "itemKey" ItemKey+ -> P x "quantity" Quantity+ -> AdminAction x Cmd ()+ AddItem+ :: P x "itemName" ItemName+ -> P x "quantity" Quantity+ -> P x "price" Price+ -> AdminAction x Cmd ItemKey+ RemoveItem+ :: P x "item" ItemKey+ -> AdminAction x Cmd ()+ deriving (HasApiOptions)++-- | The event+-- Store state of the store is fully defined by+-- `foldl' applyStoreEvent mempty listOfEvents`+data StoreEvent+ = BoughtItem ItemKey Quantity+ | Ordered ItemKey Quantity+ | Restocked ItemKey Quantity+ | AddedItem ItemKey ItemName Price+ | RemovedItem ItemKey+ deriving stock (Show, Eq, Generic, Typeable)+ deriving anyclass (FromJSON, ToJSON)++type StoreModel = M.Map ItemKey ItemInfo++------------------------------------------------------------------------------------------+-- Action handlers --+------------------------------------------------------------------------------------------+handleStoreAction+ :: (MonadIO m)+ => MonadThrow m+ => ActionHandler StoreModel StoreEvent m StoreAction+handleStoreAction = \case+ ListItems -> Query $ pure . M.elems+ Search t -> Query $ \m -> do+ let matches :: ItemInfo -> Bool+ matches (ItemInfo _ (ItemName n) _ _ _) =+ T.toUpper t `T.isInfixOf` T.toUpper n+ pure . filter matches $ M.elems m+ ItemAction iKey cmd -> handleItemAction iKey cmd+ AdminAction cmd -> handleAdminAction cmd++handleAdminAction+ :: forall m+ . (MonadThrow m)+ => MonadIO m+ => ActionHandler StoreModel StoreEvent m AdminAction+handleAdminAction = \case+ Order iKey q -> CbCmd $ \runTransaction -> do+ m <- runTransaction $ \m -> pure (const m, [])+ when (M.notMember iKey m) $ throwM err404+ -- Simulate making an external API call that takes 2s.+ -- It is important that we do not do this in a normal Cmd+ -- as this will block any other command from runnning during+ -- this time.+ let orderItems :: ItemKey -> Quantity -> m ()+ orderItems _ _ = liftIO $ threadDelay 2000000+ orderItems iKey q+ -- Note that since this whole command is not running in a transaction it is+ -- possible that the item was removed from the inventory while we were making the+ -- external API call. We ignore it here, but in a real world situation you may+ -- want to handle this.+ runTransaction $ \_ -> pure (const (), [Ordered iKey q])+ Restock iKey q -> Cmd $ \m -> do+ when (M.notMember iKey m) $ throwM err404+ pure (const (), [Restocked iKey q])+ AddItem name' quantity' price -> Cmd $ \_ -> do+ iKey <- ItemKey <$> mkId+ pure (const iKey, [AddedItem iKey name' price, Restocked iKey quantity'])+ RemoveItem iKey -> Cmd $ \m -> do+ when (M.notMember iKey m) $ throwM err404+ pure (const (), [RemovedItem iKey])++handleItemAction+ :: forall m+ . (MonadThrow m)+ => ItemKey+ -> ActionHandler StoreModel StoreEvent m ItemAction+handleItemAction iKey = \case+ ItemBuy quantity' -> Cmd $ \m -> do+ let available = maybe 0 quantity $ M.lookup iKey m+ when (available < quantity') $ throwM err422{errBody = "Out of stock"}+ pure (const (), [BoughtItem iKey quantity'])+ ItemStockQuantity -> Query $ \m -> do+ i <- getItem m+ pure $ quantity i+ ItemPrice -> Query $ \m -> do+ i <- getItem m+ pure $ price i+ where+ getItem :: StoreModel -> m ItemInfo+ getItem = maybe (throwM err404) pure . M.lookup iKey++------------------------------------------------------------------------------------------+-- Event handler --+------------------------------------------------------------------------------------------+applyStoreEvent :: StoreModel -> Stored StoreEvent -> StoreModel+applyStoreEvent m (Stored e _ _) = case e of+ Ordered iKey q ->+ M.update (\ii -> Just ii{orderedQuantity = orderedQuantity ii + q}) iKey m+ BoughtItem iKey q -> M.update (\ii -> Just ii{quantity = quantity ii - q}) iKey m+ Restocked iKey q -> M.update (\ii -> Just ii{quantity = quantity ii + q}) iKey m+ AddedItem iKey name' price -> M.insert iKey (ItemInfo iKey name' 0 0 price) m+ RemovedItem iKey -> M.delete iKey m++$(mkServerConfig "storeActionConfig")
+ test/DomainDriven/Internal/NamedJsonFieldsSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DerivingVia #-}++module DomainDriven.Internal.NamedJsonFieldsSpec where++import Control.Monad+import Data.Aeson+import Data.OpenApi+import Data.Proxy+import Data.String+import Data.Text (Text)+import DomainDriven.Internal.HasFieldName+import DomainDriven.Internal.NamedJsonFields+import GHC.Generics+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.ADT+import Test.QuickCheck.Classes+import Prelude++data Test1 = Test1+ { namedField1 :: Int+ , namedField2 :: Double+ }+ deriving (Show, Eq, Ord, Generic)+ deriving (FromJSON, ToJSON, ToSchema) via (NamedJsonFields Test1)++instance Arbitrary Test1 where+ arbitrary = genericArbitrary++newtype MyText = MyText Text+ deriving (Show, Eq, Ord, Generic)+ deriving newtype (FromJSON, ToJSON, IsString, ToSchema)+ deriving anyclass (HasFieldName)++------------------------------------------------------------------------------++instance Arbitrary Duplicated where+ arbitrary = genericArbitrary++instance Arbitrary MyText where+ arbitrary = elements ["hej", "hopp", "kalle", "anka", "ekorre"]++data Test2+ = Test2a+ | Test2b Int MyText+ | Test2c MyText+ | Test2d String String+ | Test2e (Maybe String)+ deriving (Show, Eq, Ord, Generic)+ deriving (FromJSON, ToJSON, ToSchema) via (NamedJsonFields Test2)++instance Arbitrary Test2 where+ arbitrary = genericArbitrary++data Duplicated+ = Duplicated1 Int Int Int String Int String+ | Duplicated2 Int String Int Double+ deriving (Show, Eq, Generic)+ -- deriving anyclass (FromJSON, ToJSON, ToSchema)+ deriving (FromJSON, ToJSON, ToSchema) via (NamedJsonFields Duplicated)++newtype DuplicatedNoTag = DuplicatedNoTag Duplicated+ deriving stock (Generic)+ deriving newtype (Show, Eq, Arbitrary)++noTagOpts :: NamedJsonOptions+noTagOpts = defaultNamedJsonOptions{skipTagField = True}++instance FromJSON DuplicatedNoTag where+ parseJSON = fmap DuplicatedNoTag . gNamedParseJson noTagOpts++instance ToJSON DuplicatedNoTag where+ toJSON (DuplicatedNoTag a) = gNamedToJson noTagOpts a++instance ToSchema DuplicatedNoTag where+ declareNamedSchema _ = gNamedDeclareNamedSchema noTagOpts (Proxy @Duplicated)++spec :: Spec+spec = do+ describe "ToJSON and FromJSON instances" $ do+ describe "Test1" . void $+ traverse+ (uncurry prop)+ (lawsProperties $ jsonLaws $ Proxy @Test1)+ describe "Test2" . void $+ traverse+ (uncurry prop)+ (lawsProperties $ jsonLaws $ Proxy @Test2)+ describe "Duplicated" . void $+ traverse+ (uncurry prop)+ (lawsProperties $ jsonLaws $ Proxy @Duplicated)+ describe "DuplicatedNoTag" . void $+ traverse+ (uncurry prop)+ (lawsProperties $ jsonLaws $ Proxy @DuplicatedNoTag)+ describe "ToSchema instances" $ do+ prop "Test1" $ \(a :: Test1) -> validateToJSON a == []+ prop "Test2" $ \(a :: Test2) -> validateToJSON a == []+ prop "Duplicated" $ \(a :: Duplicated) -> validateToJSON a == []
+ test/DomainDriven/ServerSpec.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE TemplateHaskell #-}++module DomainDriven.ServerSpec where++import Action.ExtraParam+import Action.ServerTest+import Action.Store+import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad.Catch (try)+import Control.Monad.Except+import Data.Map qualified as M+import Data.Text (Text)+import DomainDriven+import DomainDriven.Persistance.ForgetfulInMemory+import DomainDriven.Server.Config (ServerConfig (..))+import Network.HTTP.Client+ ( defaultManagerSettings+ , newManager+ )+import Network.Wai.Handler.Warp (run)+import Servant+import Servant.Client+import Test.Hspec+import Prelude++-- import Data.Kind (Type)+-- import UnliftIO (MonadUnliftIO)++$(mkServer extraParamConfig ''ExtraParamAction)++-----------------------------------------------------------------------------------------+-- type ExtraParamActionApi (ep_idrrs :: ExtraP) (bool_idrrr :: Bool) =+-- (:<|>) ExtraParamAction_ReverseTextEndpoint ((:<|>) ((:>) "Sub1" (ExtraParamAction_Sub1Api ep_idrrs)) ((:<|>) ((:>) "Sub2" ExtraParamAction_Sub2Api) ((:>) "Sub3" (ExtraParamAction_Sub3Api ep_idrrs bool_idrrr))))+-- type ExtraParamAction_ReverseTextEndpoint =+-- (:>) "ReverseText" ((:>) (ReqBody '[JSON] (NF1 "ExtraParamAction_ReverseText" "text" Text)) (Verb 'POST 200 ( '(:) JSON ('[] :: [Type])) Text))+-- type ExtraParamAction_Sub1Api (ep_idrrs :: ExtraP) =+-- (:<|>) ExtraParamAction_Sub1_TalkToMeEndpoint (ExtraParamAction_Sub1_SayMyNumberEndpoint ep_idrrs)+-- type ExtraParamAction_Sub1_TalkToMeEndpoint =+-- (:>) "TalkToMe" (Verb 'GET 200 ( '(:) JSON ('[] :: [Type])) Text)+-- type ExtraParamAction_Sub1_SayMyNumberEndpoint (ep_idrrs :: ExtraP) =+-- (:>) "SayMyNumber" ((:>) (ReqBody '[JSON] (NF1 "Sub1Action_SayMyNumber" "int" (MyInt ep_idrrs))) (Verb 'POST 200 ( '(:) JSON ('[] :: [Type])) [Char]))+-- extraParamAction_Sub1Server+-- :: forall (m :: Type -> Type) (ep_idrrs :: ExtraP)+-- . MonadUnliftIO m+-- => ActionRunner m (Sub1Action ep_idrrs)+-- -> ServerT (ExtraParamAction_Sub1Api ep_idrrs) m+-- extraParamAction_Sub1Server runner =+-- ( extraParamAction_Sub1_TalkToMeHandler runner+-- :<|> extraParamAction_Sub1_SayMyNumberHandler runner+-- )+-- extraParamAction_Sub1_TalkToMeHandler+-- :: forall (m :: Type -> Type) ep_idrrs+-- . MonadUnliftIO m+-- => ActionRunner m (Sub1Action ep_idrrs)+-- -> m Text+-- extraParamAction_Sub1_TalkToMeHandler runner_adryu =+-- runner_adryu TalkToMe+-- extraParamAction_Sub1_SayMyNumberHandler+-- :: forall (m :: Type -> Type) ep_idrrs+-- . MonadUnliftIO m+-- => ActionRunner m (Sub1Action ep_idrrs)+-- -> NF1 "Sub1Action_SayMyNumber" "int" (MyInt ep_idrrs)+-- -> m [Char]+-- extraParamAction_Sub1_SayMyNumberHandler+-- runner_adryw+-- (NF1 arg_adryv) =+-- runner_adryw (SayMyNumber arg_adryv)+-- type ExtraParamAction_Sub2Api =+-- ExtraParamAction_Sub2_SaySomethingEndpoint+-- type ExtraParamAction_Sub2_SaySomethingEndpoint =+-- (:>)+-- "SaySomething"+-- ( (:>)+-- ( QueryParam'+-- '[ Required+-- , Strict+-- ]+-- "number"+-- Int+-- )+-- (Verb 'GET 200 ( '(:) JSON ('[] :: [Type])) [Char])+-- )+-- extraParamAction_Sub2Server+-- :: forall (m :: Type -> Type)+-- . MonadUnliftIO m+-- => ActionRunner m Sub2Action+-- -> ServerT ExtraParamAction_Sub2Api m+-- extraParamAction_Sub2Server runner =+-- extraParamAction_Sub2_SaySomethingHandler runner+-- extraParamAction_Sub2_SaySomethingHandler+-- :: forall (m :: Type -> Type)+-- . MonadUnliftIO m+-- => ActionRunner m Sub2Action+-- -> Int+-- -> m [Char]+-- extraParamAction_Sub2_SaySomethingHandler runner_adryy arg_adryx =+-- runner_adryy (SaySomething arg_adryx)+-- type ExtraParamAction_Sub3Api a b =+-- ExtraParamAction_Sub3_SayHelloEndpoint+-- type ExtraParamAction_Sub3_SayHelloEndpoint =+-- (:>) "SayHello" (Verb 'GET 200 ( '(:) JSON ('[] :: [Type])) Text)+-- extraParamAction_Sub3Server+-- :: forall+-- (m :: Type -> Type)+-- (ep_idrrs :: ExtraP)+-- (bool_idrrr :: Bool)+-- . MonadUnliftIO m+-- => ActionRunner m (Sub3Action ep_idrrs bool_idrrr)+-- -> ServerT (ExtraParamAction_Sub3Api ep_idrrs bool_idrrr) m+-- extraParamAction_Sub3Server runner =+-- extraParamAction_Sub3_SayHelloHandler runner+-- extraParamAction_Sub3_SayHelloHandler+-- :: forall (m :: Type -> Type) ep_idrrs bool_idrrr+-- . MonadUnliftIO m+-- => ActionRunner m (Sub3Action ep_idrrs bool_idrrr)+-- -> m Text+-- extraParamAction_Sub3_SayHelloHandler runner_adryz =+-- runner_adryz SayHello+-- extraParamActionServer+-- :: forall+-- (m :: Type -> Type)+-- (bool_idrrr :: Bool)+-- (ep_idrrs :: ExtraP)+-- . MonadUnliftIO m+-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)+-- -> ServerT (ExtraParamActionApi ep_idrrs bool_idrrr) m+-- extraParamActionServer runner =+-- ( extraParamAction_ReverseTextHandler runner+-- :<|> ( extraParamAction_Sub1Handler runner+-- :<|> ( extraParamAction_Sub2Handler runner+-- :<|> extraParamAction_Sub3Handler runner+-- )+-- )+-- )+-- extraParamAction_ReverseTextHandler+-- :: forall (m :: Type -> Type) bool_idrrr ep_idrrs+-- . MonadUnliftIO m+-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)+-- -> NF1 "ExtraParamAction_ReverseText" "text" Text+-- -> m Text+-- extraParamAction_ReverseTextHandler runner_adryB (NF1 arg_adryA) =+-- runner_adryB (Action.ExtraParam.ReverseText arg_adryA)+-- extraParamAction_Sub1Handler+-- :: forall+-- (m :: Type -> Type)+-- (bool_idrrr :: Bool)+-- (ep_idrrs :: ExtraP)+-- . MonadUnliftIO m+-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)+-- -> ServerT (ExtraParamAction_Sub1Api ep_idrrs) m+-- extraParamAction_Sub1Handler runner_adryC =+-- extraParamAction_Sub1Server (runner_adryC . Sub1)+-- extraParamAction_Sub2Handler+-- :: forall+-- (m :: Type -> Type)+-- (bool_idrrr :: Bool)+-- (ep_idrrs :: ExtraP)+-- . MonadUnliftIO m+-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)+-- -> ServerT ExtraParamAction_Sub2Api m+-- extraParamAction_Sub2Handler runner_adryD =+-- extraParamAction_Sub2Server (runner_adryD . Sub2)+-- extraParamAction_Sub3Handler+-- :: forall+-- (m :: Type -> Type)+-- (bool_idrrr :: Bool)+-- (ep_idrrs :: ExtraP)+-- . MonadUnliftIO m+-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)+-- -> ServerT (ExtraParamAction_Sub3Api ep_idrrs bool_idrrr) m+-- extraParamAction_Sub3Handler runner_adryE =+-- extraParamAction_Sub3Server (runner_adryE . Sub3)++-----------------------------------------------------------------------------------------+$(mkServer storeActionConfig ''StoreAction)++--++itemStuff+ :: ItemKey+ -> (NF1 "ItemAction_Buy" "quantity" Quantity -> ClientM NoContent)+ :<|> ClientM Quantity+ :<|> ClientM Price+listItems :: ClientM [ItemInfo]+search :: Text -> ClientM [ItemInfo]+adminOrder+ :: NF2 "AdminAction_Order" "item" ItemKey "quantity" Quantity -> ClientM NoContent+adminRestock+ :: NF2 "AdminAction_Restock" "itemKey" ItemKey "quantity" Quantity+ -> ClientM NoContent+adminAddItem+ :: NF3 "AdminAction_AddItem" "itemName" ItemName "quantity" Quantity "price" Price+ -> ClientM ItemKey+adminRemoveItem :: NF1 "AdminAction_RemoveItem" "item" ItemKey -> ClientM NoContent+listItems :<|> search :<|> itemStuff :<|> (adminOrder :<|> adminRestock :<|> adminAddItem :<|> adminRemoveItem) =+ client (Proxy @StoreActionApi)++--+--+type ExpectedReverseText =+ "ReverseText" :> ReqBody '[JSON] (NF1 "a" "text" Text) :> Post '[JSON] Text++type ExpectedIntersperse =+ "Sub"+ :> QueryParam' '[Strict, Required] "text" Text+ :> "Intersperse"+ :> QueryParam' '[Strict, Required] "intersperse_text" Text+ :> Get '[JSON] Text++$(mkServer testActionConfig ''ServerTestAction)++expectedReverseText :: NF1 "a" "text" Text -> ClientM Text+expectedReverseText = client (Proxy @ExpectedReverseText)++-- expectedConcatText :: Text -> Text -> ClientM Text+-- expectedConcatText = client (Proxy @ExpectedConcatText)++expectedIntersperseText :: Text -> Text -> ClientM Text+expectedIntersperseText = client (Proxy @ExpectedIntersperse)++-- writeOpenApi :: IO ()+-- writeOpenApi =+-- BL.writeFile "/tmp/store_schema.json" $ encode $ toOpenApi (Proxy @StoreActionApi)+--+withStoreServer :: IO () -> IO ()+withStoreServer runTests = do+ p <- createForgetful applyStoreEvent mempty+ server <-+ async . run 9898 $+ serve (Proxy @StoreActionApi) $+ hoistServer+ (Proxy @StoreActionApi)+ (Handler . ExceptT . try)+ (storeActionServer $ runAction p handleStoreAction)+ threadDelay 10000 -- Ensure the server is live when the tests run+ runTests+ cancel server++withTestServer :: IO () -> IO ()+withTestServer runTests = do+ p <- createForgetful (\m _ -> m) ()+ -- server <- async . run 9898 $ serve (Proxy @StoreActionApi) undefined+ server <-+ async . run 9898 $+ serve (Proxy @ServerTestActionApi) $+ hoistServer+ (Proxy @ServerTestActionApi)+ (Handler . ExceptT . try)+ (serverTestActionServer $ runAction p handleAction)+ threadDelay 10000 -- Ensure the server is live when the tests run+ runTests+ cancel server++spec :: Spec+spec = do+ clientEnv <- runIO $ do+ man <- newManager defaultManagerSettings+ pure $ mkClientEnv man (BaseUrl Http "localhost" 9898 "")+ aroundAll_ withStoreServer $ do+ describe "Server endpoint renaming" $ do+ it "Can add item" $ do+ r <- runClientM (adminAddItem $ NF3 "Test item" 10 99) clientEnv+ r `shouldSatisfy` not . null+ it "The new item shows up when listing items" $ do+ r <- runClientM listItems clientEnv+ case r of+ Right [ItemInfo _ n _ _ _] -> n `shouldBe` "Test item"+ a -> fail $ "That shouldn't happen! " <> show a+ aroundAll_ withTestServer $ do+ describe "Endpoints generated as expected" $ do+ it "Plaintext endpoint works" $ do+ r <- runClientM (expectedReverseText $ NF1 "Hej") clientEnv+ r `shouldBe` Right "jeH"+ it "Produces the expected parameters for subserver" $ do+ r <- runClientM (expectedIntersperseText "hello" "-=") clientEnv+ r `shouldBe` Right "h=-=e=-=l=-=l=-=o"+ describe "Supports extra parameters on Actions" $ do+ it "Can get apiOptions with one extra paramter" $ do+ M.lookup "Action.ExtraParam.ExtraParamAction" (allApiOptions extraParamConfig)+ `shouldSatisfy` not . null
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}