From 93ffd47d76a2ecc78ca04835ea66b2df067df385 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 30 Oct 2012 17:14:26 -0400 Subject: [PATCH] finished pushing Assistant monad into all relevant files All temporary and old functions are removed. --- Assistant/DaemonStatus.hs | 23 --- Assistant/Drop.hs | 13 +- Assistant/Monad.hs | 9 +- Assistant/Pairing/Network.hs | 85 ++++----- Assistant/Threads/Committer.hs | 4 +- Assistant/Threads/Merger.hs | 7 +- Assistant/Threads/MountWatcher.hs | 4 +- Assistant/Threads/NetWatcher.hs | 2 +- Assistant/Threads/PairListener.hs | 18 +- Assistant/Threads/PushNotifier.hs | 8 +- Assistant/Threads/TransferScanner.hs | 42 ++--- Assistant/Threads/TransferWatcher.hs | 12 +- Assistant/Threads/Transferrer.hs | 14 +- Assistant/Threads/Watcher.hs | 11 +- Assistant/TransferQueue.hs | 207 +++++++++++----------- Assistant/TransferSlots.hs | 26 +-- Assistant/WebApp.hs | 11 +- Assistant/WebApp/Configurators.hs | 2 +- Assistant/WebApp/Configurators/Edit.hs | 2 +- Assistant/WebApp/Configurators/Pairing.hs | 13 +- Assistant/WebApp/Configurators/S3.hs | 4 +- Assistant/WebApp/Configurators/Ssh.hs | 2 +- Assistant/WebApp/Configurators/XMPP.hs | 6 +- Assistant/WebApp/DashBoard.hs | 3 +- Assistant/WebApp/SideBar.hs | 6 +- Assistant/WebApp/Utility.hs | 29 ++- 26 files changed, 262 insertions(+), 301 deletions(-) diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 4223b6ce92..4744c86ba5 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -24,30 +24,12 @@ import Data.Time import System.Locale import qualified Data.Map as M --- TODO remove this -getDaemonStatusOld :: DaemonStatusHandle -> IO DaemonStatus -getDaemonStatusOld = atomically . readTMVar - getDaemonStatus :: Assistant DaemonStatus getDaemonStatus = (atomically . readTMVar) <<~ daemonStatusHandle --- TODO remove this -modifyDaemonStatusOld_ :: DaemonStatusHandle -> (DaemonStatus -> DaemonStatus) -> IO () -modifyDaemonStatusOld_ dstatus a = modifyDaemonStatusOld dstatus $ \s -> (a s, ()) - modifyDaemonStatus_ :: (DaemonStatus -> DaemonStatus) -> Assistant () modifyDaemonStatus_ a = modifyDaemonStatus $ \s -> (a s, ()) --- TODO remove this -modifyDaemonStatusOld :: DaemonStatusHandle -> (DaemonStatus -> (DaemonStatus, b)) -> IO b -modifyDaemonStatusOld dstatus a = do - (s, b) <- atomically $ do - r@(s, _) <- a <$> takeTMVar dstatus - putTMVar dstatus s - return r - sendNotification $ changeNotifier s - return b - modifyDaemonStatus :: (DaemonStatus -> (DaemonStatus, b)) -> Assistant b modifyDaemonStatus a = do dstatus <- getAssistant daemonStatusHandle @@ -188,11 +170,6 @@ notifyTransfer = do liftIO $ sendNotification =<< transferNotifier <$> atomically (readTMVar dstatus) --- TODO remove -notifyTransferOld :: DaemonStatusHandle -> IO () -notifyTransferOld dstatus = sendNotification - =<< transferNotifier <$> atomically (readTMVar dstatus) - {- Send a notification when alerts are changed. -} notifyAlert :: Assistant () notifyAlert = do diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index 021e40a877..ed9ba577e9 100644 --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -20,12 +20,13 @@ import Config {- Drop from local and/or remote when allowed by the preferred content and - numcopies settings. -} -handleDrops :: DaemonStatusHandle -> Bool -> Key -> AssociatedFile -> Annex () -handleDrops _ _ _ Nothing = noop -handleDrops dstatus fromhere key f = do - syncrs <- liftIO $ syncRemotes <$> getDaemonStatusOld dstatus - locs <- loggedLocations key - handleDrops' locs syncrs fromhere key f +handleDrops :: Bool -> Key -> AssociatedFile -> Assistant () +handleDrops _ _ Nothing = noop +handleDrops fromhere key f = do + syncrs <- syncRemotes <$> getDaemonStatus + liftAnnex $ do + locs <- loggedLocations key + handleDrops' locs syncrs fromhere key f handleDrops' :: [UUID] -> [Remote] -> Bool -> Key -> AssociatedFile -> Annex () handleDrops' _ _ _ _ Nothing = noop diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 0dfd4e34da..fb4cb33405 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -17,6 +17,7 @@ module Assistant.Monad ( (<~>), (<<~), asIO, + asIO1, asIO2, ) where @@ -95,12 +96,16 @@ io <~> a = do liftIO $ io $ runAssistant a d {- Creates an IO action that will run an Assistant action when run. -} -asIO :: (a -> Assistant b) -> Assistant (a -> IO b) +asIO :: Assistant a -> Assistant (IO a) asIO a = do + d <- reader id + return $ runAssistant a d + +asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b) +asIO1 a = do d <- reader id return $ \v -> runAssistant (a v) d -{- Creates an IO action that will run an Assistant action when run. -} asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c) asIO2 a = do d <- reader id diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 9b030617e5..9ee1db3c6d 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -50,47 +50,50 @@ multicastAddress (IPv6Addr _) = "ff02::fb" -} multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO () multicastPairMsg repeats secret pairdata stage = go M.empty repeats - where - go _ (Just 0) = noop - go cache n = do - addrs <- activeNetworkAddresses - let cache' = updatecache cache addrs - mapM_ (sendinterface cache') addrs - threadDelaySeconds (Seconds 2) - go cache' $ pred <$> n - {- The multicast library currently chokes on ipv6 addresses. -} - sendinterface _ (IPv6Addr _) = noop - sendinterface cache i = void $ catchMaybeIO $ - withSocketsDo $ bracket setup cleanup use - where - setup = multicastSender (multicastAddress i) pairingPort - cleanup (sock, _) = sClose sock -- FIXME does not work - use (sock, addr) = do - setInterface sock (showAddr i) - maybe noop (\s -> void $ sendTo sock s addr) - (M.lookup i cache) - updatecache cache [] = cache - updatecache cache (i:is) - | M.member i cache = updatecache cache is - | otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is - mkmsg addr = PairMsg $ - mkVerifiable (stage, pairdata, addr) secret + where + go _ (Just 0) = noop + go cache n = do + addrs <- activeNetworkAddresses + let cache' = updatecache cache addrs + mapM_ (sendinterface cache') addrs + threadDelaySeconds (Seconds 2) + go cache' $ pred <$> n + {- The multicast library currently chokes on ipv6 addresses. -} + sendinterface _ (IPv6Addr _) = noop + sendinterface cache i = void $ catchMaybeIO $ + withSocketsDo $ bracket setup cleanup use + where + setup = multicastSender (multicastAddress i) pairingPort + cleanup (sock, _) = sClose sock -- FIXME does not work + use (sock, addr) = do + setInterface sock (showAddr i) + maybe noop (\s -> void $ sendTo sock s addr) + (M.lookup i cache) + updatecache cache [] = cache + updatecache cache (i:is) + | M.member i cache = updatecache cache is + | otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is + mkmsg addr = PairMsg $ + mkVerifiable (stage, pairdata, addr) secret -startSending :: DaemonStatusHandle -> PairingInProgress -> PairStage -> (PairStage -> IO ()) -> IO () -startSending dstatus pip stage sender = void $ forkIO $ do - tid <- myThreadId - let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid } - oldpip <- modifyDaemonStatusOld dstatus $ - \s -> (s { pairingInProgress = Just pip' }, pairingInProgress s) - maybe noop stopold oldpip - sender stage - where - stopold = maybe noop killThread . inProgressThreadId +startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant () +startSending pip stage sender = do + a <- asIO start + void $ liftIO $ forkIO a + where + start = do + tid <- liftIO myThreadId + let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid } + oldpip <- modifyDaemonStatus $ + \s -> (s { pairingInProgress = Just pip' }, pairingInProgress s) + maybe noop stopold oldpip + liftIO $ sender stage + stopold = maybe noop (liftIO . killThread) . inProgressThreadId -stopSending :: PairingInProgress -> DaemonStatusHandle -> IO () -stopSending pip dstatus = do - maybe noop killThread $ inProgressThreadId pip - modifyDaemonStatusOld_ dstatus $ \s -> s { pairingInProgress = Nothing } +stopSending :: PairingInProgress -> Assistant () +stopSending pip = do + maybe noop (liftIO . killThread) $ inProgressThreadId pip + modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing } class ToSomeAddr a where toSomeAddr :: a -> SomeAddr @@ -123,5 +126,5 @@ pairRepo msg = concat , ":" , remoteDirectory d ] - where - d = pairMsgData msg + where + d = pairMsgData msg diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index d73dc1eb00..445e44dea7 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 46511701c1..44056dc358 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 bb63e840f8..d3da50dd40 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 9df4f3a4d3..4396b26324 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 f682dd6da5..f29bec4b4d 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 b50a2e4b90..d2d5e08bf6 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 c37b1e3b9c..3b3c3f304b 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 f18a2acd8d..7b789b8b6f 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 c60790f9bf..84013eaa75 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 7dcde1f46c..a74976debe 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 diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs index 11c2d58d81..8e403cc438 100644 --- a/Assistant/TransferQueue.hs +++ b/Assistant/TransferQueue.hs @@ -21,9 +21,8 @@ module Assistant.TransferQueue ( dequeueTransfers, ) where -import Common.Annex +import Assistant.Common import Assistant.DaemonStatus -import Assistant.Types.DaemonStatus import Assistant.Types.TransferQueue import Logs.Transfer import Types.Remote @@ -35,8 +34,8 @@ import Control.Concurrent.STM import qualified Data.Map as M {- Reads the queue's content without blocking or changing it. -} -getTransferQueue :: TransferQueue -> IO [(Transfer, TransferInfo)] -getTransferQueue q = atomically $ readTVar $ queuelist q +getTransferQueue :: Assistant [(Transfer, TransferInfo)] +getTransferQueue = (atomically . readTVar . queuelist) <<~ transferQueue stubInfo :: AssociatedFile -> Remote -> TransferInfo stubInfo f r = stubTransferInfo @@ -46,101 +45,104 @@ stubInfo f r = stubTransferInfo {- Adds transfers to queue for some of the known remotes. - Honors preferred content settings, only transferring wanted files. -} -queueTransfers :: Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () +queueTransfers :: Schedule -> Key -> AssociatedFile -> Direction -> Assistant () queueTransfers = queueTransfersMatching (const True) {- Adds transfers to queue for some of the known remotes, that match a - condition. Honors preferred content settings. -} -queueTransfersMatching :: (UUID -> Bool) -> Schedule -> TransferQueue -> DaemonStatusHandle -> Key -> AssociatedFile -> Direction -> Annex () -queueTransfersMatching matching schedule q dstatus k f direction - | direction == Download = whenM (wantGet f) go +queueTransfersMatching :: (UUID -> Bool) -> Schedule -> Key -> AssociatedFile -> Direction -> Assistant () +queueTransfersMatching matching schedule k f direction + | direction == Download = whenM (liftAnnex $ wantGet f) go | otherwise = go - where - go = do - rs <- sufficientremotes - =<< syncRemotes <$> liftIO (getDaemonStatusOld dstatus) - let matchingrs = filter (matching . Remote.uuid) rs - if null matchingrs - then defer - else forM_ matchingrs $ \r -> liftIO $ - enqueue schedule q dstatus (gentransfer r) (stubInfo f r) - sufficientremotes rs - {- Queue downloads from all remotes that - - have the key, with the cheapest ones first. - - More expensive ones will only be tried if - - downloading from a cheap one fails. -} - | direction == Download = do - uuids <- Remote.keyLocations k - return $ filter (\r -> uuid r `elem` uuids) rs - {- Upload to all remotes that want the content. -} - | otherwise = filterM (wantSend f . Remote.uuid) $ - filter (not . Remote.readonly) rs - gentransfer r = Transfer - { transferDirection = direction - , transferKey = k - , transferUUID = Remote.uuid r - } - defer - {- Defer this download, as no known remote has the key. -} - | direction == Download = void $ liftIO $ atomically $ - modifyTVar' (deferreddownloads q) $ - \l -> (k, f):l - | otherwise = noop + where + go = do + rs <- liftAnnex . sufficientremotes + =<< syncRemotes <$> getDaemonStatus + let matchingrs = filter (matching . Remote.uuid) rs + if null matchingrs + then defer + else forM_ matchingrs $ \r -> + enqueue schedule (gentransfer r) (stubInfo f r) + sufficientremotes rs + {- Queue downloads from all remotes that + - have the key, with the cheapest ones first. + - More expensive ones will only be tried if + - downloading from a cheap one fails. -} + | direction == Download = do + uuids <- Remote.keyLocations k + return $ filter (\r -> uuid r `elem` uuids) rs + {- Upload to all remotes that want the content. -} + | otherwise = filterM (wantSend f . Remote.uuid) $ + filter (not . Remote.readonly) rs + gentransfer r = Transfer + { transferDirection = direction + , transferKey = k + , transferUUID = Remote.uuid r + } + defer + {- Defer this download, as no known remote has the key. -} + | direction == Download = do + q <- getAssistant transferQueue + void $ liftIO $ atomically $ + modifyTVar' (deferreddownloads q) $ + \l -> (k, f):l + | otherwise = noop {- Queues any deferred downloads that can now be accomplished, leaving - any others in the list to try again later. -} -queueDeferredDownloads :: Schedule -> TransferQueue -> DaemonStatusHandle -> Annex () -queueDeferredDownloads schedule q dstatus = do +queueDeferredDownloads :: Schedule -> Assistant () +queueDeferredDownloads schedule = do + q <- getAssistant transferQueue l <- liftIO $ atomically $ swapTVar (deferreddownloads q) [] - rs <- syncRemotes <$> liftIO (getDaemonStatusOld dstatus) + rs <- syncRemotes <$> getDaemonStatus left <- filterM (queue rs) l unless (null left) $ liftIO $ atomically $ modifyTVar' (deferreddownloads q) $ \new -> new ++ left - where - queue rs (k, f) = do - uuids <- Remote.keyLocations k - let sources = filter (\r -> uuid r `elem` uuids) rs - unless (null sources) $ - forM_ sources $ \r -> liftIO $ - enqueue schedule q dstatus - (gentransfer r) (stubInfo f r) - return $ null sources - where - gentransfer r = Transfer - { transferDirection = Download - , transferKey = k - , transferUUID = Remote.uuid r - } + where + queue rs (k, f) = do + uuids <- liftAnnex $ Remote.keyLocations k + let sources = filter (\r -> uuid r `elem` uuids) rs + unless (null sources) $ + forM_ sources $ \r -> + enqueue schedule (gentransfer r) (stubInfo f r) + return $ null sources + where + gentransfer r = Transfer + { transferDirection = Download + , transferKey = k + , transferUUID = Remote.uuid r + } -enqueue :: Schedule -> TransferQueue -> DaemonStatusHandle -> Transfer -> TransferInfo -> IO () -enqueue schedule q dstatus t info +enqueue :: Schedule -> Transfer -> TransferInfo -> Assistant () +enqueue schedule t info | schedule == Next = go (new:) | otherwise = go (\l -> l++[new]) - where - new = (t, info) - go modlist = do - atomically $ do - void $ modifyTVar' (queuesize q) succ - void $ modifyTVar' (queuelist q) modlist - void $ notifyTransferOld dstatus + where + new = (t, info) + go modlist = do + q <- getAssistant transferQueue + liftIO $ atomically $ do + void $ modifyTVar' (queuesize q) succ + void $ modifyTVar' (queuelist q) modlist + notifyTransfer {- Adds a transfer to the queue. -} -queueTransfer :: Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO () -queueTransfer schedule q dstatus f t remote = - enqueue schedule q dstatus t (stubInfo f remote) +queueTransfer :: Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant () +queueTransfer schedule f t remote = enqueue schedule t (stubInfo f remote) {- Blocks until the queue is no larger than a given size, and then adds a - transfer to the queue. -} -queueTransferAt :: Int -> Schedule -> TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO () -queueTransferAt wantsz schedule q dstatus f t remote = do - atomically $ do +queueTransferAt :: Int -> Schedule -> AssociatedFile -> Transfer -> Remote -> Assistant () +queueTransferAt wantsz schedule f t remote = do + q <- getAssistant transferQueue + liftIO $ atomically $ do sz <- readTVar (queuesize q) unless (sz <= wantsz) $ retry -- blocks until queuesize changes - enqueue schedule q dstatus t (stubInfo f remote) + enqueue schedule t (stubInfo f remote) -queueTransferWhenSmall :: TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO () +queueTransferWhenSmall :: AssociatedFile -> Transfer -> Remote -> Assistant () queueTransferWhenSmall = queueTransferAt 10 Later {- Blocks until a pending transfer is available in the queue, @@ -151,38 +153,45 @@ queueTransferWhenSmall = queueTransferAt 10 Later - - This is done in a single STM transaction, so there is no window - where an observer sees an inconsistent status. -} -getNextTransfer :: TransferQueue -> DaemonStatusHandle -> (TransferInfo -> Bool) -> IO (Maybe (Transfer, TransferInfo)) -getNextTransfer q dstatus acceptable = atomically $ do - sz <- readTVar (queuesize q) - if sz < 1 - then retry -- blocks until queuesize changes - else do - (r@(t,info):rest) <- readTVar (queuelist q) - writeTVar (queuelist q) rest - void $ modifyTVar' (queuesize q) pred - if acceptable info - then do - adjustTransfersSTM dstatus $ - M.insertWith' const t info - return $ Just r - else return Nothing +getNextTransfer :: (TransferInfo -> Bool) -> Assistant (Maybe (Transfer, TransferInfo)) +getNextTransfer acceptable = do + q <- getAssistant transferQueue + dstatus <- getAssistant daemonStatusHandle + liftIO $ atomically $ do + sz <- readTVar (queuesize q) + if sz < 1 + then retry -- blocks until queuesize changes + else do + (r@(t,info):rest) <- readTVar (queuelist q) + writeTVar (queuelist q) rest + void $ modifyTVar' (queuesize q) pred + if acceptable info + then do + adjustTransfersSTM dstatus $ + M.insertWith' const t info + return $ Just r + else return Nothing {- Moves transfers matching a condition from the queue, to the - currentTransfers map. -} -getMatchingTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) -> IO [(Transfer, TransferInfo)] -getMatchingTransfers q dstatus c = atomically $ do - ts <- dequeueTransfersSTM q c - unless (null ts) $ - adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts - return ts +getMatchingTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)] +getMatchingTransfers c = do + q <- getAssistant transferQueue + dstatus <- getAssistant daemonStatusHandle + liftIO $ atomically $ do + ts <- dequeueTransfersSTM q c + unless (null ts) $ + adjustTransfersSTM dstatus $ \m -> M.union m $ M.fromList ts + return ts {- Removes transfers matching a condition from the queue, and returns the - removed transfers. -} -dequeueTransfers :: TransferQueue -> DaemonStatusHandle -> (Transfer -> Bool) -> IO [(Transfer, TransferInfo)] -dequeueTransfers q dstatus c = do - removed <- atomically $ dequeueTransfersSTM q c +dequeueTransfers :: (Transfer -> Bool) -> Assistant [(Transfer, TransferInfo)] +dequeueTransfers c = do + q <- getAssistant transferQueue + removed <- liftIO $ atomically $ dequeueTransfersSTM q c unless (null removed) $ - notifyTransferOld dstatus + notifyTransfer return removed dequeueTransfersSTM :: TransferQueue -> (Transfer -> Bool) -> STM [(Transfer, TransferInfo)] diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 8afd23a124..80a062e365 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -17,7 +17,7 @@ import qualified Control.Exception as E import Control.Concurrent import qualified Control.Concurrent.MSemN as MSemN -type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, IO ())) +type TransferGenerator = Assistant (Maybe (Transfer, TransferInfo, Assistant ())) {- Waits until a transfer slot becomes available, then runs a - TransferGenerator, and then runs the transfer action in its own thread. @@ -44,26 +44,30 @@ inImmediateTransferSlot gen = do - then pausing the thread until a ResumeTransfer exception is raised, - then rerunning the action. -} -runTransferThread :: Maybe (Transfer, TransferInfo, IO ()) -> Assistant () +runTransferThread :: Maybe (Transfer, TransferInfo, Assistant ()) -> Assistant () runTransferThread Nothing = flip MSemN.signal 1 <<~ transferSlots runTransferThread (Just (t, info, a)) = do d <- getAssistant id - tid <- liftIO $ forkIO $ go d + aio <- asIO a + tid <- liftIO $ forkIO $ runTransferThread' d aio updateTransferInfo t $ info { transferTid = Just tid } + +runTransferThread' :: AssistantData -> IO () -> IO () +runTransferThread' d a = go where - go d = catchPauseResume d a - pause d = catchPauseResume d $ runEvery (Seconds 86400) noop + go = catchPauseResume a + pause = catchPauseResume $ runEvery (Seconds 86400) noop {- Note: This must use E.try, rather than E.catch. - When E.catch is used, and has called go in its exception - handler, Control.Concurrent.throwTo will block sometimes - when signaling. Using E.try avoids the problem. -} - catchPauseResume d a' = do + catchPauseResume a' = do r <- E.try a' :: IO (Either E.SomeException ()) case r of Left e -> case E.fromException e of - Just PauseTransfer -> pause d - Just ResumeTransfer -> go d - _ -> done d - _ -> done d - done d = flip runAssistant d $ + Just PauseTransfer -> pause + Just ResumeTransfer -> go + _ -> done + _ -> done + done = flip runAssistant d $ flip MSemN.signal 1 <<~ transferSlots diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs index 7cfea81198..16a07ee711 100644 --- a/Assistant/WebApp.hs +++ b/Assistant/WebApp.hs @@ -71,11 +71,8 @@ newWebAppState = do { showIntro = True , otherRepos = otherrepos } -getAssistantY :: forall sub a. (AssistantData -> a) -> GHandler sub WebApp a -getAssistantY f = f <$> (assistantData <$> getYesod) - -runAssistantY :: forall sub a. (Assistant a) -> GHandler sub WebApp a -runAssistantY a = liftIO . runAssistant a =<< assistantData <$> getYesod +liftAssistant :: forall sub a. (Assistant a) -> GHandler sub WebApp a +liftAssistant a = liftIO . runAssistant a =<< assistantData <$> getYesod getWebAppState :: forall sub. GHandler sub WebApp WebAppState getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod @@ -95,7 +92,7 @@ modifyWebAppState a = go =<< webAppState <$> getYesod runAnnex :: forall sub a. a -> Annex a -> GHandler sub WebApp a runAnnex fallback a = ifM (noAnnex <$> getYesod) ( return fallback - , runAssistantY $ liftAnnex a + , liftAssistant $ liftAnnex a ) waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp () @@ -109,7 +106,7 @@ newNotifier selector = do liftIO $ notificationHandleToId <$> newNotificationHandle notifier getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster -getNotifier selector = selector <$> runAssistantY getDaemonStatus +getNotifier selector = selector <$> liftAssistant getDaemonStatus {- Adds the auth parameter as a hidden field on a form. Must be put into - every form. -} diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs index 1e5489be9e..449c401734 100644 --- a/Assistant/WebApp/Configurators.hs +++ b/Assistant/WebApp/Configurators.hs @@ -102,7 +102,7 @@ repoList onlyconfigured includehere where configured = do rs <- filter (not . Remote.readonly) . syncRemotes - <$> runAssistantY getDaemonStatus + <$> liftAssistant getDaemonStatus runAnnex [] $ do u <- getUUID let l = map Remote.uuid rs diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs index 8505f5b5e2..5e4559205f 100644 --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -77,7 +77,7 @@ setRepoConfig uuid mremote oldc newc = do , Param name ] void $ Remote.remoteListRefresh - runAssistantY updateSyncRemotes + liftAssistant updateSyncRemotes editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig editRepositoryAForm def = RepoConfig diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index b872c0d17c..6005d0635c 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -87,17 +87,15 @@ getInprogressPairR _ = noPairing -} startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget startPairing stage oncancel alert muuid displaysecret secret = do - dstatus <- lift $ getAssistantY daemonStatusHandle urlrender <- lift getUrlRender reldir <- fromJust . relDir <$> lift getYesod - sendrequests <- lift $ runAssistantY $ asIO2 $ mksendrequests urlrender - + sendrequests <- lift $ liftAssistant $ asIO2 $ mksendrequests urlrender {- Generating a ssh key pair can take a while, so do it in the - background. -} - void $ liftIO $ forkIO $ do - keypair <- genSshKeyPair - pairdata <- PairData + thread <- lift $ liftAssistant $ asIO $ do + keypair <- liftIO $ genSshKeyPair + pairdata <- liftIO $ PairData <$> getHostname <*> myUserName <*> pure reldir @@ -105,7 +103,8 @@ startPairing stage oncancel alert muuid displaysecret secret = do <*> (maybe genUUID return muuid) let sender = multicastPairMsg Nothing secret pairdata let pip = PairingInProgress secret Nothing keypair pairdata stage - startSending dstatus pip stage $ sendrequests sender + startSending pip stage $ sendrequests sender + void $ liftIO $ forkIO thread lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret where diff --git a/Assistant/WebApp/Configurators/S3.hs b/Assistant/WebApp/Configurators/S3.hs index 9913ac0c20..c1292a248d 100644 --- a/Assistant/WebApp/Configurators/S3.hs +++ b/Assistant/WebApp/Configurators/S3.hs @@ -117,9 +117,9 @@ makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> H makeS3Remote (S3Creds ak sk) name setup config = do remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0 liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk) - r <- runAssistantY $ liftAnnex $ addRemote $ do + r <- liftAssistant $ liftAnnex $ addRemote $ do makeSpecialRemote name S3.remote config return remotename setup r - runAssistantY $ syncNewRemote r + liftAssistant $ syncNewRemote r redirect $ EditNewCloudRepositoryR $ Remote.uuid r diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index e0a4446827..2bef5c0e28 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -283,7 +283,7 @@ makeSsh' rsync setup sshdata keypair = makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml makeSshRepo forcersync setup sshdata = do - r <- runAssistantY $ makeSshRemote forcersync sshdata + r <- liftAssistant $ makeSshRemote forcersync sshdata setup r redirect $ EditNewCloudRepositoryR $ Remote.uuid r diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index dc75d5a296..8dc6924ceb 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -35,8 +35,8 @@ import qualified Data.Text as T xmppNeeded :: Handler () xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do urlrender <- getUrlRender - void $ runAssistantY $ do - close <- asIO removeAlert + void $ liftAssistant $ do + close <- asIO1 removeAlert addAlert $ xmppNeededAlert $ AlertButton { buttonLabel = "Configure a Jabber account" , buttonUrl = urlrender XMPPR @@ -60,7 +60,7 @@ getXMPPR = xmppPage $ do where storecreds creds = do void $ runAnnex undefined $ setXMPPCreds creds - runAssistantY notifyRestart + liftAssistant notifyRestart redirect ConfigR #else getXMPPR = xmppPage $ diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs index 4eb786518f..7ef9a25797 100644 --- a/Assistant/WebApp/DashBoard.hs +++ b/Assistant/WebApp/DashBoard.hs @@ -37,9 +37,8 @@ import Control.Concurrent transfersDisplay :: Bool -> Widget transfersDisplay warnNoScript = do webapp <- lift getYesod - d <- lift $ getAssistantY id current <- lift $ M.toList <$> getCurrentTransfers - queued <- liftIO $ getTransferQueue $ transferQueue d + queued <- lift $ liftAssistant getTransferQueue autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int) let transfers = simplifyTransfers $ current ++ queued if null transfers diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs index 86f3da832e..f367a20efc 100644 --- a/Assistant/WebApp/SideBar.hs +++ b/Assistant/WebApp/SideBar.hs @@ -28,7 +28,7 @@ sideBarDisplay = do let content = do {- Add newest alerts to the sidebar. -} alertpairs <- lift $ M.toList . alertMap - <$> runAssistantY getDaemonStatus + <$> liftAssistant getDaemonStatus mapM_ renderalert $ take displayAlerts $ reverse $ sortAlertPairs alertpairs let ident = "sidebar" @@ -73,12 +73,12 @@ getSideBarR nid = do {- Called by the client to close an alert. -} getCloseAlert :: AlertId -> Handler () -getCloseAlert = runAssistantY . removeAlert +getCloseAlert = liftAssistant . removeAlert {- When an alert with a button is clicked on, the button takes us here. -} getClickAlert :: AlertId -> Handler () getClickAlert i = do - m <- alertMap <$> runAssistantY getDaemonStatus + m <- alertMap <$> liftAssistant getDaemonStatus case M.lookup i m of Just (Alert { alertButton = Just b }) -> do {- Spawn a thread to run the action while redirecting. -} diff --git a/Assistant/WebApp/Utility.hs b/Assistant/WebApp/Utility.hs index 8f659e0cce..1163b4e151 100644 --- a/Assistant/WebApp/Utility.hs +++ b/Assistant/WebApp/Utility.hs @@ -36,15 +36,13 @@ changeSyncable (Just r) True = do syncRemote r changeSyncable (Just r) False = do changeSyncFlag r False - d <- getAssistantY id - let dstatus = daemonStatusHandle d - runAssistantY $ updateSyncRemotes + liftAssistant $ updateSyncRemotes {- Stop all transfers to or from this remote. - XXX Can't stop any ongoing scan, or git syncs. -} - void $ liftIO $ dequeueTransfers (transferQueue d) dstatus tofrom + void $ liftAssistant $ dequeueTransfers tofrom mapM_ (cancelTransfer False) =<< filter tofrom . M.keys <$> - runAssistantY (currentTransfers <$> getDaemonStatus) + liftAssistant (currentTransfers <$> getDaemonStatus) where tofrom t = transferUUID t == Remote.uuid r @@ -60,24 +58,21 @@ changeSyncFlag r enabled = runAnnex undefined $ do {- Start syncing remote, using a background thread. -} syncRemote :: Remote -> Handler () -syncRemote = runAssistantY . syncNewRemote +syncRemote = liftAssistant . syncNewRemote pauseTransfer :: Transfer -> Handler () pauseTransfer = cancelTransfer True cancelTransfer :: Bool -> Transfer -> Handler () cancelTransfer pause t = do - tq <- getAssistantY transferQueue m <- getCurrentTransfers - dstatus <- getAssistantY daemonStatusHandle - unless pause $ liftIO $ + unless pause $ {- remove queued transfer -} - void $ dequeueTransfers tq dstatus $ - equivilantTransfer t + void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t {- stop running transfer -} maybe noop stop (M.lookup t m) where - stop info = runAssistantY $ do + stop info = liftAssistant $ do {- When there's a thread associated with the - transfer, it's signaled first, to avoid it - displaying any alert about the transfer having @@ -107,18 +102,16 @@ startTransfer t = do where go info = maybe (start info) resume $ transferTid info startqueued = do - dstatus <- getAssistantY daemonStatusHandle - q <- getAssistantY transferQueue - is <- liftIO $ map snd <$> getMatchingTransfers q dstatus (== t) + is <- liftAssistant $ map snd <$> getMatchingTransfers (== t) maybe noop start $ headMaybe is resume tid = do - runAssistantY $ alterTransferInfo t $ + liftAssistant $ alterTransferInfo t $ \i -> i { transferPaused = False } liftIO $ throwTo tid ResumeTransfer - start info = runAssistantY $ do + start info = liftAssistant $ do program <- liftIO readProgramFile inImmediateTransferSlot $ Transferrer.startTransfer program t info getCurrentTransfers :: Handler TransferMap -getCurrentTransfers = currentTransfers <$> runAssistantY getDaemonStatus +getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus