{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
module Raft.StateMachine (
RaftStateMachinePure(..),
RaftStateMachinePureError(..),
RaftStateMachine(..),
EntryValidation(..),
applyLogEntry,
applyLogCmd
) where
import Protolude
import Raft.Log (Entry(..), EntryValue(..))
class RaftStateMachinePure sm v | sm -> v where
data RaftStateMachinePureError sm v
type RaftStateMachinePureCtx sm v = ctx | ctx -> sm v
rsmTransition
:: RaftStateMachinePureCtx sm v
-> sm
-> v
-> Either (RaftStateMachinePureError sm v) sm
class (Monad m, RaftStateMachinePure sm v) => RaftStateMachine m sm v where
validateCmd :: v -> m (Either (RaftStateMachinePureError sm v) ())
preprocessCmd :: v -> m v
askRaftStateMachinePureCtx :: m (RaftStateMachinePureCtx sm v)
default preprocessCmd :: v -> m v
preprocessCmd = return
data EntryValidation
= NoMonadicValidation
| MonadicValidation
applyLogEntry
:: RaftStateMachine m sm v
=> EntryValidation
-> sm
-> Entry v
-> m (Either (RaftStateMachinePureError sm v) sm)
applyLogEntry validation sm entry =
case entryValue entry of
NoValue -> pure (Right sm)
EntryValue cmd -> applyLogCmd validation sm cmd
applyLogCmd
:: forall sm cmd m. RaftStateMachine m sm cmd
=> EntryValidation
-> sm
-> cmd
-> m (Either (RaftStateMachinePureError sm cmd) sm)
applyLogCmd validation sm cmd = do
processedCmd <- preprocessCmd @m @sm cmd
monadicValidationRes <-
case validation of
NoMonadicValidation -> pure (Right ())
MonadicValidation -> validateCmd processedCmd
case monadicValidationRes of
Left err -> pure (Left err)
Right () -> do
ctx <- askRaftStateMachinePureCtx
pure (rsmTransition ctx sm processedCmd)