hlint
This commit is contained in:
parent
a3913f52e5
commit
df337bb63b
24 changed files with 91 additions and 97 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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]))
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue