summaryrefslogtreecommitdiff
path: root/Assistant/Threads
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/Threads')
-rw-r--r--Assistant/Threads/Committer.hs2
-rw-r--r--Assistant/Threads/Merger.hs2
-rw-r--r--Assistant/Threads/NetWatcher.hs4
-rw-r--r--Assistant/Threads/PairListener.hs11
-rw-r--r--Assistant/Threads/Pusher.hs41
-rw-r--r--Assistant/Threads/TransferScanner.hs4
-rw-r--r--Assistant/Threads/TransferWatcher.hs2
-rw-r--r--Assistant/Threads/Transferrer.hs2
-rw-r--r--Assistant/Threads/Watcher.hs8
-rw-r--r--Assistant/Threads/WebApp.hs9
10 files changed, 40 insertions, 45 deletions
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index fcf205311..43bb7b03d 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -132,7 +132,7 @@ handleAdds st changechan transferqueue dstatus cs = returnWhen (null pendingadds
returnWhen (null toadd) $ do
added <- catMaybes <$> forM toadd add
- if (DirWatcher.eventsCoalesce || null added)
+ if DirWatcher.eventsCoalesce || null added
then return $ added ++ otherchanges
else do
r <- handleAdds st changechan transferqueue dstatus
diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs
index 663ea40ff..9ed744808 100644
--- a/Assistant/Threads/Merger.hs
+++ b/Assistant/Threads/Merger.hs
@@ -44,7 +44,7 @@ type Handler = Git.Repo -> FilePath -> Maybe FileStatus -> IO ()
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: Git.Repo -> Handler -> FilePath -> Maybe FileStatus -> IO ()
-runHandler g handler file filestatus = void $ do
+runHandler g handler file filestatus = void $
either print (const noop) =<< tryIO go
where
go = handler g file filestatus
diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs
index b52657990..e9af2a53b 100644
--- a/Assistant/Threads/NetWatcher.hs
+++ b/Assistant/Threads/NetWatcher.hs
@@ -34,7 +34,7 @@ thisThread :: ThreadName
thisThread = "NetWatcher"
netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
-netWatcherThread st dstatus scanremotes = thread $ do
+netWatcherThread st dstatus scanremotes = thread $
#if WITH_DBUS
dbusThread st dstatus scanremotes
#else
@@ -49,7 +49,7 @@ netWatcherThread st dstatus scanremotes = thread $ do
- while (despite the local network staying up), are synced with
- periodically. -}
netWatcherFallbackThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
-netWatcherFallbackThread st dstatus scanremotes = thread $ do
+netWatcherFallbackThread st dstatus scanremotes = thread $
runEvery (Seconds 3600) $
handleConnection st dstatus scanremotes
where
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 746d88a96..9ce369032 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -50,7 +50,7 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
else do
pairReqReceived verified dstatus urlrenderer m
go sock (m:take 10 reqs) (invalidateCache m cache)
- (_, _, PairAck) -> do
+ (_, _, PairAck) ->
pairAckReceived verified pip st dstatus scanremotes m cache
>>= go sock reqs
(_, _, PairDone) -> do
@@ -65,8 +65,8 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
-}
verificationCheck m (Just pip) = do
let verified = verifiedPairMsg m pip
- let sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData $ m)
- if (not verified && sameuuid)
+ let sameuuid = pairUUID (inProgressPairData pip) == pairUUID (pairMsgData m)
+ if not verified && sameuuid
then do
runThreadState st $
warning "detected possible pairing brute force attempt; disabled pairing"
@@ -88,8 +88,7 @@ pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $
{- PairReqs invalidate the cache of recently finished pairings.
- This is so that, if a new pairing is started with the
- same secret used before, a bogus PairDone is not sent. -}
- invalidateCache msg =
- filter (\pip -> not $ verifiedPairMsg msg pip)
+ invalidateCache msg = filter (not . verifiedPairMsg msg)
getmsg sock c = do
(msg, n, _) <- recvFrom sock chunksz
@@ -124,7 +123,7 @@ pairAckReceived True (Just pip) st dstatus scanremotes msg cache = do
finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
startSending dstatus pip PairDone $ multicastPairMsg
(Just 1) (inProgressSecret pip) (inProgressPairData pip)
- return $ pip:(take 10 cache)
+ return $ pip : take 10 cache
{- A stale PairAck might also be seen, after we've finished pairing.
- Perhaps our PairDone was not received. To handle this, we keep
- a cache of recently finished pairings, and re-send PairDone in
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index dbe968cd7..dee563d74 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/Assistant/Threads/Pusher.hs
@@ -44,27 +44,26 @@ pushRetryThread st dstatus pushmap = thread $ runEvery (Seconds halfhour) $ do
{- This thread pushes git commits out to remotes soon after they are made. -}
pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> NamedThread
-pushThread st dstatus commitchan pushmap = thread $ do
- runEvery (Seconds 2) $ do
- -- We already waited two seconds as a simple rate limiter.
- -- Next, wait until at least one commit has been made
- commits <- getCommits commitchan
- -- Now see if now's a good time to push.
- now <- getCurrentTime
- if shouldPush now commits
- then do
- remotes <- filter pushable . knownRemotes
- <$> getDaemonStatus dstatus
- unless (null remotes) $
- void $ alertWhile dstatus (pushAlert remotes) $
- pushToRemotes thisThread now st (Just pushmap) remotes
- else do
- debug thisThread
- [ "delaying push of"
- , show (length commits)
- , "commits"
- ]
- refillCommits commitchan commits
+pushThread st dstatus commitchan pushmap = thread $ runEvery (Seconds 2) $ do
+ -- We already waited two seconds as a simple rate limiter.
+ -- Next, wait until at least one commit has been made
+ commits <- getCommits commitchan
+ -- Now see if now's a good time to push.
+ now <- getCurrentTime
+ if shouldPush now commits
+ then do
+ remotes <- filter pushable . knownRemotes
+ <$> getDaemonStatus dstatus
+ unless (null remotes) $
+ void $ alertWhile dstatus (pushAlert remotes) $
+ pushToRemotes thisThread now st (Just pushmap) remotes
+ else do
+ debug thisThread
+ [ "delaying push of"
+ , show (length commits)
+ , "commits"
+ ]
+ refillCommits commitchan commits
where
thread = NamedThread thisThread
pushable r
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index ecb9021f0..d8719f027 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -43,7 +43,7 @@ transferScannerThread st dstatus scanremotes transferqueue = thread $ do
if any fullScan infos || any (`S.notMember` scanned) rs
then do
expensiveScan st dstatus transferqueue rs
- go (S.union scanned (S.fromList rs))
+ go $ scanned `S.union` S.fromList rs
else do
mapM_ (failedTransferScan st dstatus transferqueue) rs
go scanned
@@ -129,7 +129,7 @@ expensiveScan st dstatus transferqueue rs = unless onlyweb $ do
)
check direction want key locs r
| direction == Upload && Remote.readonly r = Nothing
- | (Remote.uuid r `elem` locs) == want = Just $
+ | (Remote.uuid r `elem` locs) == want = Just
(r, Transfer direction (Remote.uuid r) key)
| otherwise = Nothing
diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs
index be15aef24..9ae4eb365 100644
--- a/Assistant/Threads/TransferWatcher.hs
+++ b/Assistant/Threads/TransferWatcher.hs
@@ -43,7 +43,7 @@ type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus
- Exceptions are ignored, otherwise a whole thread could be crashed.
-}
runHandler :: ThreadState -> DaemonStatusHandle -> Handler -> FilePath -> Maybe FileStatus -> IO ()
-runHandler st dstatus handler file filestatus = void $ do
+runHandler st dstatus handler file filestatus = void $
either print (const noop) =<< tryIO go
where
go = handler st dstatus file filestatus
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 3c1c44b9d..a38fa2ccc 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/Assistant/Threads/Transferrer.hs
@@ -38,7 +38,7 @@ transfererThread st dstatus transferqueue slots = thread $ go =<< readProgramFil
maybe (return Nothing) (uncurry $ startTransfer st dstatus program)
=<< getNextTransfer transferqueue dstatus notrunning
{- Skip transfers that are already running. -}
- notrunning i = startedTime i == Nothing
+ notrunning = isNothing . startedTime
{- By the time this is called, the daemonstatus's transfer map should
- already have been updated to include the transfer. -}
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index 3054c50e1..17ec0b81f 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/Assistant/Threads/Watcher.hs
@@ -44,7 +44,7 @@ thisThread = "Watcher"
checkCanWatch :: Annex ()
checkCanWatch
| canWatch =
- unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force) $
+ unlessM (liftIO (inPath "lsof") <||> Annex.getState Annex.force)
needLsof
| otherwise = error "watch mode is not available on this system"
@@ -75,7 +75,7 @@ watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do
startupScan :: ThreadState -> DaemonStatusHandle -> IO a -> IO a
startupScan st dstatus scanner = do
runThreadState st $ showAction "scanning"
- r <- alertWhile' dstatus startupScanAlert $ do
+ alertWhile' dstatus startupScanAlert $ do
r <- scanner
-- Notice any files that were deleted before
@@ -88,8 +88,6 @@ startupScan st dstatus scanner = do
return (True, r)
- return r
-
ignored :: FilePath -> Bool
ignored = ig . takeFileName
where
@@ -135,7 +133,7 @@ runHandler threadname st dstatus transferqueue changechan handler file filestatu
-}
onAdd :: Handler
onAdd threadname file filestatus dstatus _
- | maybe False isRegularFile filestatus = do
+ | maybe False isRegularFile filestatus =
ifM (scanComplete <$> liftIO (getDaemonStatus dstatus))
( go
, ifM (null <$> inRepo (Git.LsFiles.notInRepo False [file]))
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 1bab94b0f..646734776 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -44,7 +44,7 @@ mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
type Url = String
webAppThread
- :: (Maybe ThreadState)
+ :: Maybe ThreadState
-> DaemonStatusHandle
-> ScanRemoteMap
-> TransferQueue
@@ -71,10 +71,9 @@ webAppThread mst dstatus scanremotes transferqueue transferslots urlrenderer pos
( return $ httpDebugLogger app
, return app
)
- runWebApp app' $ \port -> do
- case mst of
- Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
- Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
+ runWebApp app' $ \port -> case mst of
+ Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
+ Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
where
thread = NamedThread thisThread
getreldir Nothing = return Nothing
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-07 09:39:41 +0000