mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

convert directory special remote to using ChunkedEncryptable

Browse source 
And clean up legacy chunking code, which is in its own module now.

So much cleaner!

This commit was sponsored by Henrik Ahlgren
This commit is contained in:
Joey Hess 2014-07-26 20:19:24 -04:00
parent 1400cbb032
commit b2922c1d6d
1 changed files with 53 additions and 146 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

197
Remote/Directory.hs
View file

@ -1,6 +1,6 @@
{- A "remote" that is just a filesystem directory. {- A "remote" that is just a filesystem directory.
- -
- Copyright 2011-2012 Joey Hess <joey@kitenet.net> - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
- -
- Licensed under the GNU GPL version 3 or higher. - Licensed under the GNU GPL version 3 or higher.
-} -}
@ -10,7 +10,6 @@
module Remote.Directory (remote) where module Remote.Directory (remote) where
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S
import qualified Data.Map as M import qualified Data.Map as M
import Common.Annex import Common.Annex
@ -21,10 +20,8 @@ import Config.Cost
import Config import Config
import Utility.FileMode import Utility.FileMode
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Encryptable import Remote.Helper.ChunkedEncryptable
import Remote.Helper.Chunked import qualified Remote.Directory.LegacyChunked as Legacy
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Crypto
import Annex.Content import Annex.Content
import Annex.UUID import Annex.UUID
import Utility.Metered import Utility.Metered
@ -41,18 +38,18 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remot
gen r u c gc = do gen r u c gc = do
cst <- remoteCost gc cheapRemoteCost cst <- remoteCost gc cheapRemoteCost
let chunkconfig = chunkConfig c let chunkconfig = chunkConfig c
return $ Just $ encryptableRemote c return $ Just $ chunkedEncryptableRemote c
(storeEncrypted dir (getGpgEncParams (c,gc)) chunkconfig) (prepareStore dir chunkconfig)
(retrieveEncrypted u dir chunkconfig) (retrieve dir chunkconfig)
Remote { Remote {
uuid = u, uuid = u,
cost = cst, cost = cst,
name = Git.repoDescribe r, name = Git.repoDescribe r,
storeKey = store u dir chunkconfig, storeKey = storeKeyDummy,
retrieveKeyFile = retrieve u dir chunkconfig, retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap u dir chunkconfig, retrieveKeyFileCheap = retrieveCheap dir chunkconfig,
removeKey = remove dir, removeKey = remove dir,
hasKey = checkPresent u dir chunkconfig, hasKey = checkPresent dir chunkconfig,
hasKeyCheap = True, hasKeyCheap = True,
whereisKey = Nothing, whereisKey = Nothing,
remoteFsck = Nothing, remoteFsck = Nothing,
@ -84,122 +81,50 @@ directorySetup mu _ c = do
gitConfigSpecialRemote u c' "directory" absdir gitConfigSpecialRemote u c' "directory" absdir
return (M.delete "directory" c', u) return (M.delete "directory" c', u)
{- Locations to try to access a given Key in the Directory. {- Locations to try to access a given Key in the directory.
- We try more than since we used to write to different hash directories. -} - We try more than one since we used to write to different hash
- directories. -}
locations :: FilePath -> Key -> [FilePath] locations :: FilePath -> Key -> [FilePath]
locations d k = map (d </>) (keyPaths k) locations d k = map (d </>) (keyPaths k)
{- Returns the location off a Key in the directory. If the key is
- present, returns the location that is actually used, otherwise
- returns the first, default location. -}
getLocation :: FilePath -> Key -> IO FilePath
getLocation d k = do
let locs = locations d k
fromMaybe (Prelude.head locs) <$> firstM doesFileExist locs
{- Directory where the file(s) for a key are stored. -} {- Directory where the file(s) for a key are stored. -}
storeDir :: FilePath -> Key -> FilePath storeDir :: FilePath -> Key -> FilePath
storeDir d k = addTrailingPathSeparator $ d </> hashDirLower k </> keyFile k storeDir d k = addTrailingPathSeparator $ d </> hashDirLower k </> keyFile k
{- Where we store temporary data for a key as it's being uploaded. -} {- Where we store temporary data for a key, in the directory, as it's being
- written. -}
tmpDir :: FilePath -> Key -> FilePath tmpDir :: FilePath -> Key -> FilePath
tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
withCheckedFiles :: (FilePath -> IO Bool) -> UUID -> ChunkConfig -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool {- Check if there is enough free disk space in the remote's directory to
withCheckedFiles _ _ _ [] _ _ = return False - store the key. Note that the unencrypted key size is checked. -}
withCheckedFiles check _ (LegacyChunks _) d k a = go $ locations d k prepareStore :: FilePath -> ChunkConfig -> PrepareStorer
where prepareStore d chunkconfig k = ifM (checkDiskSpace (Just d) k 0)
go [] = return False ( return $ Just (store d chunkconfig)
go (f:fs) = do , return Nothing
let chunkcount = f ++ Legacy.chunkCount
ifM (check chunkcount)
( do
chunks <- Legacy.listChunks f <$> readFile chunkcount
ifM (allM check chunks)
( a chunks , return False )
, do
chunks <- Legacy.probeChunks f check
if null chunks
then go fs
else a chunks
) )
withCheckedFiles check u chunkconfig d k a =
go $ locations d k
where
go [] = return False
go (f:fs) = ifM (check f) ( a [f] , go fs )
withStoredFiles :: UUID -> ChunkConfig -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool store :: FilePath -> ChunkConfig -> Storer
withStoredFiles = withCheckedFiles doesFileExist store d chunkconfig k b p = do
store :: UUID -> FilePath -> ChunkConfig -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store u d chunkconfig k _f p = whenDiskAvail d k $
sendAnnex k (void $ remove d k) $ \src ->
storeChunks u chunkconfig k src p $ \k' b meterupdate ->
storeHelper d chunkconfig k' $ \dests ->
case chunkconfig of
LegacyChunks chunksize ->
storeLegacyChunked meterupdate chunksize dests b
_ -> do
let dest = Prelude.head dests
meteredWriteFile meterupdate dest b
return [dest]
storeEncrypted :: FilePath -> [CommandParam] -> ChunkConfig -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted d gpgOpts chunkconfig (cipher, enck) k p = whenDiskAvail d k $
sendAnnex k (void $ remove d enck) $ \src ->
metered (Just p) k $ \meterupdate ->
storeHelper d chunkconfig enck $ \dests ->
encrypt gpgOpts cipher (feedFile src) $ readBytes $ \b ->
case chunkconfig of
LegacyChunks chunksize ->
storeLegacyChunked meterupdate chunksize dests b
_ -> do
let dest = Prelude.head dests
meteredWriteFile meterupdate dest b
return [dest]
{- Splits a ByteString into chunks and writes to dests, obeying configured
- chunk size (not to be confused with the L.ByteString chunk size). -}
storeLegacyChunked :: MeterUpdate -> ChunkSize -> [FilePath] -> L.ByteString -> IO [FilePath]
storeLegacyChunked _ _ [] _ = error "bad storeLegacyChunked call"
storeLegacyChunked meterupdate chunksize alldests@(firstdest:_) b
| L.null b = do
-- always write at least one file, even for empty
L.writeFile firstdest b
return [firstdest]
| otherwise = storeLegacyChunked' meterupdate chunksize alldests (L.toChunks b) []
storeLegacyChunked' :: MeterUpdate -> ChunkSize -> [FilePath] -> [S.ByteString] -> [FilePath] -> IO [FilePath]
storeLegacyChunked' _ _ [] _ _ = error "ran out of dests"
storeLegacyChunked' _ _ _ [] c = return $ reverse c
storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do
bs' <- withFile d WriteMode $
feed zeroBytesProcessed chunksize bs
storeLegacyChunked' meterupdate chunksize dests bs' (d:c)
where
feed _ _ [] _ = return []
feed bytes sz (l:ls) h = do
let len = S.length l
let s = fromIntegral len
if s <= sz || sz == chunksize
then do
S.hPut h l
let bytes' = addBytesProcessed bytes len
meterupdate bytes'
feed bytes' (sz - s) ls h
else return (l:ls)
{- An encrypted key does not have a known size, so the unencrypted
- key should always be passed. -}
whenDiskAvail :: FilePath -> Key -> Annex Bool -> Annex Bool
whenDiskAvail d k a = checkDiskSpace (Just d) k 0 <&&> a
storeHelper :: FilePath -> ChunkConfig -> Key -> ([FilePath] -> IO [FilePath]) -> Annex Bool
storeHelper d chunkconfig key storer = liftIO $ do
void $ liftIO $ tryIO $ createDirectoryIfMissing True tmpdir void $ liftIO $ tryIO $ createDirectoryIfMissing True tmpdir
case chunkconfig of case chunkconfig of
LegacyChunks _ -> Legacy.storeChunks key tmpdir destdir storer recorder finalizer LegacyChunks chunksize -> Legacy.store chunksize finalizer k b p tmpdir destdir
_ -> flip catchNonAsync (\e -> print e >> return False) $ do _ -> flip catchNonAsync (\e -> print e >> return False) $ do
let tmpf = tmpdir </> keyFile key let tmpf = tmpdir </> keyFile k
void $ storer [tmpf] meteredWriteFile p tmpf b
finalizer tmpdir destdir finalizer tmpdir destdir
return True return True
where where
tmpdir = tmpDir d key tmpdir = tmpDir d k
destdir = storeDir d key destdir = storeDir d k
finalizer tmp dest = do finalizer tmp dest = do
void $ tryIO $ allowWrite dest -- may already exist void $ tryIO $ allowWrite dest -- may already exist
void $ tryIO $ removeDirectoryRecursive dest -- or not exist void $ tryIO $ removeDirectoryRecursive dest -- or not exist
@ -210,40 +135,21 @@ storeHelper d chunkconfig key storer = liftIO $ do
mapM_ preventWrite =<< dirContents dest mapM_ preventWrite =<< dirContents dest
preventWrite dest preventWrite dest
recorder f s = do retrieve :: FilePath -> ChunkConfig -> PrepareRetriever
void $ tryIO $ allowWrite f retrieve d (LegacyChunks _) basek = Legacy.retrieve locations d basek
writeFile f s retrieve d _ _ = return $ Just $ \k -> L.readFile =<< getLocation d k
void $ tryIO $ preventWrite f
retrieve :: UUID -> FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool retrieveCheap :: FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool
retrieve u d chunkconfig k _ f p = metered (Just p) k $ \meterupdate -> -- no cheap retrieval possible for chunks
liftIO $ withStoredFiles u chunkconfig d k $ \files -> retrieveCheap _ (UnpaddedChunks _) _ _ = return False
catchBoolIO $ do retrieveCheap _ (LegacyChunks _) _ _ = return False
meteredWriteFileChunks meterupdate f files L.readFile
return True
retrieveEncrypted :: UUID -> FilePath -> ChunkConfig -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieveEncrypted u d chunkconfig (cipher, enck) k f p = metered (Just p) k $ \meterupdate ->
liftIO $ withStoredFiles u chunkconfig d enck $ \files ->
catchBoolIO $ do
decrypt cipher (feeder files) $
readBytes $ meteredWriteFile meterupdate f
return True
where
feeder files h = forM_ files $ L.hPut h <=< L.readFile
retrieveCheap :: UUID -> FilePath -> ChunkConfig -> Key -> FilePath -> Annex Bool
-- no cheap retrieval for chunks
retrieveCheap _ _ (UnpaddedChunks _) _ _ = return False
retrieveCheap _ _ (LegacyChunks _) _ _ = return False
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
retrieveCheap u d ck k f = liftIO $ withStoredFiles u ck d k go retrieveCheap d NoChunks k f = liftIO $ catchBoolIO $ do
where file <- getLocation d k
go [file] = catchBoolIO $ createSymbolicLink file f
createSymbolicLink file f >> return True return True
go _files = return False
#else #else
retrieveCheap _ _ _ _ _ = return False retrieveCheap _ _ _ _ = return False
#endif #endif
remove :: FilePath -> Key -> Annex Bool remove :: FilePath -> Key -> Annex Bool
@ -260,6 +166,7 @@ remove d k = liftIO $ do
where where
dir = storeDir d k dir = storeDir d k
checkPresent :: UUID -> FilePath -> ChunkConfig -> Key -> Annex (Either String Bool) checkPresent :: FilePath -> ChunkConfig -> Key -> Annex (Either String Bool)
checkPresent u d chunkconfig k = liftIO $ catchMsgIO $ withStoredFiles u chunkconfig d k $ checkPresent d (LegacyChunks _) k = Legacy.checkPresent d locations k
const $ return True -- withStoredFiles checked that it exists checkPresent d _ k = liftIO $ catchMsgIO $
anyM doesFileExist (locations d k)