From df337bb63b4ed6e5d2ce563ec89d28d192e791db Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 13 Sep 2012 00:57:52 -0400 Subject: hlint --- Assistant.hs | 9 ++++---- Assistant/Alert.hs | 12 +++++----- Assistant/MakeRemote.hs | 4 ++-- Assistant/Pairing.hs | 2 +- Assistant/Pairing/MakeRemote.hs | 8 +++---- Assistant/Pairing/Network.hs | 4 ++-- Assistant/Ssh.hs | 13 ++++++----- Assistant/Sync.hs | 12 +++++----- Assistant/Threads/Committer.hs | 2 +- Assistant/Threads/Merger.hs | 2 +- Assistant/Threads/NetWatcher.hs | 4 ++-- Assistant/Threads/PairListener.hs | 11 +++++----- Assistant/Threads/Pusher.hs | 41 +++++++++++++++++------------------ Assistant/Threads/TransferScanner.hs | 4 ++-- Assistant/Threads/TransferWatcher.hs | 2 +- Assistant/Threads/Transferrer.hs | 2 +- Assistant/Threads/Watcher.hs | 8 +++---- Assistant/Threads/WebApp.hs | 9 ++++---- Assistant/TransferQueue.hs | 5 ++--- Assistant/TransferSlots.hs | 4 ++-- Assistant/WebApp/Configurators.hs | 2 +- Assistant/WebApp/Configurators/Ssh.hs | 18 +++++++-------- Command/Assistant.hs | 4 ++-- Command/WebApp.hs | 6 ++--- 24 files changed, 91 insertions(+), 97 deletions(-) diff --git a/Assistant.hs b/Assistant.hs index 3e005b4ae..d71dba5fe 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -162,11 +162,10 @@ startDaemon assistant foreground webappwaiter go d = startAssistant assistant d webappwaiter startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()) -> Annex () -startAssistant assistant daemonize webappwaiter = do - withThreadState $ \st -> do - checkCanWatch - dstatus <- startDaemonStatus - liftIO $ daemonize $ run dstatus st +startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do + checkCanWatch + dstatus <- startDaemonStatus + liftIO $ daemonize $ run dstatus st where run dstatus st = do changechan <- newChangeChan 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 diff --git a/Command/Assistant.hs b/Command/Assistant.hs index eb2a4a500..53f7e4baf 100644 --- a/Command/Assistant.hs +++ b/Command/Assistant.hs @@ -34,7 +34,7 @@ seek = [withFlag Command.Watch.stopOption $ \stopdaemon -> start :: Bool -> Bool -> Bool -> CommandStart start foreground stopdaemon autostart | autostart = do - liftIO $ autoStart + liftIO autoStart stop | otherwise = do ensureInitialized @@ -43,7 +43,7 @@ start foreground stopdaemon autostart {- Run outside a git repository. Check to see if any parameter is - --autostart and enter autostart mode. -} checkAutoStart :: IO () -checkAutoStart = ifM (any (== "--autostart") <$> getArgs) +checkAutoStart = ifM (elem "--autostart" <$> getArgs) ( autoStart , error "Not in a git repository." ) diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 7360e1b0c..a7d00738f 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -39,13 +39,13 @@ seek = [withNothing start] start :: CommandStart start = notBareRepo $ do - ifM (isInitialized) ( go , liftIO startNoRepo ) + ifM isInitialized ( go , liftIO startNoRepo ) stop where go = do browser <- fromRepo webBrowser f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim - ifM (checkpid <&&> checkshim f) $ + ifM (checkpid <&&> checkshim f) ( liftIO $ openBrowser browser f , startDaemon True True $ Just $ const $ openBrowser browser @@ -116,7 +116,7 @@ firstRun = do startAssistant True id $ Just $ sendurlback v sendurlback v url _htmlshim = putMVar v url {- Set up the pid file in the new repo. -} - dummydaemonize = do + dummydaemonize = liftIO . lockPidFile =<< fromRepo gitAnnexPidFile openBrowser :: Maybe FilePath -> FilePath -> IO () -- cgit v1.2.3