From c46eba94f69151ded37988efd7e3375d327faef3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Jul 2014 00:30:04 -0400 Subject: better Preparer interface This will allow things like WebDAV to opean a single persistent connection and reuse it for all the chunked data. The crazy types allow for some nice code reuse. --- Remote/Directory.hs | 16 ++++++------- Remote/Directory/LegacyChunked.hs | 8 ++++--- Remote/Helper/ChunkedEncryptable.hs | 46 ++++++++++++++++++++++--------------- 3 files changed, 41 insertions(+), 29 deletions(-) diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 2ebf608cb..cb7553fe2 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} module Remote.Directory (remote) where @@ -106,11 +107,10 @@ tmpDir d k = addTrailingPathSeparator $ d "tmp" keyFile k {- Check if there is enough free disk space in the remote's directory to - store the key. Note that the unencrypted key size is checked. -} -prepareStore :: FilePath -> ChunkConfig -> PrepareStorer -prepareStore d chunkconfig k = ifM (checkDiskSpace (Just d) k 0) - ( return $ Just (store d chunkconfig) - , return Nothing - ) +prepareStore :: FilePath -> ChunkConfig -> Preparer Storer +prepareStore d chunkconfig = checkPrepare + (\k -> checkDiskSpace (Just d) k 0) + (store d chunkconfig) store :: FilePath -> ChunkConfig -> Storer store d chunkconfig k b p = do @@ -135,9 +135,9 @@ store d chunkconfig k b p = do mapM_ preventWrite =<< dirContents dest preventWrite dest -retrieve :: FilePath -> ChunkConfig -> PrepareRetriever -retrieve d (LegacyChunks _) basek = Legacy.retrieve locations d basek -retrieve d _ _ = return $ Just $ \k -> L.readFile =<< getLocation d k +retrieve :: FilePath -> ChunkConfig -> Preparer Retriever +retrieve d (LegacyChunks _) = Legacy.retrieve locations d +retrieve d _ = simplyPrepare $ \k -> L.readFile =<< getLocation d k retrieveCheap :: FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool -- no cheap retrieval possible for chunks diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs index df6d94d04..c7b8ad52c 100644 --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -7,6 +7,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE Rank2Types #-} + module Remote.Directory.LegacyChunked where import qualified Data.ByteString.Lazy as L @@ -88,13 +90,13 @@ store chunksize finalizer k b p = storeHelper finalizer k $ \dests -> - Done very innefficiently, by writing to a temp file. - :/ This is legacy code.. -} -retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> PrepareRetriever -retrieve locations d basek = do +retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Preparer Retriever +retrieve locations d basek a = do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." tmpdir <- fromRepo $ gitAnnexTmpMiscDir createAnnexDirectory tmpdir let tmp = tmpdir keyFile basek ++ ".directorylegacy.tmp" - return $ Just $ \k -> do + a $ Just $ \k -> do void $ withStoredFiles d locations k $ \fs -> do forM_ fs $ S.appendFile tmp <=< S.readFile diff --git a/Remote/Helper/ChunkedEncryptable.hs b/Remote/Helper/ChunkedEncryptable.hs index cfa92406e..ac8917851 100644 --- a/Remote/Helper/ChunkedEncryptable.hs +++ b/Remote/Helper/ChunkedEncryptable.hs @@ -5,12 +5,15 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE Rank2Types #-} + module Remote.Helper.ChunkedEncryptable ( - chunkedEncryptableRemote, - PrepareStorer, + Preparer, + simplyPrepare, + checkPrepare, Storer, - PrepareRetriever, Retriever, + chunkedEncryptableRemote, storeKeyDummy, retreiveKeyFileDummy, module X @@ -28,18 +31,23 @@ import Remote.Helper.Encryptable as X import Annex.Content import Annex.Exception --- Prepares to store a Key, and returns a Storer action if possible. --- May throw exceptions. -type PrepareStorer = Key -> Annex (Maybe Storer) +-- Prepares for and then runs an action that will act on a Key, +-- passing it a helper when the preparation is successful. +type Preparer helper = forall a. Key -> (Maybe helper -> Annex a) -> Annex a + +simplyPrepare :: helper -> Preparer helper +simplyPrepare helper _ a = a $ Just helper + +checkPrepare :: (Key -> Annex Bool) -> helper -> Preparer helper +checkPrepare checker helper k a = ifM (checker k) + ( a (Just helper) + , a Nothing + ) -- Stores a Key, which may be encrypted and/or a chunk key. -- May throw exceptions. type Storer = Key -> L.ByteString -> MeterUpdate -> IO Bool --- Prepares to retrieve a Key, and returns a Retriever action if possible. --- May throw exceptions. -type PrepareRetriever = Key -> Annex (Maybe Retriever) - -- Retrieves a Key, which may be encrypted and/or a chunk key. -- Throws exception if key is not present, or remote is not accessible. type Retriever = Key -> IO L.ByteString @@ -48,8 +56,8 @@ type Retriever = Key -> IO L.ByteString -} chunkedEncryptableRemote :: RemoteConfig - -> PrepareStorer - -> PrepareRetriever + -> Preparer Storer + -> Preparer Retriever -> Remote -> Remote chunkedEncryptableRemote c preparestorer prepareretriever r = encr @@ -74,13 +82,14 @@ chunkedEncryptableRemote c preparestorer prepareretriever r = encr safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False) -- chunk, then encrypt, then feed to the storer - storeKeyGen k p enc = safely $ - maybe (return False) go =<< preparestorer k + storeKeyGen k p enc = + safely $ preparestorer k $ safely . go where - go storer = sendAnnex k rollback $ \src -> + go (Just storer) = sendAnnex k rollback $ \src -> metered (Just p) k $ \p' -> storeChunks (uuid r) chunkconfig k src p' $ storechunk storer + go Nothing = return False rollback = void $ removeKey encr k storechunk storer k' b p' = case enc of Nothing -> storer k' b p' @@ -90,13 +99,14 @@ chunkedEncryptableRemote c preparestorer prepareretriever r = encr storer (enck k') encb p' -- call retriever to get chunks; decrypt them; stream to dest file - retrieveKeyFileGen k dest p enc = safely $ - maybe (return False) go =<< prepareretriever k + retrieveKeyFileGen k dest p enc = + safely $ prepareretriever k $ safely . go where - go retriever = metered (Just p) k $ \p' -> + go (Just retriever) = metered (Just p) k $ \p' -> bracketIO (openBinaryFile dest WriteMode) hClose $ \h -> retrieveChunks retriever (uuid r) chunkconfig enck k p' $ sink h + go Nothing = return False sink h p' b = do let write = meteredWrite p' h case enc of -- cgit v1.2.3