diff options
author | Joey Hess <joey@kitenet.net> | 2014-10-22 17:14:38 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2014-10-22 17:14:38 -0400 |
commit | 33e7dd2e0b756270cb51d1ed574cbe4b8173c7cd (patch) | |
tree | 0e9ff04c04c33cd1ba45171983d1b9f4d92cac60 /Remote | |
parent | 2d7b57270e628994483495159d2be715c8f9531b (diff) | |
parent | 49475bb89542e92c6f466425f29cd0640a8e80f4 (diff) |
Merge branch 'master' into s3-aws
Conflicts:
Remote/S3.hs
Diffstat (limited to 'Remote')
-rw-r--r-- | Remote/Bup.hs | 3 | ||||
-rw-r--r-- | Remote/Ddar.hs | 3 | ||||
-rw-r--r-- | Remote/Directory.hs | 5 | ||||
-rw-r--r-- | Remote/External.hs | 7 | ||||
-rw-r--r-- | Remote/GCrypt.hs | 13 | ||||
-rw-r--r-- | Remote/Git.hs | 3 | ||||
-rw-r--r-- | Remote/Glacier.hs | 21 | ||||
-rw-r--r-- | Remote/Helper/Chunked.hs | 15 | ||||
-rw-r--r-- | Remote/Helper/Encryptable.hs | 63 | ||||
-rw-r--r-- | Remote/Helper/Git.hs | 5 | ||||
-rw-r--r-- | Remote/Helper/Special.hs | 12 | ||||
-rw-r--r-- | Remote/Hook.hs | 7 | ||||
-rw-r--r-- | Remote/Rsync.hs | 5 | ||||
-rw-r--r-- | Remote/S3.hs | 29 | ||||
-rw-r--r-- | Remote/Tahoe.hs | 7 | ||||
-rw-r--r-- | Remote/Web.hs | 5 | ||||
-rw-r--r-- | Remote/WebDAV.hs | 8 |
17 files changed, 146 insertions, 65 deletions
diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 0de0e2946..4f2ddf35a 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -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.) diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs index fc226ddff..d73919bfd 100644 --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -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. diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 3137c9534..2e9e013ab 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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. diff --git a/Remote/External.hs b/Remote/External.hs index 6ba0e2f3a..e907ab0cf 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index a95f21669..995c3e838 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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 diff --git a/Remote/Git.hs b/Remote/Git.hs index 6397c1a2e..50c34a2bb 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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)) diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 18038a79c..99003f29a 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -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. diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs index 271978658..806fab542 100644 --- a/Remote/Helper/Chunked.hs +++ b/Remote/Helper/Chunked.hs @@ -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. - diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 69216a793..4903cffb4 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -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)" + ] diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs index b405fd358..156d7ac28 100644 --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -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) + ] diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index ba9ff4fb4..181d7548f 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -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 diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 8e6ac439d..f7c428e99 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 698d733e6..a87d05a33 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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. -} diff --git a/Remote/S3.hs b/Remote/S3.hs index 7c49937ce..fe0b4992a 100644 --- a/Remote/S3.hs +++ b/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 diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index bde8ee9d7..7dd231c06 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -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 diff --git a/Remote/Web.hs b/Remote/Web.hs index 04b453277..4d4b43c41 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -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 diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index d427d67a9..932ed81e0 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -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 |