diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for locked-poll + +## 0.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Scott Murphy + +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 Scott Murphy 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,70 @@ +[![Circle CI](https://circleci.com/gh/plow-technologies/locked-poll.svg?style=svg)](https://circleci.com/gh/plow-technologies/locked-poll) + +# locked-poll + + +```locked-poll``` is a package to enable simple concurrent polling with a locking scheme. + +The library is quite small, needing +* ```containers``` +* ```clock``` + +To run. + +There are lots of tests in the test-suite to ensure that it behaves itself with polls. + + + +## Usage-Example + +There is only one function : + +``` haskell + +makeLockingFunction :: forall k lockableState . (Key k,Show lockableState) => + Int64 -> -- timeout + (KeyFcn lockableState k) -> -- extract a key + IO ((lockableState -> IO ()) -> -- function to run against state + lockableState -> -- incoming state + IO ()) + +``` + +This function is used to generate a function which has an embedded action that is dependent on some given state. +The idea is to generate that locking function at the top level and then pass it to whatever needs incremental access to a resource. + +It uses an IORef under the hood to store what states are currently in use. + +Use the timeout function to say when to release the lock. + +No cleanup is performed by the lockingFunction, so wrap your things in finally or bracket as needed. + + +``` haskell +-- | 'Key' Constraint for locking down a traverse or fold +type Key k = (Ord k,Eq k,Show k) + +-- |Extract a key from a given state +type KeyFcn st k = Key k => st -> k + +``` + +KeyFcn tells the lockingFunction how to extract the LockingKey. + +Uniqueness is not necessary but if you do not have it, only one of a given group of like Keyed objects will be allowed to run at a time. + + + +## How to run tests + +``` +cabal configure --enable-tests && cabal build && cabal test +``` + +The tests are quite slow (4 or 5 min) because they are trying to test long poll concurrency + +Right now you have to hand delete the resulting output. + +## Contributing + +TODO: Write contribution instructions here 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/locked-poll.cabal b/locked-poll.cabal new file mode 100644 --- /dev/null +++ b/locked-poll.cabal @@ -0,0 +1,58 @@ +Name: locked-poll +Version: 0.1.0 +Author: Scott Murphy +Maintainer: Scott Murphy +License: BSD3 +License-File: LICENSE +Synopsis: Very simple poll lock +Description: Fire and forget actions, lock with timeout resources +Cabal-Version: >= 1.10 +Build-Type: Simple +Extra-Source-Files: README.md, ChangeLog.md + +Library + Default-Language: Haskell2010 + HS-Source-Dirs: src + GHC-Options: -Wall + Exposed-Modules: LockedPoll + LockedPoll.Internal +-- Other-Modules: + Build-Depends: base >= 4 && < 5 + , containers + , clock + +executable locked-poll + Default-Language: Haskell2010 + HS-Source-Dirs: src + GHC-Options: -Wall + main-is: Main.hs + Build-Depends: base >= 4 && < 5 + , containers + , locked-poll + , clock + +Test-Suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: src + , test + Ghc-Options: -Wall + Main-Is: Spec.hs + Build-Depends: QuickCheck + , base + , containers + , regex-genex + , tasty + , tasty-golden + , tasty-hunit + , tasty-quickcheck + , clock + , lens + , random + , bytestring + , time + , attoparsec + +Source-Repository head + Type: git + Location: https://github.com/plow-technologies/locked-poll.git diff --git a/src/LockedPoll.hs b/src/LockedPoll.hs new file mode 100644 --- /dev/null +++ b/src/LockedPoll.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | +Module : LockedPoll +Description : Lock an item while polling it for a given period of time +Copyright : Plow Technologies LLC +License : MIT License + +Maintainer : Scott Murphy +>>> let keyFcn = fst :: (Int,a) -> Int +>>> lockingFunction <- makeLockingFunction 30 keyFcn + +| -} + + + +-- module LockedPoll ( makeLockingFunction +-- , KeyFcn ) where + +module LockedPoll (Key,KeyFcn,makeLockingFunction) where + +import Control.Exception (bracket) +import Data.IORef +import Data.Int (Int64) +import Data.Monoid ((<>)) +import System.IO +import qualified Data.Map as Map +import Data.Map.Strict (Map) +import System.Clock (Clock (..), TimeSpec (..), getTime) + + + +-- | 'Key' Constraint for locking down a traverse or fold +type Key k = (Ord k,Eq k,Show k) + +-- |Extract a key from a given state +type KeyFcn st k = Key k => st -> k + +-- | Patterns to make what is going on in the locking more clear +-- They have the unfortunate side effect of requiring a match against bottom + +type LockStatus = Maybe Bool +pattern KeyAcquired :: LockStatus +pattern KeyAcquired <- Just True +pattern IOLocked :: LockStatus +pattern IOLocked <- Just False +pattern LockTimedOut :: LockStatus +pattern LockTimedOut <- Nothing + +-- | This locking Function is very simple +-- It reads a key and assigns a time to it +-- if that time has expored... then it unlocks +-- if the nested action completes then it unlocks +-- all concurrency and exception handling should be done inside the IO () +-- Notice I say it unlocks, not that it kills a nascent thread. No such thing will happen automatically + +makeLockingFunction :: forall k lockableState . (Key k,Show lockableState) => Int64 -> -- timeout + (KeyFcn lockableState k) -> -- extract a key + IO ((lockableState -> IO ()) -> -- function to run against state + lockableState -> -- incoming state + IO ()) +makeLockingFunction timeout getKey = do + ioRefMapOfKeyValues <- newIORef Map.empty :: IO (IORef (Map k TimeSpec) ) + return $ exportFunction ioRefMapOfKeyValues + where + unlock :: IORef (Map k TimeSpec) -> k -> IO () + unlock ioRef k = atomicModifyIORef' ioRef (\map' -> (Map.delete k map', ())) + + obtainLock :: (Key k) => TimeSpec -> k -> Map k TimeSpec -> (Map k TimeSpec ,Maybe Bool) + obtainLock lockTime@(TimeSpec s1 _) k map' = case Map.lookup k map' of + Just (TimeSpec s _) + | abs s1 - s >= timeout -> (Map.insert k lockTime map', Nothing) --old value timed out, aquire new lock assume old thread be dead + | otherwise -> (map',Just False) --Lock not obtained + Nothing -> (Map.insert k lockTime map',Just True) --acquire brand spanking new lock + + exportFunction :: IORef (Map k TimeSpec) -> + (lockableState -> IO ()) -> lockableState -> IO () + exportFunction ioRef f st = bracket ioLock ioUnlock runFunction + where + ioLock :: IO (Maybe Bool) + ioLock = do + lockTime <- getTime Monotonic + atomicModifyIORef' ioRef . obtainLock lockTime . getKey $ st + + ioUnlock :: LockStatus -> IO () + ioUnlock lockStatus = case lockStatus of + IOLocked -> return () + KeyAcquired -> unlock ioRef (getKey st) + LockTimedOut -> unlock ioRef (getKey st) + _ -> error "no match for bottom in ioUnlock" + + runFunction :: LockStatus -> IO () + runFunction iCanRun = case iCanRun of + KeyAcquired -> f st + IOLocked -> hPrint stderr ("skipping locked thread" <> (show . getKey $ st )) + LockTimedOut -> hPrint stderr ("thread timeout " <> show st ) >> f st + _ -> error "no match for bottom of Maybe Bool in makeLockingFunction" diff --git a/src/LockedPoll/Internal.hs b/src/LockedPoll/Internal.hs new file mode 100644 --- /dev/null +++ b/src/LockedPoll/Internal.hs @@ -0,0 +1,3 @@ +module LockedPoll.Internal + ( + ) where diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello!" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,5 @@ +import LockedPollSpec +import Test.Tasty + +main :: IO () +main = defaultMain tests