mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

where indenting

Browse source
This commit is contained in:
Joey Hess 2012-11-11 00:51:07 -04:00
parent 6a0756d2fb
commit 2172cc586e
42 changed files with 1193 additions and 1209 deletions
Download patch file Download diff file Expand all files Collapse all files

83
Backend/SHA.hs
View file

@ -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

14
Backend/URL.hs
View file

@ -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)

51
Build/Configure.hs
View file

@ -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

16
Build/InstallDesktopFile.hs
View file

@ -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

52
Build/TestConfig.hs
View file

@ -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"

64
CmdLine.hs
View file

@ -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

46
Command.hs
View file

@ -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)

8
Git.hs
View file

@ -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

13
GitAnnex.hs
View file

@ -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 ..]"

50
GitAnnexShell.hs
View file

@ -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'
]
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
{- 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

8
Logs/Group.hs
View file

@ -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

18
Logs/Location.hs
View file

@ -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

14
Logs/PreferredContent.hs
View file

@ -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. -}

34
Logs/Presence.hs
View file

@ -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

50
Logs/Remote.hs
View file

@ -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

153
Logs/Transfer.hs
View file

@ -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

19
Logs/Trust.hs
View file

@ -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"

48
Logs/UUID.hs
View file

@ -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

58
Logs/UUIDBased.hs
View file

@ -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")]

37
Logs/Unused.hs
View file

@ -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

14
Logs/Web.hs
View file

@ -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 ()

6
Messages/JSON.hs
View file

@ -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

45
Remote/Bup.hs
View file

@ -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 ':'

171
Remote/Directory.hs
View file

@ -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 $

72
Remote/Helper/Encryptable.hs
View file

@ -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 ","

103
Remote/Helper/Hooks.hs
View file

@ -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"

18
Remote/Helper/Special.hs
View file

@ -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

34
Remote/Helper/Ssh.hs
View file

@ -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.

61
Remote/Hook.hs
View file

@ -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

14
Remote/List.hs
View file

@ -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]

72
Remote/Rsync.hs
View file

@ -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

239
Remote/S3.hs
View file

@ -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. -}

14
Remote/Web.hs
View file

@ -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

43
Seek.hs
View file

@ -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

26
Setup.hs
View file

@ -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

40
Types/Key.hs
View file

@ -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

10
Upgrade.hs
View file

@ -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

14
Upgrade/V0.hs
View file

@ -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

164
Upgrade/V1.hs
View file

@ -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"

8
Upgrade/V2.hs
View file

@ -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

12
git-annex.hs
View file

@ -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

386
test.hs
View file

@ -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"
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
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
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
-- 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