convert directory special remote to using ChunkedEncryptable
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:
parent
1400cbb032
commit
b2922c1d6d
1 changed files with 53 additions and 146 deletions
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue