FSM typeclass demonstration

Door.hs

{-# LANGUAGE MultiWayIf #-}

-- | This module implements a door that can be opened and closed, and
-- locked/unlocked with a specified code when in closed state.
--
-- The state diagram looks roughly like this (p. simple):
--
--          <--Open---     <--Unlock--
--      [Opened]    [Closed]     [Locked]
--          --Close-->     ----Lock-->
--
-- Where the arrows denote events, and the bracketed words denote
-- states.
--
-- The following "door features" exist:
--
-- * Upon entering a new state, an IRC channel is informed about the
--   door state
-- * A door can be "locked" by providing an arbitrary code; and
--   unlocked by providing the same code
-- * The door calls the police if the code has been entered
--   incorrectly 10 times.
--
-- This demonstrates an FSM implementation in Haskell that is vaguely
-- inspired by BEAM's gen_statem. The implementation is backed by
-- Postgres for persisting events and tracking machine and action
-- states.
--
-- Roughly speaking, the module would be used like so:
--
--   import Door
--
--   door <- initFSM Opened
--   advance door Close
--   advance door $ Lock 1337
--   getFSM door >>= print

module Door where

import Data.Aeson    (FromJSON (..), ToJSON (..))
import Data.Data     (Data)
import FSM
import GHC.Generics
import Katip
import Katip.Monadic

-- | Code used to lock/unlock a door.
type Code = Int

-- | Number of unlock attempts.
type Attempts = Int

-- | The states that our door can be in.
data DoorState
  = Opened
  | Closed
  | Locked Code Attempts
  deriving (Eq, Data, Generic, Show)

instance ToJSON DoorState
instance FromJSON DoorState

-- | The events that the door can receive.
data DoorEvent
  = OpenDoor
  | CloseDoor
  | LockDoor Code
  | UnlockDoor Code
  deriving (Data, Generic, Show)

instance ToJSON DoorEvent
instance FromJSON DoorEvent

-- | The actions that event handlers can trigger.
data DoorAction
  = InformIRCAbout String
  | CallThePolice
  deriving (Eq, Data, Generic, Show)

instance ToJSON DoorAction
instance FromJSON DoorAction

-- This is the main implementation of FSM logic.
instance FSM DoorState where
  -- The name of the FSM is used in some places where a nice,
  -- human-readable name is useful (e.g. in logs).
  fsmName _ = "door"

  -- These two lines define which event & action type is used for the
  -- DoorState FSM.
  type FSMEvent DoorState = DoorEvent
  type FSMAction DoorState = DoorAction

  -- * Event handlers using simple pattern-matching:

  -- Most trivial: opening and closing
  handle :: DoorState -> DoorEvent -> (DoorState, [DoorAction])
  handle Opened CloseDoor = (Closed, [])
  handle Closed OpenDoor = (Opened, [])

  -- Closed door can be locked:
  handle Closed (LockDoor code) = (Locked code 0, [])

  -- Locked door can be unlocked with the correct code, or can
  -- automatically call the police if the wrong code is entered ten
  -- times.
  --
  -- (Maybe this side-effect is a bit drastic?)
  handle (Locked currentCode attempts) (UnlockDoor code) =
    if | currentCode == code -> (Closed, [])
       | attempts == 9       -> (Locked currentCode 10, [ CallThePolice ])
       | otherwise           -> (Locked currentCode $ attempts + 1, [])

  -- other event/state combinations are invalid and should be logged,
  -- but I'm gonna be lazy here and just ignore them.
  handle state _ = (state, [])

  -- * State enter calls
  --
  -- When the door transitions to a new state, these calls are made
  -- and can cause actions.

  -- Inform the fictionalIRC channel about the new door state.
  enter state =
    let message = case state of
                    Opened       -> "Door has been opened!"
                    Closed       -> "Door has been closed!"
                    (Locked _ _) -> "Door has been locked!"
    in [ InformIRCAbout message ]

  -- * Action implementation

  -- These are allowed to do IO, but lets keep it simple.
  act CallThePolice = do
    logLocM NoticeS "Calling the police!"
    return $ Right []

  -- Imagine a beautiful IRC client implementation below.
  act (InformIRCAbout _msg) = undefined