summaryrefslogtreecommitdiff
path: root/Assistant/Threads
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/Threads')
-rw-r--r--Assistant/Threads/Committer.hs4
-rw-r--r--Assistant/Threads/Merger.hs7
-rw-r--r--Assistant/Threads/MountWatcher.hs4
-rw-r--r--Assistant/Threads/NetWatcher.hs2
-rw-r--r--Assistant/Threads/PairListener.hs18
-rw-r--r--Assistant/Threads/PushNotifier.hs8
-rw-r--r--Assistant/Threads/TransferScanner.hs42
-rw-r--r--Assistant/Threads/TransferWatcher.hs12
-rw-r--r--Assistant/Threads/Transferrer.hs14
-rw-r--r--Assistant/Threads/Watcher.hs11
10 files changed, 48 insertions, 74 deletions
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index d73dc1eb0..445e44dea 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -202,9 +202,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
Git.HashObject.hashObject BlobObject link
stageSymlink file sha
showEndOk
- transferqueue <- getAssistant transferQueue
- dstatus <- getAssistant daemonStatusHandle
- liftAnnex $ queueTransfers Next transferqueue dstatus key (Just file) Upload
+ queueTransfers Next key (Just file) Upload
return $ Just change
{- Check that the keysource's keyFilename still exists,
diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs
index 46511701c..44056dc35 100644
--- a/Assistant/Threads/Merger.hs
+++ b/Assistant/Threads/Merger.hs
@@ -67,11 +67,8 @@ onAdd file
| ".lock" `isSuffixOf` file = noop
| isAnnexBranch file = do
branchChanged
- transferqueue <- getAssistant transferQueue
- dstatus <- getAssistant daemonStatusHandle
- liftAnnex $
- whenM Annex.Branch.forceUpdate $
- queueDeferredDownloads Later transferqueue dstatus
+ whenM (liftAnnex Annex.Branch.forceUpdate) $
+ queueDeferredDownloads Later
| "/synced/" `isInfixOf` file = do
mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
| otherwise = noop
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
index bb63e840f..d3da50dd4 100644
--- a/Assistant/Threads/MountWatcher.hs
+++ b/Assistant/Threads/MountWatcher.hs
@@ -48,7 +48,7 @@ mountWatcherThread = NamedThread "MountWatcher" $
dbusThread :: Assistant ()
dbusThread = do
- runclient <- asIO go
+ runclient <- asIO1 go
r <- liftIO $ E.try $ runClient getSessionAddress runclient
either onerr (const noop) r
where
@@ -59,7 +59,7 @@ dbusThread = do
- mount point from the dbus message, but this is
- easier. -}
mvar <- liftIO $ newMVar =<< currentMountPoints
- handleevent <- asIO $ \_event -> do
+ handleevent <- asIO1 $ \_event -> do
nowmounted <- liftIO $ currentMountPoints
wasmounted <- liftIO $ swapMVar mvar nowmounted
handleMounts wasmounted nowmounted
diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs
index 9df4f3a4d..4396b2632 100644
--- a/Assistant/Threads/NetWatcher.hs
+++ b/Assistant/Threads/NetWatcher.hs
@@ -49,7 +49,7 @@ netWatcherFallbackThread = NamedThread "NetWatcherFallback" $
dbusThread :: Assistant ()
dbusThread = do
handleerr <- asIO2 onerr
- runclient <- asIO go
+ runclient <- asIO1 go
liftIO $ persistentClient getSystemAddress () handleerr runclient
where
go client = ifM (checkNetMonitor client)
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index f682dd6da..f29bec4b4 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -27,7 +27,7 @@ thisThread = "PairListener"
pairListenerThread :: UrlRenderer -> NamedThread
pairListenerThread urlrenderer = NamedThread "PairListener" $ do
- listener <- asIO $ go [] []
+ listener <- asIO1 $ go [] []
liftIO $ withSocketsDo $
runEvery (Seconds 1) $ void $ tryIO $
listener =<< getsock
@@ -69,7 +69,7 @@ pairListenerThread urlrenderer = NamedThread "PairListener" $ do
| not verified && sameuuid = do
liftAnnex $ warning
"detected possible pairing brute force attempt; disabled pairing"
- stopSending pip <<~ daemonStatusHandle
+ stopSending pip
return (Nothing, False)
|otherwise = return (Just pip, verified && sameuuid)
where
@@ -104,7 +104,7 @@ pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
pairReqReceived True _ _ = noop -- ignore our own PairReq
pairReqReceived False urlrenderer msg = do
url <- liftIO $ renderUrl urlrenderer (FinishPairR msg) []
- close <- asIO removeAlert
+ close <- asIO1 removeAlert
void $ addAlert $ pairRequestReceivedAlert repo
AlertButton
{ buttonUrl = url
@@ -119,11 +119,10 @@ pairReqReceived False urlrenderer msg = do
- and send a single PairDone. -}
pairAckReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> [PairingInProgress] -> Assistant [PairingInProgress]
pairAckReceived True (Just pip) msg cache = do
- stopSending pip <<~ daemonStatusHandle
+ stopSending pip
liftIO $ setupAuthorizedKeys msg
finishedPairing msg (inProgressSshKeyPair pip)
- dstatus <- getAssistant daemonStatusHandle
- liftIO $ startSending dstatus pip PairDone $ multicastPairMsg
+ startSending pip PairDone $ multicastPairMsg
(Just 1) (inProgressSecret pip) (inProgressPairData pip)
return $ pip : take 10 cache
{- A stale PairAck might also be seen, after we've finished pairing.
@@ -132,10 +131,9 @@ pairAckReceived True (Just pip) msg cache = do
- response to stale PairAcks for them. -}
pairAckReceived _ _ msg cache = do
let pips = filter (verifiedPairMsg msg) cache
- dstatus <- getAssistant daemonStatusHandle
unless (null pips) $
- liftIO $ forM_ pips $ \pip ->
- startSending dstatus pip PairDone $ multicastPairMsg
+ forM_ pips $ \pip ->
+ startSending pip PairDone $ multicastPairMsg
(Just 1) (inProgressSecret pip) (inProgressPairData pip)
return cache
@@ -152,5 +150,5 @@ pairDoneReceived :: Bool -> Maybe PairingInProgress -> PairMsg -> Assistant ()
pairDoneReceived False _ _ = noop -- not verified
pairDoneReceived True Nothing _ = noop -- not in progress
pairDoneReceived True (Just pip) msg = do
- stopSending pip <<~ daemonStatusHandle
+ stopSending pip
finishedPairing msg (inProgressSshKeyPair pip)
diff --git a/Assistant/Threads/PushNotifier.hs b/Assistant/Threads/PushNotifier.hs
index b50a2e4b9..d2d5e08bf 100644
--- a/Assistant/Threads/PushNotifier.hs
+++ b/Assistant/Threads/PushNotifier.hs
@@ -26,10 +26,10 @@ import Data.Time.Clock
pushNotifierThread :: NamedThread
pushNotifierThread = NamedThread "PushNotifier" $ do
- iodebug <- asIO debug
- iopull <- asIO pull
- iowaitpush <- asIO $ const waitPush
- ioclient <- asIO2 $ xmppClient $ iowaitpush ()
+ iodebug <- asIO1 debug
+ iopull <- asIO1 pull
+ iowaitpush <- asIO $ waitPush
+ ioclient <- asIO2 $ xmppClient $ iowaitpush
forever $ do
tid <- liftIO $ forkIO $ ioclient iodebug iopull
waitRestart
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index c37b1e3b9..3b3c3f304 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -21,7 +21,7 @@ import qualified Remote
import qualified Types.Remote as Remote
import Utility.ThreadScheduler
import qualified Git.LsFiles as LsFiles
-import Command
+import qualified Backend
import Annex.Content
import Annex.Wanted
@@ -78,11 +78,7 @@ failedTransferScan r = do
- that the remote doesn't already have the
- key, so it's not redundantly checked here. -}
requeue t info
- requeue t info = do
- transferqueue <- getAssistant transferQueue
- dstatus <- getAssistant daemonStatusHandle
- liftIO $ queueTransferWhenSmall
- transferqueue dstatus (associatedFile info) t r
+ requeue t info = queueTransferWhenSmall (associatedFile info) t r
{- This is a expensive scan through the full git work tree, finding
- files to transfer. The scan is blocked when the transfer queue gets
@@ -101,10 +97,9 @@ expensiveScan rs = unless onlyweb $ do
void $ alertWhile (scanAlert visiblers) $ do
g <- liftAnnex gitRepo
(files, cleanup) <- liftIO $ LsFiles.inRepo [] g
- dstatus <- getAssistant daemonStatusHandle
forM_ files $ \f -> do
- ts <- liftAnnex $
- ifAnnexed f (findtransfers dstatus f) (return [])
+ ts <- maybe (return []) (findtransfers f)
+ =<< liftAnnex (Backend.lookupFile f)
mapM_ (enqueue f) ts
void $ liftIO cleanup
return True
@@ -115,25 +110,24 @@ expensiveScan rs = unless onlyweb $ do
in if null rs' then rs else rs'
enqueue f (r, t) = do
debug ["queuing", show t]
- transferqueue <- getAssistant transferQueue
- dstatus <- getAssistant daemonStatusHandle
- liftIO $ queueTransferWhenSmall transferqueue dstatus (Just f) t r
- findtransfers dstatus f (key, _) = do
- locs <- loggedLocations key
+ queueTransferWhenSmall (Just f) t r
+ findtransfers f (key, _) = do
{- The syncable remotes may have changed since this
- scan began. -}
- syncrs <- liftIO $ syncRemotes <$> getDaemonStatusOld dstatus
- present <- inAnnex key
+ syncrs <- syncRemotes <$> getDaemonStatus
+ liftAnnex $ do
+ locs <- loggedLocations key
+ present <- inAnnex key
- handleDrops' locs syncrs present key (Just f)
+ handleDrops' locs syncrs present key (Just f)
- let slocs = S.fromList locs
- let use a = return $ catMaybes $ map (a key slocs) syncrs
- if present
- then filterM (wantSend (Just f) . Remote.uuid . fst)
- =<< use (genTransfer Upload False)
- else ifM (wantGet $ Just f)
- ( use (genTransfer Download True) , return [] )
+ let slocs = S.fromList locs
+ let use a = return $ catMaybes $ map (a key slocs) syncrs
+ if present
+ then filterM (wantSend (Just f) . Remote.uuid . fst)
+ =<< use (genTransfer Upload False)
+ else ifM (wantGet $ Just f)
+ ( use (genTransfer Download True) , return [] )
genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer)
genTransfer direction want key slocs r
diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs
index f18a2acd8..7b789b8b6 100644
--- a/Assistant/Threads/TransferWatcher.hs
+++ b/Assistant/Threads/TransferWatcher.hs
@@ -115,15 +115,9 @@ finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
finishedTransfer t (Just info)
| transferDirection t == Download =
whenM (liftAnnex $ inAnnex $ transferKey t) $ do
- dstatus <- getAssistant daemonStatusHandle
- transferqueue <- getAssistant transferQueue
- liftAnnex $ handleDrops dstatus False
- (transferKey t) (associatedFile info)
- liftAnnex $ queueTransfersMatching (/= transferUUID t)
- Later transferqueue dstatus
+ handleDrops False (transferKey t) (associatedFile info)
+ queueTransfersMatching (/= transferUUID t) Later
(transferKey t) (associatedFile info) Upload
- | otherwise = do
- dstatus <- getAssistant daemonStatusHandle
- liftAnnex $ handleDrops dstatus True (transferKey t) (associatedFile info)
+ | otherwise = handleDrops True (transferKey t) (associatedFile info)
finishedTransfer _ _ = noop
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index c60790f9b..84013eaa7 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -30,26 +30,22 @@ maxTransfers = 1
transfererThread :: NamedThread
transfererThread = NamedThread "Transferr" $ do
program <- liftIO readProgramFile
- transferqueue <- getAssistant transferQueue
- dstatus <- getAssistant daemonStatusHandle
- starter <- asIO2 $ startTransfer program
- forever $ inTransferSlot $ liftIO $
- maybe (return Nothing) (uncurry starter)
- =<< getNextTransfer transferqueue dstatus notrunning
+ forever $ inTransferSlot $
+ maybe (return Nothing) (uncurry $ startTransfer program)
+ =<< getNextTransfer notrunning
where
{- Skip transfers that are already running. -}
notrunning = isNothing . startedTime
{- By the time this is called, the daemonstatus's transfer map should
- already have been updated to include the transfer. -}
-startTransfer :: FilePath -> Transfer -> TransferInfo -> Assistant (Maybe (Transfer, TransferInfo, IO ()))
+startTransfer :: FilePath -> Transfer -> TransferInfo -> Assistant (Maybe (Transfer, TransferInfo, Assistant ()))
startTransfer program t info = case (transferRemote info, associatedFile info) of
(Just remote, Just file) -> ifM (liftAnnex $ shouldTransfer t info)
( do
debug [ "Transferring:" , show t ]
notifyTransfer
- tp <- asIO2 transferprocess
- return $ Just (t, info, tp remote file)
+ return $ Just (t, info, transferprocess remote file)
, do
debug [ "Skipping unnecessary transfer:" , show t ]
void $ removeTransfer t
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 7dcde1f46..a74976deb 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -54,7 +54,7 @@ needLsof = error $ unlines
watchThread :: NamedThread
watchThread = NamedThread "Watcher" $ do
- startup <- asIO startupScan
+ startup <- asIO1 startupScan
addhook <- hook onAdd
delhook <- hook onDel
addsymlinkhook <- hook onAddSymlink
@@ -182,12 +182,9 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
checkcontent key daemonstatus
| scanComplete daemonstatus = do
present <- liftAnnex $ inAnnex key
- dstatus <- getAssistant daemonStatusHandle
- unless present $ do
- transferqueue <- getAssistant transferQueue
- liftAnnex $ queueTransfers Next transferqueue
- dstatus key (Just file) Download
- liftAnnex $ handleDrops dstatus present key (Just file)
+ unless present $
+ queueTransfers Next key (Just file) Download
+ handleDrops present key (Just file)
| otherwise = noop
onDel :: Handler
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 12:03:35 +0000