diff options
Diffstat (limited to 'Remote/Helper/Special.hs')
| -rw-r--r-- | Remote/Helper/Special.hs | 223 |
1 files changed, 218 insertions, 5 deletions
diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 7fc421f46..2bcb7d530 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -1,20 +1,51 @@ -{- common functions for special remotes +{- helpers for special remotes - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2011-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -module Remote.Helper.Special where - -import qualified Data.Map as M +module Remote.Helper.Special ( + findSpecialRemotes, + gitConfigSpecialRemote, + Preparer, + Storer, + Retriever, + simplyPrepare, + ContentSource, + checkPrepare, + resourcePrepare, + fileStorer, + byteStorer, + fileRetriever, + byteRetriever, + storeKeyDummy, + retreiveKeyFileDummy, + SpecialRemoteCfg(..), + specialRemoteCfg, + specialRemote, + specialRemote', + module X +) where import Common.Annex +import Types.StoreRetrieve import Types.Remote +import Crypto +import Config.Cost +import Utility.Metered +import Remote.Helper.Chunked as X +import Remote.Helper.Encryptable as X hiding (encryptableRemote) +import Annex.Content +import Annex.Exception import qualified Git import qualified Git.Command import qualified Git.Construct +import qualified Data.ByteString.Lazy as L +import Control.Exception (bracket) +import qualified Data.Map as M + {- Special remotes don't have a configured url, so Git.Repo does not - automatically generate remotes for them. This looks for a different - configuration key instead. @@ -38,3 +69,185 @@ gitConfigSpecialRemote u c k v = do [Param "config", Param (configsetting a), Param b] remotename = fromJust (M.lookup "name" c) configsetting s = "remote." ++ remotename ++ "." ++ s + +-- Use when nothing needs to be done to prepare a helper. +simplyPrepare :: helper -> Preparer helper +simplyPrepare helper _ a = a $ Just helper + +-- Use to run a check when preparing a helper. +checkPrepare :: (Key -> Annex Bool) -> helper -> Preparer helper +checkPrepare checker helper k a = ifM (checker k) + ( a (Just helper) + , a Nothing + ) + +-- 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 Storer that expects to be provided with a file containing +-- the content of the key to store. +fileStorer :: (Key -> FilePath -> MeterUpdate -> Annex Bool) -> Storer +fileStorer a k (FileContent f) m = a k f m +fileStorer a k (ByteContent b) m = withTmp k $ \f -> do + liftIO $ L.writeFile f b + a k f m + +-- A Storer that expects to be provided with a L.ByteString of +-- the content to store. +byteStorer :: (Key -> L.ByteString -> MeterUpdate -> Annex Bool) -> Storer +byteStorer a k c m = withBytes c $ \b -> a k b m + +-- A Retriever that writes the content of a Key to a provided file. +-- It is responsible for updating the progress meter as it retrieves data. +fileRetriever :: (FilePath -> Key -> MeterUpdate -> Annex ()) -> Retriever +fileRetriever a k m callback = do + f <- prepTmp k + a f k m + callback (FileContent f) + +-- A Retriever that generates a lazy ByteString containing the Key's +-- content, and passes it to a callback action which will fully consume it +-- before returning. +byteRetriever :: (Key -> (L.ByteString -> Annex Bool) -> Annex Bool) -> Retriever +byteRetriever a k _m callback = a k (callback . ByteContent) + +{- The base Remote that is provided to specialRemote needs to have + - storeKey and retreiveKeyFile methods, but they are never + - actually used (since specialRemote replaces them). + - Here are some dummy ones. + -} +storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool +storeKeyDummy _ _ _ = return False +retreiveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +retreiveKeyFileDummy _ _ _ _ = return False + +type RemoteModifier = RemoteConfig -> Preparer Storer -> Preparer Retriever -> Remote -> Remote + +data SpecialRemoteCfg = SpecialRemoteCfg + { chunkConfig :: ChunkConfig + , displayProgress :: Bool + } + +specialRemoteCfg :: RemoteConfig -> SpecialRemoteCfg +specialRemoteCfg c = SpecialRemoteCfg (getChunkConfig c) True + +-- Modifies a base Remote to support both chunking and encryption, +-- which special remotes typically should support. +specialRemote :: RemoteModifier +specialRemote c = specialRemote' (specialRemoteCfg c) c + +specialRemote' :: SpecialRemoteCfg -> RemoteModifier +specialRemote' cfg c preparestorer prepareretriever baser = encr + where + encr = baser + { storeKey = \k _f p -> cip >>= storeKeyGen k p + , retrieveKeyFile = \k _f d p -> cip >>= retrieveKeyFileGen k d p + , retrieveKeyFileCheap = \k d -> cip >>= maybe + (retrieveKeyFileCheap baser k d) + (\_ -> return False) + , removeKey = \k -> cip >>= removeKeyGen k + , hasKey = \k -> cip >>= hasKeyGen k + , cost = maybe + (cost baser) + (const $ cost baser + encryptedRemoteCostAdj) + (extractCipher c) + } + cip = cipherKey c + gpgopts = getGpgEncParams encr + + safely a = catchNonAsyncAnnex a (\e -> warning (show e) >> return False) + + -- chunk, then encrypt, then feed to the storer + storeKeyGen k p enc = + safely $ preparestorer k $ safely . go + where + go (Just storer) = sendAnnex k rollback $ \src -> + displayprogress p k $ \p' -> + storeChunks (uuid baser) chunkconfig k src p' + (storechunk enc storer) + (hasKey baser) + go Nothing = return False + rollback = void $ removeKey encr k + + storechunk Nothing storer k content p = storer k content p + storechunk (Just (cipher, enck)) storer k content p = + withBytes content $ \b -> + encrypt gpgopts cipher (feedBytes b) $ + readBytes $ \encb -> + storer (enck k) (ByteContent encb) p + + -- call retriever to get chunks; decrypt them; stream to dest file + retrieveKeyFileGen k dest p enc = + safely $ prepareretriever k $ safely . go + where + go (Just retriever) = displayprogress p k $ \p' -> + retrieveChunks retriever (uuid baser) chunkconfig + enck k dest p' (sink dest enc) + go Nothing = return False + enck = maybe id snd enc + + removeKeyGen k enc = removeChunks remover (uuid baser) chunkconfig enck k + where + enck = maybe id snd enc + remover = removeKey baser + + hasKeyGen k enc = hasKeyChunks checker (uuid baser) chunkconfig enck k + where + enck = maybe id snd enc + checker = hasKey baser + + chunkconfig = chunkConfig cfg + + displayprogress p k a + | displayProgress cfg = metered (Just p) k a + | otherwise = a p + +{- Sink callback for retrieveChunks. Stores the file content into the + - provided Handle, decrypting it first if necessary. + - + - If the remote did not store the content using chunks, no Handle + - will be provided, and it's up to us to open the destination file. + - + - Note that when neither chunking nor encryption is used, and the remote + - provides FileContent, that file only needs to be renamed + - into place. (And it may even already be in the right place..) + -} +sink + :: FilePath + -> Maybe (Cipher, EncKey) + -> Maybe Handle + -> Maybe MeterUpdate + -> ContentSource + -> Annex Bool +sink dest enc 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) -> + decrypt cipher (feedBytes b) $ + readBytes write + (Just (cipher, _), _, FileContent f) -> do + withBytes content $ \b -> + decrypt cipher (feedBytes b) $ + readBytes write + liftIO $ nukeFile f + (Nothing, _, FileContent f) -> do + withBytes content write + liftIO $ nukeFile f + (Nothing, _, ByteContent b) -> write b + return True + where + write b = case mh of + Just h -> liftIO $ b `streamto` h + Nothing -> liftIO $ bracket opendest hClose (b `streamto`) + streamto b h = case mp of + Just p -> meteredWrite p h b + Nothing -> L.hPut h b + opendest = openBinaryFile dest WriteMode + +withBytes :: ContentSource -> (L.ByteString -> Annex a) -> Annex a +withBytes (ByteContent b) a = a b +withBytes (FileContent f) a = a =<< liftIO (L.readFile f) |