summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-11 00:51:07 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-11 00:51:07 -0400
commit264bd9ebe37855d4005022df057da13ec8080afb (patch)
treef32f13646ece29c8f6336b8680cb07dd55187be5
parentd9f5cc9f73ea046fcd2b59b5e75d4600593ac05b (diff)
where indenting
-rw-r--r--Backend/SHA.hs83
-rw-r--r--Backend/URL.hs14
-rw-r--r--Build/Configure.hs51
-rw-r--r--Build/InstallDesktopFile.hs16
-rw-r--r--Build/TestConfig.hs52
-rw-r--r--CmdLine.hs64
-rw-r--r--Command.hs46
-rw-r--r--Git.hs8
-rw-r--r--GitAnnex.hs13
-rw-r--r--GitAnnexShell.hs52
-rw-r--r--Logs/Group.hs8
-rw-r--r--Logs/Location.hs18
-rw-r--r--Logs/PreferredContent.hs14
-rw-r--r--Logs/Presence.hs34
-rw-r--r--Logs/Remote.hs50
-rw-r--r--Logs/Transfer.hs153
-rw-r--r--Logs/Trust.hs19
-rw-r--r--Logs/UUID.hs48
-rw-r--r--Logs/UUIDBased.hs58
-rw-r--r--Logs/Unused.hs37
-rw-r--r--Logs/Web.hs14
-rw-r--r--Messages/JSON.hs6
-rw-r--r--Remote/Bup.hs45
-rw-r--r--Remote/Directory.hs171
-rw-r--r--Remote/Helper/Encryptable.hs72
-rw-r--r--Remote/Helper/Hooks.hs103
-rw-r--r--Remote/Helper/Special.hs18
-rw-r--r--Remote/Helper/Ssh.hs34
-rw-r--r--Remote/Hook.hs61
-rw-r--r--Remote/List.hs14
-rw-r--r--Remote/Rsync.hs72
-rw-r--r--Remote/S3.hs239
-rw-r--r--Remote/Web.hs14
-rw-r--r--Seek.hs43
-rw-r--r--Setup.hs26
-rw-r--r--Types/Key.hs40
-rw-r--r--Upgrade.hs10
-rw-r--r--Upgrade/V0.hs14
-rw-r--r--Upgrade/V1.hs164
-rw-r--r--Upgrade/V2.hs8
-rw-r--r--git-annex.hs12
-rw-r--r--test.hs390
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)
diff --git a/Git.hs b/Git.hs
index eab33f19d..46f995e77 100644
--- a/Git.hs
+++ b/Git.hs
@@ -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
diff --git a/Seek.hs b/Seek.hs
index 1f18861bc..cd3098664 100644
--- a/Seek.hs
+++ b/Seek.hs
@@ -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
diff --git a/Setup.hs b/Setup.hs
index 7e070938f..7a1f6cc26 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -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
diff --git a/test.hs b/test.hs
index 875668b86..3a8343114 100644
--- a/test.hs
+++ b/test.hs
@@ -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