{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}

{-|
Module      : Mealstrom.FSMApi
Description : API for FSMs
Copyright   : (c) Max Amanshauser, 2016
License     : MIT
Maintainer  : max@lambdalifting.org

This is the interface through which you primarily interact with a FSM
from the rest of your program.
-}

module Mealstrom.FSMApi where

import           Control.Concurrent
import           Control.Exception
import           Control.Monad          (void)
import qualified Data.Text           as  Text
import           System.IO
import           System.Timeout

import           Mealstrom.FSM
import           Mealstrom.FSMEngine
import           Mealstrom.FSMStore
import           Mealstrom.FSMTable
import           Mealstrom.WALStore


data FSMHandle st wal k s e a where
    FSMHandle :: (Eq s, Eq e, Eq a, FSMStore st k s e a, WALStore wal k, FSMKey k) => {
        FSMHandle st wal k s e a -> st
fsmStore   :: st,                -- ^ Which backend to use for storing FSMs.
        FSMHandle st wal k s e a -> wal
walStore   :: wal,               -- ^ Which backend to use for the WAL.
        FSMHandle st wal k s e a -> FSMTable s e a
fsmTable   :: FSMTable s e a,    -- ^ A table of transitions and effects.
                                         --   This is not in a typeclass, because you may want to use MVars or similar in effects.
                                         --   See the tests for examples.
        FSMHandle st wal k s e a -> Int
effTimeout :: Int,               -- ^ How much time to allow for Actions until they are considered failed.
        FSMHandle st wal k s e a -> Int
retryCount :: Int                -- ^ How often to automatically retry actions.
    } -> FSMHandle st wal k s e a


get :: forall st wal k s e a . FSMStore st k s e a => FSMHandle st wal k s e a -> k -> IO(Maybe s)
get :: FSMHandle st wal k s e a -> k -> IO (Maybe s)
get FSMHandle{st
wal
Int
FSMTable s e a
retryCount :: Int
effTimeout :: Int
fsmTable :: FSMTable s e a
walStore :: wal
fsmStore :: st
retryCount :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
effTimeout :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
fsmTable :: forall st wal k s e a. FSMHandle st wal k s e a -> FSMTable s e a
walStore :: forall st wal k s e a. FSMHandle st wal k s e a -> wal
fsmStore :: forall st wal k s e a. FSMHandle st wal k s e a -> st
..} k
k = st -> k -> Proxy k s e a -> IO (Maybe s)
forall st k s e a.
FSMStore st k s e a =>
st -> k -> Proxy k s e a -> IO (Maybe s)
fsmRead st
fsmStore k
k (Proxy k s e a
forall k s e a. Proxy k s e a
Proxy :: Proxy k s e a)


-- |Idempotent because of usage of caller-generated keys.
post :: forall st wal k s e a . FSMStore st k s e a =>
        FSMHandle st wal k s e a                                 ->
        k                                                        ->
        s                                                        -> IO Bool
post :: FSMHandle st wal k s e a -> k -> s -> IO Bool
post FSMHandle{st
wal
Int
FSMTable s e a
retryCount :: Int
effTimeout :: Int
fsmTable :: FSMTable s e a
walStore :: wal
fsmStore :: st
retryCount :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
effTimeout :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
fsmTable :: forall st wal k s e a. FSMHandle st wal k s e a -> FSMTable s e a
walStore :: forall st wal k s e a. FSMHandle st wal k s e a -> wal
fsmStore :: forall st wal k s e a. FSMHandle st wal k s e a -> st
..} k
k s
s0 =
    st -> Instance k s e a -> IO (Maybe String)
forall st k s e a.
FSMStore st k s e a =>
st -> Instance k s e a -> IO (Maybe String)
fsmCreate st
fsmStore (k -> s -> [Msg e] -> Instance k s e a
forall k s e a. k -> s -> [Msg e] -> Instance k s e a
mkInstance k
k s
s0 [] :: Instance k s e a) IO (Maybe String) -> (Maybe String -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe String
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Just String
s  -> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
s IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False


-- |Concurrent updates will be serialised by Postgres.
-- Returns True when the state transition has been successfully computed
-- and actions have been scheduled, now or at any time in the past.
-- Returns False on failure.
patch :: forall st wal k s e a . (FSMStore st k s e a, MealyInstance k s e a, FSMKey k) => FSMHandle st wal k s e a -> k -> [Msg e] -> IO Bool
patch :: FSMHandle st wal k s e a -> k -> [Msg e] -> IO Bool
patch h :: FSMHandle st wal k s e a
h@FSMHandle{st
wal
Int
FSMTable s e a
retryCount :: Int
effTimeout :: Int
fsmTable :: FSMTable s e a
walStore :: wal
fsmStore :: st
retryCount :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
effTimeout :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
fsmTable :: forall st wal k s e a. FSMHandle st wal k s e a -> FSMTable s e a
walStore :: forall st wal k s e a. FSMHandle st wal k s e a -> wal
fsmStore :: forall st wal k s e a. FSMHandle st wal k s e a -> st
..} k
k [Msg e]
es = do
    wal -> k -> IO ()
forall st k. WALStore st k => st -> k -> IO ()
openTxn wal
walStore k
k

    MealyStatus
status <- (SomeException -> IO MealyStatus)
-> IO MealyStatus -> IO MealyStatus
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
e::SomeException) -> Handle -> String -> IO ()
hPutStrLn Handle
stderr (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) IO () -> IO MealyStatus -> IO MealyStatus
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MealyStatus -> IO MealyStatus
forall (m :: * -> *) a. Monad m => a -> m a
return MealyStatus
MealyError)
                     (st -> k -> MachineTransformer s e a -> IO MealyStatus
forall st k s e a.
FSMStore st k s e a =>
st -> k -> MachineTransformer s e a -> IO MealyStatus
fsmUpdate st
fsmStore k
k ((FSMTable s e a -> [Msg e] -> MachineTransformer s e a
forall s e a.
(Eq s, Eq e) =>
FSMTable s e a -> [Msg e] -> Machine s e a -> IO (Machine s e a)
patchPhase1 FSMTable s e a
fsmTable [Msg e]
es) :: MachineTransformer s e a))

    if MealyStatus
status MealyStatus -> MealyStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= MealyStatus
MealyError
    then FSMHandle st wal k s e a -> k -> IO ()
forall st wal k s e a.
(FSMStore st k s e a, MealyInstance k s e a, FSMKey k) =>
FSMHandle st wal k s e a -> k -> IO ()
recover FSMHandle st wal k s e a
h k
k IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False


-- |Recovering is the process of asynchronously applying Actions. It is performed
-- immediately after the synchronous part of an update and, on failure, retried until it
-- succeeds or the retry limit is hit.
recover :: forall st wal k s e a . (FSMStore st k s e a, MealyInstance k s e a, FSMKey k) => FSMHandle st wal k s e a -> k -> IO ()
recover :: FSMHandle st wal k s e a -> k -> IO ()
recover h :: FSMHandle st wal k s e a
h@FSMHandle{st
wal
Int
FSMTable s e a
retryCount :: Int
effTimeout :: Int
fsmTable :: FSMTable s e a
walStore :: wal
fsmStore :: st
retryCount :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
effTimeout :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
fsmTable :: forall st wal k s e a. FSMHandle st wal k s e a -> FSMTable s e a
walStore :: forall st wal k s e a. FSMHandle st wal k s e a -> wal
fsmStore :: forall st wal k s e a. FSMHandle st wal k s e a -> st
..} k
k
    | Int
retryCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Alarma! Recovery retries for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack (k -> Text
forall k. FSMKey k => k -> Text
toText k
k) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" exhausted. Giving up!"
    | Bool
otherwise =
        IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe MealyStatus)
-> (Either SomeException (Maybe MealyStatus) -> IO ())
-> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Int -> IO MealyStatus -> IO (Maybe MealyStatus)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
effTimeoutInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
10Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
6) (st -> k -> MachineTransformer s e a -> IO MealyStatus
forall st k s e a.
FSMStore st k s e a =>
st -> k -> MachineTransformer s e a -> IO MealyStatus
fsmUpdate st
fsmStore k
k (FSMTable s e a -> MachineTransformer s e a
forall a s e.
Eq a =>
FSMTable s e a -> Machine s e a -> IO (Machine s e a)
patchPhase2 FSMTable s e a
fsmTable :: MachineTransformer s e a))) -- (patchPhase2 fsmTable))
                           (\case Left SomeException
exn      -> do       -- the damn thing crashed, print log and try again
                                      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Exception occurred while trying to recover " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack (k -> Text
forall k. FSMKey k => k -> Text
toText k
k)
                                      Handle -> SomeException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr SomeException
exn
                                      FSMHandle st wal k s e a -> k -> IO ()
forall st wal k s e a.
(FSMStore st k s e a, MealyInstance k s e a, FSMKey k) =>
FSMHandle st wal k s e a -> k -> IO ()
recover FSMHandle st wal k s e a
h{retryCount :: Int
retryCount = Int
retryCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1} k
k
                                  Right Maybe MealyStatus
Nothing -> do       -- We hit the timeout. Try again until we hit the retry limit.
                                      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Timeout while trying to recover " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack (k -> Text
forall k. FSMKey k => k -> Text
toText k
k)
                                      FSMHandle st wal k s e a -> k -> IO ()
forall st wal k s e a.
(FSMStore st k s e a, MealyInstance k s e a, FSMKey k) =>
FSMHandle st wal k s e a -> k -> IO ()
recover FSMHandle st wal k s e a
h{retryCount :: Int
retryCount = Int
retryCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1} k
k
                                  Right (Just MealyStatus
Done)    -> wal -> k -> IO ()
forall st k. WALStore st k => st -> k -> IO ()
closeTxn wal
walStore k
k    -- All good.
                                  Right (Just MealyStatus
Pending) ->                        -- Some actions did not complete successfully.
                                      FSMHandle st wal k s e a -> k -> IO ()
forall st wal k s e a.
(FSMStore st k s e a, MealyInstance k s e a, FSMKey k) =>
FSMHandle st wal k s e a -> k -> IO ()
recover FSMHandle st wal k s e a
h{retryCount :: Int
retryCount = Int
retryCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1} k
k)


-- |During certain long-lasting failures, like network outage, the retry limit of Actions will be exhausted.
-- You should regularly, e.g. ever 10 minutes, call this function to clean up those hard cases.
recoverAll :: forall st wal k s e a . (MealyInstance k s e a) => FSMHandle st wal k s e a -> IO ()
recoverAll :: FSMHandle st wal k s e a -> IO ()
recoverAll h :: FSMHandle st wal k s e a
h@FSMHandle{st
wal
Int
FSMTable s e a
retryCount :: Int
effTimeout :: Int
fsmTable :: FSMTable s e a
walStore :: wal
fsmStore :: st
retryCount :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
effTimeout :: forall st wal k s e a. FSMHandle st wal k s e a -> Int
fsmTable :: forall st wal k s e a. FSMHandle st wal k s e a -> FSMTable s e a
walStore :: forall st wal k s e a. FSMHandle st wal k s e a -> wal
fsmStore :: forall st wal k s e a. FSMHandle st wal k s e a -> st
..} = do
    [WALEntry k]
wals <- wal -> Int -> IO [WALEntry k]
forall st k. WALStore st k => st -> Int -> IO [WALEntry k]
walScan wal
walStore Int
effTimeout
    (WALEntry k -> IO ()) -> [WALEntry k] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FSMHandle st wal k s e a -> k -> IO ()
forall st wal k s e a.
(FSMStore st k s e a, MealyInstance k s e a, FSMKey k) =>
FSMHandle st wal k s e a -> k -> IO ()
recover FSMHandle st wal k s e a
h (k -> IO ()) -> (WALEntry k -> k) -> WALEntry k -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WALEntry k -> k
forall k. WALEntry k -> k
walId) [WALEntry k]
wals


-- |A helper that is sometimes useful
upsert :: forall st wal k s e a . MealyInstance k s e a => FSMStore st k s e a =>
          FSMHandle st wal k s e a -> k -> s -> [Msg e] -> IO ()
upsert :: FSMHandle st wal k s e a -> k -> s -> [Msg e] -> IO ()
upsert FSMHandle st wal k s e a
h k
k s
s [Msg e]
es = do
    Maybe s
ms <- FSMHandle st wal k s e a -> k -> IO (Maybe s)
forall st wal k s e a.
FSMStore st k s e a =>
FSMHandle st wal k s e a -> k -> IO (Maybe s)
get FSMHandle st wal k s e a
h k
k
    IO () -> (s -> IO ()) -> Maybe s -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FSMHandle st wal k s e a -> k -> s -> IO Bool
forall st wal k s e a.
FSMStore st k s e a =>
FSMHandle st wal k s e a -> k -> s -> IO Bool
post FSMHandle st wal k s e a
h k
k s
s IO Bool -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FSMHandle st wal k s e a -> k -> [Msg e] -> IO Bool
forall st wal k s e a.
(FSMStore st k s e a, MealyInstance k s e a, FSMKey k) =>
FSMHandle st wal k s e a -> k -> [Msg e] -> IO Bool
patch FSMHandle st wal k s e a
h k
k [Msg e]
es))
          (\s
_s -> IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ FSMHandle st wal k s e a -> k -> [Msg e] -> IO Bool
forall st wal k s e a.
(FSMStore st k s e a, MealyInstance k s e a, FSMKey k) =>
FSMHandle st wal k s e a -> k -> [Msg e] -> IO Bool
patch FSMHandle st wal k s e a
h k
k [Msg e]
es)
          Maybe s
ms