diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for domaindriven + +## 0.5.0 + +First release published on hackage. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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) + + diff --git a/domaindriven.cabal b/domaindriven.cabal new file mode 100644 --- /dev/null +++ b/domaindriven.cabal @@ -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 +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 diff --git a/src/DomainDriven.hs b/src/DomainDriven.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven.hs @@ -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 + ) diff --git a/src/DomainDriven/Internal/HasFieldName.hs b/src/DomainDriven/Internal/HasFieldName.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Internal/HasFieldName.hs @@ -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 diff --git a/src/DomainDriven/Internal/NamedFields.hs b/src/DomainDriven/Internal/NamedFields.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Internal/NamedFields.hs @@ -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 + } diff --git a/src/DomainDriven/Internal/NamedJsonFields.hs b/src/DomainDriven/Internal/NamedJsonFields.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Internal/NamedJsonFields.hs @@ -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 diff --git a/src/DomainDriven/Internal/Text.hs b/src/DomainDriven/Internal/Text.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Internal/Text.hs @@ -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 diff --git a/src/DomainDriven/Server/Class.hs b/src/DomainDriven/Server/Class.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Server/Class.hs @@ -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 diff --git a/src/DomainDriven/Server/Config.hs b/src/DomainDriven/Server/Config.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Server/Config.hs @@ -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 diff --git a/src/DomainDriven/Server/Helpers.hs b/src/DomainDriven/Server/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Server/Helpers.hs @@ -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 diff --git a/src/DomainDriven/Server/TH.hs b/src/DomainDriven/Server/TH.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Server/TH.hs @@ -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)|] diff --git a/src/DomainDriven/Server/Types.hs b/src/DomainDriven/Server/Types.hs new file mode 100644 --- /dev/null +++ b/src/DomainDriven/Server/Types.hs @@ -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) diff --git a/test/Action/Counter.hs b/test/Action/Counter.hs new file mode 100644 --- /dev/null +++ b/test/Action/Counter.hs @@ -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") diff --git a/test/Action/ExtraParam.hs b/test/Action/ExtraParam.hs new file mode 100644 --- /dev/null +++ b/test/Action/ExtraParam.hs @@ -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") diff --git a/test/Action/ServerTest.hs b/test/Action/ServerTest.hs new file mode 100644 --- /dev/null +++ b/test/Action/ServerTest.hs @@ -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") diff --git a/test/Action/Store.hs b/test/Action/Store.hs new file mode 100644 --- /dev/null +++ b/test/Action/Store.hs @@ -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") diff --git a/test/DomainDriven/Internal/NamedJsonFieldsSpec.hs b/test/DomainDriven/Internal/NamedJsonFieldsSpec.hs new file mode 100644 --- /dev/null +++ b/test/DomainDriven/Internal/NamedJsonFieldsSpec.hs @@ -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 == [] diff --git a/test/DomainDriven/ServerSpec.hs b/test/DomainDriven/ServerSpec.hs new file mode 100644 --- /dev/null +++ b/test/DomainDriven/ServerSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}