diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Drew Hess + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Drew Hess nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,28 @@ +# mellon-core + +"Speak, friend, and enter." + +`mellon-core` is a Haskell package for controlling physical access +devices designed for human factors, e.g., electric strikes. The access +control protocol is quite simple: a device is either locked, or it is +unlocked until a particular date and time (an expiration +date). Once the expiration date passes, the device is +automatically locked again. In the meantime, the device can be locked +immediately, overriding the unlocked state; or the unlock period can +be extended. + +User programs incorporate `mellon-core` functionality via a +`Controller`, which is responsible for handling user lock and unlock +commands, and for scheduling and canceling unlock expirations. + +User programs must also adapt their physical access devices to the +interface expected by the controller. For this purpose, `mellon-core` +defines a generic `Device` parametric data type with 2 simple `IO` +actions for locking and unlocking the device. (`mellon-core` does not +provide any useful device implementations; see the companion +`mellon-gpio` package for a GPIO-driven implementation.) + +Note that `mellon-core` does not provide authentication mechanisms or +network services for interacting with controllers; that is the domain +of higher-level packages which use the base `mellon-core` package +(e.g., `mellon-web`). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +## 0.7.0.0 (2016-06-02) + +Initial release. diff --git a/mellon-core.cabal b/mellon-core.cabal new file mode 100644 --- /dev/null +++ b/mellon-core.cabal @@ -0,0 +1,207 @@ +Name: mellon-core +Version: 0.7.0.0 +Cabal-Version: >= 1.10 +Build-Type: Simple +Author: Drew Hess +Maintainer: Drew Hess +Homepage: https://github.com/dhess/mellon/ +Bug-Reports: https://github.com/dhess/mellon/issues/ +Stability: experimental +License: BSD3 +License-File: LICENSE +Copyright: Copyright (c) 2016, Drew Hess +Tested-With: GHC == 7.10.3, GHC == 8.0.1 +Category: System +Synopsis: Control physical access devices +Description: + "Speak, friend, and enter." + . + @mellon-core@ is a Haskell package for controlling physical access + devices designed for human factors, e.g., electric strikes. The + access control protocol is quite simple: a device is either locked, + or it is unlocked until a particular date and time (an + /expiration date/). Once the expiration date passes, the device is + automatically locked again. In the meantime, the device can be + locked immediately, overriding the unlocked state; or the unlock + period can be extended. + . + User programs incorporate @mellon-core@ functionality via a + /controller/, which is responsible for handling user lock and unlock + commands, and for scheduling and canceling unlock expirations. + . + User programs must also adapt their physical access devices to the + interface expected by the controller. For this purpose, + @mellon-core@ defines a /device/ type with 2 simple 'IO' actions for + locking and unlocking the device. (@mellon-core@ does not provide + any useful device implementations; see the companion @mellon-gpio@ + package for a GPIO-driven implementation.) + . + Note that @mellon-core@ does not provide authentication mechanisms + or network services for interacting with controllers; that is the + domain of higher-level packages which use the base @mellon-core@ + package (e.g., @mellon-web@). + . + == On the use of UTC dates for timers + . + @mellon-core@ uses UTC dates for unlock expiration, rather than a + time delta or a monotonic clock. You might disagree with this + decision based on the common wisdom that it's a bad idea to use + "wall clock time" (of which UTC is one flavor) for timers. In + general, the common wisdom is correct. Wall clocks have lots of + problems: they may not be accurate, they may disagree from one + system to the next, they may "jump around" if the system is running + a time daemon such as NTP, and they occasionally do something + unexpected like adding a leap second. + . + If your timers must be high-precision (i.e., this timer must run for + exactly /n/ microseconds, for some definition of "exactly"), then + there's no argument: using a wall clock is a bad idea. However, as + @mellon-core@ is designed for use with physical access devices, + which themselves are typically designed for human factors, accuracy + to within a second or two is acceptable in most cases. (If you have + higher-precision needs, especially for extreme safety- or + security-related scenarios, you should probably be using a real-time + system anyway, not a Haskell program.) + . + Once the need for high precision is eliminated, and assuming that + the system(s) controlling your physical access devices use a + synchronized time source such as that provided by + , the + advantages of using UTC over most of the alternatives become + apparent: + . + * Absolute time deltas without a common reference do not work well + in networked environments, where network problems may appreciably + delay the delivery of commands from client to server. If a user + wants to unlock a device for 7 seconds, does that mean 7 seconds + from the clock time @T@ when the user presses "send," or does it + mean 7 seconds from opening to close, regardless of when the + server receives the command? Without a common reference, there is + no way for the user to communicate her intent. + . + * Monotonic clocks never go backwards, which is a nice invariant and + eliminates a problem that occurs in some NTP implementations. + However, monotonic clocks are a) non-portable, and not even + supported on all systems; b) usually system-dependent, which + renders them useless when attempting to communicate time across + two systems; c) sometimes even process-dependent, in which case + they're not even useful for communicating time between two + processes on the same system; and d) often idle while the system + is suspending or sleeping, in which case the clock does not move + forward while the system is suspended, rendering the clock useless + for absolute timers if there's any possibility that the system + will be suspended or otherwise go into a low-power mode. + . + Using the TAI coordinate system rather than UTC has the advantage of + guaranteeing that every (TAI) day is exactly 86400 (TAI) seconds, + unlike UTC and all of the time systems based on it, where very + rarely a day may have 86401 seconds, i.e., one standard day plus 1 + leap second. If TAI were well-supported and generally available, + @mellon-core@ would probably use it, but circa 2016 it is not. + Anyway, at worst, a @mellon-core@ unlock command which spans a time + period in which a leap second is added will expire approximately 1 + second too soon / too early, depending on whether the user accounted + for the leap second when she issued the command. As this error is + more or less within the expected accuracy of a @mellon-core@ system + under normal operation (due to the vagaries of thread scheduling, + and not even accounting for clock drift and other real-world + factors), it doesn't really seem worth the effort just to avoid the + minor inconvenience of leap seconds. + . + In short, synchronizing time (and timers) across multiple systems is + a very difficult problem, and one which the universally-supported + Network Time Protocol attempts to address, mostly successfully. + Given its intended application to controlling physical access for + human beings, most likely in a networked environment, @mellon-core@ + makes the choice of relying on a working, accurate NTP (or other + wall-clock synchronization) deployment for coordinating and + synchronizing time across devices. If you cannot guarantee accurate + wall clock time in your system, @mellon-core@ will not work + properly, and you should look for an alternative solution. + +Extra-Doc-Files: README.md +Extra-Source-Files: changelog.md + +-- Build doctests +Flag test-doctests + Default: True + Manual: True + +-- Build hlint test +Flag test-hlint + Default: True + Manual: True + +Library + Default-Language: Haskell2010 + HS-Source-Dirs: src + GHC-Options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + If impl(ghc > 8) + GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints + Exposed-Modules: Mellon.Controller + , Mellon.Controller.Async + , Mellon.Device + , Mellon.StateMachine + Other-Extensions: DeriveDataTypeable + , DeriveGeneric + , Safe + Build-Depends: base >= 4.8 && < 5 + , async == 2.1.* + , mtl == 2.2.* + , time >= 1.5 && < 2 + , transformers >= 0.4.2 && < 0.6 + +Test-Suite hlint + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: test + Ghc-Options: -w -threaded -rtsopts -with-rtsopts=-N + Main-Is: hlint.hs + If !flag(test-hlint) + Buildable: False + Else + Build-Depends: base + , hlint == 1.9.* + +Test-Suite doctest + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: test + Ghc-Options: -Wall -threaded + Main-Is: doctest.hs + If !flag(test-doctests) + Buildable: False + Else + Build-Depends: base + , QuickCheck == 2.8.* + , quickcheck-instances == 0.3.* + , doctest == 0.11.* + +Test-Suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: src + , test + Ghc-Options: -w -threaded -rtsopts -with-rtsopts=-N + Main-Is: Main.hs + Build-Depends: base + , async + , hspec == 2.2.* + , mtl + , time + , transformers + Other-Modules: Mellon.Controller + , Mellon.Controller.Async + , Mellon.Device + , Mellon.StateMachine + , Spec + , Mellon.Controller.AsyncSpec + +Source-Repository head + Type: git + Location: git://github.com/dhess/mellon.git + +Source-Repository this + Type: git + Location: git://github.com/dhess/mellon.git + Tag: v0.7.0.0 diff --git a/src/Mellon/Controller.hs b/src/Mellon/Controller.hs new file mode 100644 --- /dev/null +++ b/src/Mellon/Controller.hs @@ -0,0 +1,36 @@ +{-| +Module : Mellon.Controller +Description : The default @mellon-core@ controller +Copyright : (c) 2016, Drew Hess +License : BSD3 +Maintainer : Drew Hess +Stability : experimental +Portability : non-portable + +In @mellon-core@, controllers are the intermediary between the +@mellon-core@ state machine, the physical access device, and the user +who wants to control the device. The user interacts directly only with +the controller, not with the physical access device or the state +machine. + +A controller provides two commands to the user: /lock/ and /unlock/. +User lock commands are effective immediately, and the device remains +locked until the user runs a subsequent unlock command. User unlock +commands are effective immediately, but also take a 'UTCTime' argument +that specifies the date at which the controller will automatically +lock the device again. + +A controller's behavior is determined by the @mellon-core@ state +machine. See the "Mellon.StateMachine" module for a detailed +description of the state machine's operation. + +This module re-exports the default (and, currently, only) controller +implementation. + +-} + +module Mellon.Controller + ( module Mellon.Controller.Async + ) where + +import Mellon.Controller.Async diff --git a/src/Mellon/Controller/Async.hs b/src/Mellon/Controller/Async.hs new file mode 100644 --- /dev/null +++ b/src/Mellon/Controller/Async.hs @@ -0,0 +1,210 @@ +{-| +Module : Mellon.Controller.Async +Description : An asynchronous @mellon-core@ controller +Copyright : (c) 2016, Drew Hess +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 diff --git a/src/Mellon/Device.hs b/src/Mellon/Device.hs new file mode 100644 --- /dev/null +++ b/src/Mellon/Device.hs @@ -0,0 +1,128 @@ +{-| +Module : Mellon.Device +Description : An interface for physical access devices +Copyright : (c) 2016, Drew Hess +License : BSD3 +Maintainer : Drew Hess +Stability : experimental +Portability : non-portable + +This module provides both a parameterized type for adapting a +device-specific interface to the generic interface expected by a +'Mellon.Controller.Controller', and a "mock lock" device +implementation, which is useful for testing. + +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} + +module Mellon.Device + ( -- * The mellon-core device type + Device(..) + + -- * A mock lock implementation + -- + -- | The mock lock type provided here logs lock / unlock + -- events along with a timestamp. It is useful for testing + -- but doesn't have any facility to control an actual + -- physical access device. + , MockLock + , mockLock + , MockLockEvent(..) + , lockMockLock + , unlockMockLock + , events + , mockLockDevice + ) where + +import Control.Concurrent + (MVar, newMVar, putMVar, readMVar, takeMVar) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Data +import Data.Time (UTCTime, getCurrentTime) +import GHC.Generics + +-- | A parametric device type which provides two "methods," one to +-- lock the device, and the other to unlock it. +-- +-- The parameter @d@ is the concrete device type and is used during +-- construction to create the two methods by binding them to actions +-- on the specific device. +-- +-- For example, the implementation of the 'mockLockDevice' function, +-- which wraps a 'MockLock' in a 'Device' @d@, looks like this: +-- +-- > mockLockDevice :: MockLock -> Device MockLock +-- > mockLockDevice l = +-- > Device (liftIO $ lockMockLock l) +-- > (liftIO $ unlockMockLock l) +-- +-- A program can construct such a device and use it like so: +-- +-- >>> ml <- mockLock +-- >>> let mld = mockLockDevice ml +-- >>> events ml +-- [] +-- >>> lockDevice mld +-- >>> events ml +-- [LockEvent ... UTC] +-- >>> unlockDevice mld +-- >>> events ml +-- [LockEvent ... UTC,UnlockEvent ... UTC] +data Device d = + Device {lockDevice :: IO () + ,unlockDevice :: IO ()} + +-- | Events logged by 'MockLock' are of this type. +data MockLockEvent + = LockEvent !UTCTime + | UnlockEvent !UTCTime + deriving (Eq,Show,Read,Generic,Data,Typeable) + +-- | A mock lock device that logs lock / unlock events. +-- +-- No constructor is exported. Use 'mockLock' to create a new +-- instance and 'events' to extract the log. +data MockLock = + MockLock !(MVar [MockLockEvent]) + deriving (Eq) + +-- | Construct a new mock lock with an empty event log. +mockLock :: (MonadIO m) => m MockLock +mockLock = liftIO $ MockLock <$> newMVar [] + +-- | Extract the current log of events from the mock lock. +events :: (MonadIO m) => MockLock -> m [MockLockEvent] +events (MockLock m) = liftIO $ readMVar m + +data MLE = MLL | MLU deriving (Eq) + +-- | Lock the mock lock. +lockMockLock :: (MonadIO m) => MockLock -> m () +lockMockLock = updateMockLock MLL + +-- | Unlock the mock lock. +unlockMockLock :: (MonadIO m) => MockLock -> m () +unlockMockLock = updateMockLock MLU + +-- | Wrap a 'MockLock' value with a 'Device' value, for use with a +-- @mellon-core@ controller. +mockLockDevice :: MockLock -> Device MockLock +mockLockDevice l = + Device (liftIO $ lockMockLock l) + (liftIO $ unlockMockLock l) + +-- | Helpers +updateMockLock :: (MonadIO m) => MLE -> MockLock -> m () +updateMockLock mle (MockLock m) = liftIO $ + do now <- getCurrentTime + ev <- takeMVar m + putMVar m (mappend ev [event now]) + where + event :: UTCTime -> MockLockEvent + event = + case mle of + MLL -> LockEvent + MLU -> UnlockEvent diff --git a/src/Mellon/StateMachine.hs b/src/Mellon/StateMachine.hs new file mode 100644 --- /dev/null +++ b/src/Mellon/StateMachine.hs @@ -0,0 +1,190 @@ +{-| +Module : Mellon.StateMachine +Description : The @mellon-core@ state machine +Copyright : (c) 2016, Drew Hess +License : BSD3 +Maintainer : Drew Hess +Stability : experimental +Portability : non-portable + +The @mellon-core@ state machine is the heart of the locking protocol. + +A user of the @mellon-core@ package is not expected to interact +directly with the state machine, as the state machine is pure and is +not capable of setting timers or performing 'IO' actions on physical +access devices. In @mellon-core@, those operations are the +responsibility of controllers, and controllers are what users should +interact with; see the "Mellon.Controller" module. However, +understanding the state machine model is useful for understanding the +behavior of a @mellon-core@ application. + +The state machine's behavior is quite simple: + +* The locked state has indefinite duration. + +* The unlocked state has an /expiration date/ (a 'UTCTime'). The +controller will inform the state machine when this date has passed +(since the state machine cannot keep time), at which point the state +machine will advise the controller to lock the device again. + +* The user can (via the controller) send a lock command at any time, +which will immediately cancel any unlock currently in effect. + +* If the user (via the controller) sends an unlock command while a +previous unlock command is still in effect, then the unlock with the +later expiration date "wins"; i.e., if the new expiration date is +later than the current one, the unlock period is effectively extended, +otherwise the device remains unlocked until the previously-specified +date. + +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} + +module Mellon.StateMachine + ( -- * The state machine types + Input(..) + , Output(..) + , State(..) + + -- * The state machine implementation + , transition + ) where + +import Data.Data +import Data.Time (UTCTime) +import GHC.Generics + +{- $setup + +>>> import Test.QuickCheck +>>> import Test.QuickCheck.Instances + +-} + +-- | The state machine's states. +data State + = StateLocked + -- ^ The state machine is in the locked state + | StateUnlocked !UTCTime + -- ^ The state machine is unlocked until the specified date. + deriving (Eq,Show,Read,Generic,Data,Typeable) + +-- | The state machine's inputs, i.e., commands sent to the machine by +-- a controller, either in response to a user's command, or in +-- response to an expired timer. +data Input + = InputLockNow + -- ^ Lock immediately, canceling any unlock currently in effect + | InputUnlockExpired !UTCTime + -- ^ An unlock command has expired. The unlock's expiration date + -- is given by the specified 'UTCTime' timestamp. Note that in the + -- @mellon-core@ protocol, these commands are only ever sent by + -- the controller, which manages timed events, and never by the + -- user directly. + | InputUnlock !UTCTime + -- ^ Unlock until the specified time. If no existing unlock + -- command with a later expiration is currently in effect when + -- this command is executed, the controller managing the state + -- machine must schedule a lock to run at the specified time + -- (i.e., when the unlock expires). + deriving (Eq,Show,Read,Generic,Data,Typeable) + +-- | The state machine's outputs, i.e., commands to be performed by a +-- controller. +-- +-- It's reasonable to wonder why the 'OutputUnlock' and +-- 'OutputRescheduleLock' values take a 'UTCTime' parameter, when the +-- 'State' they're both always associated with ('StateUnlocked') also +-- takes a 'UTCTime' parameter. Indeed, their time values will always +-- be the same. However, this redundancy permits an interface to the +-- state machine where the state is implicit (e.g., in a state monad) +-- and the controller only "sees" the 'Output'. +data Output + = OutputLock + -- ^ Lock the device now + | OutputUnlock !UTCTime + -- ^ Unlock the device now and schedule a lock to run at the given + -- time + | OutputRescheduleLock !UTCTime + -- ^ The date for the currently scheduled lock has changed. + -- Reschedule it for the specified date. Note that the new date is + -- guaranteed to be later than the previously-scheduled time. + | OutputCancelLock + -- ^ Cancel the currently scheduled lock and lock the device now + deriving (Eq,Show,Read,Generic,Data,Typeable) + +-- | Run one iteration of the state machine. +-- +-- Note that some transitions require no action by the controller, +-- hence the first element of the returned pair (the 'Output' value) +-- is wrapped in 'Maybe'. +-- +-- == Properties +-- +-- prop> transition StateLocked InputLockNow == (Nothing,StateLocked) +-- prop> \date -> transition StateLocked (InputUnlockExpired date) == (Nothing,StateLocked) +-- prop> \date -> transition StateLocked (InputUnlock date) == (Just $ OutputUnlock date,StateUnlocked date) +-- prop> \date -> transition (StateUnlocked date) InputLockNow == (Just OutputCancelLock,StateLocked) +-- prop> \date -> transition (StateUnlocked date) (InputUnlockExpired date) == (Just OutputLock,StateLocked) +-- prop> \(date1, date2) -> date1 /= date2 ==> transition (StateUnlocked date1) (InputUnlockExpired date2) == (Nothing,StateUnlocked date1) +-- prop> \date -> transition (StateUnlocked date) (InputUnlock date) == (Nothing,StateUnlocked date) +-- prop> \(date1, date2) -> date2 > date1 ==> transition (StateUnlocked date1) (InputUnlock date2) == (Just $ OutputRescheduleLock date2,StateUnlocked date2) +-- prop> \(date1, date2) -> not (date2 > date1) ==> transition (StateUnlocked date1) (InputUnlock date2) == (Nothing,StateUnlocked date1) +transition :: State -> Input -> (Maybe Output, State) + +-- Locked state transitions. +transition StateLocked InputLockNow = (Nothing, StateLocked) +transition StateLocked (InputUnlockExpired _) = (Nothing, StateLocked) +transition StateLocked (InputUnlock untilDate) = + (Just $ OutputUnlock untilDate,StateUnlocked untilDate) + +-- Unlocked state transitions. +transition (StateUnlocked _) InputLockNow = + (Just OutputCancelLock, StateLocked) +transition (StateUnlocked scheduledDate) (InputUnlock untilDate) = + if untilDate > scheduledDate + then (Just $ OutputRescheduleLock untilDate, StateUnlocked untilDate) + else (Nothing, StateUnlocked scheduledDate) +transition (StateUnlocked scheduledDate) (InputUnlockExpired lockDate) = + -- In this case, the state machine is currently unlocked, and the + -- controller is informing the state machine that a + -- previously-scheduled lock event has fired; in other words, a + -- previously-accepted unlock command has expired, and now it's time + -- to lock the state machine again. + -- + -- However, because of various race conditions between incoming + -- asynchronous user commands and firing timer threads in the + -- controller implementation, the state machine only act on the + -- incoming lock command if its date matches the current state's + -- "until date." If they match, then the incoming lock command + -- "belongs" to the machine's current state, and the machine must + -- heed it. + -- + -- If the incoming lock command's date does /not/ match the current + -- state's date, then there are 2 possible sub-cases: + -- + -- 1. The lock command's date is /earlier/ than the current state's + -- expiration date. This can only happen if the user sent a + -- subsequent unlock command with a later expiration date, and the + -- controller informed the state machine of the new request; but + -- before the controller could cancel the earlier timer thread, that + -- thread's timer expired and its lock command reached the state + -- machine first. + -- + -- 2. The lock command's date is /later/ than the current + -- outstanding state's expiration date. This should probably never + -- happen, but there might be an odd corner case that I'm not + -- considering. + -- + -- In case 1, the right thing to do is to ignore the lock command. + -- The only question that remains is whether to treat case 2 as an + -- error. The conservative thing to do would be to add an error + -- state to the state machine, from which there is no recovery, but + -- in the interest of keeping the controller robust in the face of + -- errors, we simply ignore the lock command in this case, as well. + if lockDate == scheduledDate + then (Just OutputLock, StateLocked) + else (Nothing, StateUnlocked scheduledDate) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.Hspec +import Spec + +main :: IO () +main = hspec spec diff --git a/test/Mellon/Controller/AsyncSpec.hs b/test/Mellon/Controller/AsyncSpec.hs new file mode 100644 --- /dev/null +++ b/test/Mellon/Controller/AsyncSpec.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Mellon.Controller.AsyncSpec (spec) where + +import Control.Concurrent (MVar, newMVar, modifyMVar, threadDelay) +import Control.Concurrent.Async (race) +import Control.Exception (Exception(..), throwIO) +import Control.Monad (void, when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.RWS.Strict (RWST, execRWST, ask, tell) +import Data.Data +import Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime) +import qualified Data.Time as Time (getCurrentTime) +import Test.Hspec + +import Mellon.Controller.Async + (Controller, State(..), controller, minUnlockTime, lockController, + queryController, unlockController) +import Mellon.Device + (Device(..), MockLock, MockLockEvent(..), events, mockLock, + mockLockDevice) + +sleep :: (MonadIO m) => Int -> m () +sleep = liftIO . threadDelay . (* 1000000) + +getCurrentTime :: MonadIO m => m UTCTime +getCurrentTime = liftIO Time.getCurrentTime + +timePlusN :: UTCTime -> Integer -> UTCTime +timePlusN time n = (fromInteger n) `addUTCTime` time + +type TestController d a = RWST (Controller d) [MockLockEvent] () IO a + +testController :: Controller d -> IO [MockLockEvent] +testController cc = + do (_, expectedResults) <- execRWST theTest cc () + return expectedResults + + where theTest :: TestController d () + theTest = + do unlockWillExpire 5 + sleep 8 + unlockWontExpire 3 + sleep 1 + unlockExtend 10 + sleep 14 + unlockWillExpire 8 + sleep 2 + unlockWillBeIgnored 1 + sleep 13 + unlockWontExpire 8 + sleep 3 + lockIt + sleep 12 + + lockIt :: TestController d () + lockIt = + do now <- getCurrentTime + cc <- ask + void $ lockController cc + tell [LockEvent now] + + unlockIt :: Integer -> TestController d (UTCTime, UTCTime) + unlockIt duration = + do now <- getCurrentTime + cc <- ask + let expire = timePlusN now duration + void $ unlockController expire cc + return (now, expire) + + unlockWillExpire :: Integer -> TestController d () + unlockWillExpire duration = + do (now, expire) <- unlockIt duration + tell [UnlockEvent now] + tell [LockEvent expire] + + unlockWontExpire :: Integer -> TestController d () + unlockWontExpire duration = + do (now, _) <- unlockIt duration + tell [UnlockEvent now] + + unlockExtend :: Integer -> TestController d () + unlockExtend duration = + do (_, expire) <- unlockIt duration + tell [LockEvent expire] + + unlockWillBeIgnored :: Integer -> TestController d () + unlockWillBeIgnored duration = + do _ <- unlockIt duration + return () + +type CheckedResults = Either ((MockLockEvent, MockLockEvent), String) String + +checkResults :: [MockLockEvent] + -> [MockLockEvent] + -> NominalDiffTime + -> CheckedResults +checkResults expected actual epsilon = foldr compareResult (Right "No results to compare") $ zip expected actual + where compareResult :: (MockLockEvent, MockLockEvent) -> CheckedResults -> CheckedResults + compareResult _ (Left l) = Left l + compareResult ev@(UnlockEvent t1, UnlockEvent t2) _ = + if t2 `diffUTCTime` t1 < epsilon + then Right "OK" + else Left (ev, "Time difference exceeds epsilon") + compareResult ev@(LockEvent t1, LockEvent t2) _ = + if t2 `diffUTCTime` t1 < epsilon + then Right "OK" + else Left (ev, "Time difference exceeds epsilon") + compareResult ev _ = Left (ev, "Event types don't match") + +controllerTest :: IO CheckedResults +controllerTest = + do ml <- mockLock + cc <- controller (Just 1) $ mockLockDevice ml + ccEvents <- testController cc + -- Discard the first MockLock event, which happened when + -- controller initialized the lock. + _:lockEvents <- events ml + return $ checkResults ccEvents lockEvents (0.5 :: NominalDiffTime) + +data ExceptionLock = + ExceptionLock {_ops :: !(MVar Int) + ,_opsPerException :: !Int} + +data ExceptionLockException = + LockException + deriving (Show,Typeable) + +instance Exception ExceptionLockException + +exceptionLock :: Int -> IO ExceptionLock +exceptionLock n = + do mvar <- newMVar 0 + return $ ExceptionLock mvar n + +-- | This device throws an exception every N operations. +exceptionLockDevice :: ExceptionLock -> Device ExceptionLock +exceptionLockDevice l = + Device inc + inc + where + inc = + do ops <- modifyMVar (_ops l) $ \n -> return (succ n, succ n) + when (ops `mod` (_opsPerException l) == 0) $ + throwIO LockException + +isExceptionLockException :: ExceptionLockException -> Bool +isExceptionLockException = const True + +asyncExceptionTest :: IO () +asyncExceptionTest = + do el <- exceptionLock 3 + cc <- controller Nothing $ exceptionLockDevice el -- 1st lock op + now <- getCurrentTime + let expire = timePlusN now 3 + unlockController expire cc -- 2nd & 3rd lock op (unlock, timed lock) + (sleep 5) `shouldThrow` isExceptionLockException -- async exception + queryController cc `shouldReturn` StateUnlocked expire -- should have state prior to exception + +syncExceptionTest :: IO () +syncExceptionTest = + do el <- exceptionLock 2 + cc <- controller Nothing $ exceptionLockDevice el -- 1st lock op + now <- getCurrentTime + let expire = timePlusN now 3 + unlockController expire cc `shouldThrow` isExceptionLockException -- 2nd lock op + queryController cc `shouldReturn` StateLocked -- should have state prior to exception + +pastUnlockTimeTest :: IO () +pastUnlockTimeTest = + do ml <- mockLock + cc <- controller Nothing $ mockLockDevice ml + race + (sleep 3) -- 3 sec should be more than enough time + (do now <- getCurrentTime + let past = timePlusN now (-1) + unlockController past cc) + `shouldReturn` Right StateLocked + +ignoreUnlockTimeTest :: IO () +ignoreUnlockTimeTest = + do ml <- mockLock + cc <- controller (Just 3) $ mockLockDevice ml + race + (sleep 3) -- 3 sec should be more than enough time + (do now <- getCurrentTime + let expire = timePlusN now 2 + unlockController expire cc) + `shouldReturn` Right StateLocked + +minUnlockTimeTest :: IO () +minUnlockTimeTest = + do ml <- mockLock + cc1 <- controller Nothing $ mockLockDevice ml + minUnlockTime cc1 `shouldBe` 0 + cc2 <- controller (Just (-1)) $ mockLockDevice ml + minUnlockTime cc2 `shouldBe` 0 + +spec :: Spec +spec = do + describe "Controller tests" $ do + it "should produce the correct lock sequence plus or minus a few hundred milliseconds" $ do + controllerTest >>= (`shouldBe` Right "OK") + it "should recover from asynchronous exceptions" $ do + asyncExceptionTest + it "should recover from synchronous exceptions" $ do + syncExceptionTest + it "should not wait forever if the unlock time is in the past" $ do + pastUnlockTimeTest + it "should ignore an unlock if its duration is less than the minimum unlock time" $ do + ignoreUnlockTimeTest + it "should set the minimum unlock time to 0 if the value is Nothing or < 0" $ do + minUnlockTimeTest diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,6 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest ["src"] diff --git a/test/hlint.hs b/test/hlint.hs new file mode 100644 --- /dev/null +++ b/test/hlint.hs @@ -0,0 +1,12 @@ +module Main where + +import Control.Monad (unless) +import Language.Haskell.HLint +import System.Environment +import System.Exit + +main :: IO () +main = + do args <- getArgs + hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args + unless (null hints) exitFailure