diff options
Diffstat (limited to 'Assistant/Threads')
-rw-r--r-- | Assistant/Threads/Committer.hs | 25 | ||||
-rw-r--r-- | Assistant/Threads/ConfigMonitor.hs | 4 | ||||
-rw-r--r-- | Assistant/Threads/Glacier.hs | 2 | ||||
-rw-r--r-- | Assistant/Threads/Merger.hs | 4 | ||||
-rw-r--r-- | Assistant/Threads/MountWatcher.hs | 6 | ||||
-rw-r--r-- | Assistant/Threads/SanityChecker.hs | 4 | ||||
-rw-r--r-- | Assistant/Threads/TransferScanner.hs | 8 | ||||
-rw-r--r-- | Assistant/Threads/TransferWatcher.hs | 9 | ||||
-rw-r--r-- | Assistant/Threads/Transferrer.hs | 4 | ||||
-rw-r--r-- | Assistant/Threads/Watcher.hs | 16 | ||||
-rw-r--r-- | Assistant/Threads/XMPPClient.hs | 24 |
11 files changed, 52 insertions, 54 deletions
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 445f4753b..695703e22 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -112,7 +112,7 @@ waitChangeTime a = waitchanges 0 - that make up a file rename? Or some of the pairs that make up - a directory rename? -} - possiblyrename cs = all renamepart cs + possiblyrename = all renamepart renamepart (PendingAddChange _ _) = True renamepart c = isRmChange c @@ -309,7 +309,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do inRepo (Git.LsFiles.notInRepo False $ map changeFile pending) -- note: timestamp info is lost here let ts = changeTime exemplar - return (map (PendingAddChange ts) newfiles, void $ liftIO $ cleanup) + return (map (PendingAddChange ts) newfiles, void $ liftIO cleanup) returnWhen c a | c = return otherchanges @@ -317,12 +317,13 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do add :: Change -> Assistant (Maybe Change) add change@(InProcessAddChange { keySource = ks }) = - catchDefaultIO Nothing <~> do - sanitycheck ks $ do - (mkey, mcache) <- liftAnnex $ do - showStart "add" $ keyFilename ks - Command.Add.ingest $ Just ks - maybe (failedingest change) (done change mcache $ keyFilename ks) mkey + catchDefaultIO Nothing <~> doadd + where + doadd = sanitycheck ks $ do + (mkey, mcache) <- liftAnnex $ do + showStart "add" $ keyFilename ks + Command.Add.ingest $ Just ks + maybe (failedingest change) (done change mcache $ keyFilename ks) mkey add _ = return Nothing {- In direct mode, avoid overhead of re-injesting a renamed @@ -371,7 +372,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do ( inRepo $ gitAnnexLink file key , Command.Add.link file key mcache ) - whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do + whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ stageSymlink file =<< hashSymlink link showEndOk return $ Just $ finishedChange change key @@ -415,8 +416,8 @@ safeToAdd _ [] [] = return [] safeToAdd delayadd pending inprocess = do maybe noop (liftIO . threadDelaySeconds) delayadd liftAnnex $ do - keysources <- mapM Command.Add.lockDown (map changeFile pending) - let inprocess' = inprocess ++ catMaybes (map mkinprocess $ zip pending keysources) + keysources <- forM pending $ Command.Add.lockDown . changeFile + let inprocess' = inprocess ++ mapMaybe mkinprocess (zip pending keysources) openfiles <- S.fromList . map fst3 . filter openwrite <$> findopenfiles (map keySource inprocess') let checked = map (check openfiles) inprocess' @@ -434,7 +435,7 @@ safeToAdd delayadd pending inprocess = do | S.member (contentLocation ks) openfiles = Left change check _ change = Right change - mkinprocess (c, Just ks) = Just $ InProcessAddChange + mkinprocess (c, Just ks) = Just InProcessAddChange { changeTime = changeTime c , keySource = ks } diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index 6a01ff35e..3d8be476e 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -54,7 +54,7 @@ type Configs = S.Set (FilePath, String) {- All git-annex's config files, and actions to run when they change. -} configFilesActions :: [(FilePath, Annex ())] configFilesActions = - [ (uuidLog, void $ uuidMapLoad) + [ (uuidLog, void uuidMapLoad) , (remoteLog, void remoteListRefresh) , (trustLog, void trustMapLoad) , (groupLog, void groupMapLoad) @@ -71,7 +71,7 @@ reloadConfigs changedconfigs = do {- Changes to the remote log, or the trust log, can affect the - syncRemotes list. Changes to the uuid log may affect its - display so are also included. -} - when (any (`elem` fs) [remoteLog, trustLog, uuidLog]) $ + when (any (`elem` fs) [remoteLog, trustLog, uuidLog]) updateSyncRemotes where (fs, as) = unzip $ filter (flip S.member changedfiles . fst) diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs index 46f64cd56..4c4012a67 100644 --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -30,7 +30,7 @@ glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go go = do rs <- filter isglacier . syncDataRemotes <$> getDaemonStatus forM_ rs $ \r -> - check r =<< (liftAnnex $ getFailedTransfers $ Remote.uuid r) + check r =<< liftAnnex (getFailedTransfers $ Remote.uuid r) check _ [] = noop check r l = do let keys = map getkey l diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 650293e4b..3f4fcb0cc 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -54,7 +54,7 @@ runHandler handler file _filestatus = {- Called when there's an error with inotify. -} onErr :: Handler -onErr msg = error msg +onErr = error {- Called when a new branch ref is written, or a branch ref is modified. - @@ -110,7 +110,7 @@ equivBranches x y = base x == base y isAnnexBranch :: FilePath -> Bool isAnnexBranch f = n `isSuffixOf` f where - n = "/" ++ show Annex.Branch.name + n = '/' : show Annex.Branch.name fileToBranch :: FilePath -> Git.Ref fileToBranch f = Git.Ref $ "refs" </> base diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 970585b42..c18bfb5bd 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -34,7 +34,7 @@ import qualified Control.Exception as E #endif mountWatcherThread :: NamedThread -mountWatcherThread = namedThread "MountWatcher" $ +mountWatcherThread = namedThread "MountWatcher" #if WITH_DBUS dbusThread #else @@ -173,10 +173,10 @@ remotesUnder dir = do rs <- liftAnnex remoteList pairs <- liftAnnex $ mapM (checkremote repotop) rs let (waschanged, rs') = unzip pairs - when (any id waschanged) $ do + when (or waschanged) $ do liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = catMaybes rs' } updateSyncRemotes - return $ catMaybes $ map snd $ filter fst pairs + return $ mapMaybe snd $ filter fst pairs where checkremote repotop r = case Remote.localpath r of Just p | dirContains dir (absPathFrom repotop p) -> diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 0c97a9e8f..64fbc2fb6 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -42,7 +42,7 @@ sanityCheckerDailyThread = namedThread "SanityCheckerDaily" $ forever $ do go = do modifyDaemonStatus_ $ \s -> s { sanityCheckRunning = True } - now <- liftIO $ getPOSIXTime -- before check started + now <- liftIO getPOSIXTime -- before check started r <- either showerr return =<< (tryIO . batch) <~> dailyCheck modifyDaemonStatus_ $ \s -> s @@ -78,7 +78,7 @@ dailyCheck = do -- Find old unstaged symlinks, and add them to git. (unstaged, cleanup) <- liftIO $ Git.LsFiles.notInRepo False ["."] g - now <- liftIO $ getPOSIXTime + now <- liftIO getPOSIXTime forM_ unstaged $ \file -> do ms <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus file case ms of diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 631310987..ba302d6bb 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -85,13 +85,13 @@ failedTransferScan r = do mapM_ retry failed where retry (t, info) - | transferDirection t == Download = do + | transferDirection t == Download = {- Check if the remote still has the key. - If not, relies on the expensiveScan to - get it queued from some other remote. -} whenM (liftAnnex $ remoteHas r $ transferKey t) $ requeue t info - | otherwise = do + | otherwise = {- The Transferrer checks when uploading - that the remote doesn't already have the - key, so it's not redundantly checked here. -} @@ -161,7 +161,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do present key (Just f) Nothing liftAnnex $ do let slocs = S.fromList locs - let use a = return $ catMaybes $ map (a key slocs) syncrs + let use a = return $ mapMaybe (a key slocs) syncrs ts <- if present then filterM (wantSend True (Just f) . Remote.uuid . fst) =<< use (genTransfer Upload False) @@ -173,7 +173,7 @@ expensiveScan urlrenderer rs = unless onlyweb $ batch <~> do genTransfer :: Direction -> Bool -> Key -> S.Set UUID -> Remote -> Maybe (Remote, Transfer) genTransfer direction want key slocs r | direction == Upload && Remote.readonly r = Nothing - | (S.member (Remote.uuid r) slocs) == want = Just + | S.member (Remote.uuid r) slocs == want = Just (r, Transfer direction (Remote.uuid r) key) | otherwise = Nothing diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 7045e842d..9bc851d4e 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -51,7 +51,7 @@ runHandler handler file _filestatus = {- Called when there's an error with inotify. -} onErr :: Handler -onErr msg = error msg +onErr = error {- Called when a new transfer information file is written. -} onAdd :: Handler @@ -70,10 +70,9 @@ onAdd file = case parseTransferFile file of - The only thing that should change in the transfer info is the - bytesComplete, so that's the only thing updated in the DaemonStatus. -} onModify :: Handler -onModify file = do - case parseTransferFile file of - Nothing -> noop - Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) +onModify file = case parseTransferFile file of + Nothing -> noop + Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) where go _ Nothing = noop go t (Just newinfo) = alterTransferInfo t $ diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 67a8c2a7b..98f8b6ad7 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -31,7 +31,7 @@ transfererThread :: NamedThread transfererThread = namedThread "Transferrer" $ do program <- liftIO readProgramFile forever $ inTransferSlot program $ - maybe (return Nothing) (uncurry $ genTransfer) + maybe (return Nothing) (uncurry genTransfer) =<< getNextTransfer notrunning where {- Skip transfers that are already running. -} @@ -96,7 +96,7 @@ genTransfer t info = case (transferRemote info, associatedFile info) of True (transferKey t) (associatedFile info) (Just remote) - void $ recordCommit + void recordCommit , whenM (liftAnnex $ isNothing <$> checkTransfer t) $ void $ removeTransfer t ) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index ef8bcd41f..799537deb 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-} +{-# LANGUAGE DeriveDataTypeable, CPP #-} module Assistant.Threads.Watcher ( watchThread, @@ -79,7 +79,7 @@ watchThread = namedThread "Watcher" $ runWatcher :: Assistant () runWatcher = do startup <- asIO1 startupScan - matcher <- liftAnnex $ largeFilesMatcher + matcher <- liftAnnex largeFilesMatcher direct <- liftAnnex isDirect symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig addhook <- hook $ if direct @@ -109,7 +109,7 @@ runWatcher = do waitFor :: WatcherException -> Assistant () -> Assistant () waitFor sig next = do - r <- liftIO $ (E.try pause :: IO (Either E.SomeException ())) + r <- liftIO (E.try pause :: IO (Either E.SomeException ())) case r of Left e -> case E.fromException e of Just s @@ -124,7 +124,7 @@ startupScan :: IO a -> Assistant a startupScan scanner = do liftAnnex $ showAction "scanning" alertWhile' startupScanAlert $ do - r <- liftIO $ scanner + r <- liftIO scanner -- Notice any files that were deleted before -- watching was started. @@ -133,7 +133,7 @@ startupScan scanner = do forM_ fs $ \f -> do liftAnnex $ onDel' f maybe noop recordChange =<< madeChange f RmChange - void $ liftIO $ cleanup + void $ liftIO cleanup liftAnnex $ showAction "started" liftIO $ putStrLn "" @@ -176,7 +176,7 @@ runHandler handler file filestatus = void $ do Right (Just change) -> do -- Just in case the commit thread is not -- flushing the queue fast enough. - liftAnnex $ Annex.Queue.flushWhenFull + liftAnnex Annex.Queue.flushWhenFull recordChange change where normalize f @@ -340,8 +340,8 @@ onDelDir dir _ = do now <- liftIO getCurrentTime recordChanges $ map (\f -> Change now f RmChange) fs - void $ liftIO $ clean - liftAnnex $ Annex.Queue.flushWhenFull + void $ liftIO clean + liftAnnex Annex.Queue.flushWhenFull noChange {- Called when there's an error with inotify or kqueue. -} diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index a90ffb820..ffd487ae1 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -103,9 +103,8 @@ xmppClient urlrenderer d creds = - will also be killed. -} liftIO $ pinger `concurrently` sender `concurrently` receiver - sendnotifications selfjid = forever $ do - a <- inAssistant $ relayNetMessage selfjid - a + sendnotifications selfjid = forever $ + join $ inAssistant $ relayNetMessage selfjid receivenotifications selfjid lasttraffic = forever $ do l <- decodeStanza selfjid <$> getStanza void $ liftIO $ atomically . swapTMVar lasttraffic =<< getCurrentTime @@ -115,7 +114,7 @@ xmppClient urlrenderer d creds = sendpings selfjid lasttraffic = forever $ do putStanza pingstanza - startping <- liftIO $ getCurrentTime + startping <- liftIO getCurrentTime liftIO $ threadDelaySeconds (Seconds 120) t <- liftIO $ atomically $ readTMVar lasttraffic when (t < startping) $ do @@ -154,8 +153,7 @@ xmppClient urlrenderer d creds = , logJid jid , show $ logNetMessage msg' ] - a <- inAssistant $ convertNetMsg msg' selfjid - a + join $ inAssistant $ convertNetMsg msg' selfjid inAssistant $ sentImportantNetMessage msg c resendImportantMessages _ _ = noop @@ -196,7 +194,7 @@ logClient (Client jid) = logJid jid decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent] decodeStanza selfjid s@(ReceivedPresence p) | presenceType p == PresenceError = [ProtocolError s] - | presenceFrom p == Nothing = [Ignorable s] + | isNothing (presenceFrom p) = [Ignorable s] | presenceFrom p == Just selfjid = [Ignorable s] | otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p) where @@ -209,7 +207,7 @@ decodeStanza selfjid s@(ReceivedPresence p) - along with their real meaning. -} impliedp v = [PresenceMessage p, v] decodeStanza selfjid s@(ReceivedMessage m) - | messageFrom m == Nothing = [Ignorable s] + | isNothing (messageFrom m) = [Ignorable s] | messageFrom m == Just selfjid = [Ignorable s] | messageType m == MessageError = [ProtocolError s] | otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)] @@ -241,13 +239,13 @@ relayNetMessage selfjid = do \c -> (baseJID <$> parseJID c) == Just tojid return $ putStanza presenceQuery _ -> return noop - convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> do + convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> if tojid == baseJID tojid then do clients <- maybe [] (S.toList . buddyAssistants) <$> getBuddy (genBuddyKey tojid) <<~ buddyList debug ["exploded undirected message to clients", unwords $ map logClient clients] - return $ forM_ (clients) $ \(Client jid) -> + return $ forM_ clients $ \(Client jid) -> putStanza $ pushMessage pushstage jid selfjid else do debug ["to client:", logJid tojid] @@ -266,7 +264,7 @@ convertNetMsg msg selfjid = convert msg convert (Pushing c pushstage) = withOtherClient selfjid c $ \tojid -> return $ putStanza $ pushMessage pushstage tojid selfjid -withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> (Assistant (XMPP ())) +withOtherClient :: JID -> ClientID -> (JID -> Assistant (XMPP ())) -> Assistant (XMPP ()) withOtherClient selfjid c a = case parseJID c of Nothing -> return noop Just tojid @@ -323,10 +321,10 @@ pairMsgReceived :: UrlRenderer -> PairStage -> UUID -> JID -> JID -> Assistant ( pairMsgReceived urlrenderer PairReq theiruuid selfjid theirjid | baseJID selfjid == baseJID theirjid = autoaccept | otherwise = do - knownjids <- catMaybes . map (parseJID . getXMPPClientID) + knownjids <- mapMaybe (parseJID . getXMPPClientID) . filter isXMPPRemote . syncRemotes <$> getDaemonStatus um <- liftAnnex uuidMap - if any (== baseJID theirjid) knownjids && M.member theiruuid um + if elem (baseJID theirjid) knownjids && M.member theiruuid um then autoaccept else showalert |