summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant/DaemonStatus.hs18
-rw-r--r--Assistant/Types/DaemonStatus.hs3
-rw-r--r--Assistant/Types/TransferrerPool.hs21
-rw-r--r--Command/WebApp.hs2
-rw-r--r--Remote/External.hs46
-rw-r--r--Remote/External/Types.hs18
6 files changed, 46 insertions, 62 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
diff --git a/Command/WebApp.hs b/Command/WebApp.hs
index 87a648bdd..4dff8c9d1 100644
--- a/Command/WebApp.hs
+++ b/Command/WebApp.hs
@@ -154,7 +154,7 @@ firstRun o = do
- threadstate. -}
let st = error "annex state not available"
{- Get a DaemonStatus without running in the Annex monad. -}
- dstatus <- atomically . newTMVar =<< newDaemonStatus
+ dstatus <- atomically . newTVar =<< newDaemonStatus
d <- newAssistantData st dstatus
urlrenderer <- newUrlRenderer
v <- newEmptyMVar
diff --git a/Remote/External.hs b/Remote/External.hs
index a2d5670ec..65b05fe62 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -127,7 +127,7 @@ externalSetup mu _ c gc = do
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
_ -> Nothing
withExternalState external $
- liftIO . atomically . readTMVar . externalConfig
+ liftIO . atomically . readTVar . externalConfig
gitConfigSpecialRemote u c'' "externaltype" externaltype
return (c'', u)
@@ -234,24 +234,22 @@ handleRequest' st external req mp responsehandler
handleRemoteRequest (DIRHASH_LOWER k) =
send $ VALUE $ hashDirLower def k
handleRemoteRequest (SETCONFIG setting value) =
- liftIO $ atomically $ do
- let v = externalConfig st
- m <- takeTMVar v
- putTMVar v $ M.insert setting value m
+ liftIO $ atomically $ modifyTVar' (externalConfig st) $
+ M.insert setting value
handleRemoteRequest (GETCONFIG setting) = do
value <- fromMaybe "" . M.lookup setting
- <$> liftIO (atomically $ readTMVar $ externalConfig st)
+ <$> liftIO (atomically $ readTVar $ externalConfig st)
send $ VALUE value
handleRemoteRequest (SETCREDS setting login password) = do
let v = externalConfig st
- c <- liftIO $ atomically $ readTMVar v
+ c <- liftIO $ atomically $ readTVar v
let gc = externalGitConfig external
c' <- setRemoteCredPair encryptionAlreadySetup c gc
(credstorage setting)
(Just (login, password))
- void $ liftIO $ atomically $ swapTMVar v c'
+ void $ liftIO $ atomically $ swapTVar v c'
handleRemoteRequest (GETCREDS setting) = do
- c <- liftIO $ atomically $ readTMVar $ externalConfig st
+ c <- liftIO $ atomically $ readTVar $ externalConfig st
let gc = externalGitConfig external
creds <- fromMaybe ("", "") <$>
getRemoteCredPair c gc (credstorage setting)
@@ -356,19 +354,15 @@ withExternalState external = bracket alloc dealloc
alloc = do
ms <- liftIO $ atomically $ do
- l <- takeTMVar v
+ l <- readTVar v
case l of
- [] -> do
- putTMVar v l
- return Nothing
+ [] -> return Nothing
(st:rest) -> do
- putTMVar v rest
+ writeTVar v rest
return (Just st)
maybe (startExternal external) return ms
- dealloc st = liftIO $ atomically $ do
- l <- takeTMVar v
- putTMVar v (st:l)
+ dealloc st = liftIO $ atomically $ modifyTVar' v (st:)
{- Starts an external remote process running, and checks VERSION. -}
startExternal :: External -> Annex ExternalState
@@ -396,11 +390,11 @@ startExternal external = do
fileEncoding herr
stderrelay <- async $ errrelayer herr
checkearlytermination =<< getProcessExitCode ph
- cv <- newTMVarIO $ externalDefaultConfig external
- pv <- newTMVarIO Unprepared
+ cv <- newTVarIO $ externalDefaultConfig external
+ pv <- newTVarIO Unprepared
pid <- atomically $ do
- n <- succ <$> takeTMVar (externalLastPid external)
- putTMVar (externalLastPid external) n
+ n <- succ <$> readTVar (externalLastPid external)
+ writeTVar (externalLastPid external) n
return n
return $ ExternalState
{ externalSend = hin
@@ -431,17 +425,13 @@ startExternal external = do
stopExternal :: External -> Annex ()
stopExternal external = liftIO $ do
- l <- atomically $ do
- l <- takeTMVar v
- putTMVar v []
- return l
+ l <- atomically $ swapTVar (externalState external) []
mapM_ stop l
where
stop st = do
hClose $ externalSend st
hClose $ externalReceive st
externalShutdown st
- v = externalState external
externalRemoteProgram :: ExternalType -> String
externalRemoteProgram externaltype = "git-annex-remote-" ++ externaltype
@@ -459,7 +449,7 @@ checkVersion _ _ _ = Nothing
- the error message. -}
checkPrepared :: ExternalState -> External -> Annex ()
checkPrepared st external = do
- v <- liftIO $ atomically $ readTMVar $ externalPrepared st
+ v <- liftIO $ atomically $ readTVar $ externalPrepared st
case v of
Prepared -> noop
FailedPrepare errmsg -> error errmsg
@@ -474,7 +464,7 @@ checkPrepared st external = do
_ -> Nothing
where
setprepared status = liftIO $ atomically $ void $
- swapTMVar (externalPrepared st) status
+ swapTVar (externalPrepared st) status
{- Caches the cost in the git config to avoid needing to start up an
- external special remote every time time just to ask it what its
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index 33a22aeb1..2306989bb 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -45,10 +45,10 @@ import Network.URI
data External = External
{ externalType :: ExternalType
, externalUUID :: UUID
- , externalState :: TMVar [ExternalState]
- -- ^ TMVar is never left empty; list contains states for external
- -- special remote processes that are not currently in use.
- , externalLastPid :: TMVar PID
+ , externalState :: TVar [ExternalState]
+ -- ^ Contains states for external special remote processes
+ -- that are not currently in use.
+ , externalLastPid :: TVar PID
, externalDefaultConfig :: RemoteConfig
, externalGitConfig :: RemoteGitConfig
}
@@ -57,8 +57,8 @@ newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex
newExternal externaltype u c gc = liftIO $ External
<$> pure externaltype
<*> pure u
- <*> atomically (newTMVar [])
- <*> atomically (newTMVar 0)
+ <*> atomically (newTVar [])
+ <*> atomically (newTVar 0)
<*> pure c
<*> pure gc
@@ -69,10 +69,8 @@ data ExternalState = ExternalState
, externalReceive :: Handle
, externalShutdown :: IO ()
, externalPid :: PID
- , externalPrepared :: TMVar PrepareStatus
- -- ^ Never left empty.
- , externalConfig :: TMVar RemoteConfig
- -- ^ Never left empty.
+ , externalPrepared :: TVar PrepareStatus
+ , externalConfig :: TVar RemoteConfig
}
type PID = Int
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-15 17:12:29 +0000