diff options
Diffstat (limited to 'Remote')
-rw-r--r-- | Remote/Helper/Encryptable.hs | 38 | ||||
-rw-r--r-- | Remote/Helper/Special.hs | 4 | ||||
-rw-r--r-- | Remote/WebDAV.hs | 130 |
3 files changed, 52 insertions, 120 deletions
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index c364a69e7..dd032ce33 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -14,9 +14,7 @@ import Types.Remote import Crypto import Types.Crypto import qualified Annex -import Config.Cost import Utility.Base64 -import Utility.Metered {- 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 @@ -70,42 +68,6 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c -- remotes (while being backward-compatible). [ "keyid", "keyid+", "keyid-", "highRandomQuality" ] -{- Modifies a Remote to support encryption. -} --- TODO: deprecated -encryptableRemote - :: RemoteConfig - -> ((Cipher, Key) -> Key -> MeterUpdate -> Annex Bool) - -> ((Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool) - -> Remote - -> Remote -encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = r - { storeKey = \k f p -> cip k >>= maybe - (storeKey r k f p) - (\v -> storeKeyEncrypted v k p) - , retrieveKeyFile = \k f d p -> cip k >>= maybe - (retrieveKeyFile r k f d p) - (\v -> retrieveKeyFileEncrypted v k d p) - , retrieveKeyFileCheap = \k d -> cip k >>= maybe - (retrieveKeyFileCheap r k d) - (\_ -> return False) - , removeKey = \k -> cip k >>= maybe - (removeKey r k) - (\(_, enckey) -> removeKey r enckey) - , checkPresent = \k -> cip k >>= maybe - (checkPresent r k) - (\(_, enckey) -> checkPresent r enckey) - , cost = maybe - (cost r) - (const $ cost r + encryptedRemoteCostAdj) - (extractCipher c) - } - where - cip k = do - v <- cipherKey c - return $ case v of - Nothing -> Nothing - Just (cipher, enck) -> Just (cipher, enck k) - {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex - state. -} remoteCipher :: RemoteConfig -> Annex (Maybe Cipher) diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index f8428aff7..fc0e11d2f 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -39,7 +39,7 @@ import Crypto import Config.Cost import Utility.Metered import Remote.Helper.Chunked as X -import Remote.Helper.Encryptable as X hiding (encryptableRemote) +import Remote.Helper.Encryptable as X import Remote.Helper.Messages import Annex.Content import Annex.Exception @@ -119,7 +119,7 @@ byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retrieve byteRetriever a k _m callback = a k (callback . ByteContent) {- The base Remote that is provided to specialRemote needs to have - - storeKey, retreiveKeyFile, removeKey, and checkPresent methods, + - storeKey, retrieveKeyFile, removeKey, and checkPresent methods, - but they are never actually used (since specialRemote replaces them). - Here are some dummy ones. -} diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index f0bcac10e..6679242e5 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -27,12 +27,9 @@ import qualified Git import Config import Config.Cost import Remote.Helper.Special -import Remote.Helper.Encryptable import qualified Remote.Helper.Chunked.Legacy as Legacy -import Crypto import Creds import Utility.Metered -import Annex.Content import Annex.UUID import Remote.WebDAV.DavUrl @@ -50,20 +47,22 @@ remote = RemoteType { gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) gen r u c gc = new <$> remoteCost gc expensiveRemoteCost where - new cst = Just $ encryptableRemote c - (storeEncrypted this) - (retrieveEncrypted this) + new cst = Just $ specialRemote c + (prepareStore this chunkconfig) + (prepareRetrieve this chunkconfig) + (prepareRemove this) + (prepareCheckPresent this chunkconfig) this where this = Remote { uuid = u, cost = cst, name = Git.repoDescribe r, - storeKey = store this, - retrieveKeyFile = retrieve this, - retrieveKeyFileCheap = retrieveCheap this, - removeKey = remove this, - checkPresent = checkKey this, + storeKey = storeKeyDummy, + retrieveKeyFile = retreiveKeyFileDummy, + retrieveKeyFileCheap = retrieveCheap, + removeKey = removeKeyDummy, + checkPresent = checkPresentDummy, checkPresentCheap = False, whereisKey = Nothing, remoteFsck = Nothing, @@ -76,6 +75,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost availability = GloballyAvailable, remotetype = remote } + chunkconfig = getChunkConfig c webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) webdavSetup mu mcreds c = do @@ -89,95 +89,67 @@ webdavSetup mu mcreds c = do c'' <- setRemoteCredPair c' (davCreds u) creds return (c'', u) -store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool -store r k _f p = metered (Just p) k $ \meterupdate -> - davAction r False $ \(baseurl, user, pass) -> - sendAnnex k (void $ remove r k) $ \src -> - liftIO $ withMeteredFile src meterupdate $ - storeHelper r k baseurl user pass - -storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool -storeEncrypted r (cipher, enck) k p = metered (Just p) k $ \meterupdate -> - davAction r False $ \(baseurl, user, pass) -> - sendAnnex k (void $ remove r enck) $ \src -> - liftIO $ encrypt (getGpgEncParams r) cipher - (streamMeteredFile src meterupdate) $ - readBytes $ storeHelper r enck baseurl user pass - -storeHelper :: Remote -> Key -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool -storeHelper r k baseurl user pass b = catchBoolIO $ do +prepareStore :: Remote -> ChunkConfig -> Preparer Storer +prepareStore r chunkconfig = simplyPrepare $ fileStorer $ \k f p -> + davAction r False $ \(baseurl, user, pass) -> liftIO $ + withMeteredFile f p $ + storeHelper chunkconfig k baseurl user pass + +storeHelper :: ChunkConfig -> Key -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool +storeHelper chunkconfig k baseurl user pass b = do mkdirRecursiveDAV tmpurl user pass case chunkconfig of - NoChunks -> flip catchNonAsync (\e -> warningIO (show e) >> return False) $ do - storehttp tmpurl b - finalizer tmpurl keyurl - return True - UnpaddedChunks _ -> error "TODO: storeHelper with UnpaddedChunks" LegacyChunks chunksize -> do let storer urls = Legacy.storeChunked chunksize urls storehttp b let recorder url s = storehttp url (L8.fromString s) Legacy.storeChunks k tmpurl keyurl storer recorder finalizer - + _ -> do + storehttp tmpurl b + finalizer tmpurl keyurl + return True where tmpurl = tmpLocation baseurl k keyurl = davLocation baseurl k - chunkconfig = getChunkConfig $ config r finalizer srcurl desturl = do void $ tryNonAsync (deleteDAV desturl user pass) mkdirRecursiveDAV (urlParent desturl) user pass moveDAV srcurl desturl user pass storehttp url = putDAV url user pass -retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool -retrieveCheap _ _ _ = return False +retrieveCheap :: Key -> FilePath -> Annex Bool +retrieveCheap _ _ = return False -retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool -retrieve r k _f d p = metered (Just p) k $ \meterupdate -> - davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $ - withStoredFiles r k baseurl user pass onerr $ \urls -> do - Legacy.meteredWriteFileChunks meterupdate d urls $ \url -> do +prepareRetrieve :: Remote -> ChunkConfig -> Preparer Retriever +prepareRetrieve r chunkconfig = simplyPrepare $ fileRetriever $ \d k p -> + davAction r onerr $ \(baseurl, user, pass) -> liftIO $ + withStoredFiles chunkconfig k baseurl user pass onerr $ \urls -> do + Legacy.meteredWriteFileChunks p d urls $ \url -> do mb <- getDAV url user pass case mb of - Nothing -> throwIO "download failed" + Nothing -> onerr Just b -> return b - return True - where - onerr _ = return False - -retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool -retrieveEncrypted r (cipher, enck) k d p = metered (Just p) k $ \meterupdate -> - davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $ - withStoredFiles r enck baseurl user pass onerr $ \urls -> do - decrypt cipher (feeder user pass urls) $ - readBytes $ meteredWriteFile meterupdate d - return True where - onerr _ = return False - - feeder _ _ [] _ = noop - feeder user pass (url:urls) h = do - mb <- getDAV url user pass - case mb of - Nothing -> throwIO "download failed" - Just b -> do - L.hPut h b - feeder user pass urls h - -remove :: Remote -> Key -> Annex Bool -remove r k = davAction r False $ \(baseurl, user, pass) -> liftIO $ do - -- Delete the key's whole directory, including any chunked - -- files, etc, in a single action. - let url = davLocation baseurl k - isJust . eitherToMaybe <$> tryNonAsync (deleteDAV url user pass) - -checkKey :: Remote -> Key -> Annex Bool -checkKey r k = davAction r noconn (either error id <$$> go) + onerr = error "download failed" + +prepareRemove :: Remote -> Preparer Remover +prepareRemove r = simplyPrepare $ \k -> + davAction r False $ \(baseurl, user, pass) -> liftIO $ do + -- Delete the key's whole directory, including any + -- legacy chunked files, etc, in a single action. + let url = davLocation baseurl k + isJust . eitherToMaybe <$> tryNonAsync (deleteDAV url user pass) + +prepareCheckPresent :: Remote -> ChunkConfig -> Preparer CheckPresent +prepareCheckPresent r chunkconfig = simplyPrepare $ checkKey r chunkconfig + +checkKey :: Remote -> ChunkConfig -> Key -> Annex Bool +checkKey r chunkconfig k = davAction r noconn (either error id <$$> go) where noconn = error $ name r ++ " not configured" go (baseurl, user, pass) = do showAction $ "checking " ++ name r - liftIO $ withStoredFiles r k baseurl user pass onerr check + liftIO $ withStoredFiles chunkconfig k baseurl user pass onerr check where check [] = return $ Right True check (url:urls) = do @@ -196,7 +168,7 @@ checkKey r k = davAction r noconn (either error id <$$> go) else v withStoredFiles - :: Remote + :: ChunkConfig -> Key -> DavUrl -> DavUser @@ -204,9 +176,7 @@ withStoredFiles -> (DavUrl -> IO a) -> ([DavUrl] -> IO a) -> IO a -withStoredFiles r k baseurl user pass onerr a = case chunkconfig of - NoChunks -> a [keyurl] - UnpaddedChunks _ -> error "TODO: withStoredFiles with UnpaddedChunks" +withStoredFiles chunkconfig k baseurl user pass onerr a = case chunkconfig of LegacyChunks _ -> do let chunkcount = keyurl ++ Legacy.chunkCount v <- getDAV chunkcount user pass @@ -217,9 +187,9 @@ withStoredFiles r k baseurl user pass onerr a = case chunkconfig of if null chunks then onerr chunkcount else a chunks + _ -> a [keyurl] where keyurl = davLocation baseurl k ++ keyFile k - chunkconfig = getChunkConfig $ config r davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a davAction r unconfigured action = do |