summaryrefslogtreecommitdiff
path: root/Assistant/Threads
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-10-02 22:59:07 -0400
committerGravatar Joey Hess <joey@kitenet.net>2013-10-02 22:59:07 -0400
commitc81a8bd68c53348b9e561dc588499452a5a654c7 (patch)
treed1c52c78723784f20c33763c282860878d19f979 /Assistant/Threads
parent0d14a987dc4887de5516497206356652e846c996 (diff)
hlint
Diffstat (limited to 'Assistant/Threads')
-rw-r--r--Assistant/Threads/Committer.hs25
-rw-r--r--Assistant/Threads/ConfigMonitor.hs4
-rw-r--r--Assistant/Threads/Glacier.hs2
-rw-r--r--Assistant/Threads/Merger.hs4
-rw-r--r--Assistant/Threads/MountWatcher.hs6
-rw-r--r--Assistant/Threads/SanityChecker.hs4
-rw-r--r--Assistant/Threads/TransferScanner.hs8
-rw-r--r--Assistant/Threads/TransferWatcher.hs9
-rw-r--r--Assistant/Threads/Transferrer.hs4
-rw-r--r--Assistant/Threads/Watcher.hs16
-rw-r--r--Assistant/Threads/XMPPClient.hs24
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