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

more RawFilePath conversion

Browse source 
At this point I'll be done by new year's.

This commit was sponsored by Ethan Aubin.
This commit is contained in:
Joey Hess 2020-10-30 10:29:42 -04:00
parent 681b44236a
commit 19694fb280
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 132 additions and 94 deletions
Download patch file Download diff file Expand all files Collapse all files

175
Remote/Directory.hs
View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Remote.Directory ( module Remote.Directory (
@ -15,6 +16,7 @@ module Remote.Directory (
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
import Data.Default import Data.Default
import Annex.Common import Annex.Common
@ -25,7 +27,6 @@ import qualified Git
import Config.Cost import Config.Cost
import Config import Config
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import Utility.FileMode
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.ExportImport import Remote.Helper.ExportImport
import Types.Import import Types.Import
@ -35,10 +36,13 @@ import Annex.Perms
import Annex.UUID import Annex.UUID
import Backend import Backend
import Types.KeySource import Types.KeySource
import Types.ProposedAccepted
import Utility.Metered import Utility.Metered
import Utility.Tmp import Utility.Tmp
import Utility.InodeCache import Utility.InodeCache
import Types.ProposedAccepted import Utility.FileMode
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
remote :: RemoteType remote :: RemoteType
remote = specialRemoteType $ RemoteType remote = specialRemoteType $ RemoteType
@ -106,20 +110,21 @@ gen r u rc gc rs = do
, config = c , config = c
, getRepo = return r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Just dir , localpath = Just dir'
, readonly = False , readonly = False
, appendonly = False , appendonly = False
, availability = LocallyAvailable , availability = LocallyAvailable
, remotetype = remote , remotetype = remote
, mkUnavailable = gen r u rc , mkUnavailable = gen r u rc
(gc { remoteAnnexDirectory = Just "/dev/null" }) rs (gc { remoteAnnexDirectory = Just "/dev/null" }) rs
, getInfo = return [("directory", dir)] , getInfo = return [("directory", dir')]
, claimUrl = Nothing , claimUrl = Nothing
, checkUrl = Nothing , checkUrl = Nothing
, remoteStateHandle = rs , remoteStateHandle = rs
} }
where where
dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc dir = toRawFilePath dir'
dir' = fromMaybe (giveup "missing directory") (remoteAnnexDirectory gc)
directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
directorySetup _ mu _ c gc = do directorySetup _ mu _ c gc = do
@ -127,7 +132,7 @@ directorySetup _ mu _ c gc = do
-- verify configuration is sane -- verify configuration is sane
let dir = maybe (giveup "Specify directory=") fromProposedAccepted $ let dir = maybe (giveup "Specify directory=") fromProposedAccepted $
M.lookup directoryField c M.lookup directoryField c
absdir <- liftIO $ absPath dir absdir <- liftIO $ fromRawFilePath <$> absPath (toRawFilePath dir)
liftIO $ unlessM (doesDirectoryExist absdir) $ liftIO $ unlessM (doesDirectoryExist absdir) $
giveup $ "Directory does not exist: " ++ absdir giveup $ "Directory does not exist: " ++ absdir
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc
@ -140,27 +145,28 @@ directorySetup _ mu _ c gc = do
{- 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 one since we used to write to different hash - We try more than one since we used to write to different hash
- directories. -} - directories. -}
locations :: FilePath -> Key -> [FilePath] locations :: RawFilePath -> Key -> [RawFilePath]
locations d k = map (\f -> d </> fromRawFilePath f) (keyPaths k) locations d k = map (d P.</>) (keyPaths k)
{- Returns the location off a Key in the directory. If the key is {- Returns the location off a Key in the directory. If the key is
- present, returns the location that is actually used, otherwise - present, returns the location that is actually used, otherwise
- returns the first, default location. -} - returns the first, default location. -}
getLocation :: FilePath -> Key -> IO FilePath getLocation :: RawFilePath -> Key -> IO RawFilePath
getLocation d k = do getLocation d k = do
let locs = locations d k let locs = locations d k
fromMaybe (Prelude.head locs) <$> firstM doesFileExist locs fromMaybe (Prelude.head locs)
<$> firstM (doesFileExist . fromRawFilePath) 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 :: RawFilePath -> Key -> RawFilePath
storeDir d k = addTrailingPathSeparator $ storeDir d k = P.addTrailingPathSeparator $
d </> fromRawFilePath (hashDirLower def k) </> fromRawFilePath (keyFile k) d P.</> hashDirLower def k P.</> keyFile k
{- Check if there is enough free disk space in the remote's directory to {- 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. -} - store the key. Note that the unencrypted key size is checked. -}
storeKeyM :: FilePath -> ChunkConfig -> Storer storeKeyM :: RawFilePath -> ChunkConfig -> Storer
storeKeyM d chunkconfig k c m = storeKeyM d chunkconfig k c m =
ifM (checkDiskSpaceDirectory d k) ifM (checkDiskSpaceDirectory (fromRawFilePath d) k)
( byteStorer (store d chunkconfig) k c m ( byteStorer (store d chunkconfig) k c m
, giveup "Not enough free disk space." , giveup "Not enough free disk space."
) )
@ -174,47 +180,55 @@ checkDiskSpaceDirectory d k = do
<*> getFileStatus annexdir <*> getFileStatus annexdir
checkDiskSpace (Just d) k 0 samefilesystem checkDiskSpace (Just d) k 0 samefilesystem
store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex () store :: RawFilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex ()
store d chunkconfig k b p = liftIO $ do store d chunkconfig k b p = liftIO $ do
void $ tryIO $ createDirectoryUnder d tmpdir void $ tryIO $ createDirectoryUnder d tmpdir
case chunkconfig of case chunkconfig of
LegacyChunks chunksize -> LegacyChunks chunksize ->
Legacy.store d chunksize (finalizeStoreGeneric d) k b p tmpdir destdir Legacy.store
(fromRawFilePath d)
chunksize
(finalizeStoreGeneric d)
k b p
(fromRawFilePath tmpdir)
(fromRawFilePath destdir)
_ -> do _ -> do
let tmpf = tmpdir </> kf let tmpf = tmpdir P.</> kf
meteredWriteFile p tmpf b meteredWriteFile p (fromRawFilePath tmpf) b
finalizeStoreGeneric d tmpdir destdir finalizeStoreGeneric d tmpdir destdir
where where
tmpdir = addTrailingPathSeparator $ d </> "tmp" </> kf tmpdir = P.addTrailingPathSeparator $ d P.</> "tmp" P.</> kf
kf = fromRawFilePath (keyFile k) kf = keyFile k
destdir = storeDir d k destdir = storeDir d k
{- Passed a temp directory that contains the files that should be placed {- Passed a temp directory that contains the files that should be placed
- in the dest directory, moves it into place. Anything already existing - in the dest directory, moves it into place. Anything already existing
- in the dest directory will be deleted. File permissions will be locked - in the dest directory will be deleted. File permissions will be locked
- down. -} - down. -}
finalizeStoreGeneric :: FilePath -> FilePath -> FilePath -> IO () finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO ()
finalizeStoreGeneric d tmp dest = do finalizeStoreGeneric d tmp dest = do
removeDirGeneric d dest removeDirGeneric (fromRawFilePath d) dest'
createDirectoryUnder d (parentDir dest) createDirectoryUnder d (parentDir dest)
renameDirectory tmp dest renameDirectory (fromRawFilePath tmp) dest'
-- may fail on some filesystems -- may fail on some filesystems
void $ tryIO $ do void $ tryIO $ do
mapM_ preventWrite =<< dirContents dest mapM_ preventWrite =<< dirContents dest'
preventWrite dest preventWrite dest'
where
dest' = fromRawFilePath dest
retrieveKeyFileM :: FilePath -> ChunkConfig -> Retriever retrieveKeyFileM :: RawFilePath -> ChunkConfig -> Retriever
retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d retrieveKeyFileM d (LegacyChunks _) = Legacy.retrieve locations d
retrieveKeyFileM d _ = byteRetriever $ \k sink -> retrieveKeyFileM d _ = byteRetriever $ \k sink ->
sink =<< liftIO (L.readFile =<< getLocation d k) sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k)
retrieveKeyFileCheapM :: FilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
-- no cheap retrieval possible for chunks -- no cheap retrieval possible for chunks
retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing
retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do
file <- absPath =<< getLocation d k file <- fromRawFilePath <$> (absPath =<< getLocation d k)
ifM (doesFileExist file) ifM (doesFileExist file)
( createSymbolicLink file f ( createSymbolicLink file f
, giveup "content file not present in remote" , giveup "content file not present in remote"
@ -223,8 +237,10 @@ retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do
retrieveKeyFileCheapM _ _ = Nothing retrieveKeyFileCheapM _ _ = Nothing
#endif #endif
removeKeyM :: FilePath -> Remover removeKeyM :: RawFilePath -> Remover
removeKeyM d k = liftIO $ removeDirGeneric d (storeDir d k) removeKeyM d k = liftIO $ removeDirGeneric
(fromRawFilePath d)
(fromRawFilePath (storeDir d k))
{- Removes the directory, which must be located under the topdir. {- Removes the directory, which must be located under the topdir.
- -
@ -250,76 +266,79 @@ removeDirGeneric topdir dir = do
unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $ unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
throwM e throwM e
checkPresentM :: FilePath -> ChunkConfig -> CheckPresent checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent
checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations k
checkPresentM d _ k = checkPresentGeneric d (locations d k) checkPresentM d _ k = checkPresentGeneric d (locations d k)
checkPresentGeneric :: FilePath -> [FilePath] -> Annex Bool checkPresentGeneric :: RawFilePath -> [RawFilePath] -> Annex Bool
checkPresentGeneric d ps = checkPresentGeneric' d $ checkPresentGeneric d ps = checkPresentGeneric' d $
liftIO $ anyM doesFileExist ps liftIO $ anyM (doesFileExist . fromRawFilePath) ps
checkPresentGeneric' :: FilePath -> Annex Bool -> Annex Bool checkPresentGeneric' :: RawFilePath -> Annex Bool -> Annex Bool
checkPresentGeneric' d check = ifM check checkPresentGeneric' d check = ifM check
( return True ( return True
, ifM (liftIO $ doesDirectoryExist d) , ifM (liftIO $ doesDirectoryExist (fromRawFilePath d))
( return False ( return False
, giveup $ "directory " ++ d ++ " is not accessible" , giveup $ "directory " ++ fromRawFilePath d ++ " is not accessible"
) )
) )
storeExportM :: FilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM :: RawFilePath -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportM d src _k loc p = liftIO $ do storeExportM d src _k loc p = liftIO $ do
createDirectoryUnder d (takeDirectory dest) createDirectoryUnder d (P.takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not -- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored. -- see it until it's fully stored.
viaTmp (\tmp () -> withMeteredFile src p (L.writeFile tmp)) dest () viaTmp go (fromRawFilePath dest) ()
where where
dest = exportPath d loc dest = exportPath d loc
go tmp () = withMeteredFile src p (L.writeFile tmp)
retrieveExportM :: FilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () retrieveExportM :: RawFilePath -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
retrieveExportM d _k loc dest p = retrieveExportM d _k loc dest p =
liftIO $ withMeteredFile src p (L.writeFile dest) liftIO $ withMeteredFile src p (L.writeFile dest)
where where
src = exportPath d loc src = fromRawFilePath $ exportPath d loc
removeExportM :: FilePath -> Key -> ExportLocation -> Annex () removeExportM :: RawFilePath -> Key -> ExportLocation -> Annex ()
removeExportM d _k loc = liftIO $ do removeExportM d _k loc = liftIO $ do
removeWhenExistsWith removeLink src removeWhenExistsWith removeLink src
removeExportLocation d loc removeExportLocation d loc
where where
src = exportPath d loc src = fromRawFilePath $ exportPath d loc
checkPresentExportM :: FilePath -> Key -> ExportLocation -> Annex Bool checkPresentExportM :: RawFilePath -> Key -> ExportLocation -> Annex Bool
checkPresentExportM d _k loc = checkPresentExportM d _k loc =
checkPresentGeneric d [exportPath d loc] checkPresentGeneric d [exportPath d loc]
renameExportM :: FilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM d _k oldloc newloc = liftIO $ do renameExportM d _k oldloc newloc = liftIO $ do
createDirectoryUnder d (takeDirectory dest) createDirectoryUnder d (P.takeDirectory dest)
renameFile src dest renameFile (fromRawFilePath src) (fromRawFilePath dest)
removeExportLocation d oldloc removeExportLocation d oldloc
return (Just ()) return (Just ())
where where
src = exportPath d oldloc src = exportPath d oldloc
dest = exportPath d newloc dest = exportPath d newloc
exportPath :: FilePath -> ExportLocation -> FilePath exportPath :: RawFilePath -> ExportLocation -> RawFilePath
exportPath d loc = d </> fromRawFilePath (fromExportLocation loc) exportPath d loc = d P.</> fromExportLocation loc
{- Removes the ExportLocation's parent directory and its parents, so long as {- Removes the ExportLocation's parent directory and its parents, so long as
- they're empty, up to but not including the topdir. -} - they're empty, up to but not including the topdir. -}
removeExportLocation :: FilePath -> ExportLocation -> IO () removeExportLocation :: RawFilePath -> ExportLocation -> IO ()
removeExportLocation topdir loc = removeExportLocation topdir loc =
go (Just $ takeDirectory $ fromRawFilePath $ fromExportLocation loc) (Right ()) go (Just $ P.takeDirectory $ fromExportLocation loc) (Right ())
where where
go _ (Left _e) = return () go _ (Left _e) = return ()
go Nothing _ = return () go Nothing _ = return ()
go (Just loc') _ = go (upFrom loc') go (Just loc') _ =
=<< tryIO (removeDirectory $ exportPath topdir (mkExportLocation (toRawFilePath loc'))) let p = fromRawFilePath $ exportPath topdir $
mkExportLocation loc'
in go (upFrom loc') =<< tryIO (removeDirectory p)
listImportableContentsM :: FilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize)))
listImportableContentsM dir = catchMaybeIO $ liftIO $ do listImportableContentsM dir = catchMaybeIO $ liftIO $ do
l <- dirContentsRecursive dir l <- dirContentsRecursive (fromRawFilePath dir)
l' <- mapM go l l' <- mapM go l
return $ ImportableContents (catMaybes l') [] return $ ImportableContents (catMaybes l') []
where where
@ -328,7 +347,7 @@ listImportableContentsM dir = catchMaybeIO $ liftIO $ do
mkContentIdentifier f st >>= \case mkContentIdentifier f st >>= \case
Nothing -> return Nothing Nothing -> return Nothing
Just cid -> do Just cid -> do
relf <- toRawFilePath <$> relPathDirToFile dir f relf <- relPathDirToFile dir (toRawFilePath f)
sz <- getFileSize' f st sz <- getFileSize' f st
return $ Just (mkImportLocation relf, (cid, sz)) return $ Just (mkImportLocation relf, (cid, sz))
@ -350,33 +369,35 @@ guardSameContentIdentifiers cont old new
| new == Just old = cont | new == Just old = cont
| otherwise = giveup "file content has changed" | otherwise = giveup "file content has changed"
importKeyM :: FilePath -> ExportLocation -> ContentIdentifier -> MeterUpdate -> Annex Key importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> MeterUpdate -> Annex Key
importKeyM dir loc cid p = do importKeyM dir loc cid p = do
backend <- chooseBackend (fromRawFilePath f) backend <- chooseBackend f
k <- fst <$> genKey ks p backend k <- fst <$> genKey ks p backend
currcid <- liftIO $ mkContentIdentifier absf =<< getFileStatus absf currcid <- liftIO $ mkContentIdentifier (fromRawFilePath absf)
=<< R.getFileStatus absf
guardSameContentIdentifiers (return k) cid currcid guardSameContentIdentifiers (return k) cid currcid
where where
f = fromExportLocation loc f = fromExportLocation loc
absf = dir </> fromRawFilePath f absf = dir P.</> f
ks = KeySource ks = KeySource
{ keyFilename = f { keyFilename = f
, contentLocation = toRawFilePath absf , contentLocation = absf
, inodeCache = Nothing , inodeCache = Nothing
} }
retrieveExportWithContentIdentifierM :: FilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key retrieveExportWithContentIdentifierM :: RawFilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key
retrieveExportWithContentIdentifierM dir loc cid dest mkkey p = retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
precheck $ docopy postcheck precheck $ docopy postcheck
where where
f = exportPath dir loc f = exportPath dir loc
f' = fromRawFilePath f
docopy cont = do docopy cont = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
let open = do let open = do
-- Need a duplicate fd for the post check, since -- Need a duplicate fd for the post check, since
-- hGetContentsMetered closes its handle. -- hGetContentsMetered closes its handle.
fd <- openFd f ReadOnly Nothing defaultFileFlags fd <- openFd f' ReadOnly Nothing defaultFileFlags
dupfd <- dup fd dupfd <- dup fd
h <- fdToHandle fd h <- fdToHandle fd
return (h, dupfd) return (h, dupfd)
@ -385,7 +406,7 @@ retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
closeFd dupfd closeFd dupfd
bracketIO open close $ \(h, dupfd) -> do bracketIO open close $ \(h, dupfd) -> do
#else #else
let open = openBinaryFile f ReadMode let open = openBinaryFile f' ReadMode
let close = hClose let close = hClose
bracketIO open close $ \h -> do bracketIO open close $ \h -> do
#endif #endif
@ -400,8 +421,8 @@ retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
-- Check before copy, to avoid expensive copy of wrong file -- Check before copy, to avoid expensive copy of wrong file
-- content. -- content.
precheck cont = guardSameContentIdentifiers cont cid precheck cont = guardSameContentIdentifiers cont cid
=<< liftIO . mkContentIdentifier f =<< liftIO . mkContentIdentifier f'
=<< liftIO (getFileStatus f) =<< liftIO (R.getFileStatus f)
-- Check after copy, in case the file was changed while it was -- Check after copy, in case the file was changed while it was
-- being copied. -- being copied.
@ -421,7 +442,7 @@ retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
#else #else
postcheck cont = do postcheck cont = do
#endif #endif
currcid <- liftIO $ mkContentIdentifier f currcid <- liftIO $ mkContentIdentifier f'
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
=<< getFdStatus fd =<< getFdStatus fd
#else #else
@ -429,9 +450,9 @@ retrieveExportWithContentIdentifierM dir loc cid dest mkkey p =
#endif #endif
guardSameContentIdentifiers cont cid currcid guardSameContentIdentifiers cont cid currcid
storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM :: RawFilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do
liftIO $ createDirectoryUnder dir destdir liftIO $ createDirectoryUnder dir (toRawFilePath destdir)
withTmpFileIn destdir template $ \tmpf tmph -> do withTmpFileIn destdir template $ \tmpf tmph -> do
liftIO $ withMeteredFile src p (L.hPut tmph) liftIO $ withMeteredFile src p (L.hPut tmph)
liftIO $ hFlush tmph liftIO $ hFlush tmph
@ -446,17 +467,17 @@ storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do
(const $ liftIO $ rename tmpf dest) (const $ liftIO $ rename tmpf dest)
return newcid return newcid
where where
dest = exportPath dir loc dest = fromRawFilePath $ exportPath dir loc
(destdir, base) = splitFileName dest (destdir, base) = splitFileName dest
template = relatedTemplate (base ++ ".tmp") template = relatedTemplate (base ++ ".tmp")
removeExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () removeExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
removeExportWithContentIdentifierM dir k loc removeablecids = removeExportWithContentIdentifierM dir k loc removeablecids =
checkExportContent dir loc removeablecids (giveup "unsafe to remove modified file") $ \case checkExportContent dir loc removeablecids (giveup "unsafe to remove modified file") $ \case
DoesNotExist -> return () DoesNotExist -> return ()
KnownContentIdentifier -> removeExportM dir k loc KnownContentIdentifier -> removeExportM dir k loc
checkPresentExportWithContentIdentifierM :: FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
checkPresentExportWithContentIdentifierM dir _k loc knowncids = checkPresentExportWithContentIdentifierM dir _k loc knowncids =
checkPresentGeneric' dir $ checkPresentGeneric' dir $
checkExportContent dir loc knowncids (return False) $ \case checkExportContent dir loc knowncids (return False) $ \case
@ -480,12 +501,12 @@ data CheckResult = DoesNotExist | KnownContentIdentifier
-- --
-- So, it suffices to check if the destination file's current -- So, it suffices to check if the destination file's current
-- content is known, and immediately run the callback. -- content is known, and immediately run the callback.
checkExportContent :: FilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a checkExportContent :: RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a
checkExportContent dir loc knowncids unsafe callback = checkExportContent dir loc knowncids unsafe callback =
tryWhenExists (liftIO $ getFileStatus dest) >>= \case tryWhenExists (liftIO $ R.getFileStatus dest) >>= \case
Just destst Just destst
| not (isRegularFile destst) -> unsafe | not (isRegularFile destst) -> unsafe
| otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier dest destst) >>= \case | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier (fromRawFilePath dest) destst) >>= \case
Just destcid Just destcid
| destcid `elem` knowncids -> callback KnownContentIdentifier | destcid `elem` knowncids -> callback KnownContentIdentifier
-- dest exists with other content -- dest exists with other content

37
Remote/Directory/LegacyChunked.hs
View file

@ -7,10 +7,13 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Remote.Directory.LegacyChunked where module Remote.Directory.LegacyChunked where
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
import Annex.Common import Annex.Common
import Utility.FileMode import Utility.FileMode
@ -18,6 +21,7 @@ import Remote.Helper.Special
import qualified Remote.Helper.Chunked.Legacy as Legacy import qualified Remote.Helper.Chunked.Legacy as Legacy
import Annex.Tmp import Annex.Tmp
import Utility.Metered import Utility.Metered
import Utility.Directory.Create
withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withCheckedFiles _ [] _locations _ _ = return False withCheckedFiles _ [] _locations _ _ = return False
@ -70,17 +74,19 @@ storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do
feed bytes' (sz - s) ls h feed bytes' (sz - s) ls h
else return (l:ls) else return (l:ls)
storeHelper :: FilePath -> (FilePath -> FilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO () storeHelper :: FilePath -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> ([FilePath] -> IO [FilePath]) -> FilePath -> FilePath -> IO ()
storeHelper repotop finalizer key storer tmpdir destdir = do storeHelper repotop finalizer key storer tmpdir destdir = do
void $ liftIO $ tryIO $ createDirectoryUnder repotop tmpdir void $ liftIO $ tryIO $ createDirectoryUnder
Legacy.storeChunks key tmpdir destdir storer recorder finalizer (toRawFilePath repotop)
(toRawFilePath tmpdir)
Legacy.storeChunks key tmpdir destdir storer recorder (legacyFinalizer finalizer)
where where
recorder f s = do recorder f s = do
void $ tryIO $ allowWrite f void $ tryIO $ allowWrite f
writeFile f s writeFile f s
void $ tryIO $ preventWrite f void $ tryIO $ preventWrite f
store :: FilePath -> ChunkSize -> (FilePath -> FilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO () store :: FilePath -> ChunkSize -> (RawFilePath -> RawFilePath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO ()
store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \dests -> store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \dests ->
storeLegacyChunked p chunksize dests b storeLegacyChunked p chunksize dests b
@ -88,12 +94,13 @@ store repotop chunksize finalizer k b p = storeHelper repotop finalizer k $ \des
- Done very innefficiently, by writing to a temp file. - Done very innefficiently, by writing to a temp file.
- :/ This is legacy code.. - :/ This is legacy code..
-} -}
retrieve :: (FilePath -> Key -> [FilePath]) -> FilePath -> Retriever retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever
retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do
showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."
let tmp = tmpdir </> fromRawFilePath (keyFile basek) ++ ".directorylegacy.tmp" let tmp = fromRawFilePath $
tmpdir P.</> keyFile basek <> ".directorylegacy.tmp"
let go = \k sink -> do let go = \k sink -> do
liftIO $ void $ withStoredFiles d locations k $ \fs -> do liftIO $ void $ withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ \fs -> do
forM_ fs $ forM_ fs $
S.appendFile tmp <=< S.readFile S.appendFile tmp <=< S.readFile
return True return True
@ -102,7 +109,15 @@ retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do
sink b sink b
byteRetriever go basek p c byteRetriever go basek p c
checkKey :: FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> Annex Bool checkKey :: RawFilePath -> (RawFilePath -> Key -> [RawFilePath]) -> Key -> Annex Bool
checkKey d locations k = liftIO $ withStoredFiles d locations k $ checkKey d locations k = liftIO $
-- withStoredFiles checked that it exists withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $
const $ return True -- withStoredFiles checked that it exists
const $ return True
legacyFinalizer :: (RawFilePath -> RawFilePath -> IO ()) -> (FilePath -> FilePath -> IO ())
legacyFinalizer f = \a b -> f (toRawFilePath a) (toRawFilePath b)
legacyLocations :: (RawFilePath -> Key -> [RawFilePath]) -> (FilePath -> Key -> [FilePath])
legacyLocations locations = \f k ->
map fromRawFilePath $ locations (toRawFilePath f) k

11
Remote/Rsync.hs
View file

@ -224,7 +224,7 @@ storeGeneric o meterupdate basedest populatedest =
storeGeneric' :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex Bool storeGeneric' :: RsyncOpts -> MeterUpdate -> FilePath -> (FilePath -> Annex Bool) -> Annex Bool
storeGeneric' o meterupdate basedest populatedest = withRsyncScratchDir $ \tmp -> do storeGeneric' o meterupdate basedest populatedest = withRsyncScratchDir $ \tmp -> do
let dest = tmp </> basedest let dest = tmp </> basedest
createAnnexDirectory (parentDir dest) createAnnexDirectory (parentDir (toRawFilePath dest))
ok <- populatedest dest ok <- populatedest dest
ps <- sendParams ps <- sendParams
if ok if ok
@ -250,7 +250,7 @@ remove o k = removeGeneric o includes
where where
includes = concatMap use dirHashes includes = concatMap use dirHashes
use h = let dir = fromRawFilePath (h def k) in use h = let dir = fromRawFilePath (h def k) in
[ parentDir dir [ fromRawFilePath (parentDir (toRawFilePath dir))
, dir , dir
-- match content directory and anything in it -- match content directory and anything in it
, dir </> fromRawFilePath (keyFile k) </> "***" , dir </> fromRawFilePath (keyFile k) </> "***"
@ -314,7 +314,8 @@ checkPresentExportM o _k loc = checkPresentGeneric o [rsyncurl]
removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex () removeExportM :: RsyncOpts -> Key -> ExportLocation -> Annex ()
removeExportM o _k loc = removeExportM o _k loc =
removeGeneric o $ includes $ fromRawFilePath $ fromExportLocation loc removeGeneric o $ map fromRawFilePath $
includes $ fromExportLocation loc
where where
includes f = f : case upFrom f of includes f = f : case upFrom f of
Nothing -> [] Nothing -> []
@ -325,9 +326,9 @@ removeExportDirectoryM o ed = removeGeneric o (allbelow d : includes d)
where where
d = fromRawFilePath $ fromExportDirectory ed d = fromRawFilePath $ fromExportDirectory ed
allbelow f = f </> "***" allbelow f = f </> "***"
includes f = f : case upFrom f of includes f = f : case upFrom (toRawFilePath f) of
Nothing -> [] Nothing -> []
Just f' -> includes f' Just f' -> includes (fromRawFilePath f')
renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM :: RsyncOpts -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM _ _ _ _ = return Nothing renameExportM _ _ _ _ = return Nothing

3
Remote/Tahoe.hs
View file

@ -190,7 +190,8 @@ tahoeConfigure configdir furl mscs = do
createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool
createClient configdir furl = do createClient configdir furl = do
createDirectoryIfMissing True (parentDir configdir) createDirectoryIfMissing True $
fromRawFilePath $ parentDir $ toRawFilePath configdir
boolTahoe configdir "create-client" boolTahoe configdir "create-client"
[ Param "--nickname", Param "git-annex" [ Param "--nickname", Param "git-annex"
, Param "--introducer", Param furl , Param "--introducer", Param furl