locked-poll (empty) → 0.1.0

raw patch · 9 files changed

+278/−0 lines, 9 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, bytestring, clock, containers, lens, locked-poll, random, regex-genex, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, time

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• README.md +70/−0
• Setup.hs +2/−0
• locked-poll.cabal +58/−0
• src/LockedPoll.hs +102/−0
• src/LockedPoll/Internal.hs +3/−0
• src/Main.hs +3/−0
• test/Spec.hs +5/−0

@@ -0,0 +1,5 @@+# Revision history for locked-poll++## 0.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -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.

@@ -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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,58 @@+Name:                   locked-poll+Version:                0.1.0+Author:                 Scott Murphy <scottmurphy09@gmail.com>+Maintainer:             Scott Murphy <scottmurphy09@gmail.com>+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

@@ -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"

@@ -0,0 +1,3 @@+module LockedPoll.Internal+    (+    ) where

@@ -0,0 +1,3 @@+module Main where++main = putStrLn "Hello!"

@@ -0,0 +1,5 @@+import LockedPollSpec +import Test.Tasty++main :: IO ()+main = defaultMain tests