diff options
author | Joey Hess <joey@kitenet.net> | 2012-11-11 00:51:07 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-11-11 00:51:07 -0400 |
commit | 264bd9ebe37855d4005022df057da13ec8080afb (patch) | |
tree | f32f13646ece29c8f6336b8680cb07dd55187be5 | |
parent | d9f5cc9f73ea046fcd2b59b5e75d4600593ac05b (diff) |
where indenting
42 files changed, 1196 insertions, 1212 deletions
diff --git a/Backend/SHA.hs b/Backend/SHA.hs index bfb94df99..ef0e92d20 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -57,24 +57,23 @@ shaN shasize file filesize = do Left sha -> liftIO $ sha <$> L.readFile file Right command -> liftIO $ parse command . lines <$> readsha command (toCommand [File file]) - where - parse command [] = bad command - parse command (l:_) - | null sha = bad command - | otherwise = sha - where - sha = fst $ separate (== ' ') l - bad command = error $ command ++ " parse error" - {- sha commands output the filename, so need to set fileEncoding -} - readsha command args = - withHandle StdoutHandle createProcessSuccess p $ \h -> do - fileEncoding h - output <- hGetContentsStrict h - hClose h - return output - where - p = (proc command args) - { std_out = CreatePipe } + where + parse command [] = bad command + parse command (l:_) + | null sha = bad command + | otherwise = sha + where + sha = fst $ separate (== ' ') l + bad command = error $ command ++ " parse error" + {- sha commands output the filename, so need to set fileEncoding -} + readsha command args = + withHandle StdoutHandle createProcessSuccess p $ \h -> do + fileEncoding h + output <- hGetContentsStrict h + hClose h + return output + where + p = (proc command args) { std_out = CreatePipe } shaCommand :: SHASize -> Integer -> Either (L.ByteString -> String) String shaCommand shasize filesize @@ -84,14 +83,14 @@ shaCommand shasize filesize | shasize == 384 = use SysConfig.sha384 sha384 | shasize == 512 = use SysConfig.sha512 sha512 | otherwise = error $ "bad sha size " ++ show shasize - where - use Nothing sha = Left $ showDigest . sha - use (Just c) sha - -- use builtin, but slower sha for small files - -- benchmarking indicates it's faster up to - -- and slightly beyond 50 kb files - | filesize < 51200 = use Nothing sha - | otherwise = Right c + where + use Nothing sha = Left $ showDigest . sha + use (Just c) sha + {- use builtin, but slower sha for small files + - benchmarking indicates it's faster up to + - and slightly beyond 50 kb files -} + | filesize < 51200 = use Nothing sha + | otherwise = Right c {- A key is a checksum of its contents. -} keyValue :: SHASize -> KeySource -> Annex (Maybe Key) @@ -109,23 +108,23 @@ keyValue shasize source = do {- Extension preserving keys. -} keyValueE :: SHASize -> KeySource -> Annex (Maybe Key) keyValueE size source = keyValue size source >>= maybe (return Nothing) addE - where - addE k = return $ Just $ k - { keyName = keyName k ++ selectExtension (keyFilename source) - , keyBackendName = shaNameE size - } + where + addE k = return $ Just $ k + { keyName = keyName k ++ selectExtension (keyFilename source) + , keyBackendName = shaNameE size + } selectExtension :: FilePath -> String selectExtension f | null es = "" | otherwise = join "." ("":es) - where - es = filter (not . null) $ reverse $ - take 2 $ takeWhile shortenough $ - reverse $ split "." $ takeExtensions f - shortenough e - | '\n' `elem` e = False -- newline in extension?! - | otherwise = length e <= 4 -- long enough for "jpeg" + where + es = filter (not . null) $ reverse $ + take 2 $ takeWhile shortenough $ + reverse $ split "." $ takeExtensions f + shortenough e + | '\n' `elem` e = False -- newline in extension?! + | otherwise = length e <= 4 -- long enough for "jpeg" {- A key's checksum is checked during fsck. -} checkKeyChecksum :: SHASize -> Key -> FilePath -> Annex Bool @@ -137,7 +136,7 @@ checkKeyChecksum size key file = do let filesize = fromIntegral $ fileSize stat check <$> shaN size file filesize _ -> return True - where - check s - | s == dropExtensions (keyName key) = True - | otherwise = False + where + check s + | s == dropExtensions (keyName key) = True + | otherwise = False diff --git a/Backend/URL.hs b/Backend/URL.hs index cc9112a36..81c287cfd 100644 --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -32,10 +32,10 @@ fromUrl url size = stubKey , keyBackendName = "URL" , keySize = size } - where - -- when it's not too long, use the url as the key name - -- 256 is the absolute filename max, but use a shorter - -- length because this is not the entire key filename. - key - | length url < 128 = url - | otherwise = take 128 url ++ "-" ++ md5s (Str url) + where + {- when it's not too long, use the url as the key name + - 256 is the absolute filename max, but use a shorter + - length because this is not the entire key filename. -} + key + | length url < 128 = url + | otherwise = take 128 url ++ "-" ++ md5s (Str url) diff --git a/Build/Configure.hs b/Build/Configure.hs index b003ab6be..d25445f40 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -45,19 +45,18 @@ tests = - known-good hashes. -} shaTestCases :: [(Int, String)] -> [TestCase] shaTestCases l = map make l - where - make (n, knowngood) = - TestCase key $ maybeSelectCmd key $ - zip (shacmds n) (repeat check) - where - key = "sha" ++ show n - check = "</dev/null | grep -q '" ++ knowngood ++ "'" - shacmds n = concatMap (\x -> [x, 'g':x, osxpath </> x]) $ - map (\x -> "sha" ++ show n ++ x) ["sum", ""] - {- Max OSX sometimes puts GNU tools outside PATH, so look in - - the location it uses, and remember where to run them - - from. -} - osxpath = "/opt/local/libexec/gnubin" + where + make (n, knowngood) = TestCase key $ maybeSelectCmd key $ + zip (shacmds n) (repeat check) + where + key = "sha" ++ show n + check = "</dev/null | grep -q '" ++ knowngood ++ "'" + shacmds n = concatMap (\x -> [x, 'g':x, osxpath </> x]) $ + map (\x -> "sha" ++ show n ++ x) ["sum", ""] + {- Max OSX sometimes puts GNU tools outside PATH, so look in + - the location it uses, and remember where to run them + - from. -} + osxpath = "/opt/local/libexec/gnubin" tmpDir :: String tmpDir = "tmp" @@ -67,9 +66,9 @@ testFile = tmpDir ++ "/testfile" testCp :: ConfigKey -> String -> TestCase testCp k option = TestCase cmd $ testCmd k cmdline - where - cmd = "cp " ++ option - cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new" + where + cmd = "cp " ++ option + cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new" {- Pulls package version out of the changelog. -} getVersion :: Test @@ -82,8 +81,8 @@ getVersionString = do changelog <- readFile "CHANGELOG" let verline = head $ lines changelog return $ middle (words verline !! 1) - where - middle = drop 1 . init + where + middle = drop 1 . init getGitVersion :: Test getGitVersion = do @@ -104,14 +103,14 @@ cabalSetup = do map (setfield "Version" version) $ lines cabal renameFile tmpcabalfile cabalfile - where - cabalfile = "git-annex.cabal" - tmpcabalfile = cabalfile++".tmp" - setfield field value s - | fullfield `isPrefixOf` s = fullfield ++ value - | otherwise = s - where - fullfield = field ++ ": " + where + cabalfile = "git-annex.cabal" + tmpcabalfile = cabalfile++".tmp" + setfield field value s + | fullfield `isPrefixOf` s = fullfield ++ value + | otherwise = s + where + fullfield = field ++ ": " setup :: IO () setup = do diff --git a/Build/InstallDesktopFile.hs b/Build/InstallDesktopFile.hs index 121205687..633979155 100644 --- a/Build/InstallDesktopFile.hs +++ b/Build/InstallDesktopFile.hs @@ -46,11 +46,11 @@ autostart command = genDesktopEntry systemwideInstall :: IO Bool systemwideInstall = isroot <||> destdirset - where - isroot = do - uid <- fromIntegral <$> getRealUserID - return $ uid == (0 :: Int) - destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR") + where + isroot = do + uid <- fromIntegral <$> getRealUserID + return $ uid == (0 :: Int) + destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR") inDestDir :: FilePath -> IO FilePath inDestDir f = do @@ -91,6 +91,6 @@ install command = do main :: IO () main = getArgs >>= go - where - go [] = error "specify git-annex command" - go (command:_) = install command + where + go [] = error "specify git-annex command" + go (command:_) = install command diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs index eb920c13f..92f6f6843 100644 --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -29,22 +29,22 @@ instance Show Config where [ key ++ " :: " ++ valuetype value , key ++ " = " ++ show value ] - where - valuetype (BoolConfig _) = "Bool" - valuetype (StringConfig _) = "String" - valuetype (MaybeStringConfig _) = "Maybe String" - valuetype (MaybeBoolConfig _) = "Maybe Bool" + where + valuetype (BoolConfig _) = "Bool" + valuetype (StringConfig _) = "String" + valuetype (MaybeStringConfig _) = "Maybe String" + valuetype (MaybeBoolConfig _) = "Maybe Bool" writeSysConfig :: [Config] -> IO () writeSysConfig config = writeFile "Build/SysConfig.hs" body - where - body = unlines $ header ++ map show config ++ footer - header = [ - "{- Automatically generated. -}" - , "module Build.SysConfig where" - , "" - ] - footer = [] + where + body = unlines $ header ++ map show config ++ footer + header = [ + "{- Automatically generated. -}" + , "module Build.SysConfig where" + , "" + ] + footer = [] runTests :: [TestCase] -> IO [Config] runTests [] = return [] @@ -60,12 +60,12 @@ requireCmd :: ConfigKey -> String -> Test requireCmd k cmdline = do ret <- testCmd k cmdline handle ret - where - handle r@(Config _ (BoolConfig True)) = return r - handle r = do - testEnd r - error $ "** the " ++ c ++ " command is required" - c = head $ words cmdline + where + handle r@(Config _ (BoolConfig True)) = return r + handle r = do + testEnd r + error $ "** the " ++ c ++ " command is required" + c = head $ words cmdline {- Checks if a command is available by running a command line. -} testCmd :: ConfigKey -> String -> Test @@ -90,13 +90,13 @@ maybeSelectCmd k = searchCmd searchCmd :: (String -> Test) -> ([String] -> Test) -> [(String, String)] -> Test searchCmd success failure cmdsparams = search cmdsparams - where - search [] = failure $ fst $ unzip cmdsparams - search ((c, params):cs) = do - ret <- system $ quiet $ c ++ " " ++ params - if ret == ExitSuccess - then success c - else search cs + where + search [] = failure $ fst $ unzip cmdsparams + search ((c, params):cs) = do + ret <- system $ quiet $ c ++ " " ++ params + if ret == ExitSuccess + then success c + else search cs quiet :: String -> String quiet s = s ++ " >/dev/null 2>&1" diff --git a/CmdLine.hs b/CmdLine.hs index 66bf5b882..0b155215d 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -44,13 +44,13 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do sequence_ flags prepCommand cmd params tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdnocommit cmd] - where - err msg = msg ++ "\n\n" ++ usage header allcmds commonoptions - cmd = Prelude.head cmds - (fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err - (flags, params) = getOptCmd args cmd commonoptions err - checkfuzzy = when fuzzy $ - inRepo $ Git.AutoCorrect.prepare name cmdname cmds + where + err msg = msg ++ "\n\n" ++ usage header allcmds commonoptions + cmd = Prelude.head cmds + (fuzzy, cmds, name, args) = findCmd fuzzyok allargs allcmds err + (flags, params) = getOptCmd args cmd commonoptions err + checkfuzzy = when fuzzy $ + inRepo $ Git.AutoCorrect.prepare name cmdname cmds {- Parses command line params far enough to find the Command to run, and - returns the remaining params. @@ -61,25 +61,25 @@ findCmd fuzzyok argv cmds err | not (null exactcmds) = (False, exactcmds, fromJust name, args) | fuzzyok && not (null inexactcmds) = (True, inexactcmds, fromJust name, args) | otherwise = error $ err $ "unknown command " ++ fromJust name - where - (name, args) = findname argv [] - findname [] c = (Nothing, reverse c) - findname (a:as) c - | "-" `isPrefixOf` a = findname as (a:c) - | otherwise = (Just a, reverse c ++ as) - exactcmds = filter (\c -> name == Just (cmdname c)) cmds - inexactcmds = case name of - Nothing -> [] - Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds + where + (name, args) = findname argv [] + findname [] c = (Nothing, reverse c) + findname (a:as) c + | "-" `isPrefixOf` a = findname as (a:c) + | otherwise = (Just a, reverse c ++ as) + exactcmds = filter (\c -> name == Just (cmdname c)) cmds + inexactcmds = case name of + Nothing -> [] + Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds {- Parses command line options, and returns actions to run to configure flags - and the remaining parameters for the command. -} getOptCmd :: Params -> Command -> [Option] -> (String -> String) -> (Flags, Params) getOptCmd argv cmd commonoptions err = check $ getOpt Permute (commonoptions ++ cmdoptions cmd) argv - where - check (flags, rest, []) = (flags, rest) - check (_, _, errs) = error $ err $ concat errs + where + check (flags, rest, []) = (flags, rest) + check (_, _, errs) = error $ err $ concat errs {- Runs a list of Annex actions. Catches IO errors and continues - (but explicitly thrown errors terminate the whole command). @@ -93,18 +93,18 @@ tryRun' errnum _ cmd [] tryRun' errnum state cmd (a:as) = do r <- run handle $! r - where - run = tryIO $ Annex.run state $ do - Annex.Queue.flushWhenFull - a - handle (Left err) = showerr err >> cont False state - handle (Right (success, state')) = cont success state' - cont success s = do - let errnum' = if success then errnum else errnum + 1 - (tryRun' $! errnum') s cmd as - showerr err = Annex.eval state $ do - showErr err - showEndFail + where + run = tryIO $ Annex.run state $ do + Annex.Queue.flushWhenFull + a + handle (Left err) = showerr err >> cont False state + handle (Right (success, state')) = cont success state' + cont success s = do + let errnum' = if success then errnum else errnum + 1 + (tryRun' $! errnum') s cmd as + showerr err = Annex.eval state $ do + showErr err + showEndFail {- Actions to perform each time ran. -} startup :: Annex Bool diff --git a/Command.hs b/Command.hs index 8e7bf9758..bac26667d 100644 --- a/Command.hs +++ b/Command.hs @@ -80,14 +80,14 @@ prepCommand Command { cmdseek = seek, cmdcheck = c } params = do {- Runs a command through the start, perform and cleanup stages -} doCommand :: CommandStart -> CommandCleanup doCommand = start - where - start = stage $ maybe skip perform - perform = stage $ maybe failure cleanup - cleanup = stage $ status - stage = (=<<) - skip = return True - failure = showEndFail >> return False - status r = showEndResult r >> return r + where + start = stage $ maybe skip perform + perform = stage $ maybe failure cleanup + cleanup = stage $ status + stage = (=<<) + skip = return True + failure = showEndFail >> return False + status r = showEndResult r >> return r {- Modifies an action to only act on files that are already annexed, - and passes the key and backend on to it. -} @@ -118,26 +118,26 @@ numCopies file = readish <$> checkAttr "annex.numcopies" file -} autoCopies :: FilePath -> Key -> (Int -> Int -> Bool) -> CommandStart -> CommandStart autoCopies file key vs a = Annex.getState Annex.auto >>= go - where - go False = a - go True = do - numcopiesattr <- numCopies file - needed <- getNumCopies numcopiesattr - (_, have) <- trustPartition UnTrusted =<< Remote.keyLocations key - if length have `vs` needed then a else stop + where + go False = a + go True = do + numcopiesattr <- numCopies file + needed <- getNumCopies numcopiesattr + have <- trustExclude UnTrusted =<< Remote.keyLocations key + if length have `vs` needed then a else stop autoCopiesWith :: FilePath -> Key -> (Int -> Int -> Bool) -> (Maybe Int -> CommandStart) -> CommandStart autoCopiesWith file key vs a = do numcopiesattr <- numCopies file Annex.getState Annex.auto >>= auto numcopiesattr - where - auto numcopiesattr False = a numcopiesattr - auto numcopiesattr True = do - needed <- getNumCopies numcopiesattr - (_, have) <- trustPartition UnTrusted =<< Remote.keyLocations key - if length have `vs` needed - then a numcopiesattr - else stop + where + auto numcopiesattr False = a numcopiesattr + auto numcopiesattr True = do + needed <- getNumCopies numcopiesattr + have <- trustExclude UnTrusted =<< Remote.keyLocations key + if length have `vs` needed + then a numcopiesattr + else stop checkAuto :: Annex Bool -> Annex Bool checkAuto checker = ifM (Annex.getState Annex.auto) @@ -81,8 +81,8 @@ repoIsSsh Repo { location = Url url } | scheme == "git+ssh:" = True | scheme == "ssh+git:" = True | otherwise = False - where - scheme = uriScheme url + where + scheme = uriScheme url repoIsSsh _ = False repoIsHttp :: Repo -> Bool @@ -126,5 +126,5 @@ hookPath script repo = do let hook = localGitDir repo </> "hooks" </> script ifM (catchBoolIO $ isexecutable hook) ( return $ Just hook , return Nothing ) - where - isexecutable f = isExecutable . fileMode <$> getFileStatus f + where + isexecutable f = isExecutable . fileMode <$> getFileStatus f diff --git a/GitAnnex.hs b/GitAnnex.hs index 26a591133..dcde2644c 100644 --- a/GitAnnex.hs +++ b/GitAnnex.hs @@ -165,12 +165,13 @@ options = Option.common ++ , Option ['T'] ["time-limit"] (ReqArg Limit.addTimeLimit paramTime) "stop after the specified amount of time" ] ++ Option.matcher - where - setnumcopies v = Annex.changeState $ \s -> s { Annex.forcenumcopies = readish v } - setgitconfig :: String -> Annex () - setgitconfig v = do - newg <- inRepo $ Git.Config.store v - Annex.changeState $ \s -> s { Annex.repo = newg } + where + setnumcopies v = Annex.changeState $ + \s -> s { Annex.forcenumcopies = readish v } + setgitconfig :: String -> Annex () + setgitconfig v = do + newg <- inRepo $ Git.Config.store v + Annex.changeState $ \s -> s { Annex.repo = newg } header :: String header = "Usage: git-annex command [option ..]" diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs index 42841a647..f77347a1c 100644 --- a/GitAnnexShell.hs +++ b/GitAnnexShell.hs @@ -44,24 +44,22 @@ cmds_notreadonly = concat cmds :: [Command] cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly - where - adddirparam c = c - { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c - } + where + adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c } options :: [OptDescr (Annex ())] options = Option.common ++ [ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "local repository uuid" ] - where - checkuuid expected = getUUID >>= check - where - check u | u == toUUID expected = noop - check NoUUID = unexpected "uninitialized repository" - check u = unexpected $ "UUID " ++ fromUUID u - unexpected s = error $ - "expected repository UUID " ++ - expected ++ " but found " ++ s + where + checkuuid expected = getUUID >>= check + where + check u | u == toUUID expected = noop + check NoUUID = unexpected "uninitialized repository" + check u = unexpected $ "UUID " ++ fromUUID u + unexpected s = error $ + "expected repository UUID " ++ + expected ++ " but found " ++ s header :: String header = "Usage: git-annex-shell [-c] command [parameters ...] [option ..]" @@ -152,20 +150,20 @@ checkDirectory mdir = do if d' `equalFilePath` dir' then noop else req d' (Just dir') - where - req d mdir' = error $ unwords - [ "Only allowed to access" - , d - , maybe "and could not determine directory from command line" ("not " ++) mdir' - ] - - {- A directory may start with ~/ or in some cases, even /~/, - - or could just be relative to home, or of course could - - be absolute. -} - canondir home d - | "~/" `isPrefixOf` d = return d - | "/~/" `isPrefixOf` d = return $ drop 1 d - | otherwise = relHome $ absPathFrom home d + where + req d mdir' = error $ unwords + [ "Only allowed to access" + , d + , maybe "and could not determine directory from command line" ("not " ++) mdir' + ] + + {- A directory may start with ~/ or in some cases, even /~/, + - or could just be relative to home, or of course could + - be absolute. -} + canondir home d + | "~/" `isPrefixOf` d = return d + | "/~/" `isPrefixOf` d = return $ drop 1 d + | otherwise = relHome $ absPathFrom home d checkEnv :: String -> IO () checkEnv var = do diff --git a/Logs/Group.hs b/Logs/Group.hs index de0d1e598..a069edcdf 100644 --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -64,10 +64,10 @@ groupMapLoad = do makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap makeGroupMap byuuid = GroupMap byuuid bygroup - where - bygroup = M.fromListWith S.union $ - concat $ map explode $ M.toList byuuid - explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s) + where + bygroup = M.fromListWith S.union $ + concat $ map explode $ M.toList byuuid + explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s) {- If a repository is in exactly one standard group, returns it. -} getStandardGroup :: S.Set Group -> Maybe StandardGroup diff --git a/Logs/Location.hs b/Logs/Location.hs index e27ece5d4..4273710fc 100644 --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -47,13 +47,13 @@ loggedKeys = mapMaybe (logFileKey . takeFileName) <$> Annex.Branch.files - they are present for the specified repository. -} loggedKeysFor :: UUID -> Annex [Key] loggedKeysFor u = filterM isthere =<< loggedKeys - where - {- This should run strictly to avoid the filterM - - building many thunks containing keyLocations data. -} - isthere k = do - us <- loggedLocations k - let !there = u `elem` us - return there + where + {- This should run strictly to avoid the filterM + - building many thunks containing keyLocations data. -} + isthere k = do + us <- loggedLocations k + let !there = u `elem` us + return there {- The filename of the log file for a given key. -} logFile :: Key -> String @@ -64,5 +64,5 @@ logFileKey :: FilePath -> Maybe Key logFileKey file | ext == ".log" = fileKey base | otherwise = Nothing - where - (base, ext) = splitAt (length file - 4) file + where + (base, ext) = splitAt (length file - 4) file diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs index 003efaeae..ddcc2acf8 100644 --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -90,8 +90,8 @@ makeMatcher groupmap u s | s == "standard" = standardMatcher groupmap u | null (lefts tokens) = Utility.Matcher.generate $ rights tokens | otherwise = matchAll - where - tokens = map (parseToken (Just u) groupmap) (tokenizeMatcher s) + where + tokens = map (parseToken (Just u) groupmap) (tokenizeMatcher s) {- Standard matchers are pre-defined for some groups. If none is defined, - or a repository is in multiple groups with standard matchers, match all. -} @@ -124,17 +124,17 @@ parseToken mu groupmap t , ("smallerthan", limitSize (<)) , ("inallgroup", limitInAllGroup groupmap) ] - where - (k, v) = separate (== '=') t - use a = Utility.Matcher.Operation <$> a v + where + (k, v) = separate (== '=') t + use a = Utility.Matcher.Operation <$> a v {- This is really dumb tokenization; there's no support for quoted values. - Open and close parens are always treated as standalone tokens; - otherwise tokens must be separated by whitespace. -} tokenizeMatcher :: String -> [String] tokenizeMatcher = filter (not . null ) . concatMap splitparens . words - where - splitparens = segmentDelim (`elem` "()") + where + splitparens = segmentDelim (`elem` "()") {- Puts a UUID in a standard group, and sets its preferred content to use - the standard expression for that group, unless something is already set. -} diff --git a/Logs/Presence.hs b/Logs/Presence.hs index e75e1e4e6..ce5dd5780 100644 --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -53,23 +53,23 @@ readLog = parseLog <$$> Annex.Branch.get {- Parses a log file. Unparseable lines are ignored. -} parseLog :: String -> [LogLine] parseLog = mapMaybe (parseline . words) . lines - where - parseline (a:b:c:_) = do - d <- parseTime defaultTimeLocale "%s%Qs" a - s <- parsestatus b - Just $ LogLine (utcTimeToPOSIXSeconds d) s c - parseline _ = Nothing - parsestatus "1" = Just InfoPresent - parsestatus "0" = Just InfoMissing - parsestatus _ = Nothing + where + parseline (a:b:c:_) = do + d <- parseTime defaultTimeLocale "%s%Qs" a + s <- parsestatus b + Just $ LogLine (utcTimeToPOSIXSeconds d) s c + parseline _ = Nothing + parsestatus "1" = Just InfoPresent + parsestatus "0" = Just InfoMissing + parsestatus _ = Nothing {- Generates a log file. -} showLog :: [LogLine] -> String showLog = unlines . map genline - where - genline (LogLine d s i) = unwords [show d, genstatus s, i] - genstatus InfoPresent = "1" - genstatus InfoMissing = "0" + where + genline (LogLine d s i) = unwords [show d, genstatus s, i] + genstatus InfoPresent = "1" + genstatus InfoMissing = "0" {- Generates a new LogLine with the current date. -} logNow :: LogStatus -> String -> Annex LogLine @@ -102,7 +102,7 @@ mapLog :: LogLine -> LogMap -> LogMap mapLog l m | better = M.insert i l m | otherwise = m - where - better = maybe True newer $ M.lookup i m - newer l' = date l' <= date l - i = info l + where + better = maybe True newer $ M.lookup i m + newer l' = date l' <= date l + i = info l diff --git a/Logs/Remote.hs b/Logs/Remote.hs index d4991e272..3348059b4 100644 --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -48,40 +48,40 @@ showConfig = unwords . configToKeyVal {- Given Strings like "key=value", generates a RemoteConfig. -} keyValToConfig :: [String] -> RemoteConfig keyValToConfig ws = M.fromList $ map (/=/) ws - where - (/=/) s = (k, v) - where - k = takeWhile (/= '=') s - v = configUnEscape $ drop (1 + length k) s + where + (/=/) s = (k, v) + where + k = takeWhile (/= '=') s + v = configUnEscape $ drop (1 + length k) s configToKeyVal :: M.Map String String -> [String] configToKeyVal m = map toword $ sort $ M.toList m - where - toword (k, v) = k ++ "=" ++ configEscape v + where + toword (k, v) = k ++ "=" ++ configEscape v configEscape :: String -> String configEscape = concatMap escape - where - escape c - | isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";" - | otherwise = [c] + where + escape c + | isSpace c || c `elem` "&" = "&" ++ show (ord c) ++ ";" + | otherwise = [c] configUnEscape :: String -> String configUnEscape = unescape - where - unescape [] = [] - unescape (c:rest) - | c == '&' = entity rest - | otherwise = c : unescape rest - entity s - | not (null num) && ";" `isPrefixOf` r = - chr (Prelude.read num) : unescape rest - | otherwise = - '&' : unescape s - where - num = takeWhile isNumber s - r = drop (length num) s - rest = drop 1 r + where + unescape [] = [] + unescape (c:rest) + | c == '&' = entity rest + | otherwise = c : unescape rest + entity s + | not (null num) && ";" `isPrefixOf` r = + chr (Prelude.read num) : unescape rest + | otherwise = + '&' : unescape s + where + num = takeWhile isNumber s + r = drop (length num) s + rest = drop 1 r {- for quickcheck -} prop_idempotent_configEscape :: String -> Bool diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 99b5a9bba..0135f32dd 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -109,43 +109,42 @@ runTransfer t file shouldretry a = do bracketIO (prep tfile mode info) (cleanup tfile) (a meter) unless ok $ failed info return ok - where - prep tfile mode info = catchMaybeIO $ do - fd <- openFd (transferLockFile tfile) ReadWrite (Just mode) - defaultFileFlags { trunc = True } - locked <- catchMaybeIO $ - setLock fd (WriteLock, AbsoluteSeek, 0, 0) - when (locked == Nothing) $ - error $ "transfer already in progress" - writeTransferInfoFile info tfile - return fd - cleanup _ Nothing = noop - cleanup tfile (Just fd) = do - void $ tryIO $ removeFile tfile - void $ tryIO $ removeFile $ transferLockFile tfile - closeFd fd - failed info = do - failedtfile <- fromRepo $ failedTransferFile t - createAnnexDirectory $ takeDirectory failedtfile - liftIO $ writeTransferInfoFile info failedtfile - retry oldinfo metervar run = do - v <- tryAnnex run - case v of - Right b -> return b - Left _ -> do - b <- getbytescomplete metervar - let newinfo = oldinfo { bytesComplete = Just b } - if shouldretry oldinfo newinfo - then retry newinfo metervar run - else return False - getbytescomplete metervar - | transferDirection t == Upload = - liftIO $ readMVar metervar - | otherwise = do - f <- fromRepo $ gitAnnexTmpLocation (transferKey t) - liftIO $ catchDefaultIO 0 $ - fromIntegral . fileSize - <$> getFileStatus f + where + prep tfile mode info = catchMaybeIO $ do + fd <- openFd (transferLockFile tfile) ReadWrite (Just mode) + defaultFileFlags { trunc = True } + locked <- catchMaybeIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) + when (locked == Nothing) $ + error $ "transfer already in progress" + writeTransferInfoFile info tfile + return fd + cleanup _ Nothing = noop + cleanup tfile (Just fd) = do + void $ tryIO $ removeFile tfile + void $ tryIO $ removeFile $ transferLockFile tfile + closeFd fd + failed info = do + failedtfile <- fromRepo $ failedTransferFile t + createAnnexDirectory $ takeDirectory failedtfile + liftIO $ writeTransferInfoFile info failedtfile + retry oldinfo metervar run = do + v <- tryAnnex run + case v of + Right b -> return b + Left _ -> do + b <- getbytescomplete metervar + let newinfo = oldinfo { bytesComplete = Just b } + if shouldretry oldinfo newinfo + then retry newinfo metervar run + else return False + getbytescomplete metervar + | transferDirection t == Upload = + liftIO $ readMVar metervar + | otherwise = do + f <- fromRepo $ gitAnnexTmpLocation (transferKey t) + liftIO $ catchDefaultIO 0 $ + fromIntegral . fileSize <$> getFileStatus f {- Generates a callback that can be called as transfer progresses to update - the transfer info file. Also returns the file it'll be updating, and a @@ -156,20 +155,20 @@ mkProgressUpdater t info = do _ <- tryAnnex $ createAnnexDirectory $ takeDirectory tfile mvar <- liftIO $ newMVar 0 return (liftIO . updater tfile mvar, tfile, mvar) - where - updater tfile mvar bytes = modifyMVar_ mvar $ \oldbytes -> do - if (bytes - oldbytes >= mindelta) - then do - let info' = info { bytesComplete = Just bytes } - _ <- tryIO $ writeTransferInfoFile info' tfile - return bytes - else return oldbytes - {- The minimum change in bytesComplete that is worth - - updating a transfer info file for is 1% of the total - - keySize, rounded down. -} - mindelta = case keySize (transferKey t) of - Just sz -> sz `div` 100 - Nothing -> 100 * 1024 -- arbitrarily, 100 kb + where + updater tfile mvar bytes = modifyMVar_ mvar $ \oldbytes -> do + if (bytes - oldbytes >= mindelta) + then do + let info' = info { bytesComplete = Just bytes } + _ <- tryIO $ writeTransferInfoFile info' tfile + return bytes + else return oldbytes + {- The minimum change in bytesComplete that is worth + - updating a transfer info file for is 1% of the total + - keySize, rounded down. -} + mindelta = case keySize (transferKey t) of + Just sz -> sz `div` 100 + Nothing -> 100 * 1024 -- arbitrarily, 100 kb startTransferInfo :: Maybe FilePath -> IO TransferInfo startTransferInfo file = TransferInfo @@ -206,25 +205,23 @@ getTransfers = do infos <- mapM checkTransfer transfers return $ map (\(t, Just i) -> (t, i)) $ filter running $ zip transfers infos - where - findfiles = liftIO . mapM dirContentsRecursive - =<< mapM (fromRepo . transferDir) - [Download, Upload] - running (_, i) = isJust i + where + findfiles = liftIO . mapM dirContentsRecursive + =<< mapM (fromRepo . transferDir) [Download, Upload] + running (_, i) = isJust i {- Gets failed transfers for a given remote UUID. -} getFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)] getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles) - where - getpairs = mapM $ \f -> do - let mt = parseTransferFile f - mi <- readTransferInfoFile Nothing f - return $ case (mt, mi) of - (Just t, Just i) -> Just (t, i) - _ -> Nothing - findfiles = liftIO . mapM dirContentsRecursive - =<< mapM (fromRepo . failedTransferDir u) - [Download, Upload] + where + getpairs = mapM $ \f -> do + let mt = parseTransferFile f + mi <- readTransferInfoFile Nothing f + return $ case (mt, mi) of + (Just t, Just i) -> Just (t, i) + _ -> Nothing + findfiles = liftIO . mapM dirContentsRecursive + =<< mapM (fromRepo . failedTransferDir u) [Download, Upload] removeFailedTransfer :: Transfer -> Annex () removeFailedTransfer t = do @@ -257,8 +254,8 @@ parseTransferFile file <*> pure (toUUID u) <*> fileKey key _ -> Nothing - where - bits = splitDirectories file + where + bits = splitDirectories file writeTransferInfoFile :: TransferInfo -> FilePath -> IO () writeTransferInfoFile info tfile = do @@ -295,16 +292,16 @@ readTransferInfo mpid s = TransferInfo <*> bytes <*> pure (if null filename then Nothing else Just filename) <*> pure False - where - (firstline, filename) = separate (== '\n') s - bits = split " " firstline - numbits = length bits - time = if numbits > 0 - then Just <$> parsePOSIXTime =<< headMaybe bits - else pure Nothing -- not failure - bytes = if numbits > 1 - then Just <$> readish =<< headMaybe (drop 1 bits) - else pure Nothing -- not failure + where + (firstline, filename) = separate (== '\n') s + bits = split " " firstline + numbits = length bits + time = if numbits > 0 + then Just <$> parsePOSIXTime =<< headMaybe bits + else pure Nothing -- not failure + bytes = if numbits > 1 + then Just <$> readish =<< headMaybe (drop 1 bits) + else pure Nothing -- not failure parsePOSIXTime :: String -> Maybe POSIXTime parsePOSIXTime s = utcTimeToPOSIXSeconds diff --git a/Logs/Trust.hs b/Logs/Trust.hs index f61966b9e..e5322e04e 100644 --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -87,11 +87,10 @@ trustMapLoad = do let m = M.union overrides $ M.union configured logged Annex.changeState $ \s -> s { Annex.trustmap = Just m } return m - where - configuredtrust r = - maybe Nothing (\l -> Just (Types.Remote.uuid r, l)) <$> - maybe Nothing readTrustLevel - <$> getTrustLevel (Types.Remote.repo r) + where + configuredtrust r = maybe Nothing (\l -> Just (Types.Remote.uuid r, l)) + <$> maybe Nothing readTrustLevel + <$> getTrustLevel (Types.Remote.repo r) {- Does not include forcetrust or git config values, just those from the - log file. -} @@ -103,11 +102,11 @@ trustMapRaw = simpleMap . parseLog (Just . parseTrustLog) - trust status, which is why this defaults to Trusted. -} parseTrustLog :: String -> TrustLevel parseTrustLog s = maybe Trusted parse $ headMaybe $ words s - where - parse "1" = Trusted - parse "0" = UnTrusted - parse "X" = DeadTrusted - parse _ = SemiTrusted + where + parse "1" = Trusted + parse "0" = UnTrusted + parse "X" = DeadTrusted + parse _ = SemiTrusted showTrustLog :: TrustLevel -> String showTrustLog Trusted = "1" diff --git a/Logs/UUID.hs b/Logs/UUID.hs index 7b7090223..2f24a388e 100644 --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -53,32 +53,32 @@ describeUUID uuid desc = do -} fixBadUUID :: Log String -> Log String fixBadUUID = M.fromList . map fixup . M.toList - where - fixup (k, v) - | isbad = (fixeduuid, LogEntry (Date $ newertime v) fixedvalue) - | otherwise = (k, v) - where - kuuid = fromUUID k - isbad = not (isuuid kuuid) && isuuid lastword - ws = words $ value v - lastword = Prelude.last ws - fixeduuid = toUUID lastword - fixedvalue = unwords $ kuuid: Prelude.init ws - -- For the fixed line to take precidence, it should be - -- slightly newer, but only slightly. - newertime (LogEntry (Date d) _) = d + minimumPOSIXTimeSlice - newertime (LogEntry Unknown _) = minimumPOSIXTimeSlice - minimumPOSIXTimeSlice = 0.000001 - isuuid s = length s == 36 && length (split "-" s) == 5 + where + fixup (k, v) + | isbad = (fixeduuid, LogEntry (Date $ newertime v) fixedvalue) + | otherwise = (k, v) + where + kuuid = fromUUID k + isbad = not (isuuid kuuid) && isuuid lastword + ws = words $ value v + lastword = Prelude.last ws + fixeduuid = toUUID lastword + fixedvalue = unwords $ kuuid: Prelude.init ws + -- For the fixed line to take precidence, it should be + -- slightly newer, but only slightly. + newertime (LogEntry (Date d) _) = d + minimumPOSIXTimeSlice + newertime (LogEntry Unknown _) = minimumPOSIXTimeSlice + minimumPOSIXTimeSlice = 0.000001 + isuuid s = length s == 36 && length (split "-" s) == 5 {- Records the uuid in the log, if it's not already there. -} recordUUID :: UUID -> Annex () recordUUID u = go . M.lookup u =<< uuidMap - where - go (Just "") = set - go Nothing = set - go _ = noop - set = describeUUID u "" + where + go (Just "") = set + go Nothing = set + go _ = noop + set = describeUUID u "" {- The map is cached for speed. -} uuidMap :: Annex UUIDMap @@ -95,5 +95,5 @@ uuidMapLoad = do let m' = M.insertWith' preferold u "" m Annex.changeState $ \s -> s { Annex.uuidmap = Just m' } return m' - where - preferold = flip const + where + preferold = flip const diff --git a/Logs/UUIDBased.hs b/Logs/UUIDBased.hs index 674ac2184..c1901eef7 100644 --- a/Logs/UUIDBased.hs +++ b/Logs/UUIDBased.hs @@ -50,36 +50,36 @@ tskey = "timestamp=" showLog :: (a -> String) -> Log a -> String showLog shower = unlines . map showpair . M.toList - where - showpair (k, LogEntry (Date p) v) = - unwords [fromUUID k, shower v, tskey ++ show p] - showpair (k, LogEntry Unknown v) = - unwords [fromUUID k, shower v] + where + showpair (k, LogEntry (Date p) v) = + unwords [fromUUID k, shower v, tskey ++ show p] + showpair (k, LogEntry Unknown v) = + unwords [fromUUID k, shower v] parseLog :: (String -> Maybe a) -> String -> Log a parseLog = parseLogWithUUID . const parseLogWithUUID :: (UUID -> String -> Maybe a) -> String -> Log a parseLogWithUUID parser = M.fromListWith best . mapMaybe parse . lines - where - parse line - | null ws = Nothing - | otherwise = parser u (unwords info) >>= makepair - where - makepair v = Just (u, LogEntry ts v) - ws = words line - u = toUUID $ Prelude.head ws - t = Prelude.last ws - ts - | tskey `isPrefixOf` t = - pdate $ drop 1 $ dropWhile (/= '=') t - | otherwise = Unknown - info - | ts == Unknown = drop 1 ws - | otherwise = drop 1 $ beginning ws - pdate s = case parseTime defaultTimeLocale "%s%Qs" s of - Nothing -> Unknown - Just d -> Date $ utcTimeToPOSIXSeconds d + where + parse line + | null ws = Nothing + | otherwise = parser u (unwords info) >>= makepair + where + makepair v = Just (u, LogEntry ts v) + ws = words line + u = toUUID $ Prelude.head ws + t = Prelude.last ws + ts + | tskey `isPrefixOf` t = + pdate $ drop 1 $ dropWhile (/= '=') t + | otherwise = Unknown + info + | ts == Unknown = drop 1 ws + | otherwise = drop 1 $ beginning ws + pdate s = case parseTime defaultTimeLocale "%s%Qs" s of + Nothing -> Unknown + Just d -> Date $ utcTimeToPOSIXSeconds d changeLog :: POSIXTime -> UUID -> a -> Log a -> Log a changeLog t u v = M.insert u $ LogEntry (Date t) v @@ -106,9 +106,9 @@ prop_TimeStamp_sane = Unknown < Date 1 prop_addLog_sane :: Bool prop_addLog_sane = newWins && newestWins - where - newWins = addLog (UUID "foo") (LogEntry (Date 1) "new") l == l2 - newestWins = addLog (UUID "foo") (LogEntry (Date 1) "newest") l2 /= l2 + where + newWins = addLog (UUID "foo") (LogEntry (Date 1) "new") l == l2 + newestWins = addLog (UUID "foo") (LogEntry (Date 1) "newest") l2 /= l2 - l = M.fromList [(UUID "foo", LogEntry (Date 0) "old")] - l2 = M.fromList [(UUID "foo", LogEntry (Date 1) "new")] + l = M.fromList [(UUID "foo", LogEntry (Date 0) "old")] + l2 = M.fromList [(UUID "foo", LogEntry (Date 1) "new")] diff --git a/Logs/Unused.hs b/Logs/Unused.hs index 522c523af..9f1278dd0 100644 --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -35,13 +35,12 @@ readUnusedLog prefix = do <$> liftIO (readFile f) , return M.empty ) - where - parse line = - case (readish tag, file2key rest) of - (Just num, Just key) -> Just (num, key) - _ -> Nothing - where - (tag, rest) = separate (== ' ') line + where + parse line = case (readish tag, file2key rest) of + (Just num, Just key) -> Just (num, key) + _ -> Nothing + where + (tag, rest) = separate (== ' ') line type UnusedMap = M.Map Int Key @@ -64,10 +63,10 @@ unusedSpec :: String -> [Int] unusedSpec spec | "-" `isInfixOf` spec = range $ separate (== '-') spec | otherwise = catMaybes [readish spec] - where - range (a, b) = case (readish a, readish b) of - (Just x, Just y) -> [x..y] - _ -> [] + where + range (a, b) = case (readish a, readish b) of + (Just x, Just y) -> [x..y] + _ -> [] {- Start action for unused content. Finds the number in the maps, and - calls either of 3 actions, depending on the type of unused file. -} @@ -81,11 +80,11 @@ startUnused message unused badunused tmpunused maps n = search , (unusedBadMap maps, badunused) , (unusedTmpMap maps, tmpunused) ] - where - search [] = stop - search ((m, a):rest) = - case M.lookup n m of - Nothing -> search rest - Just key -> do - showStart message (show n) - next $ a key + where + search [] = stop + search ((m, a):rest) = + case M.lookup n m of + Nothing -> search rest + Just key -> do + showStart message (show n) + next $ a key diff --git a/Logs/Web.hs b/Logs/Web.hs index 534bd5345..c2a4deb7d 100644 --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -37,13 +37,13 @@ oldurlLogs key = {- Gets all urls that a key might be available from. -} getUrls :: Key -> Annex [URLString] getUrls key = go $ urlLog key : oldurlLogs key - where - go [] = return [] - go (l:ls) = do - us <- currentLog l - if null us - then go ls - else return us + where + go [] = return [] + go (l:ls) = do + us <- currentLog l + if null us + then go ls + else return us {- Records a change in an url for a key. -} setUrl :: Key -> URLString -> LogStatus -> Annex () diff --git a/Messages/JSON.hs b/Messages/JSON.hs index f7a031e38..e262192a8 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -20,9 +20,9 @@ import qualified Utility.JSONStream as Stream start :: String -> Maybe String -> IO () start command file = putStr $ Stream.start $ ("command", command) : filepart file - where - filepart Nothing = [] - filepart (Just f) = [("file", f)] + where + filepart Nothing = [] + filepart (Just f) = [("file", f)] end :: Bool -> IO () end b = putStr $ Stream.add [("success", b)] ++ Stream.end diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 375c5c352..f5bcc4f45 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -143,9 +143,9 @@ retrieveEncrypted buprepo (cipher, enck) _ f = liftIO $ catchBoolIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do withDecryptedContent cipher (L.hGetContents h) $ L.writeFile f return True - where - params = bupParams "join" buprepo [Param $ bupRef enck] - p = proc "bup" $ toCommand params + where + params = bupParams "join" buprepo [Param $ bupRef enck] + p = proc "bup" $ toCommand params remove :: Key -> Annex Bool remove _ = do @@ -164,10 +164,11 @@ checkPresent r bupr k return $ Right ok | otherwise = liftIO $ catchMsgIO $ boolSystem "git" $ Git.Command.gitCommandLine params bupr - where - params = - [ Params "show-ref --quiet --verify" - , Param $ "refs/heads/" ++ bupRef k] + where + params = + [ Params "show-ref --quiet --verify" + , Param $ "refs/heads/" ++ bupRef k + ] {- Store UUID in the annex.uuid setting of the bup repository. -} storeBupUUID :: UUID -> BupRepo -> Annex () @@ -185,8 +186,8 @@ storeBupUUID u buprepo = do when (olduuid == "") $ Git.Command.run "config" [Param "annex.uuid", Param v] r' - where - v = fromUUID u + where + v = fromUUID u onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a onBupRemote r a command params = do @@ -227,17 +228,17 @@ bup2GitRemote r then Git.Construct.fromAbsPath r else error "please specify an absolute path" | otherwise = Git.Construct.fromUrl $ "ssh://" ++ host ++ slash dir - where - bits = split ":" r - host = Prelude.head bits - dir = join ":" $ drop 1 bits - -- "host:~user/dir" is not supported specially by bup; - -- "host:dir" is relative to the home directory; - -- "host:" goes in ~/.bup - slash d - | null d = "/~/.bup" - | "/" `isPrefixOf` d = d - | otherwise = "/~/" ++ d + where + bits = split ":" r + host = Prelude.head bits + dir = join ":" $ drop 1 bits + -- "host:~user/dir" is not supported specially by bup; + -- "host:dir" is relative to the home directory; + -- "host:" goes in ~/.bup + slash d + | null d = "/~/.bup" + | "/" `isPrefixOf` d = d + | otherwise = "/~/" ++ d {- Converts a key into a git ref name, which bup-split -n will use to point - to it. -} @@ -245,8 +246,8 @@ bupRef :: Key -> String bupRef k | Git.Ref.legal True shown = shown | otherwise = "git-annex-" ++ showDigest (sha256 (fromString shown)) - where - shown = key2file k + where + shown = key2file k bupLocal :: BupRepo -> Bool bupLocal = notElem ':' diff --git a/Remote/Directory.hs b/Remote/Directory.hs index bac531881..006638a2f 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -57,7 +57,6 @@ gen r u c = do readonly = False, remotetype = remote } - where type ChunkSize = Maybe Int64 @@ -101,25 +100,25 @@ chunkCount f = f ++ ".chunkcount" withCheckedFiles :: (FilePath -> IO Bool) -> ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool withCheckedFiles _ _ [] _ _ = return False withCheckedFiles check Nothing d k a = go $ locations d k - where - go [] = return False - go (f:fs) = ifM (check f) ( a [f] , go fs ) + where + go [] = return False + go (f:fs) = ifM (check f) ( a [f] , go fs ) withCheckedFiles check (Just _) d k a = go $ locations d k - where - go [] = return False - go (f:fs) = do - let chunkcount = chunkCount f - use <- check chunkcount - if use - then do - count <- readcount chunkcount - let chunks = take count $ chunkStream f - ifM (all id <$> mapM check chunks) - ( a chunks , return False ) - else go fs - readcount f = fromMaybe (error $ "cannot parse " ++ f) - . (readish :: String -> Maybe Int) - <$> readFile f + where + go [] = return False + go (f:fs) = do + let chunkcount = chunkCount f + ifM (check chunkcount) + ( do + count <- readcount chunkcount + let chunks = take count $ chunkStream f + ifM (all id <$> mapM check chunks) + ( a chunks , return False ) + , go fs + ) + readcount f = fromMaybe (error $ "cannot parse " ++ f) + . (readish :: String -> Maybe Int) + <$> readFile f withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool withStoredFiles = withCheckedFiles doesFileExist @@ -170,39 +169,39 @@ storeSplit' _ _ _ [] c = return $ reverse c storeSplit' meterupdate chunksize (d:dests) bs c = do bs' <- E.bracket (openFile d WriteMode) hClose (feed chunksize bs) storeSplit' meterupdate chunksize dests bs' (d:c) - where - feed _ [] _ = return [] - feed sz (l:ls) h = do - let s = fromIntegral $ S.length l - if s <= sz - then do - S.hPut h l - meterupdate $ toInteger s - feed (sz - s) ls h - else return (l:ls) + where + feed _ [] _ = return [] + feed sz (l:ls) h = do + let s = fromIntegral $ S.length l + if s <= sz + then do + S.hPut h l + meterupdate $ toInteger s + feed (sz - s) ls h + else return (l:ls) {- Write a L.ByteString to a file, updating a progress meter - after each chunk of the L.ByteString, typically every 64 kb or so. -} meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile meterupdate dest b = meteredWriteFile' meterupdate dest (L.toChunks b) feeder - where - feeder chunks = return ([], chunks) + where + feeder chunks = return ([], chunks) {- Writes a series of S.ByteString chunks to a file, updating a progress - meter after each chunk. The feeder is called to get more chunks. -} meteredWriteFile' :: MeterUpdate -> FilePath -> s -> (s -> IO (s, [S.ByteString])) -> IO () meteredWriteFile' meterupdate dest startstate feeder = E.bracket (openFile dest WriteMode) hClose (feed startstate []) - where - feed state [] h = do - (state', cs) <- feeder state - unless (null cs) $ - feed state' cs h - feed state (c:cs) h = do - S.hPut h c - meterupdate $ toInteger $ S.length c - feed state cs h + where + feed state [] h = do + (state', cs) <- feeder state + unless (null cs) $ + feed state' cs h + feed state (c:cs) h = do + S.hPut h c + meterupdate $ toInteger $ S.length c + feed state cs h {- Generates a list of destinations to write to in order to store a key. - When chunksize is specified, this list will be a list of chunks. @@ -213,36 +212,36 @@ meteredWriteFile' meterupdate dest startstate feeder = -} storeHelper :: FilePath -> ChunkSize -> Key -> ([FilePath] -> IO [FilePath]) -> Annex Bool storeHelper d chunksize key a = prep <&&> check <&&> go - where - desttemplate = Prelude.head $ locations d key - dir = parentDir desttemplate - tmpdests = case chunksize of - Nothing -> [desttemplate ++ tmpprefix] - Just _ -> map (++ tmpprefix) (chunkStream desttemplate) - tmpprefix = ".tmp" - detmpprefix f = take (length f - tmpprefixlen) f - tmpprefixlen = length tmpprefix - prep = liftIO $ catchBoolIO $ do - createDirectoryIfMissing True dir - allowWrite dir - return True - {- The size is not exactly known when encrypting the key; - - this assumes that at least the size of the key is - - needed as free space. -} - check = checkDiskSpace (Just dir) key 0 - go = liftIO $ catchBoolIO $ do - stored <- a tmpdests - forM_ stored $ \f -> do - let dest = detmpprefix f - renameFile f dest - preventWrite dest - when (chunksize /= Nothing) $ do - let chunkcount = chunkCount desttemplate - _ <- tryIO $ allowWrite chunkcount - writeFile chunkcount (show $ length stored) - preventWrite chunkcount - preventWrite dir - return (not $ null stored) + where + desttemplate = Prelude.head $ locations d key + dir = parentDir desttemplate + tmpdests = case chunksize of + Nothing -> [desttemplate ++ tmpprefix] + Just _ -> map (++ tmpprefix) (chunkStream desttemplate) + tmpprefix = ".tmp" + detmpprefix f = take (length f - tmpprefixlen) f + tmpprefixlen = length tmpprefix + prep = liftIO $ catchBoolIO $ do + createDirectoryIfMissing True dir + allowWrite dir + return True + {- The size is not exactly known when encrypting the key; + - this assumes that at least the size of the key is + - needed as free space. -} + check = checkDiskSpace (Just dir) key 0 + go = liftIO $ catchBoolIO $ do + stored <- a tmpdests + forM_ stored $ \f -> do + let dest = detmpprefix f + renameFile f dest + preventWrite dest + when (chunksize /= Nothing) $ do + let chunkcount = chunkCount desttemplate + _ <- tryIO $ allowWrite chunkcount + writeFile chunkcount (show $ length stored) + preventWrite chunkcount + preventWrite dir + return (not $ null stored) retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool retrieve d chunksize k _ f = metered Nothing k $ \meterupdate -> @@ -250,11 +249,11 @@ retrieve d chunksize k _ f = metered Nothing k $ \meterupdate -> catchBoolIO $ do meteredWriteFile' meterupdate f files feeder return True - where - feeder [] = return ([], []) - feeder (x:xs) = do - chunks <- L.toChunks <$> L.readFile x - return (xs, chunks) + where + feeder [] = return ([], []) + feeder (x:xs) = do + chunks <- L.toChunks <$> L.readFile x + return (xs, chunks) retrieveEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> FilePath -> Annex Bool retrieveEncrypted d chunksize (cipher, enck) k f = metered Nothing k $ \meterupdate -> @@ -267,20 +266,20 @@ retrieveEncrypted d chunksize (cipher, enck) k f = metered Nothing k $ \meterupd retrieveCheap :: FilePath -> ChunkSize -> Key -> FilePath -> Annex Bool retrieveCheap _ (Just _) _ _ = return False -- no cheap retrieval for chunks retrieveCheap d _ k f = liftIO $ withStoredFiles Nothing d k go - where - go [file] = catchBoolIO $ createSymbolicLink file f >> return True - go _files = return False + where + go [file] = catchBoolIO $ createSymbolicLink file f >> return True + go _files = return False remove :: FilePath -> ChunkSize -> Key -> Annex Bool remove d chunksize k = liftIO $ withStoredFiles chunksize d k go - where - go = all id <$$> mapM removefile - removefile file = catchBoolIO $ do - let dir = parentDir file - allowWrite dir - removeFile file - _ <- tryIO $ removeDirectory dir - return True + where + go = all id <$$> mapM removefile + removefile file = catchBoolIO $ do + let dir = parentDir file + allowWrite dir + removeFile file + _ <- tryIO $ removeDirectory dir + return True checkPresent :: FilePath -> ChunkSize -> Key -> Annex (Either String Bool) checkPresent d chunksize k = liftIO $ catchMsgIO $ withStoredFiles chunksize d k $ diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 8ed2fed63..12c7d37e9 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -32,12 +32,12 @@ encryptionSetup c = case (M.lookup "encryption" c, extractCipher c) of (Just "shared", Nothing) -> use "encryption setup" $ genSharedCipher (Just keyid, Nothing) -> use "encryption setup" $ genEncryptedCipher keyid (Just keyid, Just v) -> use "encryption updated" $ updateEncryptedCipher keyid v - where - cannotchange = error "Cannot change encryption type of existing remote." - use m a = do - cipher <- liftIO a - showNote $ m ++ " " ++ describeCipher cipher - return $ M.delete "encryption" $ storeCipher c cipher + where + cannotchange = error "Cannot change encryption type of existing remote." + use m a = do + cipher <- liftIO a + showNote $ m ++ " " ++ describeCipher cipher + return $ M.delete "encryption" $ storeCipher c cipher {- Modifies a Remote to support encryption. - @@ -58,35 +58,35 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = hasKey = withkey $ hasKey r, cost = cost r + encryptedRemoteCostAdj } - where - store k f p = cip k >>= maybe - (storeKey r k f p) - (\enck -> storeKeyEncrypted enck k p) - retrieve k f d = cip k >>= maybe - (retrieveKeyFile r k f d) - (\enck -> retrieveKeyFileEncrypted enck k d) - retrieveCheap k d = cip k >>= maybe - (retrieveKeyFileCheap r k d) - (\_ -> return False) - withkey a k = cip k >>= maybe (a k) (a . snd) - cip = cipherKey c + where + store k f p = cip k >>= maybe + (storeKey r k f p) + (\enck -> storeKeyEncrypted enck k p) + retrieve k f d = cip k >>= maybe + (retrieveKeyFile r k f d) + (\enck -> retrieveKeyFileEncrypted enck k d) + retrieveCheap k d = cip k >>= maybe + (retrieveKeyFileCheap r k d) + (\_ -> return False) + withkey a k = cip k >>= maybe (a k) (a . snd) + cip = cipherKey c {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex - state. -} remoteCipher :: RemoteConfig -> Annex (Maybe Cipher) remoteCipher c = go $ extractCipher c - where - go Nothing = return Nothing - go (Just encipher) = do - cache <- Annex.getState Annex.ciphers - case M.lookup encipher cache of - Just cipher -> return $ Just cipher - Nothing -> decrypt encipher cache - decrypt encipher cache = do - showNote "gpg" - cipher <- liftIO $ decryptCipher encipher - Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache }) - return $ Just cipher + where + go Nothing = return Nothing + go (Just encipher) = do + cache <- Annex.getState Annex.ciphers + case M.lookup encipher cache of + Just cipher -> return $ Just cipher + Nothing -> decrypt encipher cache + decrypt encipher cache = do + showNote "gpg" + cipher <- liftIO $ decryptCipher encipher + Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache }) + return $ Just cipher {- Checks if there is a trusted (non-shared) cipher. -} isTrustedCipher :: RemoteConfig -> Bool @@ -97,16 +97,16 @@ isTrustedCipher c = cipherKey :: Maybe RemoteConfig -> Key -> Annex (Maybe (Cipher, Key)) cipherKey Nothing _ = return Nothing cipherKey (Just c) k = maybe Nothing encrypt <$> remoteCipher c - where - encrypt ciphertext = Just (ciphertext, encryptKey ciphertext k) + where + encrypt ciphertext = Just (ciphertext, encryptKey ciphertext k) {- Stores an StorableCipher in a remote's configuration. -} storeCipher :: RemoteConfig -> StorableCipher -> RemoteConfig storeCipher c (SharedCipher t) = M.insert "cipher" (toB64 t) c storeCipher c (EncryptedCipher t ks) = M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c - where - showkeys (KeyIds l) = join "," l + where + showkeys (KeyIds l) = join "," l {- Extracts an StorableCipher from a remote's configuration. -} extractCipher :: RemoteConfig -> Maybe StorableCipher @@ -115,5 +115,5 @@ extractCipher c = (Just t, Just ks) -> Just $ EncryptedCipher (fromB64 t) (readkeys ks) (Just t, Nothing) -> Just $ SharedCipher (fromB64 t) _ -> Nothing - where - readkeys = KeyIds . split "," + where + readkeys = KeyIds . split "," diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index eb788bc3e..91190d841 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -25,16 +25,16 @@ addHooks r = addHooks' r <$> lookupHook r "start" <*> lookupHook r "stop" addHooks' :: Remote -> Maybe String -> Maybe String -> Remote addHooks' r Nothing Nothing = r addHooks' r starthook stophook = r' - where - r' = r - { storeKey = \k f p -> wrapper $ storeKey r k f p - , retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d - , retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f - , removeKey = \k -> wrapper $ removeKey r k - , hasKey = \k -> wrapper $ hasKey r k - } - where - wrapper = runHooks r' starthook stophook + where + r' = r + { storeKey = \k f p -> wrapper $ storeKey r k f p + , retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d + , retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f + , removeKey = \k -> wrapper $ removeKey r k + , hasKey = \k -> wrapper $ hasKey r k + } + where + wrapper = runHooks r' starthook stophook runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a runHooks r starthook stophook a = do @@ -44,50 +44,49 @@ runHooks r starthook stophook a = do liftIO $ createDirectoryIfMissing True dir firstrun lck a - where - remoteid = show (uuid r) - run Nothing = noop - run (Just command) = void $ liftIO $ - boolSystem "sh" [Param "-c", Param command] - firstrun lck = do - -- Take a shared lock; This indicates that git-annex - -- is using the remote, and prevents other instances - -- of it from running the stophook. If another - -- instance is shutting down right now, this - -- will block waiting for its exclusive lock to clear. - lockFile lck + where + remoteid = show (uuid r) + run Nothing = noop + run (Just command) = void $ liftIO $ + boolSystem "sh" [Param "-c", Param command] + firstrun lck = do + -- Take a shared lock; This indicates that git-annex + -- is using the remote, and prevents other instances + -- of it from running the stophook. If another + -- instance is shutting down right now, this + -- will block waiting for its exclusive lock to clear. + lockFile lck - -- The starthook is run even if some other git-annex - -- is already running, and ran it before. - -- It would be difficult to use locking to ensure - -- it's only run once, and it's also possible for - -- git-annex to be interrupted before it can run the - -- stophook, in which case the starthook - -- would be run again by the next git-annex. - -- So, requiring idempotency is the right approach. - run starthook + -- The starthook is run even if some other git-annex + -- is already running, and ran it before. + -- It would be difficult to use locking to ensure + -- it's only run once, and it's also possible for + -- git-annex to be interrupted before it can run the + -- stophook, in which case the starthook + -- would be run again by the next git-annex. + -- So, requiring idempotency is the right approach. + run starthook - Annex.addCleanup (remoteid ++ "-stop-command") $ - runstop lck - runstop lck = do - -- Drop any shared lock we have, and take an - -- exclusive lock, without blocking. If the lock - -- succeeds, we're the only process using this remote, - -- so can stop it. - unlockFile lck - mode <- annexFileMode - fd <- liftIO $ noUmask mode $ - openFd lck ReadWrite (Just mode) defaultFileFlags - v <- liftIO $ tryIO $ - setLock fd (WriteLock, AbsoluteSeek, 0, 0) - case v of - Left _ -> noop - Right _ -> run stophook - liftIO $ closeFd fd + Annex.addCleanup (remoteid ++ "-stop-command") $ runstop lck + runstop lck = do + -- Drop any shared lock we have, and take an + -- exclusive lock, without blocking. If the lock + -- succeeds, we're the only process using this remote, + -- so can stop it. + unlockFile lck + mode <- annexFileMode + fd <- liftIO $ noUmask mode $ + openFd lck ReadWrite (Just mode) defaultFileFlags + v <- liftIO $ tryIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> noop + Right _ -> run stophook + liftIO $ closeFd fd lookupHook :: Remote -> String -> Annex (Maybe String) lookupHook r n = go =<< getRemoteConfig (repo r) hookname "" - where - go "" = return Nothing - go command = return $ Just command - hookname = n ++ "-command" + where + go "" = return Nothing + go command = return $ Just command + hookname = n ++ "-command" diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 3f6c9c155..f25ee8ee0 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -23,18 +23,18 @@ findSpecialRemotes :: String -> Annex [Git.Repo] findSpecialRemotes s = do m <- fromRepo Git.config liftIO $ mapM construct $ remotepairs m - where - remotepairs = M.toList . M.filterWithKey match - construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown - match k _ = startswith "remote." k && endswith (".annex-"++s) k + where + remotepairs = M.toList . M.filterWithKey match + construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown + match k _ = startswith "remote." k && endswith (".annex-"++s) k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex () gitConfigSpecialRemote u c k v = do set ("annex-"++k) v set ("annex-uuid") (fromUUID u) - where - set a b = inRepo $ Git.Command.run "config" - [Param (configsetting a), Param b] - remotename = fromJust (M.lookup "name" c) - configsetting s = "remote." ++ remotename ++ "." ++ s + where + set a b = inRepo $ Git.Command.run "config" + [Param (configsetting a), Param b] + remotename = fromJust (M.lookup "name" c) + configsetting s = "remote." ++ remotename ++ "." ++ s diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 4434bc65d..b6da80ec6 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex remote access with ssh - - - Copyright 2011.2012 Joey Hess <joey@kitenet.net> + - Copyright 2011,2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -34,22 +34,22 @@ git_annex_shell r command params fields sshparams <- sshToRepo r [Param $ sshcmd uuid ] return $ Just ("ssh", sshparams) | otherwise = return Nothing - where - dir = Git.repoPath r - shellcmd = "git-annex-shell" - shellopts = Param command : File dir : params - sshcmd uuid = unwords $ - shellcmd : map shellEscape (toCommand shellopts) ++ - uuidcheck uuid ++ - map shellEscape (toCommand fieldopts) - uuidcheck NoUUID = [] - uuidcheck (UUID u) = ["--uuid", u] - fieldopts - | null fields = [] - | otherwise = fieldsep : map fieldopt fields ++ [fieldsep] - fieldsep = Param "--" - fieldopt (field, value) = Param $ - fieldName field ++ "=" ++ value + where + dir = Git.repoPath r + shellcmd = "git-annex-shell" + shellopts = Param command : File dir : params + sshcmd uuid = unwords $ + shellcmd : map shellEscape (toCommand shellopts) ++ + uuidcheck uuid ++ + map shellEscape (toCommand fieldopts) + uuidcheck NoUUID = [] + uuidcheck (UUID u) = ["--uuid", u] + fieldopts + | null fields = [] + | otherwise = fieldsep : map fieldopt fields ++ [fieldsep] + fieldsep = Param "--" + fieldopt (field, value) = Param $ + fieldName field ++ "=" ++ value {- Uses a supplied function (such as boolSystem) to run a git-annex-shell - command on a remote. diff --git a/Remote/Hook.hs b/Remote/Hook.hs index f97e110d8..f9a143ccd 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -64,19 +64,18 @@ hookSetup u c = do hookEnv :: Key -> Maybe FilePath -> IO (Maybe [(String, String)]) hookEnv k f = Just <$> mergeenv (fileenv f ++ keyenv) - where - mergeenv l = M.toList . - M.union (M.fromList l) - <$> M.fromList <$> getEnvironment - env s v = ("ANNEX_" ++ s, v) - keyenv = catMaybes - [ Just $ env "KEY" (key2file k) - , env "HASH_1" <$> headMaybe hashbits - , env "HASH_2" <$> headMaybe (drop 1 hashbits) - ] - fileenv Nothing = [] - fileenv (Just file) = [env "FILE" file] - hashbits = map takeDirectory $ splitPath $ hashDirMixed k + where + mergeenv l = M.toList . M.union (M.fromList l) + <$> M.fromList <$> getEnvironment + env s v = ("ANNEX_" ++ s, v) + keyenv = catMaybes + [ Just $ env "KEY" (key2file k) + , env "HASH_1" <$> headMaybe hashbits + , env "HASH_2" <$> headMaybe (drop 1 hashbits) + ] + fileenv Nothing = [] + fileenv (Just file) = [env "FILE" file] + hashbits = map takeDirectory $ splitPath $ hashDirMixed k lookupHook :: String -> String -> Annex (Maybe String) lookupHook hooktype hook =do @@ -86,22 +85,20 @@ lookupHook hooktype hook =do warning $ "missing configuration for " ++ hookname return Nothing else return $ Just command - where - hookname = hooktype ++ "-" ++ hook ++ "-hook" + where + hookname = hooktype ++ "-" ++ hook ++ "-hook" runHook :: String -> String -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype hook - where - run command = do - showOutput -- make way for hook output - ifM (liftIO $ - boolSystemEnv "sh" [Param "-c", Param command] - =<< hookEnv k f) - ( a - , do - warning $ hook ++ " hook exited nonzero!" - return False - ) + where + run command = do + showOutput -- make way for hook output + ifM (liftIO $ boolSystemEnv "sh" [Param "-c", Param command] =<< hookEnv k f) + ( a + , do + warning $ hook ++ " hook exited nonzero!" + return False + ) store :: String -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store h k _f _p = do @@ -134,9 +131,9 @@ checkPresent r h k = do showAction $ "checking " ++ Git.repoDescribe r v <- lookupHook h "checkpresent" liftIO $ catchMsgIO $ check v - where - findkey s = key2file k `elem` lines s - check Nothing = error "checkpresent hook misconfigured" - check (Just hook) = do - env <- hookEnv k Nothing - findkey <$> readProcessEnv "sh" ["-c", hook] env + where + findkey s = key2file k `elem` lines s + check Nothing = error "checkpresent hook misconfigured" + check (Just hook) = do + env <- hookEnv k Nothing + findkey <$> readProcessEnv "sh" ["-c", hook] env diff --git a/Remote/List.hs b/Remote/List.hs index 234f310a5..ea1d61ce3 100644 --- a/Remote/List.hs +++ b/Remote/List.hs @@ -56,8 +56,8 @@ remoteList = do Annex.changeState $ \s -> s { Annex.remotes = rs' } return rs' else return rs - where - process m t = enumerate t >>= mapM (remoteGen m t) + where + process m t = enumerate t >>= mapM (remoteGen m t) {- Forces the remoteList to be re-generated, re-reading the git config. -} remoteListRefresh :: Annex [Remote] @@ -81,11 +81,11 @@ updateRemote remote = do m <- readRemoteLog remote' <- updaterepo $ repo remote remoteGen m (remotetype remote) remote' - where - updaterepo r - | Git.repoIsLocal r || Git.repoIsLocalUnknown r = - Remote.Git.configRead r - | otherwise = return r + where + updaterepo r + | Git.repoIsLocal r || Git.repoIsLocalUnknown r = + Remote.Git.configRead r + | otherwise = return r {- All remotes that are not ignored. -} enabledRemoteList :: Annex [Remote] diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index d89699270..1d5f2d28c 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -72,14 +72,14 @@ genRsyncOpts r c = do <$> getRemoteConfig r "rsync-options" "" let escape = maybe True (\m -> M.lookup "shellescape" m /= Just "no") c return $ RsyncOpts url opts escape - where - safe o - -- Don't allow user to pass --delete to rsync; - -- that could cause it to delete other keys - -- in the same hash bucket as a key it sends. - | o == "--delete" = False - | o == "--delete-excluded" = False - | otherwise = True + where + safe o + -- Don't allow user to pass --delete to rsync; + -- that could cause it to delete other keys + -- in the same hash bucket as a key it sends. + | o == "--delete" = False + | o == "--delete-excluded" = False + | otherwise = True rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig rsyncSetup u c = do @@ -100,9 +100,9 @@ rsyncEscape o s rsyncUrls :: RsyncOpts -> Key -> [String] rsyncUrls o k = map use annexHashes - where - use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f) - f = keyFile k + where + use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f) + f = keyFile k store :: RsyncOpts -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store o k _f p = rsyncSend o p k <=< inRepo $ gitAnnexLocation k @@ -146,18 +146,18 @@ remove o k = withRsyncScratchDir $ \tmp -> liftIO $ do , Param $ addTrailingPathSeparator dummy , Param $ rsyncUrl o ] - where - {- Specify include rules to match the directories where the - - content could be. Note that the parent directories have - - to also be explicitly included, due to how rsync - - traverses directories. -} - includes = concatMap use annexHashes - use h = let dir = h k in - [ parentDir dir - , dir - -- match content directory and anything in it - , dir </> keyFile k </> "***" - ] + where + {- Specify include rules to match the directories where the + - content could be. Note that the parent directories have + - to also be explicitly included, due to how rsync + - traverses directories. -} + includes = concatMap use annexHashes + use h = let dir = h k in + [ parentDir dir + , dir + -- match content directory and anything in it + , dir </> keyFile k </> "***" + ] checkPresent :: Git.Repo -> RsyncOpts -> Key -> Annex (Either String Bool) checkPresent r o k = do @@ -165,13 +165,13 @@ checkPresent r o k = do -- note: Does not currently differentiate between rsync failing -- to connect, and the file not being present. Right <$> check - where - check = untilTrue (rsyncUrls o k) $ \u -> - liftIO $ catchBoolIO $ do - withQuietOutput createProcessSuccess $ - proc "rsync" $ toCommand $ - rsyncOptions o ++ [Param u] - return True + where + check = untilTrue (rsyncUrls o k) $ \u -> + liftIO $ catchBoolIO $ do + withQuietOutput createProcessSuccess $ + proc "rsync" $ toCommand $ + rsyncOptions o ++ [Param u] + return True {- Rsync params to enable resumes of sending files safely, - ensure that files are only moved into place once complete @@ -190,9 +190,9 @@ withRsyncScratchDir a = do nuke tmp liftIO $ createDirectoryIfMissing True tmp nuke tmp `after` a tmp - where - nuke d = liftIO $ whenM (doesDirectoryExist d) $ - removeDirectoryRecursive d + where + nuke d = liftIO $ whenM (doesDirectoryExist d) $ + removeDirectoryRecursive d rsyncRemote :: RsyncOpts -> (Maybe MeterUpdate) -> [CommandParam] -> Annex Bool rsyncRemote o callback params = do @@ -203,9 +203,9 @@ rsyncRemote o callback params = do showLongNote "rsync failed -- run git annex again to resume file transfer" return False ) - where - defaultParams = [Params "--progress"] - ps = rsyncOptions o ++ defaultParams ++ params + where + defaultParams = [Params "--progress"] + ps = rsyncOptions o ++ defaultParams ++ params {- To send a single key is slightly tricky; need to build up a temporary directory structure to pass to rsync so it can create the hash diff --git a/Remote/S3.hs b/Remote/S3.hs index c4da0b2ec..0c9d523b8 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -48,74 +48,71 @@ gen' r u c cst = (storeEncrypted this) (retrieveEncrypted this) this - where - this = Remote { - uuid = u, - cost = cst, - name = Git.repoDescribe r, - storeKey = store this, - retrieveKeyFile = retrieve this, - retrieveKeyFileCheap = retrieveCheap this, - removeKey = remove this, - hasKey = checkPresent this, - hasKeyCheap = False, - whereisKey = Nothing, - config = c, - repo = r, - localpath = Nothing, - readonly = False, - remotetype = remote - } + where + this = Remote { + uuid = u, + cost = cst, + name = Git.repoDescribe r, + storeKey = store this, + retrieveKeyFile = retrieve this, + retrieveKeyFileCheap = retrieveCheap this, + removeKey = remove this, + hasKey = checkPresent this, + hasKeyCheap = False, + whereisKey = Nothing, + config = c, + repo = r, + localpath = Nothing, + readonly = False, + remotetype = remote + } s3Setup :: UUID -> RemoteConfig -> Annex RemoteConfig s3Setup u c = handlehost $ M.lookup "host" c - where - remotename = fromJust (M.lookup "name" c) - defbucket = remotename ++ "-" ++ fromUUID u - defaults = M.fromList - [ ("datacenter", "US") - , ("storageclass", "STANDARD") - , ("host", defaultAmazonS3Host) - , ("port", show defaultAmazonS3Port) - , ("bucket", defbucket) - ] + where + remotename = fromJust (M.lookup "name" c) + defbucket = remotename ++ "-" ++ fromUUID u + defaults = M.fromList + [ ("datacenter", "US") + , ("storageclass", "STANDARD") + , ("host", defaultAmazonS3Host) + , ("port", show defaultAmazonS3Port) + , ("bucket", defbucket) + ] - handlehost Nothing = defaulthost - handlehost (Just h) - | ".archive.org" `isSuffixOf` map toLower h = archiveorg - | otherwise = defaulthost + handlehost Nothing = defaulthost + handlehost (Just h) + | ".archive.org" `isSuffixOf` map toLower h = archiveorg + | otherwise = defaulthost - use fullconfig = do - gitConfigSpecialRemote u fullconfig "s3" "true" - s3SetCreds fullconfig u + use fullconfig = do + gitConfigSpecialRemote u fullconfig "s3" "true" + s3SetCreds fullconfig u - defaulthost = do - c' <- encryptionSetup c - let fullconfig = c' `M.union` defaults - genBucket fullconfig u - use fullconfig + defaulthost = do + c' <- encryptionSetup c + let fullconfig = c' `M.union` defaults + genBucket fullconfig u + use fullconfig - archiveorg = do - showNote "Internet Archive mode" - maybe (error "specify bucket=") (const noop) $ - M.lookup "bucket" archiveconfig - use archiveconfig - where - archiveconfig = - -- hS3 does not pass through - -- x-archive-* headers - M.mapKeys (replace "x-archive-" "x-amz-") $ - -- encryption does not make sense here - M.insert "encryption" "none" $ - M.union c $ - -- special constraints on key names - M.insert "mungekeys" "ia" $ - -- bucket created only when files - -- are uploaded - M.insert "x-amz-auto-make-bucket" "1" $ - -- no default bucket name; should - -- be human-readable - M.delete "bucket" defaults + archiveorg = do + showNote "Internet Archive mode" + maybe (error "specify bucket=") (const noop) $ + M.lookup "bucket" archiveconfig + use archiveconfig + where + archiveconfig = + -- hS3 does not pass through x-archive-* headers + M.mapKeys (replace "x-archive-" "x-amz-") $ + -- encryption does not make sense here + M.insert "encryption" "none" $ + M.union c $ + -- special constraints on key names + M.insert "mungekeys" "ia" $ + -- bucket created only when files are uploaded + M.insert "x-amz-auto-make-bucket" "1" $ + -- no default bucket name; should be human-readable + M.delete "bucket" defaults store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool store r k _f _p = s3Action r False $ \(conn, bucket) -> do @@ -143,15 +140,15 @@ storeHelper (conn, bucket) r k file = do S3Object bucket (bucketFile r k) "" (("Content-Length", show size) : xheaders) content sendObject conn object - where - storageclass = - case fromJust $ M.lookup "storageclass" $ fromJust $ config r of - "REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY - _ -> STANDARD - getsize = fileSize <$> (liftIO $ getFileStatus file) - - xheaders = filter isxheader $ M.assocs $ fromJust $ config r - isxheader (h, _) = "x-amz-" `isPrefixOf` h + where + storageclass = + case fromJust $ M.lookup "storageclass" $ fromJust $ config r of + "REDUCED_REDUNDANCY" -> REDUCED_REDUNDANCY + _ -> STANDARD + getsize = fileSize <$> (liftIO $ getFileStatus file) + + xheaders = filter isxheader $ M.assocs $ fromJust $ config r + isxheader (h, _) = "x-amz-" `isPrefixOf` h retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool retrieve r k _f d = s3Action r False $ \(conn, bucket) -> do @@ -188,8 +185,8 @@ checkPresent r k = s3Action r noconn $ \(conn, bucket) -> do Right _ -> return $ Right True Left (AWSError _ _) -> return $ Right False Left e -> return $ Left (s3Error e) - where - noconn = Left $ error "S3 not configured" + where + noconn = Left $ error "S3 not configured" s3Warning :: ReqError -> Annex Bool s3Warning e = do @@ -215,12 +212,12 @@ s3Action r noconn action = do bucketFile :: Remote -> Key -> FilePath bucketFile r = munge . key2file - where - munge s = case M.lookup "mungekeys" c of - Just "ia" -> iaMunge $ fileprefix ++ s - _ -> fileprefix ++ s - fileprefix = M.findWithDefault "" "fileprefix" c - c = fromJust $ config r + where + munge s = case M.lookup "mungekeys" c of + Just "ia" -> iaMunge $ fileprefix ++ s + _ -> fileprefix ++ s + fileprefix = M.findWithDefault "" "fileprefix" c + c = fromJust $ config r bucketKey :: Remote -> String -> Key -> S3Object bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty @@ -230,12 +227,12 @@ bucketKey r bucket k = S3Object bucket (bucketFile r k) "" [] L.empty - encoded. -} iaMunge :: String -> String iaMunge = (>>= munge) - where - munge c - | isAsciiUpper c || isAsciiLower c || isNumber c = [c] - | c `elem` "_-.\"" = [c] - | isSpace c = [] - | otherwise = "&" ++ show (ord c) ++ ";" + where + munge c + | isAsciiUpper c || isAsciiLower c || isNumber c = [c] + | c `elem` "_-.\"" = [c] + | isSpace c = [] + | otherwise = "&" ++ show (ord c) ++ ";" genBucket :: RemoteConfig -> UUID -> Annex () genBucket c u = do @@ -251,9 +248,9 @@ genBucket c u = do case res of Right _ -> noop Left err -> s3Error err - where - bucket = fromJust $ M.lookup "bucket" c - datacenter = fromJust $ M.lookup "datacenter" c + where + bucket = fromJust $ M.lookup "bucket" c + datacenter = fromJust $ M.lookup "datacenter" c s3ConnectionRequired :: RemoteConfig -> UUID -> Annex AWSConnection s3ConnectionRequired c u = @@ -267,46 +264,46 @@ s3Connection c u = do _ -> do warning $ "Set both " ++ s3AccessKey ++ " and " ++ s3SecretKey ++ " to use S3" return Nothing - where - host = fromJust $ M.lookup "host" c - port = let s = fromJust $ M.lookup "port" c in - case reads s of - [(p, _)] -> p - _ -> error $ "bad S3 port value: " ++ s + where + host = fromJust $ M.lookup "host" c + port = let s = fromJust $ M.lookup "port" c in + case reads s of + [(p, _)] -> p + _ -> error $ "bad S3 port value: " ++ s {- S3 creds come from the environment if set, otherwise from the cache - in gitAnnexCredsDir, or failing that, might be stored encrypted in - the remote's config. -} s3GetCreds :: RemoteConfig -> UUID -> Annex (Maybe (String, String)) s3GetCreds c u = maybe fromcache (return . Just) =<< liftIO getenv - where - getenv = liftM2 (,) - <$> get s3AccessKey - <*> get s3SecretKey - where - get = catchMaybeIO . getEnv - fromcache = do - d <- fromRepo gitAnnexCredsDir - let f = d </> fromUUID u - v <- liftIO $ catchMaybeIO $ readFile f - case lines <$> v of - Just (ak:sk:[]) -> return $ Just (ak, sk) - _ -> fromconfig - fromconfig = do - mcipher <- remoteCipher c - case (M.lookup "s3creds" c, mcipher) of - (Just s3creds, Just cipher) -> do - creds <- liftIO $ decrypt s3creds cipher - case creds of - [ak, sk] -> do - s3CacheCreds (ak, sk) u - return $ Just (ak, sk) - _ -> do error "bad s3creds" - _ -> return Nothing - decrypt s3creds cipher = lines <$> - withDecryptedContent cipher - (return $ L.pack $ fromB64 s3creds) - (return . L.unpack) + where + getenv = liftM2 (,) + <$> get s3AccessKey + <*> get s3SecretKey + where + get = catchMaybeIO . getEnv + fromcache = do + d <- fromRepo gitAnnexCredsDir + let f = d </> fromUUID u + v <- liftIO $ catchMaybeIO $ readFile f + case lines <$> v of + Just (ak:sk:[]) -> return $ Just (ak, sk) + _ -> fromconfig + fromconfig = do + mcipher <- remoteCipher c + case (M.lookup "s3creds" c, mcipher) of + (Just s3creds, Just cipher) -> do + creds <- liftIO $ decrypt s3creds cipher + case creds of + [ak, sk] -> do + s3CacheCreds (ak, sk) u + return $ Just (ak, sk) + _ -> do error "bad s3creds" + _ -> return Nothing + decrypt s3creds cipher = lines + <$> withDecryptedContent cipher + (return $ L.pack $ fromB64 s3creds) + (return . L.unpack) {- Stores S3 creds encrypted in the remote's config if possible to do so - securely, and otherwise locally in gitAnnexCredsDir. -} diff --git a/Remote/Web.hs b/Remote/Web.hs index 78f747a10..d722374ed 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -55,13 +55,13 @@ gen r _ _ = downloadKey :: Key -> AssociatedFile -> FilePath -> Annex Bool downloadKey key _file dest = get =<< getUrls key - where - get [] = do - warning "no known url" - return False - get urls = do - showOutput -- make way for download progress bar - downloadUrl urls dest + where + get [] = do + warning "no known url" + return False + get urls = do + showOutput -- make way for download progress bar + downloadUrl urls dest downloadKeyCheap :: Key -> FilePath -> Annex Bool downloadKeyCheap _ _ = return False @@ -35,21 +35,21 @@ withFilesNotInGit a params = do seekunless (null ps && not (null params)) ps dotfiles <- seekunless (null dotps) dotps prepFiltered a $ return $ preserveOrder params (files++dotfiles) - where - (dotps, ps) = partition dotfile params - seekunless True _ = return [] - seekunless _ l = do - force <- Annex.getState Annex.force - g <- gitRepo - liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g + where + (dotps, ps) = partition dotfile params + seekunless True _ = return [] + seekunless _ l = do + force <- Annex.getState Annex.force + g <- gitRepo + liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo force l g withPathContents :: ((FilePath, FilePath) -> CommandStart) -> CommandSeek withPathContents a params = map a . concat <$> liftIO (mapM get params) - where - get p = ifM (isDirectory <$> getFileStatus p) - ( map (\f -> (f, makeRelative p f)) <$> dirContentsRecursive p - , return [(p, takeFileName p)] - ) + where + get p = ifM (isDirectory <$> getFileStatus p) + ( map (\f -> (f, makeRelative p f)) <$> dirContentsRecursive p + , return [(p, takeFileName p)] + ) withWords :: ([String] -> CommandStart) -> CommandSeek withWords a params = return [a params] @@ -59,10 +59,10 @@ withStrings a params = return $ map a params withPairs :: ((String, String) -> CommandStart) -> CommandSeek withPairs a params = return $ map a $ pairs [] params - where - pairs c [] = reverse c - pairs c (x:y:xs) = pairs ((x,y):c) xs - pairs _ _ = error "expected pairs" + where + pairs c [] = reverse c + pairs c (x:y:xs) = pairs ((x,y):c) xs + pairs _ _ = error "expected pairs" withFilesToBeCommitted :: (String -> CommandStart) -> CommandSeek withFilesToBeCommitted a params = prepFiltered a $ @@ -83,8 +83,8 @@ withFilesUnlocked' typechanged a params = do withKeys :: (Key -> CommandStart) -> CommandSeek withKeys a params = return $ map (a . parse) params - where - parse p = fromMaybe (error "bad key") $ file2key p + where + parse p = fromMaybe (error "bad key") $ file2key p withValue :: Annex v -> (v -> CommandSeek) -> CommandSeek withValue v a params = do @@ -111,10 +111,9 @@ prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [Command prepFiltered a fs = do matcher <- Limit.getMatcher map (process matcher) <$> fs - where - process matcher f = do - ok <- matcher $ Annex.FileInfo f f - if ok then a f else return Nothing + where + process matcher f = ifM (matcher $ Annex.FileInfo f f) + ( a f , return Nothing ) notSymlink :: FilePath -> IO Bool notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f @@ -30,16 +30,16 @@ myPostInst _ (InstallFlags { installVerbosity }) pkg lbi = do installGitAnnexShell dest verbosity pkg lbi installManpages dest verbosity pkg lbi installDesktopFile dest verbosity pkg lbi - where - dest = NoCopyDest - verbosity = fromFlag installVerbosity + where + dest = NoCopyDest + verbosity = fromFlag installVerbosity installGitAnnexShell :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO () installGitAnnexShell copyDest verbosity pkg lbi = rawSystemExit verbosity "ln" ["-sf", "git-annex", dstBinDir </> "git-annex-shell"] - where - dstBinDir = bindir $ absoluteInstallDirs pkg lbi copyDest + where + dstBinDir = bindir $ absoluteInstallDirs pkg lbi copyDest {- See http://www.haskell.org/haskellwiki/Cabal/Developer-FAQ#Installing_manpages - @@ -49,15 +49,15 @@ installGitAnnexShell copyDest verbosity pkg lbi = installManpages :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO () installManpages copyDest verbosity pkg lbi = installOrdinaryFiles verbosity dstManDir =<< srcManpages - where - dstManDir = mandir (absoluteInstallDirs pkg lbi copyDest) </> "man1" - srcManpages = zip (repeat srcManDir) - <$> filterM doesFileExist manpages - srcManDir = "" - manpages = ["git-annex.1", "git-annex-shell.1"] + where + dstManDir = mandir (absoluteInstallDirs pkg lbi copyDest) </> "man1" + srcManpages = zip (repeat srcManDir) + <$> filterM doesFileExist manpages + srcManDir = "" + manpages = ["git-annex.1", "git-annex-shell.1"] installDesktopFile :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO () installDesktopFile copyDest verbosity pkg lbi = InstallDesktopFile.install $ dstBinDir </> "git-annex" - where - dstBinDir = bindir $ absoluteInstallDirs pkg lbi copyDest + where + dstBinDir = bindir $ absoluteInstallDirs pkg lbi copyDest diff --git a/Types/Key.hs b/Types/Key.hs index 6794ee003..ecdf7b842 100644 --- a/Types/Key.hs +++ b/Types/Key.hs @@ -46,33 +46,33 @@ fieldSep = '-' key2file :: Key -> FilePath key2file Key { keyBackendName = b, keySize = s, keyMtime = m, keyName = n } = b +++ ('s' ?: s) +++ ('m' ?: m) +++ (fieldSep : n) - where - "" +++ y = y - x +++ "" = x - x +++ y = x ++ fieldSep:y - c ?: (Just v) = c : show v - _ ?: _ = "" + where + "" +++ y = y + x +++ "" = x + x +++ y = x ++ fieldSep:y + c ?: (Just v) = c : show v + _ ?: _ = "" file2key :: FilePath -> Maybe Key file2key s = if key == Just stubKey then Nothing else key - where - key = startbackend stubKey s + where + key = startbackend stubKey s - startbackend k v = sepfield k v addbackend + startbackend k v = sepfield k v addbackend - sepfield k v a = case span (/= fieldSep) v of - (v', _:r) -> findfields r $ a k v' - _ -> Nothing + sepfield k v a = case span (/= fieldSep) v of + (v', _:r) -> findfields r $ a k v' + _ -> Nothing - findfields (c:v) (Just k) - | c == fieldSep = Just $ k { keyName = v } - | otherwise = sepfield k v $ addfield c - findfields _ v = v + findfields (c:v) (Just k) + | c == fieldSep = Just $ k { keyName = v } + | otherwise = sepfield k v $ addfield c + findfields _ v = v - addbackend k v = Just k { keyBackendName = v } - addfield 's' k v = Just k { keySize = readish v } - addfield 'm' k v = Just k { keyMtime = readish v } - addfield _ _ _ = Nothing + addbackend k v = Just k { keyBackendName = v } + addfield 's' k v = Just k { keySize = readish v } + addfield 'm' k v = Just k { keyMtime = readish v } + addfield _ _ _ = Nothing prop_idempotent_key_encode :: Key -> Bool prop_idempotent_key_encode k = Just k == (file2key . key2file) k diff --git a/Upgrade.hs b/Upgrade.hs index 44ca6323e..705b190d8 100644 --- a/Upgrade.hs +++ b/Upgrade.hs @@ -15,8 +15,8 @@ import qualified Upgrade.V2 upgrade :: Annex Bool upgrade = go =<< getVersion - where - go (Just "0") = Upgrade.V0.upgrade - go (Just "1") = Upgrade.V1.upgrade - go (Just "2") = Upgrade.V2.upgrade - go _ = return True + where + go (Just "0") = Upgrade.V0.upgrade + go (Just "1") = Upgrade.V1.upgrade + go (Just "2") = Upgrade.V2.upgrade + go _ = return True diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs index 8f3af337e..00a08cb45 100644 --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -40,10 +40,10 @@ getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir) <$> (filterM present =<< getDirectoryContents dir) , return [] ) - where - present d = do - result <- tryIO $ - getFileStatus $ dir ++ "/" ++ takeFileName d - case result of - Right s -> return $ isRegularFile s - Left _ -> return False + where + present d = do + result <- tryIO $ + getFileStatus $ dir ++ "/" ++ takeFileName d + case result of + Right s -> return $ isRegularFile s + Left _ -> return False diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 8f7de3950..966b51a44 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -70,14 +70,14 @@ moveContent = do showAction "moving content" files <- getKeyFilesPresent1 forM_ files move - where - move f = do - let k = fileKey1 (takeFileName f) - let d = parentDir f - liftIO $ allowWrite d - liftIO $ allowWrite f - moveAnnex k f - liftIO $ removeDirectory d + where + move f = do + let k = fileKey1 (takeFileName f) + let d = parentDir f + liftIO $ allowWrite d + liftIO $ allowWrite f + moveAnnex k f + liftIO $ removeDirectory d updateSymlinks :: Annex () updateSymlinks = do @@ -86,54 +86,54 @@ updateSymlinks = do (files, cleanup) <- inRepo $ LsFiles.inRepo [top] forM_ files fixlink void $ liftIO cleanup - where - fixlink f = do - r <- lookupFile1 f - case r of - Nothing -> noop - Just (k, _) -> do - link <- calcGitLink f k - liftIO $ removeFile f - liftIO $ createSymbolicLink link f - Annex.Queue.addCommand "add" [Param "--"] [f] + where + fixlink f = do + r <- lookupFile1 f + case r of + Nothing -> noop + Just (k, _) -> do + link <- calcGitLink f k + liftIO $ removeFile f + liftIO $ createSymbolicLink link f + Annex.Queue.addCommand "add" [Param "--"] [f] moveLocationLogs :: Annex () moveLocationLogs = do showAction "moving location logs" logkeys <- oldlocationlogs forM_ logkeys move - where - oldlocationlogs = do - dir <- fromRepo Upgrade.V2.gitStateDir - ifM (liftIO $ doesDirectoryExist dir) - ( mapMaybe oldlog2key - <$> (liftIO $ getDirectoryContents dir) - , return [] - ) - move (l, k) = do - dest <- fromRepo $ logFile2 k - dir <- fromRepo Upgrade.V2.gitStateDir - let f = dir </> l - liftIO $ createDirectoryIfMissing True (parentDir dest) - -- could just git mv, but this way deals with - -- log files that are not checked into git, - -- as well as merging with already upgraded - -- logs that have been pulled from elsewhere - old <- liftIO $ readLog1 f - new <- liftIO $ readLog1 dest - liftIO $ writeLog1 dest (old++new) - Annex.Queue.addCommand "add" [Param "--"] [dest] - Annex.Queue.addCommand "add" [Param "--"] [f] - Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f] - + where + oldlocationlogs = do + dir <- fromRepo Upgrade.V2.gitStateDir + ifM (liftIO $ doesDirectoryExist dir) + ( mapMaybe oldlog2key + <$> (liftIO $ getDirectoryContents dir) + , return [] + ) + move (l, k) = do + dest <- fromRepo $ logFile2 k + dir <- fromRepo Upgrade.V2.gitStateDir + let f = dir </> l + liftIO $ createDirectoryIfMissing True (parentDir dest) + -- could just git mv, but this way deals with + -- log files that are not checked into git, + -- as well as merging with already upgraded + -- logs that have been pulled from elsewhere + old <- liftIO $ readLog1 f + new <- liftIO $ readLog1 dest + liftIO $ writeLog1 dest (old++new) + Annex.Queue.addCommand "add" [Param "--"] [dest] + Annex.Queue.addCommand "add" [Param "--"] [f] + Annex.Queue.addCommand "rm" [Param "--quiet", Param "-f", Param "--"] [f] + oldlog2key :: FilePath -> Maybe (FilePath, Key) oldlog2key l | drop len l == ".log" && sane = Just (l, k) | otherwise = Nothing - where - len = length l - 4 - k = readKey1 (take len l) - sane = (not . null $ keyName k) && (not . null $ keyBackendName k) + where + len = length l - 4 + k = readKey1 (take len l) + sane = (not . null $ keyName k) && (not . null $ keyBackendName k) -- WORM backend keys: "WORM:mtime:size:filename" -- all the rest: "backend:key" @@ -150,25 +150,25 @@ readKey1 v , keySize = s , keyMtime = t } - where - bits = split ":" v - b = Prelude.head bits - n = join ":" $ drop (if wormy then 3 else 1) bits - t = if wormy - then Just (Prelude.read (bits !! 1) :: EpochTime) - else Nothing - s = if wormy - then Just (Prelude.read (bits !! 2) :: Integer) - else Nothing - wormy = Prelude.head bits == "WORM" - mixup = wormy && isUpper (Prelude.head $ bits !! 1) + where + bits = split ":" v + b = Prelude.head bits + n = join ":" $ drop (if wormy then 3 else 1) bits + t = if wormy + then Just (Prelude.read (bits !! 1) :: EpochTime) + else Nothing + s = if wormy + then Just (Prelude.read (bits !! 2) :: Integer) + else Nothing + wormy = Prelude.head bits == "WORM" + mixup = wormy && isUpper (Prelude.head $ bits !! 1) showKey1 :: Key -> String showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } = join ":" $ filter (not . null) [b, showifhere t, showifhere s, n] - where - showifhere Nothing = "" - showifhere (Just v) = show v + where + showifhere Nothing = "" + showifhere (Just v) = show v keyFile1 :: Key -> FilePath keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a" $ showKey1 key @@ -190,21 +190,21 @@ lookupFile1 file = do case tl of Left _ -> return Nothing Right l -> makekey l - where - getsymlink = takeFileName <$> readSymbolicLink file - makekey l = case maybeLookupBackendName bname of - Nothing -> do - unless (null kname || null bname || - not (isLinkToAnnex l)) $ - warning skip - return Nothing - Just backend -> return $ Just (k, backend) - where - k = fileKey1 l - bname = keyBackendName k - kname = keyName k - skip = "skipping " ++ file ++ - " (unknown backend " ++ bname ++ ")" + where + getsymlink = takeFileName <$> readSymbolicLink file + makekey l = case maybeLookupBackendName bname of + Nothing -> do + unless (null kname || null bname || + not (isLinkToAnnex l)) $ + warning skip + return Nothing + Just backend -> return $ Just (k, backend) + where + k = fileKey1 l + bname = keyBackendName k + kname = keyName k + skip = "skipping " ++ file ++ + " (unknown backend " ++ bname ++ ")" getKeyFilesPresent1 :: Annex [FilePath] getKeyFilesPresent1 = getKeyFilesPresent1' =<< fromRepo gitAnnexObjectDir @@ -217,12 +217,12 @@ getKeyFilesPresent1' dir = liftIO $ filterM present files , return [] ) - where - present f = do - result <- tryIO $ getFileStatus f - case result of - Right s -> return $ isRegularFile s - Left _ -> return False + where + present f = do + result <- tryIO $ getFileStatus f + case result of + Right s -> return $ isRegularFile s + Left _ -> return False logFile1 :: Git.Repo -> Key -> String logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log" diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index 1f4a40f3c..beddc5b8b 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -70,10 +70,10 @@ locationLogs = do levelb <- mapM tryDirContents levela files <- mapM tryDirContents (concat levelb) return $ mapMaybe islogfile (concat files) - where - tryDirContents d = catchDefaultIO [] $ dirContents d - islogfile f = maybe Nothing (\k -> Just (k, f)) $ - logFileKey $ takeFileName f + where + tryDirContents d = catchDefaultIO [] $ dirContents d + islogfile f = maybe Nothing (\k -> Just (k, f)) $ + logFileKey $ takeFileName f inject :: FilePath -> FilePath -> Annex () inject source dest = do diff --git a/git-annex.hs b/git-annex.hs index f5f2f22d7..60ed6c15e 100644 --- a/git-annex.hs +++ b/git-annex.hs @@ -13,9 +13,9 @@ import qualified GitAnnexShell main :: IO () main = run =<< getProgName - where - run n - | isshell n = go GitAnnexShell.run - | otherwise = go GitAnnex.run - isshell n = takeFileName n == "git-annex-shell" - go a = a =<< getArgs + where + run n + | isshell n = go GitAnnexShell.run + | otherwise = go GitAnnex.run + isshell n = takeFileName n == "git-annex-shell" + go a = a =<< getArgs @@ -133,45 +133,45 @@ blackbox = TestLabel "blackbox" $ TestList test_init :: Test test_init = "git-annex init" ~: TestCase $ innewrepo $ do git_annex "init" [reponame] @? "init failed" - where - reponame = "test repo" + where + reponame = "test repo" test_add :: Test test_add = "git-annex add" ~: TestList [basic, sha1dup, subdirs] - where - -- this test case runs in the main repo, to set up a basic - -- annexed file that later tests will use - basic = TestCase $ inmainrepo $ do - writeFile annexedfile $ content annexedfile - git_annex "add" [annexedfile] @? "add failed" - annexed_present annexedfile - writeFile sha1annexedfile $ content sha1annexedfile - git_annex "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" - annexed_present sha1annexedfile - checkbackend sha1annexedfile backendSHA1 - writeFile wormannexedfile $ content wormannexedfile - git_annex "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" - annexed_present wormannexedfile - checkbackend wormannexedfile backendWORM - boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed" - writeFile ingitfile $ content ingitfile - boolSystem "git" [Param "add", File ingitfile] @? "git add failed" - boolSystem "git" [Params "commit -q -a -m commit"] @? "git commit failed" - git_annex "add" [ingitfile] @? "add ingitfile should be no-op" - unannexed ingitfile - sha1dup = TestCase $ intmpclonerepo $ do - writeFile sha1annexedfiledup $ content sha1annexedfiledup - git_annex "add" [sha1annexedfiledup, "--backend=SHA1"] @? "add of second file with same SHA1 failed" - annexed_present sha1annexedfiledup - annexed_present sha1annexedfile - subdirs = TestCase $ intmpclonerepo $ do - createDirectory "dir" - writeFile "dir/foo" $ content annexedfile - git_annex "add" ["dir"] @? "add of subdir failed" - createDirectory "dir2" - writeFile "dir2/foo" $ content annexedfile - changeWorkingDirectory "dir" - git_annex "add" ["../dir2"] @? "add of ../subdir failed" + where + -- this test case runs in the main repo, to set up a basic + -- annexed file that later tests will use + basic = TestCase $ inmainrepo $ do + writeFile annexedfile $ content annexedfile + git_annex "add" [annexedfile] @? "add failed" + annexed_present annexedfile + writeFile sha1annexedfile $ content sha1annexedfile + git_annex "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" + annexed_present sha1annexedfile + checkbackend sha1annexedfile backendSHA1 + writeFile wormannexedfile $ content wormannexedfile + git_annex "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" + annexed_present wormannexedfile + checkbackend wormannexedfile backendWORM + boolSystem "git" [Params "rm --force -q", File wormannexedfile] @? "git rm failed" + writeFile ingitfile $ content ingitfile + boolSystem "git" [Param "add", File ingitfile] @? "git add failed" + boolSystem "git" [Params "commit -q -a -m commit"] @? "git commit failed" + git_annex "add" [ingitfile] @? "add ingitfile should be no-op" + unannexed ingitfile + sha1dup = TestCase $ intmpclonerepo $ do + writeFile sha1annexedfiledup $ content sha1annexedfiledup + git_annex "add" [sha1annexedfiledup, "--backend=SHA1"] @? "add of second file with same SHA1 failed" + annexed_present sha1annexedfiledup + annexed_present sha1annexedfile + subdirs = TestCase $ intmpclonerepo $ do + createDirectory "dir" + writeFile "dir/foo" $ content annexedfile + git_annex "add" ["dir"] @? "add of subdir failed" + createDirectory "dir2" + writeFile "dir2/foo" $ content annexedfile + changeWorkingDirectory "dir" + git_annex "add" ["../dir2"] @? "add of ../subdir failed" test_reinject :: Test test_reinject = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepo $ do @@ -183,53 +183,53 @@ test_reinject = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepo $ do git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" git_annex "fromkey" [key, sha1annexedfiledup] @? "fromkey failed" annexed_present sha1annexedfiledup - where - tmp = "tmpfile" + where + tmp = "tmpfile" test_unannex :: Test test_unannex = "git-annex unannex" ~: TestList [nocopy, withcopy] - where - nocopy = "no content" ~: intmpclonerepo $ do - annexed_notpresent annexedfile - git_annex "unannex" [annexedfile] @? "unannex failed with no copy" - annexed_notpresent annexedfile - withcopy = "with content" ~: intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" - annexed_present annexedfile - git_annex "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" - unannexed annexedfile - git_annex "unannex" [annexedfile] @? "unannex failed on non-annexed file" - unannexed annexedfile - git_annex "unannex" [ingitfile] @? "unannex ingitfile should be no-op" - unannexed ingitfile + where + nocopy = "no content" ~: intmpclonerepo $ do + annexed_notpresent annexedfile + git_annex "unannex" [annexedfile] @? "unannex failed with no copy" + annexed_notpresent annexedfile + withcopy = "with content" ~: intmpclonerepo $ do + git_annex "get" [annexedfile] @? "get failed" + annexed_present annexedfile + git_annex "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" + unannexed annexedfile + git_annex "unannex" [annexedfile] @? "unannex failed on non-annexed file" + unannexed annexedfile + git_annex "unannex" [ingitfile] @? "unannex ingitfile should be no-op" + unannexed ingitfile test_drop :: Test test_drop = "git-annex drop" ~: TestList [noremote, withremote, untrustedremote] - where - noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" - boolSystem "git" [Params "remote rm origin"] - @? "git remote rm origin failed" - not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" - annexed_present annexedfile - git_annex "drop" ["--force", annexedfile] @? "drop --force failed" - annexed_notpresent annexedfile - git_annex "drop" [annexedfile] @? "drop of dropped file failed" - git_annex "drop" [ingitfile] @? "drop ingitfile should be no-op" - unannexed ingitfile - withremote = "with remote" ~: TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" - annexed_present annexedfile - git_annex "drop" [annexedfile] @? "drop failed though origin has copy" - annexed_notpresent annexedfile - inmainrepo $ annexed_present annexedfile - untrustedremote = "untrusted remote" ~: TestCase $ intmpclonerepo $ do - git_annex "untrust" ["origin"] @? "untrust of origin failed" - git_annex "get" [annexedfile] @? "get failed" - annexed_present annexedfile - not <$> git_annex "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" - annexed_present annexedfile - inmainrepo $ annexed_present annexedfile + where + noremote = "no remotes" ~: TestCase $ intmpclonerepo $ do + git_annex "get" [annexedfile] @? "get failed" + boolSystem "git" [Params "remote rm origin"] + @? "git remote rm origin failed" + not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" + annexed_present annexedfile + git_annex "drop" ["--force", annexedfile] @? "drop --force failed" + annexed_notpresent annexedfile + git_annex "drop" [annexedfile] @? "drop of dropped file failed" + git_annex "drop" [ingitfile] @? "drop ingitfile should be no-op" + unannexed ingitfile + withremote = "with remote" ~: TestCase $ intmpclonerepo $ do + git_annex "get" [annexedfile] @? "get failed" + annexed_present annexedfile + git_annex "drop" [annexedfile] @? "drop failed though origin has copy" + annexed_notpresent annexedfile + inmainrepo $ annexed_present annexedfile + untrustedremote = "untrusted remote" ~: TestCase $ intmpclonerepo $ do + git_annex "untrust" ["origin"] @? "untrust of origin failed" + git_annex "get" [annexedfile] @? "get failed" + annexed_present annexedfile + not <$> git_annex "drop" [annexedfile] @? "drop wrongly suceeded with only an untrusted copy of the file" + annexed_present annexedfile + inmainrepo $ annexed_present annexedfile test_get :: Test test_get = "git-annex get" ~: TestCase $ intmpclonerepo $ do @@ -326,27 +326,27 @@ test_lock = "git-annex unlock/lock" ~: intmpclonerepo $ do test_edit :: Test test_edit = "git-annex edit/commit" ~: TestList [t False, t True] - where t precommit = TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get of file failed" - annexed_present annexedfile - git_annex "edit" [annexedfile] @? "edit failed" - unannexed annexedfile - changecontent annexedfile - if precommit - then do - -- pre-commit depends on the file being - -- staged, normally git commit does this - boolSystem "git" [Param "add", File annexedfile] - @? "git add of edited file failed" - git_annex "pre-commit" [] - @? "pre-commit failed" - else do - boolSystem "git" [Params "commit -q -a -m contentchanged"] - @? "git commit of edited file failed" - runchecks [checklink, checkunwritable] annexedfile - c <- readFile annexedfile - assertEqual "content of modified file" c (changedcontent annexedfile) - not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" + where t precommit = TestCase $ intmpclonerepo $ do + git_annex "get" [annexedfile] @? "get of file failed" + annexed_present annexedfile + git_annex "edit" [annexedfile] @? "edit failed" + unannexed annexedfile + changecontent annexedfile + if precommit + then do + -- pre-commit depends on the file being + -- staged, normally git commit does this + boolSystem "git" [Param "add", File annexedfile] + @? "git add of edited file failed" + git_annex "pre-commit" [] + @? "pre-commit failed" + else do + boolSystem "git" [Params "commit -q -a -m contentchanged"] + @? "git commit of edited file failed" + runchecks [checklink, checkunwritable] annexedfile + c <- readFile annexedfile + assertEqual "content of modified file" c (changedcontent annexedfile) + not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" test_fix :: Test test_fix = "git-annex fix" ~: intmpclonerepo $ do @@ -364,9 +364,9 @@ test_fix = "git-annex fix" ~: intmpclonerepo $ do runchecks [checklink, checkunwritable] newfile c <- readFile newfile assertEqual "content of moved file" c (content annexedfile) - where - subdir = "s" - newfile = subdir ++ "/" ++ annexedfile + where + subdir = "s" + newfile = subdir ++ "/" ++ annexedfile test_trust :: Test test_trust = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo $ do @@ -386,89 +386,89 @@ test_trust = "git-annex trust/untrust/semitrust/dead" ~: intmpclonerepo $ do trustcheck Logs.Trust.SemiTrusted "semitrusted 1" git_annex "semitrust" [repo] @? "semitrust of semitrusted failed" trustcheck Logs.Trust.SemiTrusted "semitrusted 2" - where - repo = "origin" - trustcheck expected msg = do - present <- annexeval $ do - l <- Logs.Trust.trustGet expected - u <- Remote.nameToUUID repo - return $ u `elem` l - assertBool msg present + where + repo = "origin" + trustcheck expected msg = do + present <- annexeval $ do + l <- Logs.Trust.trustGet expected + u <- Remote.nameToUUID repo + return $ u `elem` l + assertBool msg present test_fsck :: Test test_fsck = "git-annex fsck" ~: TestList [basicfsck, barefsck, withlocaluntrusted, withremoteuntrusted] - where - basicfsck = TestCase $ intmpclonerepo $ do - git_annex "fsck" [] @? "fsck failed" - boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" - fsck_should_fail "numcopies unsatisfied" - boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed" - corrupt annexedfile - corrupt sha1annexedfile - barefsck = TestCase $ intmpbareclonerepo $ do - git_annex "fsck" [] @? "fsck failed" - withlocaluntrusted = TestCase $ intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" - git_annex "untrust" ["origin"] @? "untrust of origin repo failed" - git_annex "untrust" ["."] @? "untrust of current repo failed" - fsck_should_fail "content only available in untrusted (current) repository" - git_annex "trust" ["."] @? "trust of current repo failed" - git_annex "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" - withremoteuntrusted = TestCase $ intmpclonerepo $ do - boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" - git_annex "get" [annexedfile] @? "get failed" - git_annex "get" [sha1annexedfile] @? "get failed" - git_annex "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" - git_annex "untrust" ["origin"] @? "untrust of origin failed" - fsck_should_fail "content not replicated to enough non-untrusted repositories" - - corrupt f = do - git_annex "get" [f] @? "get of file failed" - Utility.FileMode.allowWrite f - writeFile f (changedcontent f) - not <$> git_annex "fsck" [] @? "fsck failed to fail with corrupted file content" - git_annex "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f - fsck_should_fail m = do - not <$> git_annex "fsck" [] @? "fsck failed to fail with " ++ m + where + basicfsck = TestCase $ intmpclonerepo $ do + git_annex "fsck" [] @? "fsck failed" + boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" + fsck_should_fail "numcopies unsatisfied" + boolSystem "git" [Params "config annex.numcopies 1"] @? "git config failed" + corrupt annexedfile + corrupt sha1annexedfile + barefsck = TestCase $ intmpbareclonerepo $ do + git_annex "fsck" [] @? "fsck failed" + withlocaluntrusted = TestCase $ intmpclonerepo $ do + git_annex "get" [annexedfile] @? "get failed" + git_annex "untrust" ["origin"] @? "untrust of origin repo failed" + git_annex "untrust" ["."] @? "untrust of current repo failed" + fsck_should_fail "content only available in untrusted (current) repository" + git_annex "trust" ["."] @? "trust of current repo failed" + git_annex "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" + withremoteuntrusted = TestCase $ intmpclonerepo $ do + boolSystem "git" [Params "config annex.numcopies 2"] @? "git config failed" + git_annex "get" [annexedfile] @? "get failed" + git_annex "get" [sha1annexedfile] @? "get failed" + git_annex "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" + git_annex "untrust" ["origin"] @? "untrust of origin failed" + fsck_should_fail "content not replicated to enough non-untrusted repositories" + + corrupt f = do + git_annex "get" [f] @? "get of file failed" + Utility.FileMode.allowWrite f + writeFile f (changedcontent f) + not <$> git_annex "fsck" [] @? "fsck failed to fail with corrupted file content" + git_annex "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f + fsck_should_fail m = do + not <$> git_annex "fsck" [] @? "fsck failed to fail with " ++ m test_migrate :: Test test_migrate = "git-annex migrate" ~: TestList [t False, t True] - where t usegitattributes = TestCase $ intmpclonerepo $ do - annexed_notpresent annexedfile - annexed_notpresent sha1annexedfile - git_annex "migrate" [annexedfile] @? "migrate of not present failed" - git_annex "migrate" [sha1annexedfile] @? "migrate of not present failed" - git_annex "get" [annexedfile] @? "get of file failed" - git_annex "get" [sha1annexedfile] @? "get of file failed" - annexed_present annexedfile - annexed_present sha1annexedfile - if usegitattributes - then do - writeFile ".gitattributes" $ "* annex.backend=SHA1" - git_annex "migrate" [sha1annexedfile] - @? "migrate sha1annexedfile failed" - git_annex "migrate" [annexedfile] - @? "migrate annexedfile failed" - else do - git_annex "migrate" [sha1annexedfile, "--backend", "SHA1"] - @? "migrate sha1annexedfile failed" - git_annex "migrate" [annexedfile, "--backend", "SHA1"] - @? "migrate annexedfile failed" - annexed_present annexedfile - annexed_present sha1annexedfile - checkbackend annexedfile backendSHA1 - checkbackend sha1annexedfile backendSHA1 - - -- check that reversing a migration works - writeFile ".gitattributes" $ "* annex.backend=SHA256" - git_annex "migrate" [sha1annexedfile] - @? "migrate sha1annexedfile failed" - git_annex "migrate" [annexedfile] - @? "migrate annexedfile failed" - annexed_present annexedfile - annexed_present sha1annexedfile - checkbackend annexedfile backendSHA256 - checkbackend sha1annexedfile backendSHA256 + where t usegitattributes = TestCase $ intmpclonerepo $ do + annexed_notpresent annexedfile + annexed_notpresent sha1annexedfile + git_annex "migrate" [annexedfile] @? "migrate of not present failed" + git_annex "migrate" [sha1annexedfile] @? "migrate of not present failed" + git_annex "get" [annexedfile] @? "get of file failed" + git_annex "get" [sha1annexedfile] @? "get of file failed" + annexed_present annexedfile + annexed_present sha1annexedfile + if usegitattributes + then do + writeFile ".gitattributes" $ "* annex.backend=SHA1" + git_annex "migrate" [sha1annexedfile] + @? "migrate sha1annexedfile failed" + git_annex "migrate" [annexedfile] + @? "migrate annexedfile failed" + else do + git_annex "migrate" [sha1annexedfile, "--backend", "SHA1"] + @? "migrate sha1annexedfile failed" + git_annex "migrate" [annexedfile, "--backend", "SHA1"] + @? "migrate annexedfile failed" + annexed_present annexedfile + annexed_present sha1annexedfile + checkbackend annexedfile backendSHA1 + checkbackend sha1annexedfile backendSHA1 + + -- check that reversing a migration works + writeFile ".gitattributes" $ "* annex.backend=SHA256" + git_annex "migrate" [sha1annexedfile] + @? "migrate sha1annexedfile failed" + git_annex "migrate" [annexedfile] + @? "migrate annexedfile failed" + annexed_present annexedfile + annexed_present sha1annexedfile + checkbackend annexedfile backendSHA256 + checkbackend sha1annexedfile backendSHA256 test_unused :: Test test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do @@ -498,16 +498,16 @@ test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do checkunused [] "after dropunused" git_annex "dropunused" ["10", "501"] @? "dropunused failed on bogus numbers" - where - checkunused expectedkeys desc = do - git_annex "unused" [] @? "unused failed" - unusedmap <- annexeval $ Logs.Unused.readUnusedLog "" - let unusedkeys = M.elems unusedmap - assertEqual ("unused keys differ " ++ desc) - (sort expectedkeys) (sort unusedkeys) - findkey f = do - r <- Backend.lookupFile f - return $ fst $ fromJust r + where + checkunused expectedkeys desc = do + git_annex "unused" [] @? "unused failed" + unusedmap <- annexeval $ Logs.Unused.readUnusedLog "" + let unusedkeys = M.elems unusedmap + assertEqual ("unused keys differ " ++ desc) + (sort expectedkeys) (sort unusedkeys) + findkey f = do + r <- Backend.lookupFile f + return $ fst $ fromJust r test_describe :: Test test_describe = "git-annex describe" ~: intmpclonerepo $ do @@ -604,11 +604,11 @@ test_hook_remote = "git-annex hook remote" ~: intmpclonerepo $ do annexed_present annexedfile not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" annexed_present annexedfile - where - dir = "dir" - loc = dir ++ "/$ANNEX_KEY" - git_config k v = boolSystem "git" [Param "config", Param k, Param v] - @? "git config failed" + where + dir = "dir" + loc = dir ++ "/$ANNEX_KEY" + git_config k v = boolSystem "git" [Param "config", Param k, Param v] + @? "git config failed" test_directory_remote :: Test test_directory_remote = "git-annex directory remote" ~: intmpclonerepo $ do @@ -692,8 +692,8 @@ git_annex command params = do case r of Right _ -> return True Left _ -> return False - where - run = GitAnnex.run (command:"-q":params) + where + run = GitAnnex.run (command:"-q":params) {- Runs git-annex and returns its output. -} git_annex_output :: String -> [String] -> IO String |