mellon-core (empty) → 0.7.0.0
raw patch · 14 files changed
+1073/−0 lines, 14 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, doctest, hlint, hspec, mtl, quickcheck-instances, time, transformers
Files
- LICENSE +30/−0
- README.md +28/−0
- Setup.hs +2/−0
- changelog.md +3/−0
- mellon-core.cabal +207/−0
- src/Mellon/Controller.hs +36/−0
- src/Mellon/Controller/Async.hs +210/−0
- src/Mellon/Device.hs +128/−0
- src/Mellon/StateMachine.hs +190/−0
- test/Main.hs +7/−0
- test/Mellon/Controller/AsyncSpec.hs +213/−0
- test/Spec.hs +1/−0
- test/doctest.hs +6/−0
- test/hlint.hs +12/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,28 @@+# mellon-core++<em>"Speak, friend, and enter."</em>++`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 <em>expiration+date</em>). 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`).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,3 @@+## 0.7.0.0 (2016-06-02)++Initial release.
+ mellon-core.cabal view
@@ -0,0 +1,207 @@+Name: mellon-core+Version: 0.7.0.0+Cabal-Version: >= 1.10+Build-Type: Simple+Author: Drew Hess <src@drewhess.com>+Maintainer: Drew Hess <src@drewhess.com>+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+ <https://en.wikipedia.org/wiki/Network_Time_Protocol NTP>, 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
+ src/Mellon/Controller.hs view
@@ -0,0 +1,36 @@+{-|+Module : Mellon.Controller+Description : The default @mellon-core@ controller+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+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
+ src/Mellon/Controller/Async.hs view
@@ -0,0 +1,210 @@+{-|+Module : Mellon.Controller.Async+Description : An asynchronous @mellon-core@ controller+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+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
+ src/Mellon/Device.hs view
@@ -0,0 +1,128 @@+{-|+Module : Mellon.Device+Description : An interface for physical access devices+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+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
+ src/Mellon/StateMachine.hs view
@@ -0,0 +1,190 @@+{-|+Module : Mellon.StateMachine+Description : The @mellon-core@ state machine+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+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)
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.Hspec+import Spec++main :: IO ()+main = hspec spec
+ test/Mellon/Controller/AsyncSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ test/doctest.hs view
@@ -0,0 +1,6 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest ["src"]
+ test/hlint.hs view
@@ -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