diff options
author | Joey Hess <joey@kitenet.net> | 2012-10-28 22:09:09 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-10-28 22:09:09 -0400 |
commit | 9dd50063b98020add52672864922308ebb479280 (patch) | |
tree | 2d6af9da19692c7a416f8ff897e2a3d73e406a73 | |
parent | 6ea085e7fe12d6c9743b1634cb5f7c4e622ebc3f (diff) |
more indentation. must stop.
-rw-r--r-- | Assistant.hs | 80 | ||||
-rw-r--r-- | Backend.hs | 70 | ||||
-rw-r--r-- | Limit.hs | 104 | ||||
-rw-r--r-- | Messages.hs | 66 | ||||
-rw-r--r-- | Usage.hs | 48 |
5 files changed, 183 insertions, 185 deletions
diff --git a/Assistant.hs b/Assistant.hs index cf92a8625..ade4621e5 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -173,58 +173,58 @@ startDaemon assistant foreground webappwaiter logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile pidfile <- fromRepo gitAnnexPidFile go $ Utility.Daemon.daemonize logfd (Just pidfile) False - where - go d = startAssistant assistant d webappwaiter + where + go d = startAssistant assistant d webappwaiter startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()) -> Annex () startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do checkCanWatch dstatus <- startDaemonStatus liftIO $ daemonize $ run dstatus st - where - run dstatus st = do - changechan <- newChangeChan - commitchan <- newCommitChan - pushmap <- newFailedPushMap - transferqueue <- newTransferQueue - transferslots <- newTransferSlots - scanremotes <- newScanRemoteMap - branchhandle <- newBranchChangeHandle - pushnotifier <- newPushNotifier + where + run dstatus st = do + changechan <- newChangeChan + commitchan <- newCommitChan + pushmap <- newFailedPushMap + transferqueue <- newTransferQueue + transferslots <- newTransferSlots + scanremotes <- newScanRemoteMap + branchhandle <- newBranchChangeHandle + pushnotifier <- newPushNotifier #ifdef WITH_WEBAPP - urlrenderer <- newUrlRenderer + urlrenderer <- newUrlRenderer #endif - mapM_ (startthread dstatus) - [ watch $ commitThread st changechan commitchan transferqueue dstatus + mapM_ (startthread dstatus) + [ watch $ commitThread st changechan commitchan transferqueue dstatus #ifdef WITH_WEBAPP - , assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter + , assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter #ifdef WITH_PAIRING - , assist $ pairListenerThread st dstatus scanremotes urlrenderer + , assist $ pairListenerThread st dstatus scanremotes urlrenderer #endif #endif - , assist $ pushThread st dstatus commitchan pushmap pushnotifier - , assist $ pushRetryThread st dstatus pushmap pushnotifier - , assist $ mergeThread st dstatus transferqueue branchhandle - , assist $ transferWatcherThread st dstatus transferqueue - , assist $ transferPollerThread st dstatus - , assist $ transfererThread st dstatus transferqueue transferslots commitchan - , assist $ daemonStatusThread st dstatus - , assist $ sanityCheckerThread st dstatus transferqueue changechan - , assist $ mountWatcherThread st dstatus scanremotes pushnotifier - , assist $ netWatcherThread st dstatus scanremotes pushnotifier - , assist $ netWatcherFallbackThread st dstatus scanremotes pushnotifier - , assist $ transferScannerThread st dstatus scanremotes transferqueue - , assist $ configMonitorThread st dstatus branchhandle commitchan + , assist $ pushThread st dstatus commitchan pushmap pushnotifier + , assist $ pushRetryThread st dstatus pushmap pushnotifier + , assist $ mergeThread st dstatus transferqueue branchhandle + , assist $ transferWatcherThread st dstatus transferqueue + , assist $ transferPollerThread st dstatus + , assist $ transfererThread st dstatus transferqueue transferslots commitchan + , assist $ daemonStatusThread st dstatus + , assist $ sanityCheckerThread st dstatus transferqueue changechan + , assist $ mountWatcherThread st dstatus scanremotes pushnotifier + , assist $ netWatcherThread st dstatus scanremotes pushnotifier + , assist $ netWatcherFallbackThread st dstatus scanremotes pushnotifier + , assist $ transferScannerThread st dstatus scanremotes transferqueue + , assist $ configMonitorThread st dstatus branchhandle commitchan #ifdef WITH_XMPP - , assist $ pushNotifierThread st dstatus pushnotifier + , assist $ pushNotifierThread st dstatus pushnotifier #endif - , watch $ watchThread st dstatus transferqueue changechan - ] - waitForTermination + , watch $ watchThread st dstatus transferqueue changechan + ] + waitForTermination - watch a = (True, a) - assist a = (False, a) - startthread dstatus (watcher, t) - | watcher || assistant = void $ forkIO $ - runNamedThread dstatus t - | otherwise = noop + watch a = (True, a) + assist a = (False, a) + startthread dstatus (watcher, t) + | watcher || assistant = void $ forkIO $ + runNamedThread dstatus t + | otherwise = noop diff --git a/Backend.hs b/Backend.hs index d1dfdef3c..b66e6130e 100644 --- a/Backend.hs +++ b/Backend.hs @@ -40,16 +40,16 @@ orderedList = do if not $ null l then return l else handle =<< Annex.getState Annex.forcebackend - where - handle Nothing = standard - handle (Just "") = standard - handle (Just name) = do - l' <- (lookupBackendName name :) <$> standard - Annex.changeState $ \s -> s { Annex.backends = l' } - return l' - standard = parseBackendList <$> getConfig (annexConfig "backends") "" - parseBackendList [] = list - parseBackendList s = map lookupBackendName $ words s + where + handle Nothing = standard + handle (Just "") = standard + handle (Just name) = do + l' <- (lookupBackendName name :) <$> standard + Annex.changeState $ \s -> s { Annex.backends = l' } + return l' + standard = parseBackendList <$> getConfig (annexConfig "backends") "" + parseBackendList [] = list + parseBackendList s = map lookupBackendName $ words s {- Generates a key for a file, trying each backend in turn until one - accepts it. @@ -66,12 +66,12 @@ genKey' (b:bs) source = do case r of Nothing -> genKey' bs source Just k -> return $ Just (makesane k, b) - where - -- keyNames should not contain newline characters. - makesane k = k { keyName = map fixbadchar (keyName k) } - fixbadchar c - | c == '\n' = '_' - | otherwise = c + where + -- keyNames should not contain newline characters. + makesane k = k { keyName = map fixbadchar (keyName k) } + fixbadchar c + | c == '\n' = '_' + | otherwise = c {- Looks up the key and backend corresponding to an annexed file, - by examining what the file symlinks to. -} @@ -81,35 +81,33 @@ lookupFile file = do case tl of Left _ -> return Nothing Right l -> makekey l - where - makekey l = maybe (return Nothing) (makeret l) (fileKey $ takeFileName l) - makeret l k = let bname = keyBackendName k in - case maybeLookupBackendName bname of - Just backend -> do - return $ Just (k, backend) - Nothing -> do - when (isLinkToAnnex l) $ warning $ - "skipping " ++ file ++ - " (unknown backend " ++ - bname ++ ")" - return Nothing + where + makekey l = maybe (return Nothing) (makeret l) (fileKey $ takeFileName l) + makeret l k = let bname = keyBackendName k in + case maybeLookupBackendName bname of + Just backend -> do + return $ Just (k, backend) + Nothing -> do + when (isLinkToAnnex l) $ warning $ + "skipping " ++ file ++ + " (unknown backend " ++ bname ++ ")" + return Nothing {- Looks up the backend that should be used for a file. - That can be configured on a per-file basis in the gitattributes file. -} chooseBackend :: FilePath -> Annex (Maybe Backend) chooseBackend f = Annex.getState Annex.forcebackend >>= go - where - go Nothing = maybeLookupBackendName <$> - checkAttr "annex.backend" f - go (Just _) = Just . Prelude.head <$> orderedList + where + go Nothing = maybeLookupBackendName <$> checkAttr "annex.backend" f + go (Just _) = Just . Prelude.head <$> orderedList {- Looks up a backend by name. May fail if unknown. -} lookupBackendName :: String -> Backend lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s - where - unknown = error $ "unknown backend " ++ s + where + unknown = error $ "unknown backend " ++ s maybeLookupBackendName :: String -> Maybe Backend maybeLookupBackendName s = headMaybe matches - where - matches = filter (\b -> s == B.name b) list + where + matches = filter (\b -> s == B.name b) list @@ -54,9 +54,9 @@ getMatcher' = do {- Adds something to the limit list, which is built up reversed. -} add :: Utility.Matcher.Token (Annex.FileInfo -> Annex Bool) -> Annex () add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } - where - prepend (Left ls) = Left $ l:ls - prepend _ = error "internal" + where + prepend (Left ls) = Left $ l:ls + prepend _ = error "internal" {- Adds a new token. -} addToken :: String -> Annex () @@ -83,9 +83,9 @@ limitExclude glob = Right $ const $ return . not . matchglob glob matchglob :: String -> Annex.FileInfo -> Bool matchglob glob (Annex.FileInfo { Annex.matchFile = f }) = isJust $ match cregex f [] - where - cregex = compile regex [] - regex = '^':wildToRegex glob + where + cregex = compile regex [] + regex = '^':wildToRegex glob {- Adds a limit to skip files not believed to be present - in a specfied repository. -} @@ -97,21 +97,21 @@ limitIn name = Right $ \notpresent -> check $ if name == "." then inhere notpresent else inremote notpresent - where - check a = lookupFile >=> handle a - handle _ Nothing = return False - handle a (Just (key, _)) = a key - inremote notpresent key = do - u <- Remote.nameToUUID name - us <- Remote.keyLocations key - return $ u `elem` us && u `S.notMember` notpresent - inhere notpresent key - | S.null notpresent = inAnnex key - | otherwise = do - u <- getUUID - if u `S.member` notpresent - then return False - else inAnnex key + where + check a = lookupFile >=> handle a + handle _ Nothing = return False + handle a (Just (key, _)) = a key + inremote notpresent key = do + u <- Remote.nameToUUID name + us <- Remote.keyLocations key + return $ u `elem` us && u `S.notMember` notpresent + inhere notpresent key + | S.null notpresent = inAnnex key + | otherwise = do + u <- getUUID + if u `S.member` notpresent + then return False + else inAnnex key {- Limit to content that is currently present on a uuid. -} limitPresent :: Maybe UUID -> MkLimit @@ -122,10 +122,10 @@ limitPresent u _ = Right $ const $ check $ \key -> do else do us <- Remote.keyLocations key return $ maybe False (`elem` us) u - where - check a = lookupFile >=> handle a - handle _ Nothing = return False - handle a (Just (key, _)) = a key + where + check a = lookupFile >=> handle a + handle _ Nothing = return False + handle a (Just (key, _)) = a key {- Adds a limit to skip files not believed to have the specified number - of copies. -} @@ -139,18 +139,18 @@ limitCopies want = case split ":" want of Nothing -> go n $ checkgroup v [n] -> go n $ const $ return True _ -> Left "bad value for copies" - where - go num good = case readish num of - Nothing -> Left "bad number for copies" - Just n -> Right $ \notpresent f -> - lookupFile f >>= handle n good notpresent - handle _ _ _ Nothing = return False - handle n good notpresent (Just (key, _)) = do - us <- filter (`S.notMember` notpresent) - <$> (filterM good =<< Remote.keyLocations key) - return $ length us >= n - checktrust t u = (== t) <$> lookupTrust u - checkgroup g u = S.member g <$> lookupGroups u + where + go num good = case readish num of + Nothing -> Left "bad number for copies" + Just n -> Right $ \notpresent f -> + lookupFile f >>= handle n good notpresent + handle _ _ _ Nothing = return False + handle n good notpresent (Just (key, _)) = do + us <- filter (`S.notMember` notpresent) + <$> (filterM good =<< Remote.keyLocations key) + return $ length us >= n + checktrust t u = (== t) <$> lookupTrust u + checkgroup g u = S.member g <$> lookupGroups u {- Adds a limit to skip files not believed to be present in all - repositories in the specified group. -} @@ -163,15 +163,15 @@ limitInAllGroup :: GroupMap -> MkLimit limitInAllGroup m groupname | S.null want = Right $ const $ const $ return True | otherwise = Right $ \notpresent -> lookupFile >=> check notpresent - where - want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m - check _ Nothing = return False - check notpresent (Just (key, _)) - -- optimisation: Check if a wanted uuid is notpresent. - | not (S.null (S.intersection want notpresent)) = return False - | otherwise = do - present <- S.fromList <$> Remote.keyLocations key - return $ S.null $ want `S.difference` present + where + want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m + check _ Nothing = return False + check notpresent (Just (key, _)) + -- optimisation: Check if a wanted uuid is notpresent. + | not (S.null (S.intersection want notpresent)) = return False + | otherwise = do + present <- S.fromList <$> Remote.keyLocations key + return $ S.null $ want `S.difference` present {- Adds a limit to skip files not using a specified key-value backend. -} addInBackend :: String -> Annex () @@ -179,9 +179,9 @@ addInBackend = addLimit . limitInBackend limitInBackend :: MkLimit limitInBackend name = Right $ const $ lookupFile >=> check - where - wanted = Backend.lookupBackendName name - check = return . maybe False ((==) wanted . snd) + where + wanted = Backend.lookupBackendName name + check = return . maybe False ((==) wanted . snd) {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex () @@ -194,9 +194,9 @@ limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit limitSize vs s = case readSize dataUnits s of Nothing -> Left "bad size" Just sz -> Right $ const $ lookupFile >=> check sz - where - check _ Nothing = return False - check sz (Just (key, _)) = return $ keySize key `vs` Just sz + where + check _ Nothing = return False + check sz (Just (key, _)) = return $ keySize key `vs` Just sz addTimeLimit :: String -> Annex () addTimeLimit s = do diff --git a/Messages.hs b/Messages.hs index 08a17b25c..f3cd9fc0e 100644 --- a/Messages.hs +++ b/Messages.hs @@ -65,29 +65,29 @@ showProgress = handle q $ - The action is passed a callback to use to update the meter. -} metered :: (Maybe MeterUpdate) -> Key -> (MeterUpdate -> Annex a) -> Annex a metered combinemeterupdate key a = withOutputType $ go (keySize key) - where - go (Just size) NormalOutput = do - progress <- liftIO $ newProgress "" size - meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1) - showOutput - liftIO $ displayMeter stdout meter - r <- a $ \n -> liftIO $ do - incrP progress n - displayMeter stdout meter - maybe noop (\m -> m n) combinemeterupdate - liftIO $ clearMeter stdout meter - return r - go _ _ = a (const noop) + where + go (Just size) NormalOutput = do + progress <- liftIO $ newProgress "" size + meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1) + showOutput + liftIO $ displayMeter stdout meter + r <- a $ \n -> liftIO $ do + incrP progress n + displayMeter stdout meter + maybe noop (\m -> m n) combinemeterupdate + liftIO $ clearMeter stdout meter + return r + go _ _ = a (const noop) showSideAction :: String -> Annex () showSideAction m = Annex.getState Annex.output >>= go - where - go (MessageState v StartBlock) = do - p - Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock } - go (MessageState _ InBlock) = return () - go _ = p - p = handle q $ putStrLn $ "(" ++ m ++ "...)" + where + go (MessageState v StartBlock) = do + p + Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock } + go (MessageState _ InBlock) = return () + go _ = p + p = handle q $ putStrLn $ "(" ++ m ++ "...)" showStoringStateAction :: Annex () showStoringStateAction = showSideAction "Recording state in git" @@ -106,8 +106,8 @@ doSideAction' b a = do o <- Annex.getState Annex.output set $ o { sideActionBlock = b } set o `after` a - where - set o = Annex.changeState $ \s -> s { Annex.output = o } + where + set o = Annex.changeState $ \s -> s { Annex.output = o } showOutput :: Annex () showOutput = handle q $ @@ -125,10 +125,10 @@ showEndFail = showEndResult False showEndResult :: Bool -> Annex () showEndResult ok = handle (JSON.end ok) $ putStrLn msg - where - msg - | ok = "ok" - | otherwise = "failed" + where + msg + | ok = "ok" + | otherwise = "failed" showErr :: (Show a) => a -> Annex () showErr e = warning' $ "git-annex: " ++ show e @@ -153,9 +153,9 @@ maybeShowJSON v = handle (JSON.add v) q {- Shows a complete JSON value, only when in json mode. -} showFullJSON :: JSON a => [(String, a)] -> Annex Bool showFullJSON v = withOutputType $ liftIO . go - where - go JSONOutput = JSON.complete v >> return True - go _ = return False + where + go JSONOutput = JSON.complete v >> return True + go _ = return False {- Performs an action that outputs nonstandard/customized output, and - in JSON mode wraps its output in JSON.start and JSON.end, so it's @@ -184,10 +184,10 @@ setupConsole = do handle :: IO () -> IO () -> Annex () handle json normal = withOutputType go - where - go NormalOutput = liftIO normal - go QuietOutput = q - go JSONOutput = liftIO $ flushed json + where + go NormalOutput = liftIO normal + go QuietOutput = q + go JSONOutput = liftIO $ flushed json q :: Monad m => m () q = noop @@ -23,30 +23,30 @@ usage header cmds commonoptions = unlines $ , "Commands:" , "" ] ++ cmdlines - where - -- To get consistent indentation of options, generate the - -- usage for all options at once. A command's options will - -- be displayed after the command. - alloptlines = filter (not . null) $ - lines $ usageInfo "" $ - concatMap cmdoptions scmds ++ commonoptions - (cmdlines, optlines) = go scmds alloptlines [] - go [] os ls = (ls, os) - go (c:cs) os ls = go cs os' (ls++(l:o)) - where - (o, os') = splitAt (length $ cmdoptions c) os - l = concat - [ cmdname c - , namepad (cmdname c) - , cmdparamdesc c - , descpad (cmdparamdesc c) - , cmddesc c - ] - pad n s = replicate (n - length s) ' ' - namepad = pad $ longest cmdname + 1 - descpad = pad $ longest cmdparamdesc + 2 - longest f = foldl max 0 $ map (length . f) cmds - scmds = sort cmds + where + -- To get consistent indentation of options, generate the + -- usage for all options at once. A command's options will + -- be displayed after the command. + alloptlines = filter (not . null) $ + lines $ usageInfo "" $ + concatMap cmdoptions scmds ++ commonoptions + (cmdlines, optlines) = go scmds alloptlines [] + go [] os ls = (ls, os) + go (c:cs) os ls = go cs os' (ls++(l:o)) + where + (o, os') = splitAt (length $ cmdoptions c) os + l = concat + [ cmdname c + , namepad (cmdname c) + , cmdparamdesc c + , descpad (cmdparamdesc c) + , cmddesc c + ] + pad n s = replicate (n - length s) ' ' + namepad = pad $ longest cmdname + 1 + descpad = pad $ longest cmdparamdesc + 2 + longest f = foldl max 0 $ map (length . f) cmds + scmds = sort cmds {- Descriptions of params used in usage messages. -} paramPaths :: String |