Merge branch 'master' into s3-aws
Conflicts: Remote/S3.hs
This commit is contained in:
commit
35551d0ed0
502 changed files with 7127 additions and 2453 deletions
|
@ -73,6 +73,7 @@ gen r u c gc = do
|
|||
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
|
||||
, readonly = False
|
||||
, mkUnavailable = return Nothing
|
||||
, getInfo = return [("repo", buprepo)]
|
||||
}
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ store this buprepo)
|
||||
|
@ -94,7 +95,7 @@ bupSetup mu _ c = do
|
|||
-- verify configuration is sane
|
||||
let buprepo = fromMaybe (error "Specify buprepo=") $
|
||||
M.lookup "buprepo" c
|
||||
c' <- encryptionSetup c
|
||||
(c', _encsetup) <- encryptionSetup c
|
||||
|
||||
-- bup init will create the repository.
|
||||
-- (If the repository already exists, bup init again appears safe.)
|
||||
|
|
|
@ -70,6 +70,7 @@ gen r u c gc = do
|
|||
, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
|
||||
, readonly = False
|
||||
, mkUnavailable = return Nothing
|
||||
, getInfo = return [("repo", ddarrepo)]
|
||||
}
|
||||
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
|
@ -84,7 +85,7 @@ ddarSetup mu _ c = do
|
|||
-- verify configuration is sane
|
||||
let ddarrepo = fromMaybe (error "Specify ddarrepo=") $
|
||||
M.lookup "ddarrepo" c
|
||||
c' <- encryptionSetup c
|
||||
(c', _encsetup) <- encryptionSetup c
|
||||
|
||||
-- The ddarrepo is stored in git config, as well as this repo's
|
||||
-- persistant state, so it can vary between hosts.
|
||||
|
|
|
@ -67,7 +67,8 @@ gen r u c gc = do
|
|||
availability = LocallyAvailable,
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u c $
|
||||
gc { remoteAnnexDirectory = Just "/dev/null" }
|
||||
gc { remoteAnnexDirectory = Just "/dev/null" },
|
||||
getInfo = return [("directory", dir)]
|
||||
}
|
||||
where
|
||||
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
|
||||
|
@ -81,7 +82,7 @@ directorySetup mu _ c = do
|
|||
absdir <- liftIO $ absPath dir
|
||||
liftIO $ unlessM (doesDirectoryExist absdir) $
|
||||
error $ "Directory does not exist: " ++ absdir
|
||||
c' <- encryptionSetup c
|
||||
(c', _encsetup) <- encryptionSetup c
|
||||
|
||||
-- The directory is stored in git config, not in this remote's
|
||||
-- persistant state, so it can vary between hosts.
|
||||
|
|
|
@ -68,6 +68,7 @@ gen r u c gc = do
|
|||
remotetype = remote,
|
||||
mkUnavailable = gen r u c $
|
||||
gc { remoteAnnexExternalType = Just "!dne!" }
|
||||
, getInfo = return [("externaltype", externaltype)]
|
||||
}
|
||||
where
|
||||
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
|
||||
|
@ -77,7 +78,7 @@ externalSetup mu _ c = do
|
|||
u <- maybe (liftIO genUUID) return mu
|
||||
let externaltype = fromMaybe (error "Specify externaltype=") $
|
||||
M.lookup "externaltype" c
|
||||
c' <- encryptionSetup c
|
||||
(c', _encsetup) <- encryptionSetup c
|
||||
|
||||
external <- newExternal externaltype u c'
|
||||
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
|
||||
|
@ -169,7 +170,7 @@ handleRequest' lck external req mp responsehandler
|
|||
go
|
||||
| otherwise = go
|
||||
where
|
||||
go = do
|
||||
go = do
|
||||
sendMessage lck external req
|
||||
loop
|
||||
loop = receiveMessage lck external responsehandler
|
||||
|
@ -191,7 +192,7 @@ handleRequest' lck external req mp responsehandler
|
|||
send $ VALUE value
|
||||
handleRemoteRequest (SETCREDS setting login password) = do
|
||||
c <- liftIO $ atomically $ readTMVar $ externalConfig external
|
||||
c' <- setRemoteCredPair c (credstorage setting) $
|
||||
c' <- setRemoteCredPair encryptionAlreadySetup c (credstorage setting) $
|
||||
Just (login, password)
|
||||
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
|
||||
handleRemoteRequest (GETCREDS setting) = do
|
||||
|
|
|
@ -121,6 +121,7 @@ gen' r u c gc = do
|
|||
, availability = availabilityCalc r
|
||||
, remotetype = remote
|
||||
, mkUnavailable = return Nothing
|
||||
, getInfo = return $ gitRepoInfo r
|
||||
}
|
||||
return $ Just $ specialRemote' specialcfg c
|
||||
(simplyPrepare $ store this rsyncopts)
|
||||
|
@ -147,7 +148,7 @@ rsyncTransport r
|
|||
| ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc
|
||||
| otherwise = othertransport
|
||||
where
|
||||
loc = Git.repoLocation r
|
||||
loc = Git.repoLocation r
|
||||
sshtransport (host, path) = do
|
||||
let rsyncpath = if "/~/" `isPrefixOf` path
|
||||
then drop 3 path
|
||||
|
@ -166,9 +167,9 @@ gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConf
|
|||
gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
|
||||
where
|
||||
remotename = fromJust (M.lookup "name" c)
|
||||
go Nothing = error "Specify gitrepo="
|
||||
go Nothing = error "Specify gitrepo="
|
||||
go (Just gitrepo) = do
|
||||
c' <- encryptionSetup c
|
||||
(c', _encsetup) <- encryptionSetup c
|
||||
inRepo $ Git.Command.run
|
||||
[ Params "remote add"
|
||||
, Param remotename
|
||||
|
@ -234,7 +235,7 @@ setupRepo gcryptid r
|
|||
- create the objectDir on the remote,
|
||||
- which is needed for direct rsync of objects to work.
|
||||
-}
|
||||
rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
|
||||
rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
|
||||
liftIO $ createDirectoryIfMissing True $ tmp </> objectDir
|
||||
(rsynctransport, rsyncurl, _) <- rsyncTransport r
|
||||
let tmpconfig = tmp </> "config"
|
||||
|
@ -266,7 +267,7 @@ isShell r = case method of
|
|||
AccessShell -> True
|
||||
_ -> False
|
||||
where
|
||||
method = toAccessMethod $ fromMaybe "" $
|
||||
method = toAccessMethod $ fromMaybe "" $
|
||||
remoteAnnexGCrypt $ gitconfig r
|
||||
|
||||
shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a
|
||||
|
@ -352,7 +353,7 @@ checkKey r rsyncopts k
|
|||
| Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync
|
||||
| otherwise = unsupportedUrl
|
||||
where
|
||||
checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k
|
||||
checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k
|
||||
checkshell = Ssh.inAnnex (repo r) k
|
||||
|
||||
{- Annexed objects are hashed using lower-case directories for max
|
||||
|
|
|
@ -159,6 +159,7 @@ gen r u c gc
|
|||
, availability = availabilityCalc r
|
||||
, remotetype = remote
|
||||
, mkUnavailable = unavailable r u c gc
|
||||
, getInfo = return $ gitRepoInfo r
|
||||
}
|
||||
|
||||
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
||||
|
@ -305,7 +306,7 @@ inAnnex rmt key
|
|||
| Git.repoIsUrl r = checkremote
|
||||
| otherwise = checklocal
|
||||
where
|
||||
r = repo rmt
|
||||
r = repo rmt
|
||||
checkhttp = do
|
||||
showChecking r
|
||||
ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key))
|
||||
|
|
|
@ -66,7 +66,9 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
|||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote,
|
||||
mkUnavailable = return Nothing
|
||||
mkUnavailable = return Nothing,
|
||||
getInfo = includeCredsInfo c (AWS.creds u) $
|
||||
[ ("glacier vault", getVault c) ]
|
||||
}
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
-- Disabled until jobList gets support for chunks.
|
||||
|
@ -76,12 +78,12 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
|
|||
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup mu mcreds c = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
c' <- setRemoteCredPair c (AWS.creds u) mcreds
|
||||
glacierSetup' (isJust mu) u c'
|
||||
glacierSetup' :: Bool -> UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup' enabling u c = do
|
||||
c' <- encryptionSetup c
|
||||
let fullconfig = c' `M.union` defaults
|
||||
glacierSetup' (isJust mu) u mcreds c
|
||||
glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
glacierSetup' enabling u mcreds c = do
|
||||
(c', encsetup) <- encryptionSetup c
|
||||
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
unless enabling $
|
||||
genVault fullconfig u
|
||||
gitConfigSpecialRemote u fullconfig "glacier" "true"
|
||||
|
@ -141,7 +143,10 @@ retrieve r k sink = go =<< glacierEnv c u
|
|||
]
|
||||
go Nothing = error "cannot retrieve from glacier"
|
||||
go (Just e) = do
|
||||
let cmd = (proc "glacier" (toCommand params)) { env = Just e }
|
||||
let cmd = (proc "glacier" (toCommand params))
|
||||
{ env = Just e
|
||||
, std_out = CreatePipe
|
||||
}
|
||||
(_, Just h, _, pid) <- liftIO $ createProcess cmd
|
||||
-- Glacier cannot store empty files, so if the output is
|
||||
-- empty, the content is not available yet.
|
||||
|
|
|
@ -8,6 +8,7 @@
|
|||
module Remote.Helper.Chunked (
|
||||
ChunkSize,
|
||||
ChunkConfig(..),
|
||||
describeChunkConfig,
|
||||
getChunkConfig,
|
||||
storeChunks,
|
||||
removeChunks,
|
||||
|
@ -34,6 +35,14 @@ data ChunkConfig
|
|||
| LegacyChunks ChunkSize
|
||||
deriving (Show)
|
||||
|
||||
describeChunkConfig :: ChunkConfig -> String
|
||||
describeChunkConfig NoChunks = "none"
|
||||
describeChunkConfig (UnpaddedChunks sz) = describeChunkSize sz ++ "chunks"
|
||||
describeChunkConfig (LegacyChunks sz) = describeChunkSize sz ++ " chunks (old style)"
|
||||
|
||||
describeChunkSize :: ChunkSize -> String
|
||||
describeChunkSize sz = roughSize storageUnits False (fromIntegral sz)
|
||||
|
||||
noChunks :: ChunkConfig -> Bool
|
||||
noChunks NoChunks = True
|
||||
noChunks _ = False
|
||||
|
@ -123,7 +132,7 @@ storeChunks u chunkconfig k f p storer checker =
|
|||
|
||||
loop bytesprocessed (chunk, bs) chunkkeys
|
||||
| L.null chunk && numchunks > 0 = do
|
||||
-- Once all chunks are successfully
|
||||
-- Once all chunks are successfully
|
||||
-- stored, update the chunk log.
|
||||
chunksStored u k (FixedSizeChunks chunksize) numchunks
|
||||
return True
|
||||
|
@ -138,7 +147,7 @@ storeChunks u chunkconfig k f p storer checker =
|
|||
)
|
||||
where
|
||||
numchunks = numChunks chunkkeys
|
||||
{- The MeterUpdate that is passed to the action
|
||||
{- The MeterUpdate that is passed to the action
|
||||
- storing a chunk is offset, so that it reflects
|
||||
- the total bytes that have already been stored
|
||||
- in previous chunks. -}
|
||||
|
@ -290,7 +299,7 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
|
|||
hSeek h AbsoluteSeek startpoint
|
||||
return h
|
||||
|
||||
{- Progress meter updating is a bit tricky: If the Retriever
|
||||
{- Progress meter updating is a bit tricky: If the Retriever
|
||||
- populates a file, it is responsible for updating progress
|
||||
- as the file is being retrieved.
|
||||
-
|
||||
|
|
|
@ -5,7 +5,19 @@
|
|||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Remote.Helper.Encryptable where
|
||||
module Remote.Helper.Encryptable (
|
||||
EncryptionIsSetup,
|
||||
encryptionSetup,
|
||||
noEncryptionUsed,
|
||||
encryptionAlreadySetup,
|
||||
remoteCipher,
|
||||
remoteCipher',
|
||||
embedCreds,
|
||||
cipherKey,
|
||||
storeCipher,
|
||||
extractCipher,
|
||||
describeEncryption,
|
||||
) where
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
|
@ -16,11 +28,26 @@ import Types.Crypto
|
|||
import qualified Annex
|
||||
import Utility.Base64
|
||||
|
||||
-- Used to ensure that encryption has been set up before trying to
|
||||
-- eg, store creds in the remote config that would need to use the
|
||||
-- encryption setup.
|
||||
data EncryptionIsSetup = EncryptionIsSetup | NoEncryption
|
||||
|
||||
-- Remotes that don't use encryption can use this instead of
|
||||
-- encryptionSetup.
|
||||
noEncryptionUsed :: EncryptionIsSetup
|
||||
noEncryptionUsed = NoEncryption
|
||||
|
||||
-- Using this avoids the type-safe check, so you'd better be sure
|
||||
-- of what you're doing.
|
||||
encryptionAlreadySetup :: EncryptionIsSetup
|
||||
encryptionAlreadySetup = EncryptionIsSetup
|
||||
|
||||
{- Encryption setup for a remote. The user must specify whether to use
|
||||
- an encryption key, or not encrypt. An encrypted cipher is created, or is
|
||||
- updated to be accessible to an additional encryption key. Or the user
|
||||
- could opt to use a shared cipher, which is stored unencrypted. -}
|
||||
encryptionSetup :: RemoteConfig -> Annex RemoteConfig
|
||||
encryptionSetup :: RemoteConfig -> Annex (RemoteConfig, EncryptionIsSetup)
|
||||
encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
|
||||
where
|
||||
-- The type of encryption
|
||||
|
@ -28,11 +55,11 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
|
|||
-- Generate a new cipher, depending on the chosen encryption scheme
|
||||
genCipher = case encryption of
|
||||
_ | M.member "cipher" c || M.member "cipherkeys" c -> cannotchange
|
||||
Just "none" -> return c
|
||||
Just "none" -> return (c, NoEncryption)
|
||||
Just "shared" -> use "encryption setup" . genSharedCipher
|
||||
=<< highRandomQuality
|
||||
-- hybrid encryption is the default when a keyid is
|
||||
-- specified but no encryption
|
||||
-- specified but no encryption
|
||||
_ | maybe (M.member "keyid" c) (== "hybrid") encryption ->
|
||||
use "encryption setup" . genEncryptedCipher key Hybrid
|
||||
=<< highRandomQuality
|
||||
|
@ -48,7 +75,7 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
|
|||
cannotchange = error "Cannot set encryption type of existing remotes."
|
||||
-- Update an existing cipher if possible.
|
||||
updateCipher v = case v of
|
||||
SharedCipher _ | maybe True (== "shared") encryption -> return c'
|
||||
SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup)
|
||||
EncryptedCipher _ variant _
|
||||
| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption ->
|
||||
use "encryption update" $ updateEncryptedCipher newkeys v
|
||||
|
@ -57,22 +84,22 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
|
|||
showNote m
|
||||
cipher <- liftIO a
|
||||
showNote $ describeCipher cipher
|
||||
return $ storeCipher c' cipher
|
||||
return (storeCipher c' cipher, EncryptionIsSetup)
|
||||
highRandomQuality =
|
||||
(&&) (maybe True ( /= "false") $ M.lookup "highRandomQuality" c)
|
||||
<$> fmap not (Annex.getState Annex.fast)
|
||||
c' = foldr M.delete c
|
||||
-- git-annex used to remove 'encryption' as well, since
|
||||
-- it was redundant; we now need to keep it for
|
||||
-- public-key encryption, hence we leave it on newer
|
||||
-- remotes (while being backward-compatible).
|
||||
-- git-annex used to remove 'encryption' as well, since
|
||||
-- it was redundant; we now need to keep it for
|
||||
-- public-key encryption, hence we leave it on newer
|
||||
-- remotes (while being backward-compatible).
|
||||
[ "keyid", "keyid+", "keyid-", "highRandomQuality" ]
|
||||
|
||||
{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
|
||||
- state. -}
|
||||
remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
|
||||
remoteCipher = fmap fst <$$> remoteCipher'
|
||||
|
||||
{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
|
||||
- state. -}
|
||||
remoteCipher' :: RemoteConfig -> Annex (Maybe (Cipher, StorableCipher))
|
||||
remoteCipher' c = go $ extractCipher c
|
||||
where
|
||||
|
@ -131,3 +158,15 @@ extractCipher c = case (M.lookup "cipher" c,
|
|||
_ -> Nothing
|
||||
where
|
||||
readkeys = KeyIds . split ","
|
||||
|
||||
describeEncryption :: RemoteConfig -> String
|
||||
describeEncryption c = case extractCipher c of
|
||||
Nothing -> "not encrypted"
|
||||
(Just (SharedCipher _)) -> "encrypted (encryption key stored in git repository)"
|
||||
(Just (EncryptedCipher _ v (KeyIds { keyIds = ks }))) -> unwords $ catMaybes
|
||||
[ Just "encrypted (to gpg keys:"
|
||||
, Just (unwords ks ++ ")")
|
||||
, case v of
|
||||
PubKey -> Nothing
|
||||
Hybrid -> Just "(hybrid mode)"
|
||||
]
|
||||
|
|
|
@ -30,3 +30,8 @@ guardUsable :: Git.Repo -> Annex a -> Annex a -> Annex a
|
|||
guardUsable r fallback a
|
||||
| Git.repoIsLocalUnknown r = fallback
|
||||
| otherwise = a
|
||||
|
||||
gitRepoInfo :: Git.Repo -> [(String, String)]
|
||||
gitRepoInfo r =
|
||||
[ ("repository location", Git.repoLocation r)
|
||||
]
|
||||
|
|
|
@ -87,7 +87,7 @@ checkPrepare checker helper k a = ifM (checker k)
|
|||
-- Use to acquire a resource when preparing a helper.
|
||||
resourcePrepare :: (Key -> (r -> Annex Bool) -> Annex Bool) -> (r -> helper) -> Preparer helper
|
||||
resourcePrepare withr helper k a = withr k $ \r ->
|
||||
a (Just (helper r))
|
||||
a (Just (helper r))
|
||||
|
||||
-- A Storer that expects to be provided with a file containing
|
||||
-- the content of the key to store.
|
||||
|
@ -168,6 +168,12 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
(cost baser)
|
||||
(const $ cost baser + encryptedRemoteCostAdj)
|
||||
(extractCipher c)
|
||||
, getInfo = do
|
||||
l <- getInfo baser
|
||||
return $ l ++
|
||||
[ ("encryption", describeEncryption c)
|
||||
, ("chunking", describeChunkConfig (chunkConfig cfg))
|
||||
]
|
||||
}
|
||||
cip = cipherKey c
|
||||
gpgopts = getGpgEncParams encr
|
||||
|
@ -196,7 +202,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
retrieveKeyFileGen k dest p enc =
|
||||
safely $ prepareretriever k $ safely . go
|
||||
where
|
||||
go (Just retriever) = displayprogress p k $ \p' ->
|
||||
go (Just retriever) = displayprogress p k $ \p' ->
|
||||
retrieveChunks retriever (uuid baser) chunkconfig
|
||||
enck k dest p' (sink dest enc)
|
||||
go Nothing = return False
|
||||
|
@ -210,7 +216,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
|
|||
|
||||
checkPresentGen k enc = preparecheckpresent k go
|
||||
where
|
||||
go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k
|
||||
go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k
|
||||
go Nothing = cantCheck baser
|
||||
enck = maybe id snd enc
|
||||
|
||||
|
|
|
@ -60,7 +60,8 @@ gen r u c gc = do
|
|||
availability = GloballyAvailable,
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u c $
|
||||
gc { remoteAnnexHookType = Just "!dne!" }
|
||||
gc { remoteAnnexHookType = Just "!dne!" },
|
||||
getInfo = return [("hooktype", hooktype)]
|
||||
}
|
||||
where
|
||||
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
|
||||
|
@ -70,7 +71,7 @@ hookSetup mu _ c = do
|
|||
u <- maybe (liftIO genUUID) return mu
|
||||
let hooktype = fromMaybe (error "Specify hooktype=") $
|
||||
M.lookup "hooktype" c
|
||||
c' <- encryptionSetup c
|
||||
(c', _encsetup) <- encryptionSetup c
|
||||
gitConfigSpecialRemote u c' "hooktype" hooktype
|
||||
return (c', u)
|
||||
|
||||
|
@ -138,7 +139,7 @@ checkKey r h k = do
|
|||
v <- lookupHook h action
|
||||
liftIO $ check v
|
||||
where
|
||||
action = "checkpresent"
|
||||
action = "checkpresent"
|
||||
findkey s = key2file k `elem` lines s
|
||||
check Nothing = error $ action ++ " hook misconfigured"
|
||||
check (Just hook) = do
|
||||
|
|
|
@ -83,6 +83,7 @@ gen r u c gc = do
|
|||
, availability = if islocal then LocallyAvailable else GloballyAvailable
|
||||
, remotetype = remote
|
||||
, mkUnavailable = return Nothing
|
||||
, getInfo = return [("url", url)]
|
||||
}
|
||||
where
|
||||
specialcfg = (specialRemoteCfg c)
|
||||
|
@ -138,7 +139,7 @@ rsyncSetup mu _ c = do
|
|||
-- verify configuration is sane
|
||||
let url = fromMaybe (error "Specify rsyncurl=") $
|
||||
M.lookup "rsyncurl" c
|
||||
c' <- encryptionSetup c
|
||||
(c', _encsetup) <- encryptionSetup c
|
||||
|
||||
-- The rsyncurl is stored in git config, not only in this remote's
|
||||
-- persistant state, so it can vary between hosts.
|
||||
|
@ -175,7 +176,7 @@ store o k src meterupdate = withRsyncScratchDir $ \tmp -> do
|
|||
]
|
||||
else return False
|
||||
where
|
||||
{- If the key being sent is encrypted or chunked, the file
|
||||
{- If the key being sent is encrypted or chunked, the file
|
||||
- containing its content is a temp file, and so can be
|
||||
- renamed into place. Otherwise, the file is the annexed
|
||||
- object file, and has to be copied or hard linked into place. -}
|
||||
|
|
29
Remote/S3.hs
29
Remote/S3.hs
|
@ -5,9 +5,7 @@
|
|||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Remote.S3 (remote, iaHost, configIA, isIAHost, iaItemUrl) where
|
||||
module Remote.S3 (remote, iaHost, configIA, isIA, iaItemUrl) where
|
||||
|
||||
import qualified Aws as AWS
|
||||
import qualified Aws.Core as AWS
|
||||
|
@ -83,16 +81,21 @@ gen r u c gc = do
|
|||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
|
||||
mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc,
|
||||
getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes
|
||||
[ Just ("bucket", fromMaybe "unknown" (getBucket c))
|
||||
, if isIA c
|
||||
then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucket c)
|
||||
else Nothing
|
||||
]
|
||||
}
|
||||
|
||||
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
s3Setup mu mcreds c = do
|
||||
u <- maybe (liftIO genUUID) return mu
|
||||
c' <- setRemoteCredPair c (AWS.creds u) mcreds
|
||||
s3Setup' u c'
|
||||
s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
s3Setup' u c = if configIA c then archiveorg else defaulthost
|
||||
s3Setup' u mcreds c
|
||||
s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
s3Setup' u mcreds c = if isIA c then archiveorg else defaulthost
|
||||
where
|
||||
remotename = fromJust (M.lookup "name" c)
|
||||
defbucket = remotename ++ "-" ++ fromUUID u
|
||||
|
@ -109,25 +112,27 @@ s3Setup' u c = if configIA c then archiveorg else defaulthost
|
|||
return (fullconfig, u)
|
||||
|
||||
defaulthost = do
|
||||
c' <- encryptionSetup c
|
||||
let fullconfig = c' `M.union` defaults
|
||||
(c', encsetup) <- encryptionSetup c
|
||||
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
|
||||
let fullconfig = c'' `M.union` defaults
|
||||
genBucket fullconfig u
|
||||
use fullconfig
|
||||
|
||||
archiveorg = do
|
||||
showNote "Internet Archive mode"
|
||||
c' <- setRemoteCredPair noEncryptionUsed c (AWS.creds u) mcreds
|
||||
-- Ensure user enters a valid bucket name, since
|
||||
-- this determines the name of the archive.org item.
|
||||
let validbucket = replace " " "-" $ map toLower $
|
||||
fromMaybe (error "specify bucket=") $
|
||||
getBucketName c
|
||||
getBucketName c'
|
||||
let archiveconfig =
|
||||
-- IA acdepts x-amz-* as an alias for x-archive-*
|
||||
M.mapKeys (replace "x-archive-" "x-amz-") $
|
||||
-- encryption does not make sense here
|
||||
M.insert "encryption" "none" $
|
||||
M.insert "bucket" validbucket $
|
||||
M.union c $
|
||||
M.union c' $
|
||||
-- special constraints on key names
|
||||
M.insert "mungekeys" "ia" defaults
|
||||
info <- extractS3Info archiveconfig
|
||||
|
|
|
@ -84,7 +84,8 @@ gen r u c gc = do
|
|||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote,
|
||||
mkUnavailable = return Nothing
|
||||
mkUnavailable = return Nothing,
|
||||
getInfo = return []
|
||||
}
|
||||
|
||||
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
|
||||
|
@ -167,7 +168,7 @@ writeSharedConvergenceSecret configdir scs =
|
|||
getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret
|
||||
getSharedConvergenceSecret configdir = go (60 :: Int)
|
||||
where
|
||||
f = convergenceFile configdir
|
||||
f = convergenceFile configdir
|
||||
go n
|
||||
| n == 0 = error $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?"
|
||||
| otherwise = do
|
||||
|
@ -190,7 +191,7 @@ startTahoeDaemon configdir = void $ boolTahoe configdir "start" []
|
|||
withTahoeConfigDir :: TahoeHandle -> (TahoeConfigDir -> IO a) -> IO a
|
||||
withTahoeConfigDir (TahoeHandle configdir v) a = go =<< atomically needsstart
|
||||
where
|
||||
go True = do
|
||||
go True = do
|
||||
startTahoeDaemon configdir
|
||||
a configdir
|
||||
go False = a configdir
|
||||
|
|
|
@ -62,7 +62,8 @@ gen r _ c gc =
|
|||
readonly = True,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote,
|
||||
mkUnavailable = return Nothing
|
||||
mkUnavailable = return Nothing,
|
||||
getInfo = return []
|
||||
}
|
||||
|
||||
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
|
||||
|
@ -120,7 +121,7 @@ checkKey' key us = firsthit us (Right False) $ \u -> do
|
|||
Url.withUrlOptions $ catchMsgIO .
|
||||
Url.checkBoth u' (keySize key)
|
||||
where
|
||||
firsthit [] miss _ = return miss
|
||||
firsthit [] miss _ = return miss
|
||||
firsthit (u:rest) _ a = do
|
||||
r <- a u
|
||||
case r of
|
||||
|
|
|
@ -71,7 +71,9 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
|||
readonly = False,
|
||||
availability = GloballyAvailable,
|
||||
remotetype = remote,
|
||||
mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
|
||||
mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc,
|
||||
getInfo = includeCredsInfo c (davCreds u) $
|
||||
[("url", fromMaybe "unknown" (M.lookup "url" c))]
|
||||
}
|
||||
chunkconfig = getChunkConfig c
|
||||
|
||||
|
@ -81,11 +83,11 @@ webdavSetup mu mcreds c = do
|
|||
url <- case M.lookup "url" c of
|
||||
Nothing -> error "Specify url="
|
||||
Just url -> return url
|
||||
c' <- encryptionSetup c
|
||||
(c', encsetup) <- encryptionSetup c
|
||||
creds <- maybe (getCreds c' u) (return . Just) mcreds
|
||||
testDav url creds
|
||||
gitConfigSpecialRemote u c' "webdav" "true"
|
||||
c'' <- setRemoteCredPair c' (davCreds u) creds
|
||||
c'' <- setRemoteCredPair encsetup c' (davCreds u) creds
|
||||
return (c'', u)
|
||||
|
||||
-- Opens a http connection to the DAV server, which will be reused
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue