{-| Module : Mellon.Controller.Async Description : An asynchronous @mellon-core@ controller Copyright : (c) 2017, Quixoftic, LLC License : BSD3 Maintainer : Drew Hess Stability : experimental Portability : non-portable This module implements a thread-safe, asynchronous controller. Scheduled locks are run as background threads, which sleep until their events fire. == Exception safety All the controller actions provided in this module are exception-safe. If an exception occurs in a controller action (e.g., because the device throws an exception), the controller will be restored to its state as it was immediately prior to the execution of the action, and the exception will be re-thrown. After handling the exception, you can continue to execute actions on the controller, if you wish. However, the controller and the device may be out of sync at that point, or the device may continue to throw exceptions until it can be reset. The safest action to take after an exception occurs in a controller is to reset the device to a known working state; and then to create, from scratch, a new controller for the device. -} module Mellon.Controller.Async ( -- * An asynchronous controller implementation Controller , controller , minUnlockTime , lockController , unlockController , queryController -- * Re-exported types , Device(..) , State(..) ) where import Control.Concurrent (MVar, modifyMVar, newMVar, readMVar, threadDelay) import Control.Concurrent.Async (async, link) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, picosecondsToDiffTime) import Mellon.Device (Device(..)) import Mellon.StateMachine (Input(..), Output(..), State(..), transition) -- | A concurrent, thread-safe controller type parameterized on its -- device type. -- -- Note that the type's constructor is not exported. You must use the -- 'controller' constructor to create a new value of this type; it -- ensures that the controller is initialized properly. data Controller d = Controller {_state :: !(MVar State) ,_minUnlockTime :: !NominalDiffTime ,_device :: !(Device d)} -- | Create a new 'Controller' value to control the given 'Device'. -- -- Controllers created by this constructor are thread-safe and may be -- passed around and controlled simultaneously on multiple threads. -- All actions exported by this module which act on a 'Controller' -- value are thread-safe. -- -- The controller locks and unlocks the given device in response to -- user commands and expiring unlocks. The controller assumes that -- this device has already been initialized and is ready for -- operation. It also assumes that it exclusively owns the device; do -- not pass the device to any other controllers or otherwise attempt -- to control the device while the returned 'Controller' value is -- live. -- -- The controller treats the device as a critical section; only one -- thread at a time will issue operations to the device. -- -- In order to synchronize the current device state with the state -- machine, the constructor will lock the device and set the state -- machine's initial state to 'StateLocked' before returning the new -- 'Controller' value. -- -- The optional 'NominalDiffTime' argument can be used to prevent the -- device from too rapidly switching from the locked->unlocked->locked -- states (/glitching/). Effectively, it specifies the minimum amount -- of time that the controller will unlock the device. This is useful -- for handling delayed unlock commands (for example, if the user is -- communicating with the controller via a network connection but the -- unlock command is delayed in transit because connection is down or -- lagged), extremely short unlock durations that might damage the -- physical access device, or hacking attempts. When the controller -- receives an unlock command, it compares the current time to the -- unlock command's expiration date. If the difference between the two -- times is less than the minimum unlock duration, or if the -- expiration date is in the past, then the controller will -- effectively ignore the unlock request. If the value of this -- argument is 'Nothing' or is negative, the controller treats it as a -- 0 value. controller :: (MonadIO m) => Maybe NominalDiffTime -> Device d -> m (Controller d) controller minUnlock device = liftIO $ do lockDevice device mvar <- newMVar StateLocked return $ Controller mvar (maybe 0 (max 0) minUnlock) device -- | Get the controller's minimum unlock time. minUnlockTime :: Controller d -> NominalDiffTime minUnlockTime = _minUnlockTime -- | Immediately lock the device controlled by the controller. -- -- Returns the new state of the controller. lockController :: (MonadIO m) => Controller d -> m State lockController = runMachine InputLockNow -- | Immediately unlock the device controlled by the controller, and -- keep it unlocked until the specified 'UTCTime'. -- -- If the specified time is in the past, then the device will unlock -- briefly, and then lock again after a brief amount of time. -- (__NOTE__: this behavior is considered to be a bug and will be -- fixed in a subsequent release.) -- -- Returns the new state of the controller. unlockController :: (MonadIO m) => UTCTime -> Controller d -> m State unlockController date = runMachine (InputUnlock date) -- | Query the controller's current state. queryController :: (MonadIO m) => Controller d -> m State queryController c = liftIO $ readMVar (_state c) runMachine :: (MonadIO m) => Input -> Controller d -> m State runMachine i c = let state = _state c in liftIO $ modifyMVar state $ \currentState -> do nextState <- go $ transition currentState i return (nextState, nextState) where go :: (MonadIO m) => (Maybe Output, State) -> m State go (Nothing, s) = return s go (Just OutputLock, s) = do liftIO $ lockDevice (_device c) return s go (Just (OutputUnlock date), s) = liftIO $ -- Don't let the lock glitch. If the expiration date is too near -- (or in the past), we ignore it (in which case we must keep -- the state machine in sync by telling it that the unlock has -- already expired). do now <- getCurrentTime if _minUnlockTime c `addUTCTime` now > date then return $ snd $ transition s (InputUnlockExpired date) else do unlockDevice (_device c) scheduleLock date return s go (Just (OutputRescheduleLock date), s) = liftIO $ -- The device is already unlocked, so we don't need to worry -- about a glitch here. do scheduleLock date return s -- For this particular implementation, it's safe simply to ignore -- this command. When the "unscheduled" lock fires, the state -- machine will simply ignore it. go (Just OutputCancelLock, s) = return s scheduleLock :: UTCTime -> IO () scheduleLock date = do a <- async $ do threadSleepUntil date void $ runMachine (InputUnlockExpired date) c -- Ensure exceptions which occur in the child thread are -- reported in the parent. link a -- 'threadDelay' takes an 'Int' argument which is measured in -- microseconds, so on 32-bit platforms, 'threadDelay' might not be -- able to delay long enough to accommodate even a day's sleep. -- Therefore, we need this mess. -- -- Does not account for leap seconds and is only precise to about 1 -- second, but I think that's probably OK. threadSleepUntil :: UTCTime -> IO () threadSleepUntil t = do now <- getCurrentTime let timeRemaining = diffUTCTime t now sleep timeRemaining where sleep :: NominalDiffTime -> IO () sleep r | r <= 0 = return () | r > maxThreadDelayInDiffTime = threadDelay maxThreadDelay >> threadSleepUntil t | otherwise = threadDelay $ nominalDiffTimeToMicroseconds r maxThreadDelay :: Int maxThreadDelay = maxBound maxThreadDelayInDiffTime :: NominalDiffTime maxThreadDelayInDiffTime = diffTimeToNominalDiffTime $ picosecondsToDiffTime $ toInteger maxThreadDelay * 1000000 where diffTimeToNominalDiffTime = realToFrac nominalDiffTimeToMicroseconds :: NominalDiffTime -> Int nominalDiffTimeToMicroseconds d = truncate $ d * 1000000