From acec36711090577752532a39f472e734e6b67fdb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 31 Oct 2012 02:34:03 -0400 Subject: where indentation --- Assistant/Alert.hs | 68 ++++++++++++------------- Assistant/DaemonStatus.hs | 98 ++++++++++++++++++------------------ Assistant/Drop.hs | 45 ++++++++--------- Assistant/Install.hs | 55 ++++++++++---------- Assistant/MakeRemote.hs | 64 +++++++++++------------ Assistant/Pairing/MakeRemote.hs | 22 ++++---- Assistant/Pairing/Network.hs | 14 +++--- Assistant/Pushes.hs | 16 +++--- Assistant/ScanRemotes.hs | 12 ++--- Assistant/Ssh.hs | 84 +++++++++++++++---------------- Assistant/Sync.hs | 18 +++---- Assistant/Threads/Merger.hs | 12 ++--- Assistant/Threads/MountWatcher.hs | 60 +++++++++++----------- Assistant/Threads/PairListener.hs | 4 +- Assistant/Threads/Pusher.hs | 4 +- Assistant/Threads/TransferWatcher.hs | 8 +-- Assistant/Threads/Transferrer.hs | 4 +- Assistant/TransferSlots.hs | 32 ++++++------ Assistant/XMPP.hs | 70 +++++++++++++------------- 19 files changed, 344 insertions(+), 346 deletions(-) (limited to 'Assistant') diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 102863ea3..b73a67b67 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -158,11 +158,11 @@ makeAlertFiller success alert , alertButton = Nothing , alertIcon = Just $ if success then SuccessIcon else ErrorIcon } - where - c = alertClass alert - c' - | success = Success - | otherwise = Error + where + c = alertClass alert + c' + | success = Success + | otherwise = Error isFiller :: Alert -> Bool isFiller alert = alertPriority alert == Filler @@ -179,23 +179,23 @@ isFiller alert = alertPriority alert == Filler -} mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al) - where - pruneSame k al' = k == i || not (effectivelySameAlert al al') - pruneBloat m' - | bloat > 0 = M.fromList $ pruneold $ M.toList m' - | otherwise = m' - where - bloat = M.size m' - maxAlerts - pruneold l = - let (f, rest) = partition (\(_, a) -> isFiller a) l - in drop bloat f ++ rest - updatePrune = pruneBloat $ M.filterWithKey pruneSame $ - M.insertWith' const i al m - updateCombine combiner = - let combined = M.mapMaybe (combiner al) m - in if M.null combined - then updatePrune - else M.delete i $ M.union combined m + where + pruneSame k al' = k == i || not (effectivelySameAlert al al') + pruneBloat m' + | bloat > 0 = M.fromList $ pruneold $ M.toList m' + | otherwise = m' + where + bloat = M.size m' - maxAlerts + pruneold l = + let (f, rest) = partition (\(_, a) -> isFiller a) l + in drop bloat f ++ rest + updatePrune = pruneBloat $ M.filterWithKey pruneSame $ + M.insertWith' const i al m + updateCombine combiner = + let combined = M.mapMaybe (combiner al) m + in if M.null combined + then updatePrune + else M.delete i $ M.union combined m baseActivityAlert :: Alert baseActivityAlert = Alert @@ -288,10 +288,10 @@ sanityCheckFixAlert msg = Alert , alertCombiner = Just $ dataCombiner (++) , alertButton = Nothing } - where - render dta = tenseWords $ alerthead : dta ++ [alertfoot] - alerthead = "The daily sanity check found and fixed a problem:" - alertfoot = "If these problems persist, consider filing a bug report." + where + render dta = tenseWords $ alerthead : dta ++ [alertfoot] + alerthead = "The daily sanity check found and fixed a problem:" + alertfoot = "If these problems persist, consider filing a bug report." pairingAlert :: AlertButton -> Alert pairingAlert button = baseActivityAlert @@ -344,10 +344,10 @@ fileAlert msg file = (activityAlert Nothing [f]) , alertMessageRender = render , alertCombiner = Just $ dataCombiner combiner } - where - f = fromString $ shortFile $ takeFileName file - render fs = tenseWords $ msg : fs - combiner new old = take 10 $ new ++ old + where + f = fromString $ shortFile $ takeFileName file + render fs = tenseWords $ msg : fs + combiner new old = take 10 $ new ++ old addFileAlert :: FilePath -> Alert addFileAlert = fileAlert (Tensed "Adding" "Added") @@ -372,8 +372,8 @@ shortFile :: FilePath -> String shortFile f | len < maxlen = f | otherwise = take half f ++ ".." ++ drop (len - half) f - where - len = length f - maxlen = 20 - half = (maxlen - 2) `div` 2 + where + len = length f + maxlen = 20 + half = (maxlen - 2) `div` 2 diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 4744c86ba..5e1ecab3c 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -77,34 +77,34 @@ startDaemonStatus = do writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO () writeDaemonStatusFile file status = viaTmp writeFile file =<< serialized <$> getPOSIXTime - where - serialized now = unlines - [ "lastRunning:" ++ show now - , "scanComplete:" ++ show (scanComplete status) - , "sanityCheckRunning:" ++ show (sanityCheckRunning status) - , "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status) - ] + where + serialized now = unlines + [ "lastRunning:" ++ show now + , "scanComplete:" ++ show (scanComplete status) + , "sanityCheckRunning:" ++ show (sanityCheckRunning status) + , "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status) + ] readDaemonStatusFile :: FilePath -> IO DaemonStatus readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file - where - parse status = foldr parseline status . lines - parseline line status - | key == "lastRunning" = parseval readtime $ \v -> - status { lastRunning = Just v } - | key == "scanComplete" = parseval readish $ \v -> - status { scanComplete = v } - | key == "sanityCheckRunning" = parseval readish $ \v -> - status { sanityCheckRunning = v } - | key == "lastSanityCheck" = parseval readtime $ \v -> - status { lastSanityCheck = Just v } - | otherwise = status -- unparsable line - where - (key, value) = separate (== ':') line - parseval parser a = maybe status a (parser value) - readtime s = do - d <- parseTime defaultTimeLocale "%s%Qs" s - Just $ utcTimeToPOSIXSeconds d + where + parse status = foldr parseline status . lines + parseline line status + | key == "lastRunning" = parseval readtime $ \v -> + status { lastRunning = Just v } + | key == "scanComplete" = parseval readish $ \v -> + status { scanComplete = v } + | key == "sanityCheckRunning" = parseval readish $ \v -> + status { sanityCheckRunning = v } + | key == "lastSanityCheck" = parseval readtime $ \v -> + status { lastSanityCheck = Just v } + | otherwise = status -- unparsable line + where + (key, value) = separate (== ':') line + parseval parser a = maybe status a (parser value) + readtime s = do + d <- parseTime defaultTimeLocale "%s%Qs" s + Just $ utcTimeToPOSIXSeconds d {- Checks if a time stamp was made after the daemon was lastRunning. - @@ -116,9 +116,9 @@ readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file -} afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status) - where - t = realToFrac (timestamp + slop) :: POSIXTime - slop = fromIntegral tenMinutes + where + t = realToFrac (timestamp + slop) :: POSIXTime + slop = fromIntegral tenMinutes tenMinutes :: Int tenMinutes = 10 * 60 @@ -141,27 +141,27 @@ alterTransferInfo t a = updateTransferInfo' $ M.adjust a t - transferPaused, and bytesComplete values, which are not written to disk. -} updateTransferInfo :: Transfer -> TransferInfo -> Assistant () updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info - where - merge new old = new - { transferTid = maybe (transferTid new) Just (transferTid old) - , transferPaused = transferPaused new || transferPaused old - , bytesComplete = maybe (bytesComplete new) Just (bytesComplete old) - } + where + merge new old = new + { transferTid = maybe (transferTid new) Just (transferTid old) + , transferPaused = transferPaused new || transferPaused old + , bytesComplete = maybe (bytesComplete new) Just (bytesComplete old) + } updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant () updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update - where - update s = s { currentTransfers = a (currentTransfers s) } + where + update s = s { currentTransfers = a (currentTransfers s) } {- Removes a transfer from the map, and returns its info. -} removeTransfer :: Transfer -> Assistant (Maybe TransferInfo) removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove - where - remove s = - let (info, ts) = M.updateLookupWithKey - (\_k _v -> Nothing) - t (currentTransfers s) - in (s { currentTransfers = ts }, info) + where + remove s = + let (info, ts) = M.updateLookupWithKey + (\_k _v -> Nothing) + t (currentTransfers s) + in (s { currentTransfers = ts }, info) {- Send a notification when a transfer is changed. -} notifyTransfer :: Assistant () @@ -180,11 +180,11 @@ notifyAlert = do {- Returns the alert's identifier, which can be used to remove it. -} addAlert :: Alert -> Assistant AlertId addAlert alert = notifyAlert `after` modifyDaemonStatus add - where - add s = (s { lastAlertId = i, alertMap = m }, i) - where - i = nextAlertId $ lastAlertId s - m = mergeAlert i alert (alertMap s) + where + add s = (s { lastAlertId = i, alertMap = m }, i) + where + i = nextAlertId $ lastAlertId s + m = mergeAlert i alert (alertMap s) removeAlert :: AlertId -> Assistant () removeAlert i = updateAlert i (const Nothing) @@ -194,8 +194,8 @@ updateAlert i a = updateAlertMap $ \m -> M.update a i m updateAlertMap :: (AlertMap -> AlertMap) -> Assistant () updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update - where - update s = s { alertMap = a (alertMap s) } + where + update s = s { alertMap = a (alertMap s) } {- Displays an alert while performing an activity that returns True on - success. diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs index ed9ba577e..a02f58652 100644 --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -37,30 +37,29 @@ handleDrops' locs rs fromhere key (Just f) then go rs =<< dropl n else go rs n | otherwise = go rs =<< getcopies - where - getcopies = do - have <- length . snd <$> trustPartition UnTrusted locs - numcopies <- getNumCopies =<< numCopies f - return (have, numcopies) - checkcopies (have, numcopies) = have > numcopies - decrcopies (have, numcopies) = (have - 1, numcopies) + where + getcopies = do + have <- length . snd <$> trustPartition UnTrusted locs + numcopies <- getNumCopies =<< numCopies f + return (have, numcopies) + checkcopies (have, numcopies) = have > numcopies + decrcopies (have, numcopies) = (have - 1, numcopies) - go [] _ = noop - go (r:rest) n - | checkcopies n = dropr r n >>= go rest - | otherwise = noop + go [] _ = noop + go (r:rest) n + | checkcopies n = dropr r n >>= go rest + | otherwise = noop - checkdrop n@(_, numcopies) u a = - ifM (wantDrop u (Just f)) - ( ifM (doCommand $ a (Just numcopies)) - ( return $ decrcopies n - , return n - ) - , return n - ) + checkdrop n@(_, numcopies) u a = ifM (wantDrop u (Just f)) + ( ifM (doCommand $ a (Just numcopies)) + ( return $ decrcopies n + , return n + ) + , return n + ) - dropl n = checkdrop n Nothing $ \numcopies -> - Command.Drop.startLocal f numcopies key + dropl n = checkdrop n Nothing $ \numcopies -> + Command.Drop.startLocal f numcopies key - dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies -> - Command.Drop.startRemote f numcopies key r + dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies -> + Command.Drop.startRemote f numcopies key r diff --git a/Assistant/Install.hs b/Assistant/Install.hs index 1bf424cc9..635c265f4 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -36,36 +36,35 @@ standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE" -} ensureInstalled :: IO () ensureInstalled = go =<< standaloneAppBase - where - go Nothing = noop - go (Just base) = do - let program = base ++ "runshell git-annex" - programfile <- programFile - createDirectoryIfMissing True (parentDir programfile) - writeFile programfile program + where + go Nothing = noop + go (Just base) = do + let program = base ++ "runshell git-annex" + programfile <- programFile + createDirectoryIfMissing True (parentDir programfile) + writeFile programfile program #ifdef darwin_HOST_OS - autostartfile <- userAutoStart osxAutoStartLabel + autostartfile <- userAutoStart osxAutoStartLabel #else - autostartfile <- autoStartPath "git-annex" - <$> userConfigDir + autostartfile <- autoStartPath "git-annex" <$> userConfigDir #endif - installAutoStart program autostartfile + installAutoStart program autostartfile - {- This shim is only updated if it doesn't - - already exist with the right content. This - - ensures that there's no race where it would have - - worked, but is unavailable due to being updated. -} - sshdir <- sshDir - let shim = sshdir "git-annex-shell" - let content = unlines - [ "#!/bin/sh" - , "set -e" - , "exec", base "runshell" ++ - " git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\"" - ] - curr <- catchDefaultIO "" $ readFileStrict shim - when (curr /= content) $ do - createDirectoryIfMissing True (parentDir shim) - writeFile shim content - modifyFileMode shim $ addModes [ownerExecuteMode] + {- This shim is only updated if it doesn't + - already exist with the right content. This + - ensures that there's no race where it would have + - worked, but is unavailable due to being updated. -} + sshdir <- sshDir + let shim = sshdir "git-annex-shell" + let content = unlines + [ "#!/bin/sh" + , "set -e" + , "exec", base "runshell" ++ + " git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\"" + ] + curr <- catchDefaultIO "" $ readFileStrict shim + when (curr /= content) $ do + createDirectoryIfMissing True (parentDir shim) + writeFile shim content + modifyFileMode shim $ addModes [ownerExecuteMode] diff --git a/Assistant/MakeRemote.hs b/Assistant/MakeRemote.hs index 1eb9d3919..8f5d903e6 100644 --- a/Assistant/MakeRemote.hs +++ b/Assistant/MakeRemote.hs @@ -31,21 +31,21 @@ makeSshRemote forcersync sshdata = do addRemote $ maker (sshRepoName sshdata) sshurl syncNewRemote r return r - where - rsync = forcersync || rsyncOnly sshdata - maker - | rsync = makeRsyncRemote - | otherwise = makeGitRemote - sshurl = T.unpack $ T.concat $ - if rsync - then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"] - else [T.pack "ssh://", u, h, d, T.pack "/"] - where - u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata - h = sshHostName sshdata - d - | T.pack "/" `T.isPrefixOf` sshDirectory sshdata = d - | otherwise = T.concat [T.pack "/~/", sshDirectory sshdata] + where + rsync = forcersync || rsyncOnly sshdata + maker + | rsync = makeRsyncRemote + | otherwise = makeGitRemote + sshurl = T.unpack $ T.concat $ + if rsync + then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"] + else [T.pack "ssh://", u, h, d, T.pack "/"] + where + u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata + h = sshHostName sshdata + d + | T.pack "/" `T.isPrefixOf` sshDirectory sshdata = d + | otherwise = T.concat [T.pack "/~/", sshDirectory sshdata] {- Runs an action that returns a name of the remote, and finishes adding it. -} addRemote :: Annex String -> Annex Remote @@ -58,12 +58,12 @@ addRemote a = do makeRsyncRemote :: String -> String -> Annex String makeRsyncRemote name location = makeRemote name location $ const $ makeSpecialRemote name Rsync.remote config - where - config = M.fromList - [ ("encryption", "shared") - , ("rsyncurl", location) - , ("type", "rsync") - ] + where + config = M.fromList + [ ("encryption", "shared") + , ("rsyncurl", location) + , ("type", "rsync") + ] {- Inits a special remote. -} makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex () @@ -95,8 +95,8 @@ makeRemote basename location a = do a name return name else return basename - where - samelocation x = Git.repoLocation x == location + where + samelocation x = Git.repoLocation x == location {- Generate an unused name for a remote, adding a number if - necessary. @@ -106,12 +106,12 @@ uniqueRemoteName :: String -> Int -> Git.Repo -> String uniqueRemoteName basename n r | null namecollision = name | otherwise = uniqueRemoteName legalbasename (succ n) r - where - namecollision = filter samename (Git.remotes r) - samename x = Git.remoteName x == Just name - name - | n == 0 = legalbasename - | otherwise = legalbasename ++ show n - legalbasename = filter legal basename - legal '_' = True - legal c = isAlphaNum c + where + namecollision = filter samename (Git.remotes r) + samename x = Git.remoteName x == Just name + name + | n == 0 = legalbasename + | otherwise = legalbasename ++ show n + legalbasename = filter legal basename + legal '_' = True + legal c = isAlphaNum c diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs index 7c971c2e1..8324fe1bd 100644 --- a/Assistant/Pairing/MakeRemote.hs +++ b/Assistant/Pairing/MakeRemote.hs @@ -23,8 +23,8 @@ setupAuthorizedKeys msg = do validateSshPubKey pubkey unlessM (liftIO $ addAuthorizedKeys False pubkey) $ error "failed setting up ssh authorized keys" - where - pubkey = remoteSshPubKey $ pairMsgData msg + where + pubkey = remoteSshPubKey $ pairMsgData msg {- When pairing is complete, this is used to set up the remote for the host - we paired with. -} @@ -78,12 +78,12 @@ bestHostName msg = case remoteHostName $ pairMsgData msg of getAddrInfo Nothing (Just localname) Nothing maybe fallback (const $ return localname) (headMaybe addrs) Nothing -> fallback - where - fallback = do - let a = pairMsgAddr msg - let sockaddr = case a of - IPv4Addr addr -> SockAddrInet (PortNum 0) addr - IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0 - fromMaybe (showAddr a) - <$> catchDefaultIO Nothing - (fst <$> getNameInfo [] True False sockaddr) + where + fallback = do + let a = pairMsgAddr msg + let sockaddr = case a of + IPv4Addr addr -> SockAddrInet (PortNum 0) addr + IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0 + fromMaybe (showAddr a) + <$> catchDefaultIO Nothing + (fst <$> getNameInfo [] True False sockaddr) diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 9ee1db3c6..44a63df36 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -62,13 +62,13 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats sendinterface _ (IPv6Addr _) = noop sendinterface cache i = void $ catchMaybeIO $ withSocketsDo $ bracket setup cleanup use - where - setup = multicastSender (multicastAddress i) pairingPort - cleanup (sock, _) = sClose sock -- FIXME does not work - use (sock, addr) = do - setInterface sock (showAddr i) - maybe noop (\s -> void $ sendTo sock s addr) - (M.lookup i cache) + where + setup = multicastSender (multicastAddress i) pairingPort + cleanup (sock, _) = sClose sock -- FIXME does not work + use (sock, addr) = do + setInterface sock (showAddr i) + maybe noop (\s -> void $ sendTo sock s addr) + (M.lookup i cache) updatecache cache [] = cache updatecache cache (i:is) | M.member i cache = updatecache cache is diff --git a/Assistant/Pushes.hs b/Assistant/Pushes.hs index 122d46d21..6ac19405a 100644 --- a/Assistant/Pushes.hs +++ b/Assistant/Pushes.hs @@ -26,20 +26,20 @@ getFailedPushesBefore duration = do m <- atomically $ readTMVar v now <- getCurrentTime return $ M.keys $ M.filter (not . toorecent now) m - where - toorecent now time = now `diffUTCTime` time < duration + where + toorecent now time = now `diffUTCTime` time < duration {- Modifies the map. -} changeFailedPushMap :: (PushMap -> PushMap) -> Assistant () changeFailedPushMap a = do v <- getAssistant failedPushMap liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v - where - {- tryTakeTMVar empties the TMVar; refill it only if - - the modified map is not itself empty -} - store v m - | m == M.empty = noop - | otherwise = putTMVar v $! m + where + {- tryTakeTMVar empties the TMVar; refill it only if + - the modified map is not itself empty -} + store v m + | m == M.empty = noop + | otherwise = putTMVar v $! m notifyPush :: [UUID] -> Assistant () notifyPush us = flip putTSet us <<~ (pushNotifierSuccesses . pushNotifier) diff --git a/Assistant/ScanRemotes.hs b/Assistant/ScanRemotes.hs index f367ab745..2743c0f36 100644 --- a/Assistant/ScanRemotes.hs +++ b/Assistant/ScanRemotes.hs @@ -33,9 +33,9 @@ addScanRemotes full rs = do liftIO $ atomically $ do m <- fromMaybe M.empty <$> tryTakeTMVar v putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m - where - info r = ScanInfo (-1 * Remote.cost r) full - merge x y = ScanInfo - { scanPriority = max (scanPriority x) (scanPriority y) - , fullScan = fullScan x || fullScan y - } + where + info r = ScanInfo (-1 * Remote.cost r) full + merge x y = ScanInfo + { scanPriority = max (scanPriority x) (scanPriority y) + , fullScan = fullScan x || fullScan y + } diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index de7665dad..69e633ac8 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -56,9 +56,9 @@ genSshRepoName :: String -> FilePath -> String genSshRepoName host dir | null dir = filter legal host | otherwise = filter legal $ host ++ "_" ++ replace "/" "_" dir - where - legal '_' = True - legal c = isAlphaNum c + where + legal '_' = True + legal c = isAlphaNum c {- The output of ssh, including both stdout and stderr. -} sshTranscript :: [String] -> String -> IO (String, Bool) @@ -97,26 +97,26 @@ sshTranscript opts input = do - command=foo, or other weirdness -} validateSshPubKey :: SshPubKey -> IO () validateSshPubKey pubkey = either error return $ check $ words pubkey - where - check [prefix, _key, comment] = do - checkprefix prefix - checkcomment comment - check [prefix, _key] = - checkprefix prefix - check _ = err "wrong number of words in ssh public key" + where + check [prefix, _key, comment] = do + checkprefix prefix + checkcomment comment + check [prefix, _key] = + checkprefix prefix + check _ = err "wrong number of words in ssh public key" - ok = Right () - err msg = Left $ unwords [msg, pubkey] + ok = Right () + err msg = Left $ unwords [msg, pubkey] - checkprefix prefix - | ssh == "ssh" && all isAlphaNum keytype = ok - | otherwise = err "bad ssh public key prefix" - where - (ssh, keytype) = separate (== '-') prefix + checkprefix prefix + | ssh == "ssh" && all isAlphaNum keytype = ok + | otherwise = err "bad ssh public key prefix" + where + (ssh, keytype) = separate (== '-') prefix - checkcomment comment - | all (\c -> isAlphaNum c || c == '@' || c == '-' || c == '_') comment = ok - | otherwise = err "bad comment in ssh public key" + checkcomment comment + | all (\c -> isAlphaNum c || c == '@' || c == '-' || c == '_') comment = ok + | otherwise = err "bad comment in ssh public key" addAuthorizedKeys :: Bool -> SshPubKey -> IO Bool addAuthorizedKeys rsynconly pubkey = boolSystem "sh" @@ -153,14 +153,14 @@ addAuthorizedKeysCommand rsynconly pubkey = join "&&" , ">>~/.ssh/authorized_keys" ] ] - where - echoval v = "echo " ++ shellEscape v - wrapper = "~/.ssh/git-annex-shell" - script = - [ "#!/bin/sh" - , "set -e" - , "exec git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\"" - ] + where + echoval v = "echo " ++ shellEscape v + wrapper = "~/.ssh/git-annex-shell" + script = + [ "#!/bin/sh" + , "set -e" + , "exec git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\"" + ] authorizedKeysLine :: Bool -> SshPubKey -> String authorizedKeysLine rsynconly pubkey @@ -168,8 +168,8 @@ authorizedKeysLine rsynconly pubkey - long perl script. -} | rsynconly = pubkey | otherwise = limitcommand ++ pubkey - where - limitcommand = "command=\"~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding " + where + limitcommand = "command=\"~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding " {- Generates a ssh key pair. -} genSshKeyPair :: IO SshKeyPair @@ -213,12 +213,12 @@ setupSshKeyPair sshkeypair sshdata = do ] return $ sshdata { sshHostName = T.pack mangledhost } - where - sshprivkeyfile = "key." ++ mangledhost - sshpubkeyfile = sshprivkeyfile ++ ".pub" - mangledhost = mangleSshHostName - (T.unpack $ sshHostName sshdata) - (T.unpack <$> sshUserName sshdata) + where + sshprivkeyfile = "key." ++ mangledhost + sshpubkeyfile = sshprivkeyfile ++ ".pub" + mangledhost = mangleSshHostName + (T.unpack $ sshHostName sshdata) + (T.unpack <$> sshUserName sshdata) mangleSshHostName :: String -> Maybe String -> String mangleSshHostName host user = "git-annex-" ++ host ++ (maybe "-" ('-':) user) @@ -227,8 +227,8 @@ unMangleSshHostName :: String -> String unMangleSshHostName h | "git-annex-" `isPrefixOf` h = join "-" (beginning $ drop 2 dashbits) | otherwise = h - where - dashbits = split "-" h + where + dashbits = split "-" h {- Does ssh have known_hosts data for a hostname? -} knownHost :: Text -> IO Bool @@ -238,7 +238,7 @@ knownHost hostname = do ( not . null <$> checkhost , return False ) - where - {- ssh-keygen -F can crash on some old known_hosts file -} - checkhost = catchDefaultIO "" $ - readProcess "ssh-keygen" ["-F", T.unpack hostname] + where + {- ssh-keygen -F can crash on some old known_hosts file -} + checkhost = catchDefaultIO "" $ + readProcess "ssh-keygen" ["-F", T.unpack hostname] diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index ccc359672..c2c81c57d 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -133,15 +133,15 @@ pushToRemotes now notifypushes remotes = do , Param $ refspec Annex.Branch.name , Param $ refspec branch ] g - where - {- Push to refs/synced/uuid/branch; this - - avoids cluttering up the branch display. -} - refspec b = concat - [ s - , ":" - , "refs/synced/" ++ fromUUID u ++ "/" ++ s - ] - where s = show $ Git.Ref.base b + where + {- Push to refs/synced/uuid/branch; this + - avoids cluttering up the branch display. -} + refspec b = concat + [ s + , ":" + , "refs/synced/" ++ fromUUID u ++ "/" ++ s + ] + where s = show $ Git.Ref.base b {- Manually pull from remotes and merge their branches. -} manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool) diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 44056dc35..105f0cc9f 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -86,15 +86,15 @@ onAdd file equivBranches :: Git.Ref -> Git.Ref -> Bool equivBranches x y = base x == base y - where - base = takeFileName . show + where + base = takeFileName . show isAnnexBranch :: FilePath -> Bool isAnnexBranch f = n `isSuffixOf` f - where - n = "/" ++ show Annex.Branch.name + where + n = "/" ++ show Annex.Branch.name fileToBranch :: FilePath -> Git.Ref fileToBranch f = Git.Ref $ "refs" base - where - base = Prelude.last $ split "/refs/" f + where + base = Prelude.last $ split "/refs/" f diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index d3da50dd4..fa7d4ec3c 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -119,36 +119,36 @@ startOneService client (x:xs) = do {- Filter matching events recieved when drives are mounted and unmounted. -} mountChanged :: [MatchRule] mountChanged = [gvfs True, gvfs False, kde, kdefallback] - where - {- gvfs reliably generates this event whenever a drive is mounted/unmounted, - - whether automatically, or manually -} - gvfs mount = matchAny - { matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor" - , matchMember = Just $ if mount then "MountAdded" else "MountRemoved" - } - {- This event fires when KDE prompts the user what to do with a drive, - - but maybe not at other times. And it's not received -} - kde = matchAny - { matchInterface = Just "org.kde.Solid.Device" - , matchMember = Just "setupDone" - } - {- This event may not be closely related to mounting a drive, but it's - - observed reliably when a drive gets mounted or unmounted. -} - kdefallback = matchAny - { matchInterface = Just "org.kde.KDirNotify" - , matchMember = Just "enteredDirectory" - } + where + {- gvfs reliably generates this event whenever a + - drive is mounted/unmounted, whether automatically, or manually -} + gvfs mount = matchAny + { matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor" + , matchMember = Just $ if mount then "MountAdded" else "MountRemoved" + } + {- This event fires when KDE prompts the user what to do with a drive, + - but maybe not at other times. And it's not received -} + kde = matchAny + { matchInterface = Just "org.kde.Solid.Device" + , matchMember = Just "setupDone" + } + {- This event may not be closely related to mounting a drive, but it's + - observed reliably when a drive gets mounted or unmounted. -} + kdefallback = matchAny + { matchInterface = Just "org.kde.KDirNotify" + , matchMember = Just "enteredDirectory" + } #endif pollingThread :: Assistant () pollingThread = go =<< liftIO currentMountPoints - where - go wasmounted = do - liftIO $ threadDelaySeconds (Seconds 10) - nowmounted <- liftIO currentMountPoints - handleMounts wasmounted nowmounted - go nowmounted + where + go wasmounted = do + liftIO $ threadDelaySeconds (Seconds 10) + nowmounted <- liftIO currentMountPoints + handleMounts wasmounted nowmounted + go nowmounted handleMounts :: MountPoints -> MountPoints -> Assistant () handleMounts wasmounted nowmounted = @@ -179,11 +179,11 @@ remotesUnder dir = do liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' } updateSyncRemotes return $ map snd $ filter fst pairs - where - checkremote repotop r = case Remote.localpath r of - Just p | dirContains dir (absPathFrom repotop p) -> - (,) <$> pure True <*> updateRemote r - _ -> return (False, r) + where + checkremote repotop r = case Remote.localpath r of + Just p | dirContains dir (absPathFrom repotop p) -> + (,) <$> pure True <*> updateRemote r + _ -> return (False, r) type MountPoints = S.Set Mntent diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index f29bec4b4..90fce8777 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -96,8 +96,8 @@ pairListenerThread urlrenderer = NamedThread "PairListener" $ do if n < chunksz then return $ c ++ msg else getmsg sock $ c ++ msg - where - chunksz = 1024 + where + chunksz = 1024 {- Show an alert when a PairReq is seen. -} pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant () diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index ac65ca14c..69974a21c 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -34,8 +34,8 @@ pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do void $ alertWhile (pushRetryAlert topush) $ do now <- liftIO $ getCurrentTime pushToRemotes now True topush - where - halfhour = 1800 + where + halfhour = 1800 {- This thread pushes git commits out to remotes soon after they are made. -} pushThread :: NamedThread diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index 7b789b8b6..7deafb14d 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -76,10 +76,10 @@ onModify file = do case parseTransferFile file of Nothing -> noop Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) - where - go _ Nothing = noop - go t (Just newinfo) = alterTransferInfo t $ - \i -> i { bytesComplete = bytesComplete newinfo } + where + go _ Nothing = noop + go t (Just newinfo) = alterTransferInfo t $ + \i -> i { bytesComplete = bytesComplete newinfo } {- This thread can only watch transfer sizes when the DirWatcher supports - tracking modificatons to files. -} diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 84013eaa7..1d23487fa 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -104,5 +104,5 @@ shouldTransfer t info notElem (Remote.uuid remote) <$> loggedLocations key | otherwise = return False - where - key = transferKey t + where + key = transferKey t diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs index 80a062e36..8039c561d 100644 --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -54,20 +54,20 @@ runTransferThread (Just (t, info, a)) = do runTransferThread' :: AssistantData -> IO () -> IO () runTransferThread' d a = go - where - go = catchPauseResume a - 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 - - when signaling. Using E.try avoids the problem. -} - catchPauseResume a' = do - r <- E.try a' :: IO (Either E.SomeException ()) - case r of - Left e -> case E.fromException e of - Just PauseTransfer -> pause - Just ResumeTransfer -> go - _ -> done + where + go = catchPauseResume a + 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 + - when signaling. Using E.try avoids the problem. -} + catchPauseResume a' = do + r <- E.try a' :: IO (Either E.SomeException ()) + case r of + Left e -> case E.fromException e of + Just PauseTransfer -> pause + Just ResumeTransfer -> go _ -> done - done = flip runAssistant d $ - flip MSemN.signal 1 <<~ transferSlots + _ -> done + done = flip runAssistant d $ + flip MSemN.signal 1 <<~ transferSlots diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index e599e2072..a2197cd26 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -36,28 +36,28 @@ connectXMPP c a = case parseJID (xmppJID c) of {- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -} connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ()) connectXMPP' jid c a = go =<< lookupSRV srvrecord - where - srvrecord = mkSRVTcp "xmpp-client" $ - T.unpack $ strDomain $ jidDomain jid - serverjid = JID Nothing (jidDomain jid) Nothing - - go [] = run (xmppHostname c) - (PortNumber $ fromIntegral $ xmppPort c) - (a jid) - go ((h,p):rest) = do - {- Try each SRV record in turn, until one connects, - - at which point the MVar will be full. -} - mv <- newEmptyMVar - r <- run h p $ do - liftIO $ putMVar mv () - a jid - ifM (isEmptyMVar mv) (go rest, return r) - - {- Async exceptions are let through so the XMPP thread can - - be killed. -} - run h p a' = tryNonAsync $ - runClientError (Server serverjid h p) jid - (xmppUsername c) (xmppPassword c) (void a') + where + srvrecord = mkSRVTcp "xmpp-client" $ + T.unpack $ strDomain $ jidDomain jid + serverjid = JID Nothing (jidDomain jid) Nothing + + go [] = run (xmppHostname c) + (PortNumber $ fromIntegral $ xmppPort c) + (a jid) + go ((h,p):rest) = do + {- Try each SRV record in turn, until one connects, + - at which point the MVar will be full. -} + mv <- newEmptyMVar + r <- run h p $ do + liftIO $ putMVar mv () + a jid + ifM (isEmptyMVar mv) (go rest, return r) + + {- Async exceptions are let through so the XMPP thread can + - be killed. -} + run h p a' = tryNonAsync $ + runClientError (Server serverjid h p) jid + (xmppUsername c) (xmppPassword c) (void a') {- XMPP runClient, that throws errors rather than returning an Either -} runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a @@ -88,9 +88,9 @@ xmppCredsFile = do gitAnnexPresence :: Element -> Presence gitAnnexPresence tag = (emptyPresence PresenceAvailable) { presencePayloads = [extendedAway, tag] } - where - extendedAway = Element (Name (T.pack "show") Nothing Nothing) [] - [NodeContent $ ContentText $ T.pack "xa"] + where + extendedAway = Element (Name (T.pack "show") Nothing Nothing) [] + [NodeContent $ ContentText $ T.pack "xa"] {- Name of a git-annex tag, in our own XML namespace. - (Not using a namespace URL to avoid unnecessary bloat.) -} @@ -111,18 +111,18 @@ uuidSep = T.pack "," encodePushNotification :: [UUID] -> Element encodePushNotification us = Element gitAnnexTagName [(pushAttr, [ContentText pushvalue])] [] - where - pushvalue = T.intercalate uuidSep $ - map (T.pack . fromUUID) us + where + pushvalue = T.intercalate uuidSep $ + map (T.pack . fromUUID) us decodePushNotification :: Element -> Maybe [UUID] decodePushNotification (Element name attrs _nodes) | name == gitAnnexTagName && not (null us) = Just us | otherwise = Nothing - where - us = map (toUUID . T.unpack) $ - concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $ - filter ispush attrs - ispush (k, _) = k == pushAttr - fromContent (ContentText t) = t - fromContent (ContentEntity t) = t + where + us = map (toUUID . T.unpack) $ + concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $ + filter ispush attrs + ispush (k, _) = k == pushAttr + fromContent (ContentText t) = t + fromContent (ContentEntity t) = t -- cgit v1.2.3