Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

where indenting

  • Loading branch information...
commit 2172cc586ee46adb9506d081a1215687421c1b81 1 parent 6a0756d
Joey Hess authored
Showing with 1,196 additions and 1,212 deletions.
  1. +41 −42 Backend/SHA.hs
  2. +7 −7 Backend/URL.hs
  3. +25 −26 Build/Configure.hs
  4. +8 −8 Build/InstallDesktopFile.hs
  5. +26 −26 Build/TestConfig.hs
  6. +32 −32 CmdLine.hs
  7. +23 −23 Command.hs
  8. +4 −4 Git.hs
  9. +7 −6 GitAnnex.hs
  10. +25 −27 GitAnnexShell.hs
  11. +4 −4 Logs/Group.hs
  12. +9 −9 Logs/Location.hs
  13. +7 −7 Logs/PreferredContent.hs
  14. +17 −17 Logs/Presence.hs
  15. +25 −25 Logs/Remote.hs
  16. +75 −78 Logs/Transfer.hs
  17. +9 −10 Logs/Trust.hs
  18. +24 −24 Logs/UUID.hs
  19. +29 −29 Logs/UUIDBased.hs
  20. +18 −19 Logs/Unused.hs
  21. +7 −7 Logs/Web.hs
  22. +3 −3 Messages/JSON.hs
  23. +23 −22 Remote/Bup.hs
  24. +85 −86 Remote/Directory.hs
  25. +36 −36 Remote/Helper/Encryptable.hs
  26. +51 −52 Remote/Helper/Hooks.hs
  27. +9 −9 Remote/Helper/Special.hs
  28. +17 −17 Remote/Helper/Ssh.hs
  29. +29 −32 Remote/Hook.hs
  30. +7 −7 Remote/List.hs
  31. +36 −36 Remote/Rsync.hs
  32. +118 −121 Remote/S3.hs
  33. +7 −7 Remote/Web.hs
  34. +21 −22 Seek.hs
  35. +13 −13 Setup.hs
  36. +20 −20 Types/Key.hs
  37. +5 −5 Upgrade.hs
  38. +7 −7 Upgrade/V0.hs
  39. +82 −82 Upgrade/V1.hs
  40. +4 −4 Upgrade/V2.hs
  41. +6 −6 git-annex.hs
  42. +195 −195 test.hs
83 Backend/SHA.hs
View
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 ..]"
52 GitAnnexShell.hs
View
@@ -44,24 +44,22 @@ cmds_notreadonly = concat
cmds :: [Command]
cmds = map adddirparam $ cmds_readonly ++ cmds_notreadonly
- where
- adddirparam c = c
- { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c
- }
+ where
+ adddirparam c = c { cmdparamdesc = "DIRECTORY " ++ cmdparamdesc c }
options :: [OptDescr (Annex ())]
options = Option.common ++
[ Option [] ["uuid"] (ReqArg checkuuid paramUUID) "local repository uuid"
]
- where
- checkuuid expected = getUUID >>= check
- where
- check u | u == toUUID expected = noop
- check NoUUID = unexpected "uninitialized repository"
- check u = unexpected $ "UUID " ++ fromUUID u
- unexpected s = error $
- "expected repository UUID " ++
- expected ++ " but found " ++ s
+ where
+ checkuuid expected = getUUID >>= check
+ where
+ check u | u == toUUID expected = noop
+ check NoUUID = unexpected "uninitialized repository"
+ check u = unexpected $ "UUID " ++ fromUUID u
+ unexpected s = error $
+ "expected repository UUID " ++
+ expected ++ " but found " ++ s
header :: String
header = "Usage: git-annex-shell [-c] command [parameters ...] [option ..]"
@@ -152,20 +150,20 @@ checkDirectory mdir = do
if d' `equalFilePath` dir'
then noop
else req d' (Just dir')
- where
- req d mdir' = error $ unwords
- [ "Only allowed to access"
- , d
- , maybe "and could not determine directory from command line" ("not " ++) mdir'
- ]
-
- {- A directory may start with ~/ or in some cases, even /~/,
- - or could just be relative to home, or of course could
- - be absolute. -}
- canondir home d
- | "~/" `isPrefixOf` d = return d
- | "/~/" `isPrefixOf` d = return $ drop 1 d
- | otherwise = relHome $ absPathFrom home d
+ where
+ req d mdir' = error $ unwords
+ [ "Only allowed to access"
+ , d
+ , maybe "and could not determine directory from command line" ("not " ++) mdir'
+ ]
+
+ {- A directory may start with ~/ or in some cases, even /~/,
+ - or could just be relative to home, or of course could
+ - be absolute. -}
+ canondir home d
+ | "~/" `isPrefixOf` d = return d
+ | "/~/" `isPrefixOf` d = return $ drop 1 d
+ | otherwise = relHome $ absPathFrom home d
checkEnv :: String -> IO ()
checkEnv var = do
8 Logs/Group.hs
View
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 $