summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Alert.hs12
-rw-r--r--Assistant/MakeRemote.hs4
-rw-r--r--Assistant/Pairing.hs2
-rw-r--r--Assistant/Pairing/MakeRemote.hs8
-rw-r--r--Assistant/Pairing/Network.hs4
-rw-r--r--Assistant/Ssh.hs13
-rw-r--r--Assistant/Sync.hs12
-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
-rw-r--r--Assistant/TransferQueue.hs5
-rw-r--r--Assistant/TransferSlots.hs4
-rw-r--r--Assistant/WebApp/Configurators.hs2
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs18
21 files changed, 82 insertions, 87 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 118c5e43d..f11ad8f58 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -5,7 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
-{-# LANGUAGE RankNTypes, BangPatterns, OverloadedStrings #-}
+{-# LANGUAGE RankNTypes, OverloadedStrings #-}
module Assistant.Alert where
@@ -227,24 +227,24 @@ activityAlert header dat = baseActivityAlert
}
startupScanAlert :: Alert
-startupScanAlert = activityAlert Nothing $
+startupScanAlert = activityAlert Nothing
[Tensed "Performing" "Performed", "startup scan"]
commitAlert :: Alert
-commitAlert = activityAlert Nothing $
+commitAlert = activityAlert Nothing
[Tensed "Committing" "Committed", "changes to git"]
showRemotes :: [Remote] -> TenseChunk
showRemotes = UnTensed . T.unwords . map (T.pack . Remote.name)
pushAlert :: [Remote] -> Alert
-pushAlert rs = activityAlert Nothing $
+pushAlert rs = activityAlert Nothing
[Tensed "Syncing" "Synced", "with", showRemotes rs]
pushRetryAlert :: [Remote] -> Alert
pushRetryAlert rs = activityAlert
(Just $ tenseWords [Tensed "Retrying" "Retried", "sync"])
- (["with", showRemotes rs])
+ ["with", showRemotes rs]
syncAlert :: [Remote] -> Alert
syncAlert rs = baseActivityAlert
@@ -308,7 +308,7 @@ pairRequestReceivedAlert repo button = Alert
, alertButton = Just button
}
-pairRequestAcknowledgedAlert :: String -> (Maybe AlertButton) -> Alert
+pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
pairRequestAcknowledgedAlert repo button = baseActivityAlert
{ alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
, alertPriority = High
diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs
index 1b3e6dd7d..8e9867b2c 100644
--- a/Assistant/MakeRemote.hs
+++ b/Assistant/MakeRemote.hs
@@ -52,7 +52,7 @@ makeSshRemote st dstatus scanremotes forcersync sshdata = do
addRemote :: Annex String -> Annex Remote
addRemote a = do
name <- a
- void $ remoteListRefresh
+ void remoteListRefresh
maybe (error "failed to add remote") return =<< Remote.byName (Just name)
{- Inits a rsync special remote, and returns the name of the remote. -}
@@ -84,7 +84,7 @@ makeGitRemote basename location = makeRemote basename location $ \name ->
makeRemote :: String -> String -> (String -> Annex ()) -> Annex String
makeRemote basename location a = do
r <- fromRepo id
- if (null $ filter samelocation $ Git.remotes r)
+ if not (any samelocation $ Git.remotes r)
then do
let name = uniqueRemoteName r basename 0
a name
diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs
index 662654255..6df54873a 100644
--- a/Assistant/Pairing.hs
+++ b/Assistant/Pairing.hs
@@ -34,7 +34,7 @@ newtype PairMsg = PairMsg (Verifiable (PairStage, PairData, SomeAddr))
verifiedPairMsg :: PairMsg -> PairingInProgress -> Bool
verifiedPairMsg (PairMsg m) pip = verify m $ inProgressSecret pip
-fromPairMsg :: PairMsg -> (Verifiable (PairStage, PairData, SomeAddr))
+fromPairMsg :: PairMsg -> Verifiable (PairStage, PairData, SomeAddr)
fromPairMsg (PairMsg m) = m
pairMsgStage :: PairMsg -> PairStage
diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index 1b39fcff7..f3c5e0d50 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -37,7 +37,7 @@ finishedPairing st dstatus scanremotes msg keypair = do
{- Ensure that we know
- the ssh host key for the host we paired with.
- If we don't, ssh over to get it. -}
- unlessM (knownHost $ sshHostName sshdata) $ do
+ unlessM (knownHost $ sshHostName sshdata) $
void $ sshTranscript
[ sshOpt "StrictHostKeyChecking" "no"
, sshOpt "NumberOfPasswordPrompts" "0"
@@ -59,14 +59,14 @@ pairMsgToSshData msg = do
let dir = case remoteDirectory d of
('~':'/':v) -> v
v -> v
- return $ SshData
+ return SshData
{ sshHostName = T.pack hostname
, sshUserName = Just (T.pack $ remoteUserName d)
, sshDirectory = T.pack dir
, sshRepoName = genSshRepoName hostname dir
, needsPubKey = True
, rsyncOnly = False
- }
+ }
{- Finds the best hostname to use for the host that sent the PairMsg.
-
@@ -75,7 +75,7 @@ pairMsgToSshData msg = do
- Otherwise, looks up the hostname in the DNS for the remoteAddress,
- if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
bestHostName :: PairMsg -> IO HostName
-bestHostName msg = case (remoteHostName $ pairMsgData msg) of
+bestHostName msg = case remoteHostName $ pairMsgData msg of
Just h -> do
let localname = h ++ ".local"
addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs
index 7ce34962d..a6289c035 100644
--- a/Assistant/Pairing/Network.hs
+++ b/Assistant/Pairing/Network.hs
@@ -58,7 +58,7 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats
threadDelaySeconds (Seconds 2)
go cache' $ pred <$> n
{- The multicast library currently chokes on ipv6 addresses. -}
- sendinterface cache (IPv6Addr _) = noop
+ sendinterface _ (IPv6Addr _) = noop
sendinterface cache i = void $ catchMaybeIO $
withSocketsDo $ bracket setup cleanup use
where
@@ -106,7 +106,7 @@ showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4
activeNetworkAddresses :: IO [SomeAddr]
activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
- . concat . map (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
+ . concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
<$> getNetworkInterfaces
{- A human-visible description of the repository being paired with.
diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs
index 47c2cb48a..ded2b0056 100644
--- a/Assistant/Ssh.hs
+++ b/Assistant/Ssh.hs
@@ -79,7 +79,9 @@ sshTranscript opts input = do
_ <- forkIO $ E.evaluate (length transcript) >> putMVar outMVar ()
-- now write and flush any input
- when (not (null input)) $ do hPutStr inh input; hFlush inh
+ unless (null input) $ do
+ hPutStr inh input
+ hFlush inh
hClose inh -- done with stdin
-- wait on the output
@@ -114,13 +116,12 @@ removeAuthorizedKeys rsynconly pubkey = do
sshdir <- sshDir
let keyfile = sshdir </> ".authorized_keys"
ls <- lines <$> readFileStrict keyfile
- writeFile keyfile $ unlines $
- filter (\l -> not $ l == keyline) ls
+ writeFile keyfile $ unlines $ filter (/= keyline) ls
{- Implemented as a shell command, so it can be run on remote servers over
- ssh. -}
addAuthorizedKeysCommand :: Bool -> SshPubKey -> String
-addAuthorizedKeysCommand rsynconly pubkey = join "&&" $
+addAuthorizedKeysCommand rsynconly pubkey = join "&&"
[ "mkdir -p ~/.ssh"
, "touch ~/.ssh/authorized_keys"
, "chmod 600 ~/.ssh/authorized_keys"
@@ -169,7 +170,7 @@ setupSshKeyPair sshkeypair sshdata = do
(unionFileModes ownerWriteMode ownerReadMode)
hPutStr h (sshPrivKey sshkeypair)
hClose h
- unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $ do
+ unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $
writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair)
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $
@@ -186,7 +187,7 @@ setupSshKeyPair sshkeypair sshdata = do
sshprivkeyfile = "key." ++ mangledhost
sshpubkeyfile = sshprivkeyfile ++ ".pub"
mangledhost = "git-annex-" ++ T.unpack (sshHostName sshdata) ++ user
- user = maybe "" (\u -> "-" ++ T.unpack u) (sshUserName sshdata)
+ user = maybe "" (\u -> '-' : T.unpack u) (sshUserName sshdata)
{- Does ssh have known_hosts data for a hostname? -}
knownHost :: Text -> IO Bool
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 4a9cae767..c75767760 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -60,7 +60,7 @@ reconnectRemotes threadname st dstatus scanremotes rs = void $
-
- Avoids running possibly long-duration commands in the Annex monad, so
- as not to block other threads. -}
-pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> (Maybe FailedPushMap) -> [Remote] -> IO Bool
+pushToRemotes :: ThreadName -> UTCTime -> ThreadState -> Maybe FailedPushMap -> [Remote] -> IO Bool
pushToRemotes threadname now st mpushmap remotes = do
(g, branch) <- runThreadState st $
(,) <$> fromRepo id <*> inRepo Git.Branch.current
@@ -81,12 +81,12 @@ pushToRemotes threadname now st mpushmap remotes = do
changeFailedPushMap pushmap $ \m ->
M.union (makemap failed) $
M.difference m (makemap succeeded)
- unless (ok) $
+ unless ok $
debug threadname
[ "failed to push to"
, show failed
]
- if (ok || not shouldretry)
+ if ok || not shouldretry
then return ok
else retry branch g failed
@@ -100,12 +100,12 @@ pushToRemotes threadname now st mpushmap remotes = do
go False (Just branch) g rs
{- Manually pull from remotes and merge their branches. -}
-manualPull :: ThreadState -> (Maybe Git.Ref) -> [Remote] -> IO Bool
+manualPull :: ThreadState -> Maybe Git.Ref -> [Remote] -> IO Bool
manualPull st currentbranch remotes = do
g <- runThreadState st $ fromRepo id
forM_ remotes $ \r ->
Git.Command.runBool "fetch" [Param $ Remote.name r] g
- haddiverged <- runThreadState st $ Annex.Branch.forceUpdate
+ haddiverged <- runThreadState st Annex.Branch.forceUpdate
forM_ remotes $ \r ->
runThreadState st $ Command.Sync.mergeRemote r currentbranch
return haddiverged
@@ -114,4 +114,4 @@ manualPull st currentbranch remotes = do
syncNewRemote :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> Remote -> IO ()
syncNewRemote st dstatus scanremotes remote = do
runThreadState st $ updateKnownRemotes dstatus
- void $ forkIO $ do reconnectRemotes "SyncRemote" st dstatus scanremotes [remote]
+ void $ forkIO $ reconnectRemotes "SyncRemote" st dstatus scanremotes [remote]
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
diff --git a/Assistant/TransferQueue.hs b/Assistant/TransferQueue.hs
index 63710ce82..3d0464c73 100644
--- a/Assistant/TransferQueue.hs
+++ b/Assistant/TransferQueue.hs
@@ -107,9 +107,8 @@ queueTransferAt :: Int -> Schedule -> TransferQueue -> DaemonStatusHandle -> Ass
queueTransferAt wantsz schedule q dstatus f t remote = do
atomically $ do
sz <- readTVar (queuesize q)
- if sz <= wantsz
- then return ()
- else retry -- blocks until queuesize changes
+ unless (sz <= wantsz) $
+ retry -- blocks until queuesize changes
enqueue schedule q dstatus t (stubInfo f remote)
queueTransferWhenSmall :: TransferQueue -> DaemonStatusHandle -> AssociatedFile -> Transfer -> Remote -> IO ()
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 2633c04c9..9e9156ad9 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -69,11 +69,11 @@ inImmediateTransferSlot dstatus s gen = do
runTransferThread :: DaemonStatusHandle -> TransferSlots -> Maybe (Transfer, TransferInfo, IO ()) -> IO ()
runTransferThread _ s Nothing = signalQSemN s 1
runTransferThread dstatus s (Just (t, info, a)) = do
- tid <- forkIO $ go
+ tid <- forkIO go
updateTransferInfo dstatus t $ info { transferTid = Just tid }
where
go = catchPauseResume a
- pause = catchPauseResume $ runEvery (Seconds 86400) $ noop
+ 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
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index ec0a53ea8..f6de32166 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@@ -48,7 +48,7 @@ repoList = do
(liftIO . getDaemonStatus =<< daemonStatus <$> getYesod)
l <- runAnnex [] $ do
u <- getUUID
- Remote.prettyListUUIDs $ nub $ u:(map Remote.uuid rs)
+ Remote.prettyListUUIDs $ nub $ u : map Remote.uuid rs
return $ zip counter l
where
counter = map show ([1..] :: [Int])
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index e39291459..925ed23c5 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -50,7 +50,7 @@ mkSshData sshserver = SshData
, rsyncOnly = False
}
-sshServerAForm :: (Maybe Text) -> AForm WebApp WebApp SshServer
+sshServerAForm :: Maybe Text -> AForm WebApp WebApp SshServer
sshServerAForm localusername = SshServer
<$> aopt check_hostname "Host name" Nothing
<*> aopt check_username "User name" (Just localusername)
@@ -99,7 +99,7 @@ getAddSshR = sshConfigurator $ do
then lift $ redirect $ ConfirmSshR $
(mkSshData sshserver)
{ needsPubKey = needspubkey
- , rsyncOnly = (status == UsableRsyncServer)
+ , rsyncOnly = status == UsableRsyncServer
}
else showform form enctype status
_ -> showform form enctype UntestedServer
@@ -130,7 +130,7 @@ testServer sshserver@(SshServer { hostname = Just hn }) = do
return (status', True)
where
probe extraopts = do
- let remotecommand = join ";" $
+ let remotecommand = join ";"
[ report "loggedin"
, checkcommand "git-annex-shell"
, checkcommand "rsync"
@@ -186,7 +186,7 @@ getMakeSshRsyncR = makeSsh True
makeSsh :: Bool -> SshData -> Handler RepHtml
makeSsh rsync sshdata
| needsPubKey sshdata = do
- keypair <- liftIO $ genSshKeyPair
+ keypair <- liftIO genSshKeyPair
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
makeSsh' rsync sshdata' (Just keypair)
| otherwise = makeSsh' rsync sshdata Nothing
@@ -201,10 +201,10 @@ makeSsh' rsync sshdata keypair =
remoteCommand = join "&&" $ catMaybes
[ Just $ "mkdir -p " ++ shellEscape remotedir
, Just $ "cd " ++ shellEscape remotedir
- , if rsync then Nothing else Just $ "git init --bare --shared"
- , if rsync then Nothing else Just $ "git annex init"
+ , if rsync then Nothing else Just "git init --bare --shared"
+ , if rsync then Nothing else Just "git annex init"
, if needsPubKey sshdata
- then maybe Nothing (Just . addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey) keypair
+ then addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey <$> keypair
else Nothing
]
@@ -246,13 +246,13 @@ getAddRsyncNetR = do
- to not need to use a different method to create
- it.
-}
- let remotecommand = join ";" $
+ let remotecommand = join ";"
[ "mkdir -p .ssh"
, "touch .ssh/authorized_keys"
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
]
- let sshopts = filter (not . null) $
+ let sshopts = filter (not . null)
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
, remotecommand
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 15:13:29 +0000