summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-10-28 14:21:25 -0400
committerJoey Hess2015-10-28 14:21:25 -0400
commit99ae20dedef013397d9d9febf3beb71061491f86 (patch)
treeea878ef6765d5764331a4b53cc8c0318555bac98
parent725501f4c3538436c80ea682098c8fa069fc6a58 (diff)
propellor spin
-rw-r--r--debian/changelog1
-rw-r--r--debian/control2
-rw-r--r--propellor.cabal6
-rw-r--r--src/Propellor/Bootstrap.hs3
-rw-r--r--src/Utility/ConcurrentOutput.hs101
5 files changed, 60 insertions, 53 deletions
diff --git a/debian/changelog b/debian/changelog
index 6c154e1a..f3522b7c 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -19,6 +19,7 @@ propellor (2.13.0) UNRELEASED; urgency=medium
actions are combined (API change).
* Added Propellor.Property.Concurrent for concurrent properties.
* execProcess and everything built on it is now concurrent output safe.
+ * Propellor now depends on stm.
* Add File.isCopyOf. Thanks, Per Olofsson.
-- Joey Hess <id@joeyh.name> Sat, 24 Oct 2015 15:16:45 -0400
diff --git a/debian/control b/debian/control
index 7f42c916..2956fdaa 100644
--- a/debian/control
+++ b/debian/control
@@ -17,6 +17,7 @@ Build-Depends:
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev (>= 0.6),
+ libghc-stm-dev,
Maintainer: Gergely Nagy <algernon@madhouse-project.org>
Standards-Version: 3.9.6
Vcs-Git: git://git.joeyh.name/propellor
@@ -39,6 +40,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev (>= 0.6),
+ libghc-stm-dev,
git,
make,
Description: property-based host configuration management in haskell
diff --git a/propellor.cabal b/propellor.cabal
index 20e82407..da43775f 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -39,7 +39,7 @@ Executable propellor
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
- exceptions (>= 0.6)
+ exceptions (>= 0.6), stm
if (! os(windows))
Build-Depends: unix
@@ -51,7 +51,7 @@ Executable propellor-config
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
- exceptions
+ exceptions, stm
if (! os(windows))
Build-Depends: unix
@@ -62,7 +62,7 @@ Library
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
- exceptions
+ exceptions, stm
if (! os(windows))
Build-Depends: unix
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 6a5d5acb..2318b910 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -65,7 +65,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ "
aptinstall p = "apt-get --no-upgrade --no-install-recommends -y install " ++ p
- -- This is the same build deps listed in debian/control.
+ -- This is the same deps listed in debian/control.
debdeps =
[ "gnupg"
, "ghc"
@@ -81,6 +81,7 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ "
, "libghc-mtl-dev"
, "libghc-transformers-dev"
, "libghc-exceptions-dev"
+ , "libghc-stm-dev"
, "make"
]
diff --git a/src/Utility/ConcurrentOutput.hs b/src/Utility/ConcurrentOutput.hs
index b49447cc..301a89bc 100644
--- a/src/Utility/ConcurrentOutput.hs
+++ b/src/Utility/ConcurrentOutput.hs
@@ -14,6 +14,7 @@ import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Applicative
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent
+import Control.Concurrent.STM
import Control.Concurrent.Async
import Data.Maybe
import Data.List
@@ -25,8 +26,7 @@ import Utility.Monad
import Utility.Exception
data OutputHandle = OutputHandle
- { outputLock :: MVar () -- ^ empty when locked
- , outputLockedBy :: MVar Locker
+ { outputLock :: TMVar (Maybe Locker)
}
data Locker
@@ -42,8 +42,7 @@ instance Show Locker where
globalOutputHandle :: MVar OutputHandle
globalOutputHandle = unsafePerformIO $
newMVar =<< OutputHandle
- <$> newMVar ()
- <*> newEmptyMVar
+ <$> newTMVarIO Nothing
-- | Gets the global OutputHandle.
getOutputHandle :: IO OutputHandle
@@ -62,61 +61,65 @@ takeOutputLock = void $ takeOutputLock' True
tryTakeOutputLock :: IO Bool
tryTakeOutputLock = takeOutputLock' False
-takeOutputLock' :: Bool -> IO Bool
-takeOutputLock' block = do
+withLock :: (TMVar (Maybe Locker) -> STM a) -> IO a
+withLock a = do
lck <- outputLock <$> getOutputHandle
- go =<< tryTakeMVar lck
+ atomically (a lck)
+
+-- The lock TMVar is kept full normally, even if only with Nothing,
+-- so if we take it here, that blocks anyone else from trying
+-- to take the lock while we are checking it.
+takeOutputLock' :: Bool -> IO Bool
+takeOutputLock' block = go =<< withLock tryTakeTMVar
where
- -- lck was full, and we've emptied it, so we hold the lock now.
- go (Just ()) = havelock
- -- lck is empty, so someone else is holding the lock.
- go Nothing = do
- lcker <- outputLockedBy <$> getOutputHandle
- v' <- tryTakeMVar lcker
- case v' of
- Just orig@(ProcessLock h _) ->
- -- if process has exited, lock is stale
- ifM (isJust <$> P.getProcessExitCode h)
- ( havelock
- , if block
- then do
- void $ P.waitForProcess h
- havelock
- else do
- putMVar lcker orig
- return False
- )
- Just GeneralLock -> do
- putMVar lcker GeneralLock
- whenblock waitlock
- Nothing -> whenblock waitlock
+ go Nothing = whenblock waitlock
+ -- Something has the lock. It may be stale, so check it.
+ -- We must always be sure to fill the TMVar back with Just or Nothing.
+ go (Just orig) = case orig of
+ Nothing -> havelock
+ (Just (ProcessLock h _)) ->
+ -- when process has exited, lock is stale
+ ifM (isJust <$> P.getProcessExitCode h)
+ ( havelock
+ , if block
+ then do
+ void $ P.waitForProcess h
+ havelock
+ else do
+ withLock (`putTMVar` orig)
+ return False
+ )
+ (Just GeneralLock) -> do
+ withLock (`putTMVar` orig)
+ whenblock waitlock
havelock = do
- updateOutputLocker GeneralLock
+ withLock (`putTMVar` Just GeneralLock)
return True
- waitlock = do
- -- Wait for current lock holder to relinquish
- -- it and take the lock.
- lck <- outputLock <$> getOutputHandle
- takeMVar lck
- havelock
+
+ -- Wait for current lock holder (if any) to relinquish
+ -- it and take the lock for ourselves.
+ waitlock = withLock $ \l -> do
+ v <- tryTakeTMVar l
+ case v of
+ Just (Just _) -> retry
+ _ -> do
+ putTMVar l (Just GeneralLock)
+ return True
+
whenblock a = if block then a else return False
-- | Only safe to call after taking the output lock.
dropOutputLock :: IO ()
-dropOutputLock = do
- lcker <- outputLockedBy <$> getOutputHandle
- lck <- outputLock <$> getOutputHandle
- void $ takeMVar lcker
- putMVar lck ()
+dropOutputLock = withLock $ \l -> do
+ void $ takeTMVar l
+ putTMVar l Nothing
-- | Only safe to call after takeOutputLock; updates the Locker.
updateOutputLocker :: Locker -> IO ()
-updateOutputLocker l = do
- lcker <- outputLockedBy <$> getOutputHandle
- void $ tryTakeMVar lcker
- putMVar lcker l
- modifyMVar_ lcker (const $ return l)
+updateOutputLocker locker = withLock $ \l -> do
+ void $ takeTMVar l
+ putTMVar l (Just locker)
-- | Use this around any IO actions that use `outputConcurrent`
-- or `createProcessConcurrent`
@@ -174,8 +177,8 @@ createProcessConcurrent p
hFlush stderr
firstprocess
, do
- lcker <- outputLockedBy <$> getOutputHandle
- hPutStrLn stderr $ show ("IS CONCURRENT", cmd)
+ v <- withLock $ tryReadTMVar
+ hPutStrLn stderr $ show ("IS CONCURRENT", cmd, v)
hFlush stderr
concurrentprocess
)