Pass the various gnupg-options configs to gpg in several cases where they were not before.
Removed the instance LensGpgEncParams RemoteConfig because it encouraged code that does not take the RemoteGitConfig into account. RemoteType's setup was changed to take a RemoteGitConfig, although the only place that is able to provide a non-empty one is enableremote, when it's changing an existing remote. This led to several folow-on changes, and got RemoteGitConfig plumbed through.
This commit is contained in:
Joey Hess
parent
16efe45a35
commit
91df4c6b53
24 changed files with 140 additions and 126 deletions
|
|
@ -80,7 +80,7 @@ autoEnable = do
|
|||
case (M.lookup nameKey c, findType c) of
|
||||
(Just name, Right t) -> whenM (canenable u) $ do
|
||||
showSideAction $ "Auto enabling special remote " ++ name
|
||||
res <- tryNonAsync $ setup t (Just u) Nothing c
|
||||
res <- tryNonAsync $ setup t (Just u) Nothing c def
|
||||
case res of
|
||||
Left e -> warning (show e)
|
||||
Right _ -> return ()
|
||||
|
|
|
|||
|
|
@ -101,8 +101,8 @@ setupSpecialRemote' setdesc name remotetype config mcreds (mu, c) = do
|
|||
- assistant, because otherwise GnuPG may block once the entropy
|
||||
- pool is drained, and as of now there's no way to tell the user
|
||||
- to perform IO actions to refill the pool. -}
|
||||
(c', u) <- R.setup remotetype mu mcreds $
|
||||
M.insert "highRandomQuality" "false" $ M.union config c
|
||||
let weakc = M.insert "highRandomQuality" "false" $ M.union config c
|
||||
(c', u) <- R.setup remotetype mu mcreds weakc def
|
||||
configSet u c'
|
||||
when setdesc $
|
||||
whenM (isNothing . M.lookup u <$> uuidMap) $
|
||||
|
|
@ -168,4 +168,4 @@ previouslyUsedCredPair getstorage remotetype criteria =
|
|||
sametype r = R.typename (R.remotetype r) == R.typename remotetype
|
||||
fromstorage r = do
|
||||
let storage = getstorage (R.uuid r)
|
||||
getRemoteCredPair (R.config r) storage
|
||||
getRemoteCredPair (R.config r) (R.gitconfig r) storage
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ postEnableWebDAVR uuid = do
|
|||
let name = fromJust $ M.lookup "name" c
|
||||
let url = fromJust $ M.lookup "url" c
|
||||
mcreds <- liftAnnex $
|
||||
getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
|
||||
getRemoteCredPairFor "webdav" c def (WebDAV.davCreds uuid)
|
||||
case mcreds of
|
||||
Just creds -> webDAVConfigurator $ liftH $
|
||||
makeWebDavRemote enableSpecialRemote name creds M.empty
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@ import qualified Logs.Remote
|
|||
import qualified Types.Remote as R
|
||||
import qualified Annex.SpecialRemote
|
||||
import qualified Remote
|
||||
import qualified Types.Remote as Remote
|
||||
import Logs.UUID
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
|
@ -43,7 +44,8 @@ start (name:ws) = go =<< Annex.SpecialRemote.findExisting name
|
|||
let fullconfig = config `M.union` c
|
||||
t <- either error return (Annex.SpecialRemote.findType fullconfig)
|
||||
showStart "enableremote" name
|
||||
next $ perform t u fullconfig
|
||||
gc <- maybe def Remote.gitconfig <$> Remote.byUUID u
|
||||
next $ perform t u fullconfig gc
|
||||
|
||||
unknownNameError :: String -> Annex a
|
||||
unknownNameError prefix = do
|
||||
|
|
@ -56,9 +58,9 @@ unknownNameError prefix = do
|
|||
descm (M.keys m)
|
||||
error $ prefix ++ "\n" ++ msg
|
||||
|
||||
perform :: RemoteType -> UUID -> R.RemoteConfig -> CommandPerform
|
||||
perform t u c = do
|
||||
(c', u') <- R.setup t (Just u) Nothing c
|
||||
perform :: RemoteType -> UUID -> R.RemoteConfig -> RemoteGitConfig -> CommandPerform
|
||||
perform t u c gc = do
|
||||
(c', u') <- R.setup t (Just u) Nothing c gc
|
||||
next $ cleanup u' c'
|
||||
|
||||
cleanup :: UUID -> R.RemoteConfig -> CommandCleanup
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@ start (name:ws) = ifM (isJust <$> findExisting name)
|
|||
|
||||
perform :: RemoteType -> String -> R.RemoteConfig -> CommandPerform
|
||||
perform t name c = do
|
||||
(c', u) <- R.setup t Nothing Nothing c
|
||||
(c', u) <- R.setup t Nothing Nothing c def
|
||||
next $ cleanup u name c'
|
||||
|
||||
cleanup :: UUID -> String -> R.RemoteConfig -> CommandCleanup
|
||||
|
|
|
|||
38
Creds.hs
38
Creds.hs
|
|
@ -52,33 +52,37 @@ data CredPairStorage = CredPairStorage
|
|||
- cipher. The EncryptionIsSetup phantom type ensures that is the case.
|
||||
-}
|
||||
setRemoteCredPair :: EncryptionIsSetup -> RemoteConfig -> CredPairStorage -> Maybe CredPair -> Annex RemoteConfig
|
||||
setRemoteCredPair encsetup c storage Nothing =
|
||||
maybe (return c) (setRemoteCredPair encsetup c storage . Just)
|
||||
=<< getRemoteCredPair c storage
|
||||
setRemoteCredPair _ c storage (Just creds)
|
||||
| embedCreds c = case credPairRemoteKey storage of
|
||||
Nothing -> localcache
|
||||
Just key -> storeconfig key =<< remoteCipher =<< localcache
|
||||
| otherwise = localcache
|
||||
setRemoteCredPair encsetup c storage mcreds = case mcreds of
|
||||
Nothing -> maybe (return c) (setRemoteCredPair encsetup c storage . Just)
|
||||
=<< getRemoteCredPair c nogitconfig storage
|
||||
Just creds
|
||||
| embedCreds c -> case credPairRemoteKey storage of
|
||||
Nothing -> localcache creds
|
||||
Just key -> storeconfig creds key =<< remoteCipher =<< localcache creds
|
||||
| otherwise -> localcache creds
|
||||
where
|
||||
localcache = do
|
||||
localcache creds = do
|
||||
writeCacheCredPair creds storage
|
||||
return c
|
||||
|
||||
storeconfig key (Just cipher) = do
|
||||
storeconfig creds key (Just cipher) = do
|
||||
cmd <- gpgCmd <$> Annex.getGitConfig
|
||||
s <- liftIO $ encrypt cmd (getGpgEncParams c) cipher
|
||||
s <- liftIO $ encrypt cmd (c, nogitconfig) cipher
|
||||
(feedBytes $ L.pack $ encodeCredPair creds)
|
||||
(readBytes $ return . L.unpack)
|
||||
return $ M.insert key (toB64 s) c
|
||||
storeconfig key Nothing =
|
||||
storeconfig creds key Nothing =
|
||||
return $ M.insert key (toB64 $ encodeCredPair creds) c
|
||||
-- This is used before a remote is set up typically, so
|
||||
-- use a default RemoteGitConfig
|
||||
nogitconfig :: RemoteGitConfig
|
||||
nogitconfig = def
|
||||
|
||||
{- Gets a remote's credpair, from the environment if set, otherwise
|
||||
- from the cache in gitAnnexCredsDir, or failing that, from the
|
||||
- value in RemoteConfig. -}
|
||||
getRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair)
|
||||
getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
|
||||
getRemoteCredPair :: RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
|
||||
getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
|
||||
where
|
||||
fromenv = liftIO $ getEnvCredPair storage
|
||||
fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
|
||||
|
|
@ -94,7 +98,7 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
|
|||
Nothing -> return Nothing
|
||||
fromenccreds enccreds cipher storablecipher = do
|
||||
cmd <- gpgCmd <$> Annex.getGitConfig
|
||||
mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (getGpgDecParams c) cipher
|
||||
mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher
|
||||
(feedBytes $ L.pack $ fromB64 enccreds)
|
||||
(readBytes $ return . L.unpack)
|
||||
case mcreds of
|
||||
|
|
@ -114,8 +118,8 @@ getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
|
|||
return $ Just credpair
|
||||
_ -> error "bad creds"
|
||||
|
||||
getRemoteCredPairFor :: String -> RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair)
|
||||
getRemoteCredPairFor this c storage = go =<< getRemoteCredPair c storage
|
||||
getRemoteCredPairFor :: String -> RemoteConfig -> RemoteGitConfig -> CredPairStorage -> Annex (Maybe CredPair)
|
||||
getRemoteCredPairFor this c gc storage = go =<< getRemoteCredPair c gc storage
|
||||
where
|
||||
go Nothing = do
|
||||
warnMissingCredPairFor this storage
|
||||
|
|
|
|||
41
Crypto.hs
41
Crypto.hs
|
|
@ -28,8 +28,7 @@ module Crypto (
|
|||
readBytes,
|
||||
encrypt,
|
||||
decrypt,
|
||||
getGpgEncParams,
|
||||
getGpgDecParams,
|
||||
LensGpgEncParams(..),
|
||||
|
||||
prop_HmacSha1WithCipher_sane
|
||||
) where
|
||||
|
|
@ -179,24 +178,24 @@ readBytes a h = liftIO (L.hGetContents h) >>= a
|
|||
{- Runs a Feeder action, that generates content that is symmetrically
|
||||
- encrypted with the Cipher (unless it is empty, in which case
|
||||
- public-key encryption is used) using the given gpg options, and then
|
||||
- read by the Reader action. Note: For public-key encryption,
|
||||
- recipients MUST be included in 'params' (for instance using
|
||||
- 'getGpgEncParams'). -}
|
||||
encrypt :: (MonadIO m, MonadMask m) => Gpg.GpgCmd -> [CommandParam] -> Cipher -> Feeder -> Reader m a -> m a
|
||||
encrypt cmd params cipher = case cipher of
|
||||
- read by the Reader action. -}
|
||||
encrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a
|
||||
encrypt cmd c cipher = case cipher of
|
||||
Cipher{} -> Gpg.feedRead cmd (params ++ Gpg.stdEncryptionParams True) $
|
||||
cipherPassphrase cipher
|
||||
MacOnlyCipher{} -> Gpg.pipeLazy cmd $ params ++ Gpg.stdEncryptionParams False
|
||||
where
|
||||
params = getGpgEncParams c
|
||||
|
||||
{- Runs a Feeder action, that generates content that is decrypted with the
|
||||
- Cipher (or using a private key if the Cipher is empty), and read by the
|
||||
- Reader action. -}
|
||||
decrypt :: (MonadIO m, MonadMask m) => Gpg.GpgCmd -> [CommandParam] -> Cipher -> Feeder -> Reader m a -> m a
|
||||
decrypt cmd params cipher = case cipher of
|
||||
decrypt :: (MonadIO m, MonadMask m, LensGpgEncParams c) => Gpg.GpgCmd -> c -> Cipher -> Feeder -> Reader m a -> m a
|
||||
decrypt cmd c cipher = case cipher of
|
||||
Cipher{} -> Gpg.feedRead cmd params' $ cipherPassphrase cipher
|
||||
MacOnlyCipher{} -> Gpg.pipeLazy cmd params'
|
||||
where
|
||||
params' = Param "--decrypt" : params
|
||||
params' = Param "--decrypt" : getGpgDecParams c
|
||||
|
||||
macWithCipher :: Mac -> Cipher -> String -> String
|
||||
macWithCipher mac c = macWithCipher' mac (cipherMac c)
|
||||
|
|
@ -218,20 +217,14 @@ class LensGpgEncParams a where
|
|||
{- Extract the GnuPG options from a pair of a Remote Config and a Remote
|
||||
- Git Config. -}
|
||||
instance LensGpgEncParams (RemoteConfig, RemoteGitConfig) where
|
||||
getGpgEncParams (c,gc) = map Param (remoteAnnexGnupgOptions gc) ++ getGpgEncParams c
|
||||
getGpgDecParams (c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc) ++ getGpgDecParams c
|
||||
|
||||
{- Extract the GnuPG options from a Remote Config, ignoring any
|
||||
- git config settings. (Which is ok if the remote is just being set up
|
||||
- and so doesn't have any.) -}
|
||||
instance LensGpgEncParams RemoteConfig where
|
||||
{- If the remote is configured to use public-key encryption,
|
||||
- look up the recipient keys and add them to the option list. -}
|
||||
getGpgEncParams c = case M.lookup "encryption" c of
|
||||
Just "pubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "cipherkeys" c
|
||||
Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "pubkeys" c
|
||||
_ -> []
|
||||
getGpgDecParams _ = []
|
||||
getGpgEncParams (c,gc) = map Param (remoteAnnexGnupgOptions gc) ++
|
||||
{- When the remote is configured to use public-key encryption,
|
||||
- look up the recipient keys and add them to the option list. -}
|
||||
case M.lookup "encryption" c of
|
||||
Just "pubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "cipherkeys" c
|
||||
Just "sharedpubkey" -> Gpg.pkEncTo $ maybe [] (split ",") $ M.lookup "pubkeys" c
|
||||
_ -> []
|
||||
getGpgDecParams (_c,gc) = map Param (remoteAnnexGnupgDecryptOptions gc)
|
||||
|
||||
{- Extract the GnuPG options from a Remote. -}
|
||||
instance LensGpgEncParams (RemoteA a) where
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ module Remote (
|
|||
byNameOrGroup,
|
||||
byNameOnly,
|
||||
byNameWithUUID,
|
||||
byUUID,
|
||||
byCost,
|
||||
prettyPrintUUIDs,
|
||||
prettyPrintUUIDsDescs,
|
||||
|
|
@ -98,6 +99,11 @@ addName desc n
|
|||
| desc == n || null desc = "[" ++ n ++ "]"
|
||||
| otherwise = desc ++ " [" ++ n ++ "]"
|
||||
|
||||
byUUID :: UUID -> Annex (Maybe Remote)
|
||||
byUUID u = headMaybe . filter matching <$> remoteList
|
||||
where
|
||||
matching r = uuid r == u
|
||||
|
||||
{- When a name is specified, looks up the remote matching that name.
|
||||
- (Or it can be a UUID.)
|
||||
-
|
||||
|
|
|
|||
|
|
@ -90,8 +90,8 @@ gen r u c gc = do
|
|||
{ chunkConfig = NoChunks
|
||||
}
|
||||
|
||||
bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
bupSetup mu _ c = do
|
||||
bupSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
bupSetup mu _ c _ = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
|
||||
-- verify configuration is sane
|
||||
|
|
|
|||
|
|
@ -82,8 +82,8 @@ gen r u c gc = do
|
|||
{ chunkConfig = NoChunks
|
||||
}
|
||||
|
||||
ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
ddarSetup mu _ c = do
|
||||
ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
ddarSetup mu _ c _ = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
|
||||
-- verify configuration is sane
|
||||
|
|
|
|||
|
|
@ -77,8 +77,8 @@ gen r u c gc = do
|
|||
where
|
||||
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
|
||||
|
||||
directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
directorySetup mu _ c = do
|
||||
directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
directorySetup mu _ c _ = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
-- verify configuration is sane
|
||||
let dir = fromMaybe (error "Specify directory=") $
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@ gen r u c gc
|
|||
Nothing
|
||||
Nothing
|
||||
| otherwise = do
|
||||
external <- newExternal externaltype u c
|
||||
external <- newExternal externaltype u c gc
|
||||
Annex.addCleanup (RemoteCleanup u) $ stopExternal external
|
||||
cst <- getCost external r gc
|
||||
avail <- getAvailability external r gc
|
||||
|
|
@ -108,8 +108,8 @@ gen r u c gc
|
|||
rmt
|
||||
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
|
||||
|
||||
externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
externalSetup mu _ c = do
|
||||
externalSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
externalSetup mu _ c gc = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
let externaltype = fromMaybe (error "Specify externaltype=") $
|
||||
M.lookup "externaltype" c
|
||||
|
|
@ -120,7 +120,7 @@ externalSetup mu _ c = do
|
|||
setConfig (remoteConfig (fromJust (M.lookup "name" c)) "readonly") (boolConfig True)
|
||||
return c'
|
||||
_ -> do
|
||||
external <- newExternal externaltype u c'
|
||||
external <- newExternal externaltype u c' gc
|
||||
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
|
||||
INITREMOTE_SUCCESS -> Just noop
|
||||
INITREMOTE_FAILURE errmsg -> Just $ error errmsg
|
||||
|
|
@ -246,8 +246,9 @@ handleRequest' lck external req mp responsehandler
|
|||
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
|
||||
handleRemoteRequest (GETCREDS setting) = do
|
||||
c <- liftIO $ atomically $ readTMVar $ externalConfig external
|
||||
gc <- liftIO $ atomically $ readTMVar $ externalGitConfig external
|
||||
creds <- fromMaybe ("", "") <$>
|
||||
getRemoteCredPair c (credstorage setting)
|
||||
getRemoteCredPair c gc (credstorage setting)
|
||||
send $ CREDS (fst creds) (snd creds)
|
||||
handleRemoteRequest GETUUID = send $
|
||||
VALUE $ fromUUID $ externalUUID external
|
||||
|
|
|
|||
7
Remote/External/Types.hs
vendored
7
Remote/External/Types.hs
vendored
|
|
@ -54,15 +54,18 @@ data External = External
|
|||
, externalLock :: TMVar ExternalLock
|
||||
-- Never left empty.
|
||||
, externalConfig :: TMVar RemoteConfig
|
||||
-- Never left empty.
|
||||
, externalGitConfig :: TMVar RemoteGitConfig
|
||||
}
|
||||
|
||||
newExternal :: ExternalType -> UUID -> RemoteConfig -> Annex External
|
||||
newExternal externaltype u c = liftIO $ External
|
||||
newExternal :: ExternalType -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex External
|
||||
newExternal externaltype u c gc = liftIO $ External
|
||||
<$> pure externaltype
|
||||
<*> pure u
|
||||
<*> atomically newEmptyTMVar
|
||||
<*> atomically (newTMVar ExternalLock)
|
||||
<*> atomically (newTMVar c)
|
||||
<*> atomically (newTMVar gc)
|
||||
|
||||
type ExternalType = String
|
||||
|
||||
|
|
|
|||
|
|
@ -169,8 +169,8 @@ noCrypto = error "cannot use gcrypt remote without encryption enabled"
|
|||
unsupportedUrl :: a
|
||||
unsupportedUrl = error "using non-ssh remote repo url with gcrypt is not supported"
|
||||
|
||||
gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
|
||||
gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
gCryptSetup mu _ c _ = go $ M.lookup "gitrepo" c
|
||||
where
|
||||
remotename = fromJust (M.lookup "name" c)
|
||||
go Nothing = error "Specify gitrepo="
|
||||
|
|
|
|||
|
|
@ -93,8 +93,8 @@ list autoinit = do
|
|||
- No attempt is made to make the remote be accessible via ssh key setup,
|
||||
- etc.
|
||||
-}
|
||||
gitSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
gitSetup Nothing _ c = do
|
||||
gitSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
gitSetup Nothing _ c _ = do
|
||||
let location = fromMaybe (error "Specify location=url") $
|
||||
Url.parseURIRelaxed =<< M.lookup "location" c
|
||||
g <- Annex.gitRepo
|
||||
|
|
@ -103,7 +103,7 @@ gitSetup Nothing _ c = do
|
|||
[] -> error "could not find existing git remote with specified location"
|
||||
_ -> error "found multiple git remotes with specified location"
|
||||
return (c, u)
|
||||
gitSetup (Just u) _ c = do
|
||||
gitSetup (Just u) _ c _ = do
|
||||
inRepo $ Git.Command.run
|
||||
[ Param "remote"
|
||||
, Param "add"
|
||||
|
|
|
|||
|
|
@ -78,17 +78,17 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
|||
{ chunkConfig = NoChunks
|
||||
}
|
||||
|
||||
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup mu mcreds c = do
|
||||
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup mu mcreds c gc = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
glacierSetup' (isJust mu) u mcreds c
|
||||
glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup' enabling u mcreds c = do
|
||||
glacierSetup' (isJust mu) u mcreds c gc
|
||||
glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup' enabling u mcreds c gc = do
|
||||
(c', encsetup) <- encryptionSetup c
|
||||
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
unless enabling $
|
||||
genVault fullconfig u
|
||||
genVault fullconfig gc u
|
||||
gitConfigSpecialRemote u fullconfig "glacier" "true"
|
||||
return (fullconfig, u)
|
||||
where
|
||||
|
|
@ -110,9 +110,10 @@ nonEmpty k
|
|||
| otherwise = return True
|
||||
|
||||
store :: Remote -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
|
||||
store r k b p = go =<< glacierEnv c u
|
||||
store r k b p = go =<< glacierEnv c gc u
|
||||
where
|
||||
c = config r
|
||||
gc = gitconfig r
|
||||
u = uuid r
|
||||
params = glacierParams c
|
||||
[ Param "archive"
|
||||
|
|
@ -133,9 +134,10 @@ prepareRetrieve :: Remote -> Preparer Retriever
|
|||
prepareRetrieve = simplyPrepare . byteRetriever . retrieve
|
||||
|
||||
retrieve :: Remote -> Key -> (L.ByteString -> Annex Bool) -> Annex Bool
|
||||
retrieve r k sink = go =<< glacierEnv c u
|
||||
retrieve r k sink = go =<< glacierEnv c gc u
|
||||
where
|
||||
c = config r
|
||||
gc = gitconfig r
|
||||
u = uuid r
|
||||
params = glacierParams c
|
||||
[ Param "archive"
|
||||
|
|
@ -178,7 +180,7 @@ remove r k = glacierAction r
|
|||
checkKey :: Remote -> CheckPresent
|
||||
checkKey r k = do
|
||||
showChecking r
|
||||
go =<< glacierEnv (config r) (uuid r)
|
||||
go =<< glacierEnv (config r) (gitconfig r) (uuid r)
|
||||
where
|
||||
go Nothing = error "cannot check glacier"
|
||||
go (Just e) = do
|
||||
|
|
@ -207,10 +209,10 @@ checkKey r k = do
|
|||
]
|
||||
|
||||
glacierAction :: Remote -> [CommandParam] -> Annex Bool
|
||||
glacierAction r = runGlacier (config r) (uuid r)
|
||||
glacierAction r = runGlacier (config r) (gitconfig r) (uuid r)
|
||||
|
||||
runGlacier :: RemoteConfig -> UUID -> [CommandParam] -> Annex Bool
|
||||
runGlacier c u params = go =<< glacierEnv c u
|
||||
runGlacier :: RemoteConfig -> RemoteGitConfig -> UUID -> [CommandParam] -> Annex Bool
|
||||
runGlacier c gc u params = go =<< glacierEnv c gc u
|
||||
where
|
||||
go Nothing = return False
|
||||
go (Just e) = liftIO $
|
||||
|
|
@ -223,10 +225,10 @@ glacierParams c params = datacenter:params
|
|||
fromMaybe (error "Missing datacenter configuration")
|
||||
(M.lookup "datacenter" c)
|
||||
|
||||
glacierEnv :: RemoteConfig -> UUID -> Annex (Maybe [(String, String)])
|
||||
glacierEnv c u = do
|
||||
glacierEnv :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe [(String, String)])
|
||||
glacierEnv c gc u = do
|
||||
liftIO checkSaneGlacierCommand
|
||||
go =<< getRemoteCredPairFor "glacier" c creds
|
||||
go =<< getRemoteCredPairFor "glacier" c gc creds
|
||||
where
|
||||
go Nothing = return Nothing
|
||||
go (Just (user, pass)) = do
|
||||
|
|
@ -245,8 +247,8 @@ archive r k = fileprefix ++ key2file k
|
|||
where
|
||||
fileprefix = M.findWithDefault "" "fileprefix" $ config r
|
||||
|
||||
genVault :: RemoteConfig -> UUID -> Annex ()
|
||||
genVault c u = unlessM (runGlacier c u params) $
|
||||
genVault :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
|
||||
genVault c gc u = unlessM (runGlacier c gc u params) $
|
||||
error "Failed creating glacier vault."
|
||||
where
|
||||
params =
|
||||
|
|
@ -266,7 +268,7 @@ genVault c u = unlessM (runGlacier c u params) $
|
|||
- not supported.
|
||||
-}
|
||||
jobList :: Remote -> [Key] -> Annex ([Key], [Key])
|
||||
jobList r keys = go =<< glacierEnv (config r) (uuid r)
|
||||
jobList r keys = go =<< glacierEnv (config r) (gitconfig r) (uuid r)
|
||||
where
|
||||
params = [ Param "job", Param "list" ]
|
||||
nada = ([], [])
|
||||
|
|
|
|||
|
|
@ -178,8 +178,6 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
}
|
||||
cip = cipherKey c
|
||||
isencrypted = isJust (extractCipher c)
|
||||
gpgencopts = getGpgEncParams encr
|
||||
gpgdecopts = getGpgDecParams encr
|
||||
|
||||
safely a = catchNonAsync a (\e -> warning (show e) >> return False)
|
||||
|
||||
|
|
@ -201,7 +199,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
storechunk (Just (cipher, enck)) storer k content p = do
|
||||
cmd <- gpgCmd <$> Annex.getGitConfig
|
||||
withBytes content $ \b ->
|
||||
encrypt cmd gpgencopts cipher (feedBytes b) $
|
||||
encrypt cmd encr cipher (feedBytes b) $
|
||||
readBytes $ \encb ->
|
||||
storer (enck k) (ByteContent encb) p
|
||||
|
||||
|
|
@ -211,7 +209,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
where
|
||||
go (Just retriever) = displayprogress p k $ \p' ->
|
||||
retrieveChunks retriever (uuid baser) chunkconfig
|
||||
enck k dest p' (sink dest enc gpgdecopts)
|
||||
enck k dest p' (sink dest enc encr)
|
||||
go Nothing = return False
|
||||
enck = maybe id snd enc
|
||||
|
||||
|
|
@ -244,26 +242,27 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
- into place. (And it may even already be in the right place..)
|
||||
-}
|
||||
sink
|
||||
:: FilePath
|
||||
:: LensGpgEncParams c
|
||||
=> FilePath
|
||||
-> Maybe (Cipher, EncKey)
|
||||
-> [CommandParam]
|
||||
-> c
|
||||
-> Maybe Handle
|
||||
-> Maybe MeterUpdate
|
||||
-> ContentSource
|
||||
-> Annex Bool
|
||||
sink dest enc gpgdecopts mh mp content = do
|
||||
sink dest enc c mh mp content = do
|
||||
case (enc, mh, content) of
|
||||
(Nothing, Nothing, FileContent f)
|
||||
| f == dest -> noop
|
||||
| otherwise -> liftIO $ moveFile f dest
|
||||
(Just (cipher, _), _, ByteContent b) -> do
|
||||
cmd <- gpgCmd <$> Annex.getGitConfig
|
||||
decrypt cmd gpgdecopts cipher (feedBytes b) $
|
||||
decrypt cmd c cipher (feedBytes b) $
|
||||
readBytes write
|
||||
(Just (cipher, _), _, FileContent f) -> do
|
||||
cmd <- gpgCmd <$> Annex.getGitConfig
|
||||
withBytes content $ \b ->
|
||||
decrypt cmd gpgdecopts cipher (feedBytes b) $
|
||||
decrypt cmd c cipher (feedBytes b) $
|
||||
readBytes write
|
||||
liftIO $ nukeFile f
|
||||
(Nothing, _, FileContent f) -> do
|
||||
|
|
|
|||
|
|
@ -70,8 +70,8 @@ gen r u c gc = do
|
|||
where
|
||||
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
|
||||
|
||||
hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
hookSetup mu _ c = do
|
||||
hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
hookSetup mu _ c _ = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
let hooktype = fromMaybe (error "Specify hooktype=") $
|
||||
M.lookup "hooktype" c
|
||||
|
|
|
|||
|
|
@ -137,8 +137,8 @@ rsyncTransport gc url
|
|||
loginopt = maybe [] (\l -> ["-l",l]) login
|
||||
fromNull as xs = if null xs then as else xs
|
||||
|
||||
rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
rsyncSetup mu _ c = do
|
||||
rsyncSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
rsyncSetup mu _ c _ = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
-- verify configuration is sane
|
||||
let url = fromMaybe (error "Specify rsyncurl=") $
|
||||
|
|
|
|||
36
Remote/S3.hs
36
Remote/S3.hs
|
|
@ -99,12 +99,14 @@ gen r u c gc = do
|
|||
, checkUrl = Nothing
|
||||
}
|
||||
|
||||
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
s3Setup mu mcreds c = do
|
||||
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
s3Setup mu mcreds c gc = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
s3Setup' (isNothing mu) u mcreds c
|
||||
s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
|
||||
s3Setup' (isNothing mu) u mcreds c gc
|
||||
s3Setup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
s3Setup' new u mcreds c gc
|
||||
| configIA c = archiveorg
|
||||
| otherwise = defaulthost
|
||||
where
|
||||
remotename = fromJust (M.lookup "name" c)
|
||||
defbucket = remotename ++ "-" ++ fromUUID u
|
||||
|
|
@ -125,7 +127,7 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
|
|||
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
when new $
|
||||
genBucket fullconfig u
|
||||
genBucket fullconfig gc u
|
||||
use fullconfig
|
||||
|
||||
archiveorg = do
|
||||
|
|
@ -146,7 +148,7 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
|
|||
-- special constraints on key names
|
||||
M.insert "mungekeys" "ia" defaults
|
||||
info <- extractS3Info archiveconfig
|
||||
withS3Handle archiveconfig u $
|
||||
withS3Handle archiveconfig gc u $
|
||||
writeUUIDFile archiveconfig u info
|
||||
use archiveconfig
|
||||
|
||||
|
|
@ -154,12 +156,12 @@ s3Setup' new u mcreds c = if configIA c then archiveorg else defaulthost
|
|||
-- http connections to be reused across calls to the helper.
|
||||
prepareS3Handle :: Remote -> (S3Handle -> helper) -> Preparer helper
|
||||
prepareS3Handle r = resourcePrepare $ const $
|
||||
withS3Handle (config r) (uuid r)
|
||||
withS3Handle (config r) (gitconfig r) (uuid r)
|
||||
|
||||
-- Allows for read-only actions, which can be run without a S3Handle.
|
||||
prepareS3HandleMaybe :: Remote -> (Maybe S3Handle -> helper) -> Preparer helper
|
||||
prepareS3HandleMaybe r = resourcePrepare $ const $
|
||||
withS3HandleMaybe (config r) (uuid r)
|
||||
withS3HandleMaybe (config r) (gitconfig r) (uuid r)
|
||||
|
||||
store :: Remote -> S3Info -> S3Handle -> Storer
|
||||
store _r info h = fileStorer $ \k f p -> do
|
||||
|
|
@ -311,11 +313,11 @@ checkKey r info Nothing k = case getpublicurl info of
|
|||
- so first check if the UUID file already exists and we can skip doing
|
||||
- anything.
|
||||
-}
|
||||
genBucket :: RemoteConfig -> UUID -> Annex ()
|
||||
genBucket c u = do
|
||||
genBucket :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex ()
|
||||
genBucket c gc u = do
|
||||
showAction "checking bucket"
|
||||
info <- extractS3Info c
|
||||
withS3Handle c u $ \h ->
|
||||
withS3Handle c gc u $ \h ->
|
||||
go info h =<< checkUUIDFile c u info h
|
||||
where
|
||||
go _ _ (Right True) = noop
|
||||
|
|
@ -408,16 +410,16 @@ sendS3Handle'
|
|||
-> ResourceT IO a
|
||||
sendS3Handle' h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r
|
||||
|
||||
withS3Handle :: RemoteConfig -> UUID -> (S3Handle -> Annex a) -> Annex a
|
||||
withS3Handle c u a = withS3HandleMaybe c u $ \mh -> case mh of
|
||||
withS3Handle :: RemoteConfig -> RemoteGitConfig -> UUID -> (S3Handle -> Annex a) -> Annex a
|
||||
withS3Handle c gc u a = withS3HandleMaybe c gc u $ \mh -> case mh of
|
||||
Just h -> a h
|
||||
Nothing -> do
|
||||
warnMissingCredPairFor "S3" (AWS.creds u)
|
||||
error "No S3 credentials configured"
|
||||
|
||||
withS3HandleMaybe :: RemoteConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a
|
||||
withS3HandleMaybe c u a = do
|
||||
mcreds <- getRemoteCredPair c (AWS.creds u)
|
||||
withS3HandleMaybe :: RemoteConfig -> RemoteGitConfig -> UUID -> (Maybe S3Handle -> Annex a) -> Annex a
|
||||
withS3HandleMaybe c gc u a = do
|
||||
mcreds <- getRemoteCredPair c gc (AWS.creds u)
|
||||
case mcreds of
|
||||
Just creds -> do
|
||||
awscreds <- liftIO $ genCredentials creds
|
||||
|
|
|
|||
|
|
@ -91,8 +91,8 @@ gen r u c gc = do
|
|||
, checkUrl = Nothing
|
||||
}
|
||||
|
||||
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
tahoeSetup mu _ c = do
|
||||
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
tahoeSetup mu _ c _ = do
|
||||
furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)
|
||||
<$> liftIO (getEnv "TAHOE_FURL")
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
|
|
|
|||
|
|
@ -81,14 +81,14 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
|||
}
|
||||
chunkconfig = getChunkConfig c
|
||||
|
||||
webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
webdavSetup mu mcreds c = do
|
||||
webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
||||
webdavSetup mu mcreds c gc = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
url <- case M.lookup "url" c of
|
||||
Nothing -> error "Specify url="
|
||||
Just url -> return url
|
||||
(c', encsetup) <- encryptionSetup c
|
||||
creds <- maybe (getCreds c' u) (return . Just) mcreds
|
||||
creds <- maybe (getCreds c' gc u) (return . Just) mcreds
|
||||
testDav url creds
|
||||
gitConfigSpecialRemote u c' "webdav" "true"
|
||||
c'' <- setRemoteCredPair encsetup c' (davCreds u) creds
|
||||
|
|
@ -234,8 +234,8 @@ mkColRecursive d = go =<< existsDAV d
|
|||
inLocation d mkCol
|
||||
)
|
||||
|
||||
getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair)
|
||||
getCreds c u = getRemoteCredPairFor "webdav" c (davCreds u)
|
||||
getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)
|
||||
getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u)
|
||||
|
||||
davCreds :: UUID -> CredPairStorage
|
||||
davCreds u = CredPairStorage
|
||||
|
|
@ -291,7 +291,7 @@ data DavHandle = DavHandle DAVContext DavUser DavPass URLString
|
|||
|
||||
withDAVHandle :: Remote -> (Maybe DavHandle -> Annex a) -> Annex a
|
||||
withDAVHandle r a = do
|
||||
mcreds <- getCreds (config r) (uuid r)
|
||||
mcreds <- getCreds (config r) (gitconfig r) (uuid r)
|
||||
case (mcreds, configUrl r) of
|
||||
(Just (user, pass), Just baseurl) ->
|
||||
withDAVContext baseurl $ \ctx ->
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ data RemoteTypeA a = RemoteType {
|
|||
-- generates a remote of this type
|
||||
generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)),
|
||||
-- initializes or changes a remote
|
||||
setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> a (RemoteConfig, UUID)
|
||||
setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)
|
||||
}
|
||||
|
||||
instance Eq (RemoteTypeA a) where
|
||||
|
|
|
|||
2
debian/changelog
vendored
2
debian/changelog
vendored
|
|
@ -20,6 +20,8 @@ git-annex (6.20160512) UNRELEASED; urgency=medium
|
|||
* Fix crash when entering/changing view in a subdirectory of a repo that
|
||||
has a dotfile in its root.
|
||||
* Support building with ghc 8.0.1.
|
||||
* Pass the various gnupg-options configs to gpg in several cases where
|
||||
they were not before.
|
||||
|
||||
-- Joey Hess <id@joeyh.name> Wed, 11 May 2016 16:08:38 -0400
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue