{-# 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 (Int -> ParamPart -> ShowS
[ParamPart] -> ShowS
ParamPart -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParamPart] -> ShowS
$cshowList :: [ParamPart] -> ShowS
show :: ParamPart -> String
$cshow :: ParamPart -> String
showsPrec :: Int -> ParamPart -> ShowS
$cshowsPrec :: Int -> ParamPart -> ShowS
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 :: forall (m :: * -> *) event model0 model1 method a.
Monad m =>
(model0 -> model1)
-> HandlerType method model1 event m a
-> HandlerType method model0 event m a
mapModel model0 -> model1
f = \case
    Query model1 -> m a
h -> forall method model (m :: * -> *) a event.
(CanMutate method ~ 'False, GetModelAccess method ~ 'Direct) =>
(model -> m a) -> HandlerType method model event m a
Query (model1 -> m a
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. model0 -> model1
f)
    CbQuery m model1 -> m a
withModel -> forall method (m :: * -> *) model a event.
(CanMutate method ~ 'False, GetModelAccess method ~ 'Callback) =>
(m model -> m a) -> HandlerType method model event m a
CbQuery \m model0
fetchModel ->
        m model1 -> m a
withModel (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap model0 -> model1
f m model0
fetchModel)
    Cmd model1 -> m (model1 -> a, [event])
h -> forall method model (m :: * -> *) a event.
(CanMutate method ~ 'True, GetModelAccess method ~ 'Direct) =>
(model -> m (model -> a, [event]))
-> HandlerType method model event m a
Cmd forall a b. (a -> b) -> a -> b
$ \model0
m -> do
        (model1 -> a
fm, [event]
evs) <- model1 -> m (model1 -> a, [event])
h forall a b. (a -> b) -> a -> b
$ model0 -> model1
f model0
m
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (model1 -> a
fm forall b c a. (b -> c) -> (a -> b) -> a -> c
. model0 -> model1
f, [event]
evs)
    CbCmd (forall x. (model1 -> m (model1 -> x, [event])) -> m x) -> m a
withTrans -> forall method model (m :: * -> *) event a.
(CanMutate method ~ 'True, GetModelAccess method ~ 'Callback) =>
((forall x. (model -> m (model -> x, [event])) -> m x) -> m a)
-> HandlerType method model event m a
CbCmd forall a b. (a -> b) -> a -> b
$ \forall x. (model0 -> m (model0 -> x, [event])) -> m x
runTrans ->
        (forall x. (model1 -> m (model1 -> x, [event])) -> m x) -> m a
withTrans forall a b. (a -> b) -> a -> b
$ \(model1 -> m (model1 -> x, [event])
trans :: model -> m (x, [e0])) -> do
            forall x. (model0 -> m (model0 -> x, [event])) -> m x
runTrans forall a b. (a -> b) -> a -> b
$ \model0
model -> do
                (model1 -> x
r, [event]
evs) <- model1 -> m (model1 -> x, [event])
trans (model0 -> model1
f model0
model)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (model1 -> x
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. model0 -> model1
f, [event]
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 :: forall (m :: * -> *) e0 e1 a method model.
Monad m =>
(e0 -> e1)
-> HandlerType method model e0 m a
-> HandlerType method model e1 m a
mapEvent e0 -> e1
f = \case
    Query model -> m a
h -> forall method model (m :: * -> *) a event.
(CanMutate method ~ 'False, GetModelAccess method ~ 'Direct) =>
(model -> m a) -> HandlerType method model event m a
Query model -> m a
h
    CbQuery m model -> m a
h -> forall method (m :: * -> *) model a event.
(CanMutate method ~ 'False, GetModelAccess method ~ 'Callback) =>
(m model -> m a) -> HandlerType method model event m a
CbQuery m model -> m a
h
    Cmd model -> m (model -> a, [e0])
h -> forall method model (m :: * -> *) a event.
(CanMutate method ~ 'True, GetModelAccess method ~ 'Direct) =>
(model -> m (model -> a, [event]))
-> HandlerType method model event m a
Cmd forall a b. (a -> b) -> a -> b
$ \model
m -> do
        (model -> a
ret, [e0]
evs) <- model -> m (model -> a, [e0])
h model
m
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (model -> a
ret, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e0 -> e1
f [e0]
evs)
    CbCmd (forall x. (model -> m (model -> x, [e0])) -> m x) -> m a
withTrans -> forall method model (m :: * -> *) event a.
(CanMutate method ~ 'True, GetModelAccess method ~ 'Callback) =>
((forall x. (model -> m (model -> x, [event])) -> m x) -> m a)
-> HandlerType method model event m a
CbCmd forall a b. (a -> b) -> a -> b
$ \forall x. (model -> m (model -> x, [e1])) -> m x
runTrans ->
        (forall x. (model -> m (model -> x, [e0])) -> m x) -> m a
withTrans forall a b. (a -> b) -> a -> b
$ \(model -> m (model -> x, [e0])
trans :: model -> m (x, [e0])) -> do
            forall x. (model -> m (model -> x, [e1])) -> m x
runTrans forall a b. (a -> b) -> a -> b
$ \model
model -> do
                (model -> x
r, [e0]
evs) <- model -> m (model -> x, [e0])
trans model
model
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (model -> x
r, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e0 -> e1
f [e0]
evs)

mapResult
    :: Monad m
    => (r0 -> r1)
    -> HandlerType method model e m r0
    -> HandlerType method model e m r1
mapResult :: forall (m :: * -> *) r0 r1 method model e.
Monad m =>
(r0 -> r1)
-> HandlerType method model e m r0
-> HandlerType method model e m r1
mapResult r0 -> r1
f = \case
    Query model -> m r0
h -> forall method model (m :: * -> *) a event.
(CanMutate method ~ 'False, GetModelAccess method ~ 'Direct) =>
(model -> m a) -> HandlerType method model event m a
Query forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r0 -> r1
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. model -> m r0
h
    CbQuery m model -> m r0
h -> forall method (m :: * -> *) model a event.
(CanMutate method ~ 'False, GetModelAccess method ~ 'Callback) =>
(m model -> m a) -> HandlerType method model event m a
CbQuery forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r0 -> r1
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. m model -> m r0
h
    Cmd model -> m (model -> r0, [e])
h -> forall method model (m :: * -> *) a event.
(CanMutate method ~ 'True, GetModelAccess method ~ 'Direct) =>
(model -> m (model -> a, [event]))
-> HandlerType method model event m a
Cmd forall a b. (a -> b) -> a -> b
$ \model
m -> do
        (model -> r0
ret, [e]
evs) <- model -> m (model -> r0, [e])
h model
m
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (r0 -> r1
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. model -> r0
ret, [e]
evs)
    CbCmd (forall x. (model -> m (model -> x, [e])) -> m x) -> m r0
withTrans -> forall method model (m :: * -> *) event a.
(CanMutate method ~ 'True, GetModelAccess method ~ 'Callback) =>
((forall x. (model -> m (model -> x, [event])) -> m x) -> m a)
-> HandlerType method model event m a
CbCmd forall a b. (a -> b) -> a -> b
$ \forall x. (model -> m (model -> x, [e])) -> m x
transact -> r0 -> r1
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall x. (model -> m (model -> x, [e])) -> m x) -> m r0
withTrans forall x. (model -> m (model -> x, [e])) -> m x
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 :: forall (m :: * -> *) p model event
       (cmd :: ParamPart -> * -> * -> *) method ret.
(MonadUnliftIO m, WriteModel p, model ~ Model p,
 event ~ Event p) =>
p
-> ActionHandler model event m cmd
-> cmd 'ParamType method ret
-> m ret
runAction p
p ActionHandler model event m cmd
handleCmd cmd 'ParamType method ret
cmd = case ActionHandler model event m cmd
handleCmd cmd 'ParamType method ret
cmd of
    Query model -> m ret
m -> model -> m ret
m forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall p. ReadModel p => p -> IO (Model p)
getModel p
p)
    CbQuery m model -> m ret
m -> m model -> m ret
m (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall p. ReadModel p => p -> IO (Model p)
getModel p
p))
    Cmd model -> m (model -> ret, [event])
m -> forall p (m :: * -> *) a.
(WriteModel p, MonadUnliftIO m) =>
p -> (Model p -> m (Model p -> a, [Event p])) -> m a
transactionalUpdate p
p model -> m (model -> ret, [event])
m
    CbCmd (forall x. (model -> m (model -> x, [event])) -> m x) -> m ret
withTrans -> (forall x. (model -> m (model -> x, [event])) -> m x) -> m ret
withTrans forall a b. (a -> b) -> a -> b
$ \model -> m (model -> x, [event])
runTrans -> do
        forall p (m :: * -> *) a.
(WriteModel p, MonadUnliftIO m) =>
p -> (Model p -> m (Model p -> a, [Event p])) -> m a
transactionalUpdate p
p model -> m (model -> x, [event])
runTrans