indentation foo, and a new coding style page. no code changes
This commit is contained in:
Joey Hess
parent
dd63cbb7bc
commit
6eca362c5d
11 changed files with 395 additions and 301 deletions
4
Annex.hs
4
Annex.hs
|
|
@ -73,8 +73,8 @@ instance MonadBaseControl IO Annex where
|
|||
liftBaseWith f = Annex $ liftBaseWith $ \runInIO ->
|
||||
f $ liftM StAnnex . runInIO . runAnnex
|
||||
restoreM = Annex . restoreM . unStAnnex
|
||||
where
|
||||
unStAnnex (StAnnex st) = st
|
||||
where
|
||||
unStAnnex (StAnnex st) = st
|
||||
|
||||
type Matcher a = Either [Utility.Matcher.Token a] (Utility.Matcher.Matcher a)
|
||||
|
||||
|
|
|
|||
18
Config.hs
18
Config.hs
|
|
@ -95,24 +95,24 @@ repoSyncable r = fromMaybe True . Git.Config.isTrue
|
|||
- in git config. forcenumcopies overrides everything. -}
|
||||
getNumCopies :: Maybe Int -> Annex Int
|
||||
getNumCopies v = perhaps (use v) =<< Annex.getState Annex.forcenumcopies
|
||||
where
|
||||
use (Just n) = return n
|
||||
use Nothing = perhaps (return 1) =<<
|
||||
readish <$> getConfig (annexConfig "numcopies") "1"
|
||||
perhaps fallback = maybe fallback (return . id)
|
||||
where
|
||||
use (Just n) = return n
|
||||
use Nothing = perhaps (return 1) =<<
|
||||
readish <$> getConfig (annexConfig "numcopies") "1"
|
||||
perhaps fallback = maybe fallback (return . id)
|
||||
|
||||
{- Gets the trust level set for a remote in git config. -}
|
||||
getTrustLevel :: Git.Repo -> Annex (Maybe String)
|
||||
getTrustLevel r = fromRepo $ Git.Config.getMaybe key
|
||||
where
|
||||
(ConfigKey key) = remoteConfig r "trustlevel"
|
||||
where
|
||||
(ConfigKey key) = remoteConfig r "trustlevel"
|
||||
|
||||
{- Gets annex.diskreserve setting. -}
|
||||
getDiskReserve :: Annex Integer
|
||||
getDiskReserve = fromMaybe megabyte . readSize dataUnits
|
||||
<$> getConfig (annexConfig "diskreserve") ""
|
||||
where
|
||||
megabyte = 1000000
|
||||
where
|
||||
megabyte = 1000000
|
||||
|
||||
{- Gets annex.httpheaders or annex.httpheaders-command setting,
|
||||
- splitting it into lines. -}
|
||||
|
|
|
|||
40
Crypto.hs
40
Crypto.hs
|
|
@ -75,16 +75,16 @@ updateEncryptedCipher keyid encipher@(EncryptedCipher _ ks) = do
|
|||
ks' <- Gpg.findPubKeys keyid
|
||||
cipher <- decryptCipher encipher
|
||||
encryptCipher cipher (merge ks ks')
|
||||
where
|
||||
merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b
|
||||
where
|
||||
merge (KeyIds a) (KeyIds b) = KeyIds $ a ++ b
|
||||
|
||||
describeCipher :: StorableCipher -> String
|
||||
describeCipher (SharedCipher _) = "shared cipher"
|
||||
describeCipher (EncryptedCipher _ (KeyIds ks)) =
|
||||
"with gpg " ++ keys ks ++ " " ++ unwords ks
|
||||
where
|
||||
keys [_] = "key"
|
||||
keys _ = "keys"
|
||||
where
|
||||
keys [_] = "key"
|
||||
keys _ = "keys"
|
||||
|
||||
{- Encrypts a Cipher to the specified KeyIds. -}
|
||||
encryptCipher :: Cipher -> KeyIds -> IO StorableCipher
|
||||
|
|
@ -92,20 +92,20 @@ encryptCipher (Cipher c) (KeyIds ks) = do
|
|||
let ks' = nub $ sort ks -- gpg complains about duplicate recipient keyids
|
||||
encipher <- Gpg.pipeStrict (encrypt++recipients ks') c
|
||||
return $ EncryptedCipher encipher (KeyIds ks')
|
||||
where
|
||||
encrypt = [ Params "--encrypt" ]
|
||||
recipients l = force_recipients :
|
||||
concatMap (\k -> [Param "--recipient", Param k]) l
|
||||
-- Force gpg to only encrypt to the specified
|
||||
-- recipients, not configured defaults.
|
||||
force_recipients = Params "--no-encrypt-to --no-default-recipient"
|
||||
where
|
||||
encrypt = [ Params "--encrypt" ]
|
||||
recipients l = force_recipients :
|
||||
concatMap (\k -> [Param "--recipient", Param k]) l
|
||||
-- Force gpg to only encrypt to the specified
|
||||
-- recipients, not configured defaults.
|
||||
force_recipients = Params "--no-encrypt-to --no-default-recipient"
|
||||
|
||||
{- Decrypting an EncryptedCipher is expensive; the Cipher should be cached. -}
|
||||
decryptCipher :: StorableCipher -> IO Cipher
|
||||
decryptCipher (SharedCipher t) = return $ Cipher t
|
||||
decryptCipher (EncryptedCipher t _) = Cipher <$> Gpg.pipeStrict decrypt t
|
||||
where
|
||||
decrypt = [ Param "--decrypt" ]
|
||||
where
|
||||
decrypt = [ Param "--decrypt" ]
|
||||
|
||||
{- Generates an encrypted form of a Key. The encryption does not need to be
|
||||
- reversable, nor does it need to be the same type of encryption used
|
||||
|
|
@ -136,8 +136,12 @@ withEncryptedContent = pass withEncryptedHandle
|
|||
withDecryptedContent :: Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
|
||||
withDecryptedContent = pass withDecryptedHandle
|
||||
|
||||
pass :: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a)
|
||||
-> Cipher -> IO L.ByteString -> (L.ByteString -> IO a) -> IO a
|
||||
pass
|
||||
:: (Cipher -> IO L.ByteString -> (Handle -> IO a) -> IO a)
|
||||
-> Cipher
|
||||
-> IO L.ByteString
|
||||
-> (L.ByteString -> IO a)
|
||||
-> IO a
|
||||
pass to n s a = to n s $ a <=< L.hGetContents
|
||||
|
||||
hmacWithCipher :: Cipher -> String -> String
|
||||
|
|
@ -148,5 +152,5 @@ hmacWithCipher' c s = showDigest $ hmacSha1 (fromString c) (fromString s)
|
|||
{- Ensure that hmacWithCipher' returns the same thing forevermore. -}
|
||||
prop_hmacWithCipher_sane :: Bool
|
||||
prop_hmacWithCipher_sane = known_good == hmacWithCipher' "foo" "bar"
|
||||
where
|
||||
known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51"
|
||||
where
|
||||
known_good = "46b4ec586117154dacd49d664e5d63fdc88efb51"
|
||||
|
|
|
|||
10
Init.hs
10
Init.hs
|
|
@ -52,11 +52,11 @@ uninitialize = do
|
|||
repos that did not intend to use it. -}
|
||||
ensureInitialized :: Annex ()
|
||||
ensureInitialized = getVersion >>= maybe needsinit checkVersion
|
||||
where
|
||||
needsinit = ifM Annex.Branch.hasSibling
|
||||
( initialize Nothing
|
||||
, error "First run: git-annex init"
|
||||
)
|
||||
where
|
||||
needsinit = ifM Annex.Branch.hasSibling
|
||||
( initialize Nothing
|
||||
, error "First run: git-annex init"
|
||||
)
|
||||
|
||||
{- Checks if a repository is initialized. Does not check version for ugrade. -}
|
||||
isInitialized :: Annex Bool
|
||||
|
|
|
|||
49
Locations.hs
49
Locations.hs
|
|
@ -100,10 +100,10 @@ gitAnnexLocation key r
|
|||
- don't need to do any work to check if the file is
|
||||
- present. -}
|
||||
return $ inrepo $ annexLocation key hashDirMixed
|
||||
where
|
||||
inrepo d = Git.localGitDir r </> d
|
||||
check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs
|
||||
check [] = error "internal"
|
||||
where
|
||||
inrepo d = Git.localGitDir r </> d
|
||||
check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs
|
||||
check [] = error "internal"
|
||||
|
||||
{- The annex directory of a repository. -}
|
||||
gitAnnexDir :: Git.Repo -> FilePath
|
||||
|
|
@ -204,8 +204,8 @@ gitAnnexAssistantDefaultDir = "annex"
|
|||
{- Checks a symlink target to see if it appears to point to annexed content. -}
|
||||
isLinkToAnnex :: FilePath -> Bool
|
||||
isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s
|
||||
where
|
||||
d = ".git" </> objectDir
|
||||
where
|
||||
d = ".git" </> objectDir
|
||||
|
||||
{- Converts a key into a filename fragment without any directory.
|
||||
-
|
||||
|
|
@ -232,8 +232,8 @@ keyFile key = replace "/" "%" $ replace ":" "&c" $
|
|||
-}
|
||||
keyPath :: Key -> Hasher -> FilePath
|
||||
keyPath key hasher = hasher key </> f </> f
|
||||
where
|
||||
f = keyFile key
|
||||
where
|
||||
f = keyFile key
|
||||
|
||||
{- All possibile locations to store a key using different directory hashes. -}
|
||||
keyPaths :: Key -> [FilePath]
|
||||
|
|
@ -249,7 +249,8 @@ fileKey file = file2key $
|
|||
{- for quickcheck -}
|
||||
prop_idempotent_fileKey :: String -> Bool
|
||||
prop_idempotent_fileKey s = Just k == fileKey (keyFile k)
|
||||
where k = stubKey { keyName = s, keyBackendName = "test" }
|
||||
where
|
||||
k = stubKey { keyName = s, keyBackendName = "test" }
|
||||
|
||||
{- Two different directory hashes may be used. The mixed case hash
|
||||
- came first, and is fine, except for the problem of case-strict
|
||||
|
|
@ -262,14 +263,14 @@ annexHashes = [hashDirLower, hashDirMixed]
|
|||
|
||||
hashDirMixed :: Hasher
|
||||
hashDirMixed k = addTrailingPathSeparator $ take 2 dir </> drop 2 dir
|
||||
where
|
||||
dir = take 4 $ display_32bits_as_dir =<< [a,b,c,d]
|
||||
ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file k
|
||||
where
|
||||
dir = take 4 $ display_32bits_as_dir =<< [a,b,c,d]
|
||||
ABCD (a,b,c,d) = md5 $ md5FilePath $ key2file k
|
||||
|
||||
hashDirLower :: Hasher
|
||||
hashDirLower k = addTrailingPathSeparator $ take 3 dir </> drop 3 dir
|
||||
where
|
||||
dir = take 6 $ md5s $ md5FilePath $ key2file k
|
||||
where
|
||||
dir = take 6 $ md5s $ md5FilePath $ key2file k
|
||||
|
||||
{- modified version of display_32bits_as_hex from Data.Hash.MD5
|
||||
- Copyright (C) 2001 Ian Lynagh
|
||||
|
|
@ -277,13 +278,13 @@ hashDirLower k = addTrailingPathSeparator $ take 3 dir </> drop 3 dir
|
|||
-}
|
||||
display_32bits_as_dir :: Word32 -> String
|
||||
display_32bits_as_dir w = trim $ swap_pairs cs
|
||||
where
|
||||
-- Need 32 characters to use. To avoid inaverdently making
|
||||
-- a real word, use letters that appear less frequently.
|
||||
chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF"
|
||||
cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7]
|
||||
getc n = chars !! fromIntegral n
|
||||
swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs
|
||||
swap_pairs _ = []
|
||||
-- Last 2 will always be 00, so omit.
|
||||
trim = take 6
|
||||
where
|
||||
-- Need 32 characters to use. To avoid inaverdently making
|
||||
-- a real word, use letters that appear less frequently.
|
||||
chars = ['0'..'9'] ++ "zqjxkmvwgpfZQJXKMVWGPF"
|
||||
cs = map (\x -> getc $ (shiftR w (6*x)) .&. 31) [0..7]
|
||||
getc n = chars !! fromIntegral n
|
||||
swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs
|
||||
swap_pairs _ = []
|
||||
-- Last 2 will always be 00, so omit.
|
||||
trim = take 6
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@ showSideAction m = Annex.getState Annex.output >>= go
|
|||
where
|
||||
go (MessageState v StartBlock) = do
|
||||
p
|
||||
Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock }
|
||||
Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock }
|
||||
go (MessageState _ InBlock) = return ()
|
||||
go _ = p
|
||||
p = handle q $ putStrLn $ "(" ++ m ++ "...)"
|
||||
|
|
|
|||
30
Option.hs
30
Option.hs
|
|
@ -46,18 +46,18 @@ common =
|
|||
, Option ['b'] ["backend"] (ReqArg setforcebackend paramName)
|
||||
"specify key-value backend to use"
|
||||
]
|
||||
where
|
||||
setforce v = Annex.changeState $ \s -> s { Annex.force = v }
|
||||
setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
|
||||
setauto v = Annex.changeState $ \s -> s { Annex.auto = v }
|
||||
setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
|
||||
setdebug = liftIO $ do
|
||||
s <- simpledebug
|
||||
updateGlobalLogger rootLoggerName
|
||||
(setLevel DEBUG . setHandlers [s])
|
||||
simpledebug = setFormatter
|
||||
<$> streamHandler stderr DEBUG
|
||||
<*> pure (simpleLogFormatter "[$time] $msg")
|
||||
where
|
||||
setforce v = Annex.changeState $ \s -> s { Annex.force = v }
|
||||
setfast v = Annex.changeState $ \s -> s { Annex.fast = v }
|
||||
setauto v = Annex.changeState $ \s -> s { Annex.auto = v }
|
||||
setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
|
||||
setdebug = liftIO $ do
|
||||
s <- simpledebug
|
||||
updateGlobalLogger rootLoggerName
|
||||
(setLevel DEBUG . setHandlers [s])
|
||||
simpledebug = setFormatter
|
||||
<$> streamHandler stderr DEBUG
|
||||
<*> pure (simpleLogFormatter "[$time] $msg")
|
||||
|
||||
matcher :: [Option]
|
||||
matcher =
|
||||
|
|
@ -67,9 +67,9 @@ matcher =
|
|||
, shortopt "(" "open group of options"
|
||||
, shortopt ")" "close group of options"
|
||||
]
|
||||
where
|
||||
longopt o = Option [] [o] $ NoArg $ addToken o
|
||||
shortopt o = Option o [] $ NoArg $ addToken o
|
||||
where
|
||||
longopt o = Option [] [o] $ NoArg $ addToken o
|
||||
shortopt o = Option o [] $ NoArg $ addToken o
|
||||
|
||||
{- An option that sets a flag. -}
|
||||
flag :: String -> String -> String -> Option
|
||||
|
|
|
|||
96
Remote.hs
96
Remote.hs
|
|
@ -80,10 +80,10 @@ byName (Just n) = either error Just <$> byName' n
|
|||
byName' :: String -> Annex (Either String Remote)
|
||||
byName' "" = return $ Left "no remote specified"
|
||||
byName' n = handle . filter matching <$> remoteList
|
||||
where
|
||||
handle [] = Left $ "there is no available git remote named \"" ++ n ++ "\""
|
||||
handle match = Right $ Prelude.head match
|
||||
matching r = n == name r || toUUID n == uuid r
|
||||
where
|
||||
handle [] = Left $ "there is no available git remote named \"" ++ n ++ "\""
|
||||
handle match = Right $ Prelude.head match
|
||||
matching r = n == name r || toUUID n == uuid r
|
||||
|
||||
{- Looks up a remote by name (or by UUID, or even by description),
|
||||
- and returns its UUID. Finds even remotes that are not configured in
|
||||
|
|
@ -93,17 +93,17 @@ nameToUUID "." = getUUID -- special case for current repo
|
|||
nameToUUID "here" = getUUID
|
||||
nameToUUID "" = error "no remote specified"
|
||||
nameToUUID n = byName' n >>= go
|
||||
where
|
||||
go (Right r) = return $ uuid r
|
||||
go (Left e) = fromMaybe (error e) <$> bydescription
|
||||
bydescription = do
|
||||
m <- uuidMap
|
||||
case M.lookup n $ transform swap m of
|
||||
Just u -> return $ Just u
|
||||
Nothing -> return $ byuuid m
|
||||
byuuid m = M.lookup (toUUID n) $ transform double m
|
||||
transform a = M.fromList . map a . M.toList
|
||||
double (a, _) = (a, a)
|
||||
where
|
||||
go (Right r) = return $ uuid r
|
||||
go (Left e) = fromMaybe (error e) <$> bydescription
|
||||
bydescription = do
|
||||
m <- uuidMap
|
||||
case M.lookup n $ transform swap m of
|
||||
Just u -> return $ Just u
|
||||
Nothing -> return $ byuuid m
|
||||
byuuid m = M.lookup (toUUID n) $ transform double m
|
||||
transform a = M.fromList . map a . M.toList
|
||||
double (a, _) = (a, a)
|
||||
|
||||
{- Pretty-prints a list of UUIDs of remotes, for human display.
|
||||
-
|
||||
|
|
@ -115,23 +115,23 @@ prettyPrintUUIDs desc uuids = do
|
|||
m <- uuidDescriptions
|
||||
maybeShowJSON [(desc, map (jsonify m hereu) uuids)]
|
||||
return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids
|
||||
where
|
||||
finddescription m u = M.findWithDefault "" u m
|
||||
prettify m hereu u
|
||||
| not (null d) = fromUUID u ++ " -- " ++ d
|
||||
| otherwise = fromUUID u
|
||||
where
|
||||
ishere = hereu == u
|
||||
n = finddescription m u
|
||||
d
|
||||
| null n && ishere = "here"
|
||||
| ishere = addName n "here"
|
||||
| otherwise = n
|
||||
jsonify m hereu u = toJSObject
|
||||
[ ("uuid", toJSON $ fromUUID u)
|
||||
, ("description", toJSON $ finddescription m u)
|
||||
, ("here", toJSON $ hereu == u)
|
||||
]
|
||||
where
|
||||
finddescription m u = M.findWithDefault "" u m
|
||||
prettify m hereu u
|
||||
| not (null d) = fromUUID u ++ " -- " ++ d
|
||||
| otherwise = fromUUID u
|
||||
where
|
||||
ishere = hereu == u
|
||||
n = finddescription m u
|
||||
d
|
||||
| null n && ishere = "here"
|
||||
| ishere = addName n "here"
|
||||
| otherwise = n
|
||||
jsonify m hereu u = toJSObject
|
||||
[ ("uuid", toJSON $ fromUUID u)
|
||||
, ("description", toJSON $ finddescription m u)
|
||||
, ("here", toJSON $ hereu == u)
|
||||
]
|
||||
|
||||
{- List of remote names and/or descriptions, for human display. -}
|
||||
prettyListUUIDs :: [UUID] -> Annex [String]
|
||||
|
|
@ -139,13 +139,13 @@ prettyListUUIDs uuids = do
|
|||
hereu <- getUUID
|
||||
m <- uuidDescriptions
|
||||
return $ map (\u -> prettify m hereu u) uuids
|
||||
where
|
||||
finddescription m u = M.findWithDefault "" u m
|
||||
prettify m hereu u
|
||||
| u == hereu = addName n "here"
|
||||
| otherwise = n
|
||||
where
|
||||
n = finddescription m u
|
||||
where
|
||||
finddescription m u = M.findWithDefault "" u m
|
||||
prettify m hereu u
|
||||
| u == hereu = addName n "here"
|
||||
| otherwise = n
|
||||
where
|
||||
n = finddescription m u
|
||||
|
||||
{- Gets the git repo associated with a UUID.
|
||||
- There's no associated remote when this is the UUID of the local repo. -}
|
||||
|
|
@ -213,12 +213,12 @@ showLocations key exclude = do
|
|||
ppuuidswanted <- Remote.prettyPrintUUIDs "wanted" uuidswanted
|
||||
ppuuidsskipped <- Remote.prettyPrintUUIDs "skipped" uuidsskipped
|
||||
showLongNote $ message ppuuidswanted ppuuidsskipped
|
||||
where
|
||||
filteruuids l x = filter (`notElem` x) l
|
||||
message [] [] = "No other repository is known to contain the file."
|
||||
message rs [] = "Try making some of these repositories available:\n" ++ rs
|
||||
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
|
||||
message rs us = message rs [] ++ message [] us
|
||||
where
|
||||
filteruuids l x = filter (`notElem` x) l
|
||||
message [] [] = "No other repository is known to contain the file."
|
||||
message rs [] = "Try making some of these repositories available:\n" ++ rs
|
||||
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
|
||||
message rs us = message rs [] ++ message [] us
|
||||
|
||||
showTriedRemotes :: [Remote] -> Annex ()
|
||||
showTriedRemotes [] = noop
|
||||
|
|
@ -242,6 +242,6 @@ logStatus remote key = logChange key (uuid remote)
|
|||
{- Orders remotes by cost, with ones with the lowest cost grouped together. -}
|
||||
byCost :: [Remote] -> [[Remote]]
|
||||
byCost = map snd . sort . M.toList . costmap
|
||||
where
|
||||
costmap = M.fromListWith (++) . map costpair
|
||||
costpair r = (cost r, [r])
|
||||
where
|
||||
costmap = M.fromListWith (++) . map costpair
|
||||
costpair r = (cost r, [r])
|
||||
|
|
|
|||
356
Remote/Git.hs
356
Remote/Git.hs
|
|
@ -55,15 +55,15 @@ list = do
|
|||
c <- fromRepo Git.config
|
||||
rs <- mapM (tweakurl c) =<< fromRepo Git.remotes
|
||||
mapM configRead rs
|
||||
where
|
||||
annexurl n = "remote." ++ n ++ ".annexurl"
|
||||
tweakurl c r = do
|
||||
let n = fromJust $ Git.remoteName r
|
||||
case M.lookup (annexurl n) c of
|
||||
Nothing -> return r
|
||||
Just url -> inRepo $ \g ->
|
||||
Git.Construct.remoteNamed n $
|
||||
Git.Construct.fromRemoteLocation url g
|
||||
where
|
||||
annexurl n = "remote." ++ n ++ ".annexurl"
|
||||
tweakurl c r = do
|
||||
let n = fromJust $ Git.remoteName r
|
||||
case M.lookup (annexurl n) c of
|
||||
Nothing -> return r
|
||||
Just url -> inRepo $ \g ->
|
||||
Git.Construct.remoteNamed n $
|
||||
Git.Construct.fromRemoteLocation url g
|
||||
|
||||
{- It's assumed to be cheap to read the config of non-URL remotes, so this is
|
||||
- done each time git-annex is run in a way that uses remotes.
|
||||
|
|
@ -85,28 +85,27 @@ repoCheap = not . Git.repoIsUrl
|
|||
|
||||
gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
|
||||
gen r u _ = new <$> remoteCost r defcst
|
||||
where
|
||||
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
|
||||
new cst = Remote
|
||||
{ uuid = u
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
, storeKey = copyToRemote r
|
||||
, retrieveKeyFile = copyFromRemote r
|
||||
, retrieveKeyFileCheap = copyFromRemoteCheap r
|
||||
, removeKey = dropKey r
|
||||
, hasKey = inAnnex r
|
||||
, hasKeyCheap = repoCheap r
|
||||
, whereisKey = Nothing
|
||||
, config = Nothing
|
||||
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
|
||||
then Just $ Git.repoPath r
|
||||
else Nothing
|
||||
, repo = r
|
||||
, readonly = Git.repoIsHttp r
|
||||
, remotetype = remote
|
||||
}
|
||||
|
||||
where
|
||||
defcst = if repoCheap r then cheapRemoteCost else expensiveRemoteCost
|
||||
new cst = Remote
|
||||
{ uuid = u
|
||||
, cost = cst
|
||||
, name = Git.repoDescribe r
|
||||
, storeKey = copyToRemote r
|
||||
, retrieveKeyFile = copyFromRemote r
|
||||
, retrieveKeyFileCheap = copyFromRemoteCheap r
|
||||
, removeKey = dropKey r
|
||||
, hasKey = inAnnex r
|
||||
, hasKeyCheap = repoCheap r
|
||||
, whereisKey = Nothing
|
||||
, config = Nothing
|
||||
, localpath = if Git.repoIsLocal r || Git.repoIsLocalUnknown r
|
||||
then Just $ Git.repoPath r
|
||||
else Nothing
|
||||
, repo = r
|
||||
, readonly = Git.repoIsHttp r
|
||||
, remotetype = remote
|
||||
}
|
||||
|
||||
{- Checks relatively inexpensively if a repository is available for use. -}
|
||||
repoAvail :: Git.Repo -> Annex Bool
|
||||
|
|
@ -149,40 +148,40 @@ tryGitConfigRead r
|
|||
| otherwise = store $ safely $ onLocal r $ do
|
||||
ensureInitialized
|
||||
Annex.getState Annex.repo
|
||||
where
|
||||
-- Reading config can fail due to IO error or
|
||||
-- for other reasons; catch all possible exceptions.
|
||||
safely a = either (const $ return r) return
|
||||
=<< liftIO (try a :: IO (Either SomeException Git.Repo))
|
||||
where
|
||||
-- Reading config can fail due to IO error or
|
||||
-- for other reasons; catch all possible exceptions.
|
||||
safely a = either (const $ return r) return
|
||||
=<< liftIO (try a :: IO (Either SomeException Git.Repo))
|
||||
|
||||
pipedconfig cmd params =
|
||||
withHandle StdoutHandle createProcessSuccess p $
|
||||
Git.Config.hRead r
|
||||
where
|
||||
p = proc cmd $ toCommand params
|
||||
pipedconfig cmd params =
|
||||
withHandle StdoutHandle createProcessSuccess p $
|
||||
Git.Config.hRead r
|
||||
where
|
||||
p = proc cmd $ toCommand params
|
||||
|
||||
pipedsshconfig cmd params =
|
||||
liftIO (try (pipedconfig cmd params) :: IO (Either SomeException Git.Repo))
|
||||
pipedsshconfig cmd params =
|
||||
liftIO (try (pipedconfig cmd params) :: IO (Either SomeException Git.Repo))
|
||||
|
||||
geturlconfig headers = do
|
||||
s <- Url.get (Git.repoLocation r ++ "/config") headers
|
||||
withTempFile "git-annex.tmp" $ \tmpfile h -> do
|
||||
hPutStr h s
|
||||
hClose h
|
||||
safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
|
||||
geturlconfig headers = do
|
||||
s <- Url.get (Git.repoLocation r ++ "/config") headers
|
||||
withTempFile "git-annex.tmp" $ \tmpfile h -> do
|
||||
hPutStr h s
|
||||
hClose h
|
||||
safely $ pipedconfig "git" [Param "config", Param "--null", Param "--list", Param "--file", File tmpfile]
|
||||
|
||||
store = observe $ \r' -> do
|
||||
g <- gitRepo
|
||||
let l = Git.remotes g
|
||||
let g' = g { Git.remotes = exchange l r' }
|
||||
Annex.changeState $ \s -> s { Annex.repo = g' }
|
||||
store = observe $ \r' -> do
|
||||
g <- gitRepo
|
||||
let l = Git.remotes g
|
||||
let g' = g { Git.remotes = exchange l r' }
|
||||
Annex.changeState $ \s -> s { Annex.repo = g' }
|
||||
|
||||
exchange [] _ = []
|
||||
exchange (old:ls) new
|
||||
| Git.remoteName old == Git.remoteName new =
|
||||
new : exchange ls new
|
||||
| otherwise =
|
||||
old : exchange ls new
|
||||
exchange [] _ = []
|
||||
exchange (old:ls) new
|
||||
| Git.remoteName old == Git.remoteName new =
|
||||
new : exchange ls new
|
||||
| otherwise =
|
||||
old : exchange ls new
|
||||
|
||||
{- Checks if a given remote has the content for a key inAnnex.
|
||||
- If the remote cannot be accessed, or if it cannot determine
|
||||
|
|
@ -193,32 +192,32 @@ inAnnex r key
|
|||
| Git.repoIsHttp r = checkhttp =<< getHttpHeaders
|
||||
| Git.repoIsUrl r = checkremote
|
||||
| otherwise = checklocal
|
||||
where
|
||||
checkhttp headers = liftIO $ go undefined $ keyUrls r key
|
||||
where
|
||||
go e [] = return $ Left e
|
||||
go _ (u:us) = do
|
||||
res <- catchMsgIO $
|
||||
Url.check u headers (keySize key)
|
||||
case res of
|
||||
Left e -> go e us
|
||||
v -> return v
|
||||
checkremote = do
|
||||
showAction $ "checking " ++ Git.repoDescribe r
|
||||
onRemote r (check, unknown) "inannex" [Param (key2file key)] []
|
||||
where
|
||||
check c p = dispatch <$> safeSystem c p
|
||||
dispatch ExitSuccess = Right True
|
||||
dispatch (ExitFailure 1) = Right False
|
||||
dispatch _ = unknown
|
||||
checklocal = guardUsable r unknown $ dispatch <$> check
|
||||
where
|
||||
check = liftIO $ catchMsgIO $ onLocal r $
|
||||
Annex.Content.inAnnexSafe key
|
||||
dispatch (Left e) = Left e
|
||||
dispatch (Right (Just b)) = Right b
|
||||
dispatch (Right Nothing) = unknown
|
||||
unknown = Left $ "unable to check " ++ Git.repoDescribe r
|
||||
where
|
||||
checkhttp headers = liftIO $ go undefined $ keyUrls r key
|
||||
where
|
||||
go e [] = return $ Left e
|
||||
go _ (u:us) = do
|
||||
res <- catchMsgIO $
|
||||
Url.check u headers (keySize key)
|
||||
case res of
|
||||
Left e -> go e us
|
||||
v -> return v
|
||||
checkremote = do
|
||||
showAction $ "checking " ++ Git.repoDescribe r
|
||||
onRemote r (check, unknown) "inannex" [Param (key2file key)] []
|
||||
where
|
||||
check c p = dispatch <$> safeSystem c p
|
||||
dispatch ExitSuccess = Right True
|
||||
dispatch (ExitFailure 1) = Right False
|
||||
dispatch _ = unknown
|
||||
checklocal = guardUsable r unknown $ dispatch <$> check
|
||||
where
|
||||
check = liftIO $ catchMsgIO $ onLocal r $
|
||||
Annex.Content.inAnnexSafe key
|
||||
dispatch (Left e) = Left e
|
||||
dispatch (Right (Just b)) = Right b
|
||||
dispatch (Right Nothing) = unknown
|
||||
unknown = Left $ "unable to check " ++ Git.repoDescribe r
|
||||
|
||||
{- Runs an action on a local repository inexpensively, by making an annex
|
||||
- monad using that repository. -}
|
||||
|
|
@ -233,8 +232,8 @@ onLocal r a = do
|
|||
|
||||
keyUrls :: Git.Repo -> Key -> [String]
|
||||
keyUrls r key = map tourl (annexLocations key)
|
||||
where
|
||||
tourl l = Git.repoLocation r ++ "/" ++ l
|
||||
where
|
||||
tourl l = Git.repoLocation r ++ "/" ++ l
|
||||
|
||||
dropKey :: Git.Repo -> Key -> Annex Bool
|
||||
dropKey r key
|
||||
|
|
@ -271,44 +270,44 @@ copyFromRemote r key file dest
|
|||
=<< rsyncParamsRemote r True key dest file
|
||||
| Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
|
||||
| otherwise = error "copying from non-ssh, non-http repo not supported"
|
||||
where
|
||||
{- Feed local rsync's progress info back to the remote,
|
||||
- by forking a feeder thread that runs
|
||||
- git-annex-shell transferinfo at the same time
|
||||
- git-annex-shell sendkey is running.
|
||||
-
|
||||
- Note that it actually waits for rsync to indicate
|
||||
- progress before starting transferinfo, in order
|
||||
- to ensure ssh connection caching works and reuses
|
||||
- the connection set up for the sendkey.
|
||||
-
|
||||
- Also note that older git-annex-shell does not support
|
||||
- transferinfo, so stderr is dropped and failure ignored.
|
||||
-}
|
||||
feedprogressback a = do
|
||||
u <- getUUID
|
||||
let fields = (Fields.remoteUUID, fromUUID u)
|
||||
: maybe [] (\f -> [(Fields.associatedFile, f)]) file
|
||||
Just (cmd, params) <- git_annex_shell r "transferinfo"
|
||||
[Param $ key2file key] fields
|
||||
v <- liftIO $ newEmptySV
|
||||
tid <- liftIO $ forkIO $ void $ tryIO $ do
|
||||
bytes <- readSV v
|
||||
p <- createProcess $
|
||||
(proc cmd (toCommand params))
|
||||
{ std_in = CreatePipe
|
||||
, std_err = CreatePipe
|
||||
}
|
||||
hClose $ stderrHandle p
|
||||
let h = stdinHandle p
|
||||
let send b = do
|
||||
hPutStrLn h $ show b
|
||||
hFlush h
|
||||
send bytes
|
||||
forever $
|
||||
send =<< readSV v
|
||||
let feeder = writeSV v
|
||||
bracketIO noop (const $ tryIO $ killThread tid) (a feeder)
|
||||
where
|
||||
{- Feed local rsync's progress info back to the remote,
|
||||
- by forking a feeder thread that runs
|
||||
- git-annex-shell transferinfo at the same time
|
||||
- git-annex-shell sendkey is running.
|
||||
-
|
||||
- Note that it actually waits for rsync to indicate
|
||||
- progress before starting transferinfo, in order
|
||||
- to ensure ssh connection caching works and reuses
|
||||
- the connection set up for the sendkey.
|
||||
-
|
||||
- Also note that older git-annex-shell does not support
|
||||
- transferinfo, so stderr is dropped and failure ignored.
|
||||
-}
|
||||
feedprogressback a = do
|
||||
u <- getUUID
|
||||
let fields = (Fields.remoteUUID, fromUUID u)
|
||||
: maybe [] (\f -> [(Fields.associatedFile, f)]) file
|
||||
Just (cmd, params) <- git_annex_shell r "transferinfo"
|
||||
[Param $ key2file key] fields
|
||||
v <- liftIO $ newEmptySV
|
||||
tid <- liftIO $ forkIO $ void $ tryIO $ do
|
||||
bytes <- readSV v
|
||||
p <- createProcess $
|
||||
(proc cmd (toCommand params))
|
||||
{ std_in = CreatePipe
|
||||
, std_err = CreatePipe
|
||||
}
|
||||
hClose $ stderrHandle p
|
||||
let h = stdinHandle p
|
||||
let send b = do
|
||||
hPutStrLn h $ show b
|
||||
hFlush h
|
||||
send bytes
|
||||
forever $
|
||||
send =<< readSV v
|
||||
let feeder = writeSV v
|
||||
bracketIO noop (const $ tryIO $ killThread tid) (a feeder)
|
||||
|
||||
copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool
|
||||
copyFromRemoteCheap r key file
|
||||
|
|
@ -359,26 +358,26 @@ rsyncHelper callback params = do
|
|||
rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool
|
||||
rsyncOrCopyFile rsyncparams src dest p =
|
||||
ifM (sameDeviceIds src dest) (docopy, dorsync)
|
||||
where
|
||||
sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b)
|
||||
getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)
|
||||
dorsync = rsyncHelper (Just p) $
|
||||
rsyncparams ++ [Param src, Param dest]
|
||||
docopy = liftIO $ bracket
|
||||
(forkIO $ watchfilesize 0)
|
||||
(void . tryIO . killThread)
|
||||
(const $ copyFileExternal src dest)
|
||||
watchfilesize oldsz = do
|
||||
threadDelay 500000 -- 0.5 seconds
|
||||
v <- catchMaybeIO $
|
||||
fromIntegral . fileSize
|
||||
<$> getFileStatus dest
|
||||
case v of
|
||||
Just sz
|
||||
| sz /= oldsz -> do
|
||||
p sz
|
||||
watchfilesize sz
|
||||
_ -> watchfilesize oldsz
|
||||
where
|
||||
sameDeviceIds a b = (==) <$> (getDeviceId a) <*> (getDeviceId b)
|
||||
getDeviceId f = deviceID <$> liftIO (getFileStatus $ parentDir f)
|
||||
dorsync = rsyncHelper (Just p) $
|
||||
rsyncparams ++ [Param src, Param dest]
|
||||
docopy = liftIO $ bracket
|
||||
(forkIO $ watchfilesize 0)
|
||||
(void . tryIO . killThread)
|
||||
(const $ copyFileExternal src dest)
|
||||
watchfilesize oldsz = do
|
||||
threadDelay 500000 -- 0.5 seconds
|
||||
v <- catchMaybeIO $
|
||||
fromIntegral . fileSize
|
||||
<$> getFileStatus dest
|
||||
case v of
|
||||
Just sz
|
||||
| sz /= oldsz -> do
|
||||
p sz
|
||||
watchfilesize sz
|
||||
_ -> watchfilesize oldsz
|
||||
|
||||
{- Generates rsync parameters that ssh to the remote and asks it
|
||||
- to either receive or send the key's content. -}
|
||||
|
|
@ -397,44 +396,43 @@ rsyncParamsRemote r sending key file afile = do
|
|||
if sending
|
||||
then return $ o ++ rsyncopts eparam dummy (File file)
|
||||
else return $ o ++ rsyncopts eparam (File file) dummy
|
||||
where
|
||||
rsyncopts ps source dest
|
||||
| end ps == [dashdash] = ps ++ [source, dest]
|
||||
| otherwise = ps ++ [dashdash, source, dest]
|
||||
dashdash = Param "--"
|
||||
-- The rsync shell parameter controls where rsync
|
||||
-- goes, so the source/dest parameter can be a dummy value,
|
||||
-- that just enables remote rsync mode.
|
||||
-- For maximum compatability with some patched rsyncs,
|
||||
-- the dummy value needs to still contain a hostname,
|
||||
-- even though this hostname will never be used.
|
||||
dummy = Param "dummy:"
|
||||
where
|
||||
rsyncopts ps source dest
|
||||
| end ps == [dashdash] = ps ++ [source, dest]
|
||||
| otherwise = ps ++ [dashdash, source, dest]
|
||||
dashdash = Param "--"
|
||||
{- The rsync shell parameter controls where rsync
|
||||
- goes, so the source/dest parameter can be a dummy value,
|
||||
- that just enables remote rsync mode.
|
||||
- For maximum compatability with some patched rsyncs,
|
||||
- the dummy value needs to still contain a hostname,
|
||||
- even though this hostname will never be used. -}
|
||||
dummy = Param "dummy:"
|
||||
|
||||
rsyncParams :: Git.Repo -> Annex [CommandParam]
|
||||
rsyncParams r = do
|
||||
o <- getRemoteConfig r "rsync-options" ""
|
||||
return $ options ++ map Param (words o)
|
||||
where
|
||||
-- --inplace to resume partial files
|
||||
options = [Params "-p --progress --inplace"]
|
||||
where
|
||||
-- --inplace to resume partial files
|
||||
options = [Params "-p --progress --inplace"]
|
||||
|
||||
commitOnCleanup :: Git.Repo -> Annex a -> Annex a
|
||||
commitOnCleanup r a = go `after` a
|
||||
where
|
||||
go = Annex.addCleanup (Git.repoLocation r) cleanup
|
||||
cleanup
|
||||
| not $ Git.repoIsUrl r = liftIO $ onLocal r $
|
||||
doQuietSideAction $
|
||||
Annex.Branch.commit "update"
|
||||
| otherwise = void $ do
|
||||
Just (shellcmd, shellparams) <-
|
||||
git_annex_shell r "commit" [] []
|
||||
|
||||
-- Throw away stderr, since the remote may not
|
||||
-- have a new enough git-annex shell to
|
||||
-- support committing.
|
||||
liftIO $ catchMaybeIO $ do
|
||||
print "!!!!!!!!!!!!!"
|
||||
withQuietOutput createProcessSuccess $
|
||||
proc shellcmd $
|
||||
toCommand shellparams
|
||||
where
|
||||
go = Annex.addCleanup (Git.repoLocation r) cleanup
|
||||
cleanup
|
||||
| not $ Git.repoIsUrl r = liftIO $ onLocal r $
|
||||
doQuietSideAction $
|
||||
Annex.Branch.commit "update"
|
||||
| otherwise = void $ do
|
||||
Just (shellcmd, shellparams) <-
|
||||
git_annex_shell r "commit" [] []
|
||||
|
||||
-- Throw away stderr, since the remote may not
|
||||
-- have a new enough git-annex shell to
|
||||
-- support committing.
|
||||
liftIO $ catchMaybeIO $ do
|
||||
withQuietOutput createProcessSuccess $
|
||||
proc shellcmd $
|
||||
toCommand shellparams
|
||||
|
|
|
|||
86
doc/coding_style.mdwn
Normal file
86
doc/coding_style.mdwn
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
If you do nothing else, avoid use of partial functions from the Prelude!
|
||||
`import Utility.PartialPrelude` helps avoid this by defining conflicting
|
||||
functions for all the common ones. Also avoid `!!`, it's partial too.
|
||||
|
||||
Use tabs for indentation. The one exception to this rule are
|
||||
the Hamlet format files in `templates/*`. Hamlet, infuriatingly, refuses
|
||||
to allow tabs to be used for indentation.
|
||||
|
||||
Code should make sense with any tab stop setting, but 8 space tabs are
|
||||
the default. With 8 space tabs, code should not exceed 80 characters
|
||||
per line. (With larger tabs, it may of course.)
|
||||
|
||||
Use spaces for layout. For example, here spaces (indicated with `.`
|
||||
are used after the initial tab to make the third test line up with
|
||||
the others.
|
||||
|
||||
when (foo_test || bar_test ||
|
||||
......some_other_long_test)
|
||||
print "hi"
|
||||
|
||||
As a special Haskell-specific rule, "where" clauses are indented with two
|
||||
spaces, rather than a tab. This makes them stand out from the main body
|
||||
of the function, and avoids excessive indentation of the where cause content.
|
||||
The definitions within the where clause should be put on separate lines,
|
||||
each indented with a tab.
|
||||
|
||||
foo = do
|
||||
foo
|
||||
bar
|
||||
foo
|
||||
where
|
||||
foo = ...
|
||||
bar = ...
|
||||
|
||||
Where clauses for instance definitions and modules tend to appear at the end
|
||||
of a line, rather than on a separate line.
|
||||
|
||||
instance MonadBaseControl IO Annex where
|
||||
|
||||
When a function's type signature needs to be wrapped to another line,
|
||||
it's typical to switch to displaying one parameter per line.
|
||||
|
||||
foo :: Bar -> Baz -> (Bar -> Baz) -> IO Baz
|
||||
|
||||
foo'
|
||||
:: Bar
|
||||
-> Baz
|
||||
-> (Bar -> Baz)
|
||||
-> IO Baz
|
||||
|
||||
Note that the "::" then starts its own line. It is not put on the same
|
||||
line as the function name because then it would not be guaranteed to line
|
||||
up with the "->" at all tab width settings. Similarly, guards are put
|
||||
on their own lines:
|
||||
|
||||
splat i
|
||||
| odd i = error "splat!"
|
||||
| otherwise = i
|
||||
|
||||
Multiline lists and record syntax are written with leading commas,
|
||||
that line up with the open and close punctuation.
|
||||
|
||||
list =
|
||||
[ item1
|
||||
, item2
|
||||
, item3
|
||||
]
|
||||
|
||||
foo = DataStructure
|
||||
{ name = "bar"
|
||||
, address = "baz"
|
||||
}
|
||||
|
||||
Module imports are separated into two blocks, one for third-party modules,
|
||||
and one for modules that are part of git-annex. (Additional blocks can be used
|
||||
if it makes sense.)
|
||||
|
||||
Using tabs for indentation makes use of `let .. in` particularly tricky.
|
||||
There's no really good way to bind multiple names in a let clause with
|
||||
tab indentation. Instead, a where clause is typically used. To bind a single
|
||||
name in a let clause, this is sometimes used:
|
||||
|
||||
foo = let x = 42
|
||||
in x + (x-1) + x
|
||||
|
||||
(Of course, monadic let binding are no problem.)
|
||||
|
|
@ -33,3 +33,8 @@ The git repository has some branches:
|
|||
* `setup` contains configuration for this website
|
||||
* `pristine-tar` contains [pristine-tar](http://kitenet.net/~joey/code/pristine-tar)
|
||||
data to create tarballs of any past git-annex release.
|
||||
|
||||
----
|
||||
|
||||
Developing git-annex? Patches are very welcome.
|
||||
You should read [[coding_style]].
|
||||
|
|
|
|||
Loading…
Reference in a new issue