aboutsummaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-09-30 19:51:16 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-09-30 19:51:16 -0400
commitd684c2f53135f51872c112732acc4079b2d4693d (patch)
treed7a6895a1b2874d436fb094625174859c325bac8 /Assistant
parent0a588575977bc74a61917801477e03da3897507d (diff)
convert TMVars that are never left empty into TVars
This is probably more efficient, and it avoids mistakenly leaving them empty.
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/DaemonStatus.hs18
-rw-r--r--Assistant/Types/DaemonStatus.hs3
-rw-r--r--Assistant/Types/TransferrerPool.hs21
3 files changed, 19 insertions, 23 deletions
diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs
index 3b2c6f3cd..6e11b923e 100644
--- a/Assistant/DaemonStatus.hs
+++ b/Assistant/DaemonStatus.hs
@@ -30,7 +30,7 @@ import qualified Data.Set as S
import qualified Data.Text as T
getDaemonStatus :: Assistant DaemonStatus
-getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle
+getDaemonStatus = (atomically . readTVar) <<~ daemonStatusHandle
modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant ()
modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ())
@@ -40,8 +40,8 @@ modifyDaemonStatus a = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ do
(s, b) <- atomically $ do
- r@(!s, _) <- a <$> takeTMVar dstatus
- putTMVar dstatus s
+ r@(!s, _) <- a <$> readTVar dstatus
+ writeTVar dstatus s
return r
sendNotification $ changeNotifier s
return b
@@ -102,7 +102,7 @@ startDaemonStatus = do
flip catchDefaultIO (readDaemonStatusFile file) =<< newDaemonStatus
transfers <- M.fromList <$> getTransfers
addsync <- calcSyncRemotes
- liftIO $ atomically $ newTMVar $ addsync $ status
+ liftIO $ atomically $ newTVar $ addsync $ status
{ scanComplete = False
, sanityCheckRunning = False
, currentTransfers = transfers
@@ -162,14 +162,14 @@ tenMinutes = 10 * 60
- to the caller. -}
adjustTransfersSTM :: DaemonStatusHandle -> (TransferMap -> TransferMap) -> STM ()
adjustTransfersSTM dstatus a = do
- s <- takeTMVar dstatus
+ s <- readTVar dstatus
let !v = a (currentTransfers s)
- putTMVar dstatus $ s { currentTransfers = v }
+ writeTVar dstatus $ s { currentTransfers = v }
{- Checks if a transfer is currently running. -}
checkRunningTransferSTM :: DaemonStatusHandle -> Transfer -> STM Bool
checkRunningTransferSTM dstatus t = M.member t . currentTransfers
- <$> readTMVar dstatus
+ <$> readTVar dstatus
{- Alters a transfer's info, if the transfer is in the map. -}
alterTransferInfo :: Transfer -> (TransferInfo -> TransferInfo) -> Assistant ()
@@ -207,14 +207,14 @@ notifyTransfer :: Assistant ()
notifyTransfer = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ sendNotification
- =<< transferNotifier <$> atomically (readTMVar dstatus)
+ =<< transferNotifier <$> atomically (readTVar dstatus)
{- Send a notification when alerts are changed. -}
notifyAlert :: Assistant ()
notifyAlert = do
dstatus <- getAssistant daemonStatusHandle
liftIO $ sendNotification
- =<< alertNotifier <$> atomically (readTMVar dstatus)
+ =<< alertNotifier <$> atomically (readTVar dstatus)
{- Returns the alert's identifier, which can be used to remove it. -}
addAlert :: Alert -> Assistant AlertId
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index 8bb66261e..0e52d3477 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -86,8 +86,7 @@ data DaemonStatus = DaemonStatus
type TransferMap = M.Map Transfer TransferInfo
-{- This TMVar is never left empty, so accessing it will never block. -}
-type DaemonStatusHandle = TMVar DaemonStatus
+type DaemonStatusHandle = TVar DaemonStatus
newDaemonStatus :: IO DaemonStatus
newDaemonStatus = DaemonStatus
diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs
index a2425eb62..742d8437c 100644
--- a/Assistant/Types/TransferrerPool.hs
+++ b/Assistant/Types/TransferrerPool.hs
@@ -13,8 +13,7 @@ import Assistant.Types.DaemonStatus
import Control.Concurrent.STM hiding (check)
-{- This TMVar is never left empty. -}
-type TransferrerPool = TMVar (MkCheckTransferrer, [TransferrerPoolItem])
+type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem])
type CheckTransferrer = IO Bool
type MkCheckTransferrer = IO (IO Bool)
@@ -31,24 +30,22 @@ data Transferrer = Transferrer
}
newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool
-newTransferrerPool c = newTMVarIO (c, [])
+newTransferrerPool c = newTVarIO (c, [])
popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int)
popTransferrerPool p = do
- (c, l) <- takeTMVar p
+ (c, l) <- readTVar p
case l of
- [] -> do
- putTMVar p (c, [])
- return (Nothing, 0)
+ [] -> return (Nothing, 0)
(i:is) -> do
- putTMVar p (c, is)
+ writeTVar p (c, is)
return $ (Just i, length is)
pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM ()
pushTransferrerPool p i = do
- (c, l) <- takeTMVar p
+ (c, l) <- readTVar p
let l' = i:l
- putTMVar p (c, l')
+ writeTVar p (c, l')
{- Note that making a CheckTransferrer may allocate resources,
- such as a NotificationHandle, so it's important that the returned
@@ -56,12 +53,12 @@ pushTransferrerPool p i = do
- garbage collected. -}
mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem
mkTransferrerPoolItem p t = do
- mkcheck <- atomically $ fst <$> readTMVar p
+ mkcheck <- atomically $ fst <$> readTVar p
check <- mkcheck
return $ TransferrerPoolItem (Just t) check
checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer
checkNetworkConnections dstatushandle = do
- dstatus <- atomically $ readTMVar dstatushandle
+ dstatus <- atomically $ readTVar dstatushandle
h <- newNotificationHandle False (networkConnectedNotifier dstatus)
return $ not <$> checkNotification h