Merge branch 'master' into s3-aws
Conflicts: git-annex.cabal
This commit is contained in:
commit
ef01ff1e77
128 changed files with 1219 additions and 511 deletions
|
@ -72,6 +72,7 @@ gen r u c gc = do
|
|||
, remotetype = remote
|
||||
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
|
||||
, readonly = False
|
||||
, mkUnavailable = return Nothing
|
||||
}
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ store this buprepo)
|
||||
|
|
|
@ -69,6 +69,7 @@ gen r u c gc = do
|
|||
, remotetype = remote
|
||||
, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
|
||||
, readonly = False
|
||||
, mkUnavailable = return Nothing
|
||||
}
|
||||
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
|
|
|
@ -65,7 +65,9 @@ gen r u c gc = do
|
|||
localpath = Just dir,
|
||||
readonly = False,
|
||||
availability = LocallyAvailable,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u c $
|
||||
gc { remoteAnnexDirectory = Just "/dev/null" }
|
||||
}
|
||||
where
|
||||
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
|
||||
|
@ -196,5 +198,8 @@ checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
|
|||
checkKey d _ k = liftIO $
|
||||
ifM (anyM doesFileExist (locations d k))
|
||||
( return True
|
||||
, error $ "directory " ++ d ++ " is not accessible"
|
||||
, ifM (doesDirectoryExist d)
|
||||
( return False
|
||||
, error $ "directory " ++ d ++ " is not accessible"
|
||||
)
|
||||
)
|
||||
|
|
|
@ -65,7 +65,9 @@ gen r u c gc = do
|
|||
gitconfig = gc,
|
||||
readonly = False,
|
||||
availability = avail,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u c $
|
||||
gc { remoteAnnexExternalType = Just "!dne!" }
|
||||
}
|
||||
where
|
||||
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
|
||||
|
|
|
@ -120,6 +120,7 @@ gen' r u c gc = do
|
|||
, readonly = Git.repoIsHttp r
|
||||
, availability = availabilityCalc r
|
||||
, remotetype = remote
|
||||
, mkUnavailable = return Nothing
|
||||
}
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ store this rsyncopts)
|
||||
|
@ -255,7 +256,7 @@ setupRepo gcryptid r
|
|||
|
||||
{- Ask git-annex-shell to configure the repository as a gcrypt
|
||||
- repository. May fail if it is too old. -}
|
||||
gitannexshellsetup = Ssh.onRemote r (boolSystem, False)
|
||||
gitannexshellsetup = Ssh.onRemote r (boolSystem, return False)
|
||||
"gcryptsetup" [ Param gcryptid ] []
|
||||
|
||||
denyNonFastForwards = "receive.denyNonFastForwards"
|
||||
|
@ -389,7 +390,7 @@ getGCryptId fast r
|
|||
| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$>
|
||||
liftIO (catchMaybeIO $ Git.Config.read r)
|
||||
| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)
|
||||
[ Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []
|
||||
[ Ssh.onRemote r (Git.Config.fromPipe r, return (Left undefined)) "configlist" [] []
|
||||
, getConfigViaRsync r
|
||||
]
|
||||
| otherwise = return (Nothing, r)
|
||||
|
|
|
@ -55,6 +55,7 @@ import Creds
|
|||
import Control.Concurrent
|
||||
import Control.Concurrent.MSampleVar
|
||||
import qualified Data.Map as M
|
||||
import Network.URI
|
||||
|
||||
remote :: RemoteType
|
||||
remote = RemoteType {
|
||||
|
@ -156,8 +157,22 @@ gen r u c gc
|
|||
, readonly = Git.repoIsHttp r
|
||||
, availability = availabilityCalc r
|
||||
, remotetype = remote
|
||||
, mkUnavailable = unavailable r u c gc
|
||||
}
|
||||
|
||||
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||
unavailable r u c gc = gen r' u c gc
|
||||
where
|
||||
r' = case Git.location r of
|
||||
Git.Local { Git.gitdir = d } ->
|
||||
r { Git.location = Git.LocalUnknown d }
|
||||
Git.Url url -> case uriAuthority url of
|
||||
Just auth ->
|
||||
let auth' = auth { uriRegName = "!dne!" }
|
||||
in r { Git.location = Git.Url (url { uriAuthority = Just auth' })}
|
||||
Nothing -> r { Git.location = Git.Unknown }
|
||||
_ -> r -- already unavailable
|
||||
|
||||
{- Checks relatively inexpensively if a repository is available for use. -}
|
||||
repoAvail :: Git.Repo -> Annex Bool
|
||||
repoAvail r
|
||||
|
@ -180,7 +195,7 @@ tryGitConfigRead :: Git.Repo -> Annex Git.Repo
|
|||
tryGitConfigRead r
|
||||
| haveconfig r = return r -- already read
|
||||
| Git.repoIsSsh r = store $ do
|
||||
v <- Ssh.onRemote r (pipedconfig, Left undefined) "configlist" [] []
|
||||
v <- Ssh.onRemote r (pipedconfig, return (Left undefined)) "configlist" [] []
|
||||
case v of
|
||||
Right r'
|
||||
| haveconfig r' -> return r'
|
||||
|
@ -298,8 +313,8 @@ inAnnex rmt key
|
|||
)
|
||||
checkremote = Ssh.inAnnex r key
|
||||
checklocal = guardUsable r (cantCheck r) $
|
||||
fromMaybe (cantCheck r)
|
||||
<$> onLocal rmt (Annex.Content.inAnnexSafe key)
|
||||
maybe (cantCheck r) return
|
||||
=<< onLocal rmt (Annex.Content.inAnnexSafe key)
|
||||
|
||||
keyUrls :: Remote -> Key -> [String]
|
||||
keyUrls r key = map tourl locs'
|
||||
|
|
|
@ -65,7 +65,8 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
|||
localpath = Nothing,
|
||||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = return Nothing
|
||||
}
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- Disabled until jobList gets support for chunks.
|
||||
|
|
|
@ -348,11 +348,12 @@ checkPresentChunks checker u chunkconfig encryptor basek
|
|||
v <- check basek
|
||||
case v of
|
||||
Right True -> return True
|
||||
Left e -> checklists (Just e) =<< chunkKeysOnly u basek
|
||||
_ -> checklists Nothing =<< chunkKeysOnly u basek
|
||||
| otherwise = checklists Nothing =<< chunkKeys u chunkconfig basek
|
||||
where
|
||||
checklists Nothing [] = return False
|
||||
checklists (Just deferrederror) [] = error deferrederror
|
||||
checklists (Just deferrederror) [] = throwM deferrederror
|
||||
checklists d (l:ls)
|
||||
| not (null l) = do
|
||||
v <- checkchunks l
|
||||
|
@ -362,14 +363,14 @@ checkPresentChunks checker u chunkconfig encryptor basek
|
|||
Right False -> checklists Nothing ls
|
||||
| otherwise = checklists d ls
|
||||
|
||||
checkchunks :: [Key] -> Annex (Either String Bool)
|
||||
checkchunks :: [Key] -> Annex (Either SomeException Bool)
|
||||
checkchunks [] = return (Right True)
|
||||
checkchunks (k:ks) = do
|
||||
v <- check k
|
||||
case v of
|
||||
Right True -> checkchunks ks
|
||||
Right False -> return $ Right False
|
||||
Left e -> return $ Left $ show e
|
||||
Left e -> return $ Left e
|
||||
|
||||
check = tryNonAsync . checker . encryptor
|
||||
|
||||
|
|
|
@ -71,18 +71,21 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
|
|||
{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
|
||||
- state. -}
|
||||
remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
|
||||
remoteCipher c = go $ extractCipher c
|
||||
remoteCipher = fmap fst <$$> remoteCipher'
|
||||
|
||||
remoteCipher' :: RemoteConfig -> Annex (Maybe (Cipher, StorableCipher))
|
||||
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
|
||||
Just cipher -> return $ Just (cipher, encipher)
|
||||
Nothing -> do
|
||||
showNote "gpg"
|
||||
cipher <- liftIO $ decryptCipher encipher
|
||||
Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache })
|
||||
return $ Just cipher
|
||||
return $ Just (cipher, encipher)
|
||||
|
||||
{- Checks if the remote's config allows storing creds in the remote's config.
|
||||
-
|
||||
|
|
|
@ -69,7 +69,7 @@ git_annex_shell r command params fields
|
|||
- a specified error value. -}
|
||||
onRemote
|
||||
:: Git.Repo
|
||||
-> (FilePath -> [CommandParam] -> IO a, a)
|
||||
-> (FilePath -> [CommandParam] -> IO a, Annex a)
|
||||
-> String
|
||||
-> [CommandParam]
|
||||
-> [(Field, String)]
|
||||
|
@ -78,7 +78,7 @@ onRemote r (with, errorval) command params fields = do
|
|||
s <- git_annex_shell r command params fields
|
||||
case s of
|
||||
Just (c, ps) -> liftIO $ with c ps
|
||||
Nothing -> return errorval
|
||||
Nothing -> errorval
|
||||
|
||||
{- Checks if a remote contains a key. -}
|
||||
inAnnex :: Git.Repo -> Key -> Annex Bool
|
||||
|
@ -86,14 +86,14 @@ inAnnex r k = do
|
|||
showChecking r
|
||||
onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] []
|
||||
where
|
||||
check c p = dispatch <$> safeSystem c p
|
||||
dispatch ExitSuccess = True
|
||||
dispatch (ExitFailure 1) = False
|
||||
check c p = dispatch =<< safeSystem c p
|
||||
dispatch ExitSuccess = return True
|
||||
dispatch (ExitFailure 1) = return False
|
||||
dispatch _ = cantCheck r
|
||||
|
||||
{- Removes a key from a remote. -}
|
||||
dropKey :: Git.Repo -> Key -> Annex Bool
|
||||
dropKey r key = onRemote r (boolSystem, False) "dropkey"
|
||||
dropKey r key = onRemote r (boolSystem, return False) "dropkey"
|
||||
[ Params "--quiet --force"
|
||||
, Param $ key2file key
|
||||
]
|
||||
|
|
|
@ -58,7 +58,9 @@ gen r u c gc = do
|
|||
gitconfig = gc,
|
||||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u c $
|
||||
gc { remoteAnnexHookType = Just "!dne!" }
|
||||
}
|
||||
where
|
||||
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
|
||||
|
|
|
@ -82,6 +82,7 @@ gen r u c gc = do
|
|||
, readonly = False
|
||||
, availability = if islocal then LocallyAvailable else GloballyAvailable
|
||||
, remotetype = remote
|
||||
, mkUnavailable = return Nothing
|
||||
}
|
||||
where
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
|
|
|
@ -82,7 +82,8 @@ gen r u c gc = do
|
|||
localpath = Nothing,
|
||||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
|
||||
}
|
||||
|
||||
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
|
|
|
@ -83,7 +83,8 @@ gen r u c gc = do
|
|||
localpath = Nothing,
|
||||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = return Nothing
|
||||
}
|
||||
|
||||
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
|
|
|
@ -61,7 +61,8 @@ gen r _ c gc =
|
|||
repo = r,
|
||||
readonly = True,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = return Nothing
|
||||
}
|
||||
|
||||
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
|
||||
|
|
|
@ -70,7 +70,8 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
|||
localpath = Nothing,
|
||||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
|
||||
}
|
||||
chunkconfig = getChunkConfig c
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue