{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-|
Module      : Mealstrom.FSM
Description : Finite State Machine Definitions
Copyright   : (c) Max Amanshauser, 2016
License     : MIT
Maintainer  : max@lambdalifting.org

These defintions are concerned with the basic functions of
finite state machines, keeping a memory and state transitions.
-}

module Mealstrom.FSM where

import           Data.Aeson
import           Data.Foldable     (asum)
import           Data.Hashable     (Hashable)
import           Data.Maybe        (fromJust, fromMaybe)
import           Data.Text         (Text)
import           Data.Time.Clock
import           Data.Typeable     (Typeable)
import qualified Data.UUID as       UUID
import           Data.UUID         (UUID)
import           Data.UUID.V4
import           GHC.Generics

type MachineTransformer s e a = Machine s e a -> IO (Machine s e a)

-- |A data type that often comes in handy when describing whether
-- updates have succeeded in the backend.
data MealyStatus              = MealyError | Pending | Done deriving (MealyStatus -> MealyStatus -> Bool
(MealyStatus -> MealyStatus -> Bool)
-> (MealyStatus -> MealyStatus -> Bool) -> Eq MealyStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MealyStatus -> MealyStatus -> Bool
$c/= :: MealyStatus -> MealyStatus -> Bool
== :: MealyStatus -> MealyStatus -> Bool
$c== :: MealyStatus -> MealyStatus -> Bool
Eq, Int -> MealyStatus -> ShowS
[MealyStatus] -> ShowS
MealyStatus -> String
(Int -> MealyStatus -> ShowS)
-> (MealyStatus -> String)
-> ([MealyStatus] -> ShowS)
-> Show MealyStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MealyStatus] -> ShowS
$cshowList :: [MealyStatus] -> ShowS
show :: MealyStatus -> String
$cshow :: MealyStatus -> String
showsPrec :: Int -> MealyStatus -> ShowS
$cshowsPrec :: Int -> MealyStatus -> ShowS
Show)


-- |FSMs are uniquely identified by a type k, which must be convertible from/to Text.
class (Hashable k, Eq k) => FSMKey k where
    toText   :: k -> Text
    fromText :: Text -> k

-- |This typeclass is needed to provide a constraint for the FSMStore abstraction.
class (FSMKey k) => MealyInstance k s e a

-- |A change in a FSM is either a (Step Timestamp oldState event newState Actions)
-- or an increase in a counter.
data Change s e a = Step UTCTime s e s [a] | Count Int deriving (Int -> Change s e a -> ShowS
[Change s e a] -> ShowS
Change s e a -> String
(Int -> Change s e a -> ShowS)
-> (Change s e a -> String)
-> ([Change s e a] -> ShowS)
-> Show (Change s e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s e a.
(Show s, Show e, Show a) =>
Int -> Change s e a -> ShowS
forall s e a. (Show s, Show e, Show a) => [Change s e a] -> ShowS
forall s e a. (Show s, Show e, Show a) => Change s e a -> String
showList :: [Change s e a] -> ShowS
$cshowList :: forall s e a. (Show s, Show e, Show a) => [Change s e a] -> ShowS
show :: Change s e a -> String
$cshow :: forall s e a. (Show s, Show e, Show a) => Change s e a -> String
showsPrec :: Int -> Change s e a -> ShowS
$cshowsPrec :: forall s e a.
(Show s, Show e, Show a) =>
Int -> Change s e a -> ShowS
Show)

-- |Steps are equal to each other when they originated in the same state
-- received the same event and ended up in the same state
instance (Eq s, Eq e) => Eq (Change s e a) where
    == :: Change s e a -> Change s e a -> Bool
(==) (Count Int
a)             (Count Int
b)             = Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b
    (==) (Step UTCTime
_ s
os1 e
e1 s
ns1 [a]
_) (Step UTCTime
_ s
os2 e
e2 s
ns2 [a]
_) = (s
os1 s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
os2) Bool -> Bool -> Bool
&& (e
e1 e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
e2) Bool -> Bool -> Bool
&& (s
ns1 s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
ns2)
    (==) (Count Int
_)              Step{}               = Bool
False
    (==)  Step{}               (Count Int
_)             = Bool
False

data Instance k s e a = Instance {
    Instance k s e a -> k
key     :: k,
    Instance k s e a -> Machine s e a
machine :: Machine s e a
} deriving (Instance k s e a -> Instance k s e a -> Bool
(Instance k s e a -> Instance k s e a -> Bool)
-> (Instance k s e a -> Instance k s e a -> Bool)
-> Eq (Instance k s e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k s e a.
(Eq k, Eq e, Eq a, Eq s) =>
Instance k s e a -> Instance k s e a -> Bool
/= :: Instance k s e a -> Instance k s e a -> Bool
$c/= :: forall k s e a.
(Eq k, Eq e, Eq a, Eq s) =>
Instance k s e a -> Instance k s e a -> Bool
== :: Instance k s e a -> Instance k s e a -> Bool
$c== :: forall k s e a.
(Eq k, Eq e, Eq a, Eq s) =>
Instance k s e a -> Instance k s e a -> Bool
Eq,Int -> Instance k s e a -> ShowS
[Instance k s e a] -> ShowS
Instance k s e a -> String
(Int -> Instance k s e a -> ShowS)
-> (Instance k s e a -> String)
-> ([Instance k s e a] -> ShowS)
-> Show (Instance k s e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k s e a.
(Show k, Show e, Show a, Show s) =>
Int -> Instance k s e a -> ShowS
forall k s e a.
(Show k, Show e, Show a, Show s) =>
[Instance k s e a] -> ShowS
forall k s e a.
(Show k, Show e, Show a, Show s) =>
Instance k s e a -> String
showList :: [Instance k s e a] -> ShowS
$cshowList :: forall k s e a.
(Show k, Show e, Show a, Show s) =>
[Instance k s e a] -> ShowS
show :: Instance k s e a -> String
$cshow :: forall k s e a.
(Show k, Show e, Show a, Show s) =>
Instance k s e a -> String
showsPrec :: Int -> Instance k s e a -> ShowS
$cshowsPrec :: forall k s e a.
(Show k, Show e, Show a, Show s) =>
Int -> Instance k s e a -> ShowS
Show,(forall x. Instance k s e a -> Rep (Instance k s e a) x)
-> (forall x. Rep (Instance k s e a) x -> Instance k s e a)
-> Generic (Instance k s e a)
forall x. Rep (Instance k s e a) x -> Instance k s e a
forall x. Instance k s e a -> Rep (Instance k s e a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k s e a x. Rep (Instance k s e a) x -> Instance k s e a
forall k s e a x. Instance k s e a -> Rep (Instance k s e a) x
$cto :: forall k s e a x. Rep (Instance k s e a) x -> Instance k s e a
$cfrom :: forall k s e a x. Instance k s e a -> Rep (Instance k s e a) x
Generic,Typeable)

data Machine s e a = Machine {
    Machine s e a -> [Msg e]
inbox     :: [Msg e],
    Machine s e a -> [Msg a]
outbox    :: [Msg a],
    Machine s e a -> [UUID]
committed :: [UUID],
    Machine s e a -> s
initState :: s,
    Machine s e a -> s
currState :: s,
    Machine s e a -> [Change s e a]
hist      :: [Change s e a]
} deriving (Machine s e a -> Machine s e a -> Bool
(Machine s e a -> Machine s e a -> Bool)
-> (Machine s e a -> Machine s e a -> Bool) -> Eq (Machine s e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s e a.
(Eq e, Eq a, Eq s) =>
Machine s e a -> Machine s e a -> Bool
/= :: Machine s e a -> Machine s e a -> Bool
$c/= :: forall s e a.
(Eq e, Eq a, Eq s) =>
Machine s e a -> Machine s e a -> Bool
== :: Machine s e a -> Machine s e a -> Bool
$c== :: forall s e a.
(Eq e, Eq a, Eq s) =>
Machine s e a -> Machine s e a -> Bool
Eq,Int -> Machine s e a -> ShowS
[Machine s e a] -> ShowS
Machine s e a -> String
(Int -> Machine s e a -> ShowS)
-> (Machine s e a -> String)
-> ([Machine s e a] -> ShowS)
-> Show (Machine s e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s e a.
(Show e, Show a, Show s) =>
Int -> Machine s e a -> ShowS
forall s e a. (Show e, Show a, Show s) => [Machine s e a] -> ShowS
forall s e a. (Show e, Show a, Show s) => Machine s e a -> String
showList :: [Machine s e a] -> ShowS
$cshowList :: forall s e a. (Show e, Show a, Show s) => [Machine s e a] -> ShowS
show :: Machine s e a -> String
$cshow :: forall s e a. (Show e, Show a, Show s) => Machine s e a -> String
showsPrec :: Int -> Machine s e a -> ShowS
$cshowsPrec :: forall s e a.
(Show e, Show a, Show s) =>
Int -> Machine s e a -> ShowS
Show,(forall x. Machine s e a -> Rep (Machine s e a) x)
-> (forall x. Rep (Machine s e a) x -> Machine s e a)
-> Generic (Machine s e a)
forall x. Rep (Machine s e a) x -> Machine s e a
forall x. Machine s e a -> Rep (Machine s e a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s e a x. Rep (Machine s e a) x -> Machine s e a
forall s e a x. Machine s e a -> Rep (Machine s e a) x
$cto :: forall s e a x. Rep (Machine s e a) x -> Machine s e a
$cfrom :: forall s e a x. Machine s e a -> Rep (Machine s e a) x
Generic,Typeable)

mkEmptyMachine :: s -> Machine s e a
mkEmptyMachine :: s -> Machine s e a
mkEmptyMachine s
s = [Msg e]
-> [Msg a] -> [UUID] -> s -> s -> [Change s e a] -> Machine s e a
forall s e a.
[Msg e]
-> [Msg a] -> [UUID] -> s -> s -> [Change s e a] -> Machine s e a
Machine [] [] [] s
s s
s []

mkEmptyInstance :: k -> s -> Instance k s e a
mkEmptyInstance :: k -> s -> Instance k s e a
mkEmptyInstance k
k s
s = k -> Machine s e a -> Instance k s e a
forall k s e a. k -> Machine s e a -> Instance k s e a
Instance k
k (s -> Machine s e a
forall s e a. s -> Machine s e a
mkEmptyMachine s
s)

mkInstance :: k -> s -> [Msg e] -> Instance k s e a
mkInstance :: k -> s -> [Msg e] -> Instance k s e a
mkInstance k
k s
s [Msg e]
es = k -> Machine s e a -> Instance k s e a
forall k s e a. k -> Machine s e a -> Instance k s e a
Instance k
k ((s -> Machine s e a
forall s e a. s -> Machine s e a
mkEmptyMachine s
s) {inbox :: [Msg e]
inbox = [Msg e]
es})


-- |Type of messages that are sent between FSMs
-- Messages are always identified by UUID.
-- The purpose of Msg is to attach a unique ID to an event, so that
-- certain guarantees can be provided.
data Msg e = Msg {
    Msg e -> Maybe UUID
msgID       :: Maybe UUID,
    Msg e -> e
msgContents :: e
} deriving (Int -> Msg e -> ShowS
[Msg e] -> ShowS
Msg e -> String
(Int -> Msg e -> ShowS)
-> (Msg e -> String) -> ([Msg e] -> ShowS) -> Show (Msg e)
forall e. Show e => Int -> Msg e -> ShowS
forall e. Show e => [Msg e] -> ShowS
forall e. Show e => Msg e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Msg e] -> ShowS
$cshowList :: forall e. Show e => [Msg e] -> ShowS
show :: Msg e -> String
$cshow :: forall e. Show e => Msg e -> String
showsPrec :: Int -> Msg e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> Msg e -> ShowS
Show,Msg e -> Msg e -> Bool
(Msg e -> Msg e -> Bool) -> (Msg e -> Msg e -> Bool) -> Eq (Msg e)
forall e. Eq e => Msg e -> Msg e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Msg e -> Msg e -> Bool
$c/= :: forall e. Eq e => Msg e -> Msg e -> Bool
== :: Msg e -> Msg e -> Bool
$c== :: forall e. Eq e => Msg e -> Msg e -> Bool
Eq,(forall x. Msg e -> Rep (Msg e) x)
-> (forall x. Rep (Msg e) x -> Msg e) -> Generic (Msg e)
forall x. Rep (Msg e) x -> Msg e
forall x. Msg e -> Rep (Msg e) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e x. Rep (Msg e) x -> Msg e
forall e x. Msg e -> Rep (Msg e) x
$cto :: forall e x. Rep (Msg e) x -> Msg e
$cfrom :: forall e x. Msg e -> Rep (Msg e) x
Generic)

mkMsg :: t -> IO (Msg t)
mkMsg :: t -> IO (Msg t)
mkMsg t
t = IO UUID
nextRandom IO UUID -> (UUID -> IO (Msg t)) -> IO (Msg t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UUID
i -> Msg t -> IO (Msg t)
forall (m :: * -> *) a. Monad m => a -> m a
return (Msg t -> IO (Msg t)) -> Msg t -> IO (Msg t)
forall a b. (a -> b) -> a -> b
$ Maybe UUID -> t -> Msg t
forall e. Maybe UUID -> e -> Msg e
Msg (UUID -> Maybe UUID
forall a. a -> Maybe a
Just UUID
i) t
t

mkMsgs :: [t] -> IO [Msg t]
mkMsgs :: [t] -> IO [Msg t]
mkMsgs = (t -> IO (Msg t)) -> [t] -> IO [Msg t]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM t -> IO (Msg t)
forall t. t -> IO (Msg t)
mkMsg

mkBogusMsg :: (Eq t) => t -> Msg t
mkBogusMsg :: t -> Msg t
mkBogusMsg = Maybe UUID -> t -> Msg t
forall e. Maybe UUID -> e -> Msg e
Msg Maybe UUID
forall a. Maybe a
Nothing

-- |Append a Change to a history.
-- Identical steps are just counted, otherwise they are consed to the history.
histAppend :: (Eq s, Eq e) => Change s e a -> [Change s e a] -> [Change s e a]
histAppend :: Change s e a -> [Change s e a] -> [Change s e a]
histAppend Change s e a
s1 all :: [Change s e a]
all@(Count Int
i:Change s e a
s2:[Change s e a]
rest)
    | Change s e a
s1 Change s e a -> Change s e a -> Bool
forall a. Eq a => a -> a -> Bool
== Change s e a
s2 = Int -> Change s e a
forall s e a. Int -> Change s e a
Count (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)Change s e a -> [Change s e a] -> [Change s e a]
forall a. a -> [a] -> [a]
:Change s e a
s2Change s e a -> [Change s e a] -> [Change s e a]
forall a. a -> [a] -> [a]
:[Change s e a]
rest
    | Bool
otherwise = Change s e a
s1 Change s e a -> [Change s e a] -> [Change s e a]
forall a. a -> [a] -> [a]
: [Change s e a]
all
histAppend Change s e a
s1 all :: [Change s e a]
all@(Change s e a
s2:[Change s e a]
_rest)
    | Change s e a
s1 Change s e a -> Change s e a -> Bool
forall a. Eq a => a -> a -> Bool
== Change s e a
s2 = Int -> Change s e a
forall s e a. Int -> Change s e a
Count Int
1 Change s e a -> [Change s e a] -> [Change s e a]
forall a. a -> [a] -> [a]
: [Change s e a]
all
    | Bool
otherwise = Change s e a
s1 Change s e a -> [Change s e a] -> [Change s e a]
forall a. a -> [a] -> [a]
: [Change s e a]
all
histAppend Change s e a
s [Change s e a]
ss = Change s e a
sChange s e a -> [Change s e a] -> [Change s e a]
forall a. a -> [a] -> [a]
:[Change s e a]
ss


-- ##############
-- # JSON Codecs
-- ##############

instance (ToJSON s, ToJSON e, ToJSON a) => ToJSON (Change s e a) where
    toJSON :: Change s e a -> Value
toJSON (Count Int
i) = [Pair] -> Value
object [ Text
"count" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
i]
    toJSON (Step UTCTime
ts s
os e
ev s
ns [a]
as) =
        [Pair] -> Value
object [
            Text
"timestamp" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
ts,
            Text
"old_state" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= s -> Value
forall a. ToJSON a => a -> Value
toJSON s
os,
            Text
"event"     Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= e -> Value
forall a. ToJSON a => a -> Value
toJSON e
ev,
            Text
"new_state" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= s -> Value
forall a. ToJSON a => a -> Value
toJSON s
ns,
            Text
"actions"   Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [a] -> Value
forall a. ToJSON a => a -> Value
toJSON [a]
as
        ]

instance (FromJSON s, FromJSON e, FromJSON a) => FromJSON (Change s e a) where
    parseJSON :: Value -> Parser (Change s e a)
parseJSON =
        String
-> (Object -> Parser (Change s e a))
-> Value
-> Parser (Change s e a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Change" ((Object -> Parser (Change s e a))
 -> Value -> Parser (Change s e a))
-> (Object -> Parser (Change s e a))
-> Value
-> Parser (Change s e a)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
            [Parser (Change s e a)] -> Parser (Change s e a)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [
                Int -> Change s e a
forall s e a. Int -> Change s e a
Count (Int -> Change s e a) -> Parser Int -> Parser (Change s e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"count",
                UTCTime -> s -> e -> s -> [a] -> Change s e a
forall s e a. UTCTime -> s -> e -> s -> [a] -> Change s e a
Step  (UTCTime -> s -> e -> s -> [a] -> Change s e a)
-> Parser UTCTime -> Parser (s -> e -> s -> [a] -> Change s e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser UTCTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"timestamp" Parser (s -> e -> s -> [a] -> Change s e a)
-> Parser s -> Parser (e -> s -> [a] -> Change s e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser s
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"old_state" Parser (e -> s -> [a] -> Change s e a)
-> Parser e -> Parser (s -> [a] -> Change s e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser e
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"event" Parser (s -> [a] -> Change s e a)
-> Parser s -> Parser ([a] -> Change s e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser s
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"new_state" Parser ([a] -> Change s e a) -> Parser [a] -> Parser (Change s e a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser [a]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"actions"
            ]


-- Other Instances
instance FSMKey Text where
    toText :: Text -> Text
toText   = Text -> Text
forall a. a -> a
id
    fromText :: Text -> Text
fromText = Text -> Text
forall a. a -> a
id

instance FSMKey UUID where
    toText :: UUID -> Text
toText     = UUID -> Text
UUID.toText
    fromText :: Text -> UUID
fromText Text
a = UUID -> Maybe UUID -> UUID
forall a. a -> Maybe a -> a
fromMaybe (String -> UUID
forall a. HasCallStack => String -> a
error String
"Conversion from UUID failed") (Text -> Maybe UUID
UUID.fromText Text
a)