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

more OsPath conversion

Browse source 
Sponsored-by: Joshua Antonishen
This commit is contained in:
Joey Hess 2025-02-02 14:03:43 -04:00
parent 71195cce13
commit 8af91a4c92
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 69 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

18
Annex/AdjustedBranch.hs
View file

@ -161,7 +161,7 @@ adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case
Database.Keys.addAssociatedFile k f Database.Keys.addAssociatedFile k f
exe <- catchDefaultIO False $ exe <- catchDefaultIO False $
(isExecutable . fileMode) <$> (isExecutable . fileMode) <$>
(liftIO . R.getFileStatus (liftIO . R.getFileStatus . fromOsPath
=<< calcRepo (gitAnnexLocation k)) =<< calcRepo (gitAnnexLocation k))
let mode = fromTreeItemType $ let mode = fromTreeItemType $
if exe then TreeExecutable else TreeFile if exe then TreeExecutable else TreeFile
@ -171,13 +171,13 @@ adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case
adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem) adjustToSymlink :: TreeItem -> Annex (Maybe TreeItem)
adjustToSymlink = adjustToSymlink' gitAnnexLink adjustToSymlink = adjustToSymlink' gitAnnexLink
adjustToSymlink' :: (RawFilePath -> Key -> Git.Repo -> GitConfig -> IO RawFilePath) -> TreeItem -> Annex (Maybe TreeItem) adjustToSymlink' :: (OsPath -> Key -> Git.Repo -> GitConfig -> IO OsPath) -> TreeItem -> Annex (Maybe TreeItem)
adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case adjustToSymlink' gitannexlink ti@(TreeItem f _m s) = catKey s >>= \case
Just k -> do Just k -> do
absf <- inRepo $ \r -> absPath $ fromTopFilePath f r absf <- inRepo $ \r -> absPath $ fromTopFilePath f r
linktarget <- calcRepo $ gitannexlink absf k linktarget <- calcRepo $ gitannexlink absf k
Just . TreeItem f (fromTreeItemType TreeSymlink) Just . TreeItem f (fromTreeItemType TreeSymlink)
<$> hashSymlink linktarget <$> hashSymlink (fromOsPath linktarget)
Nothing -> return (Just ti) Nothing -> return (Just ti)
-- This is a hidden branch ref, that's used as the basis for the AdjBranch, -- This is a hidden branch ref, that's used as the basis for the AdjBranch,
@ -269,7 +269,7 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
-- origbranch. -- origbranch.
_ <- propigateAdjustedCommits' True origbranch adj commitlck _ <- propigateAdjustedCommits' True origbranch adj commitlck
origheadfile <- inRepo $ F.readFile' . toOsPath . Git.Ref.headFile origheadfile <- inRepo $ F.readFile' . Git.Ref.headFile
origheadsha <- inRepo (Git.Ref.sha currbranch) origheadsha <- inRepo (Git.Ref.sha currbranch)
b <- adjustBranch adj origbranch b <- adjustBranch adj origbranch
@ -282,7 +282,7 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
Just s -> do Just s -> do
inRepo $ \r -> do inRepo $ \r -> do
let newheadfile = fromRef' s let newheadfile = fromRef' s
F.writeFile' (toOsPath (Git.Ref.headFile r)) newheadfile F.writeFile' (Git.Ref.headFile r) newheadfile
return (Just newheadfile) return (Just newheadfile)
_ -> return Nothing _ -> return Nothing
@ -296,9 +296,9 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
unless ok $ case newheadfile of unless ok $ case newheadfile of
Nothing -> noop Nothing -> noop
Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do
v' <- F.readFile' (toOsPath (Git.Ref.headFile r)) v' <- F.readFile' (Git.Ref.headFile r)
when (v == v') $ when (v == v') $
F.writeFile' (toOsPath (Git.Ref.headFile r)) origheadfile F.writeFile' (Git.Ref.headFile r) origheadfile
return ok return ok
| otherwise = preventCommits $ \commitlck -> do | otherwise = preventCommits $ \commitlck -> do
@ -451,7 +451,7 @@ preventCommits = bracket setup cleanup
where where
setup = do setup = do
lck <- fromRepo $ indexFileLock . indexFile lck <- fromRepo $ indexFileLock . indexFile
liftIO $ Git.LockFile.openLock (fromRawFilePath lck) liftIO $ Git.LockFile.openLock lck
cleanup = liftIO . Git.LockFile.closeLock cleanup = liftIO . Git.LockFile.closeLock
{- Commits a given adjusted tree, with the provided parent ref. {- Commits a given adjusted tree, with the provided parent ref.
@ -631,7 +631,7 @@ reverseAdjustedTree basis adj csha = do
where where
m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $ m = M.fromList $ map (\i@(TreeItem f' _ _) -> (norm f', i)) $
map diffTreeToTreeItem changes map diffTreeToTreeItem changes
norm = normalise . fromRawFilePath . getTopFilePath norm = normalise . getTopFilePath
diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem
diffTreeToTreeItem dti = TreeItem diffTreeToTreeItem dti = TreeItem

123
Annex/Content.hs
View file

@ -110,7 +110,6 @@ import Utility.FileMode
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isSymbolicLink, linkCount) import System.PosixCompat.Files (isSymbolicLink, linkCount)
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
@ -248,7 +247,7 @@ lockContentForRemoval key fallback a = lockContentUsing lock key fallback $
{- Passed the object content file, and maybe a separate lock file to use, {- Passed the object content file, and maybe a separate lock file to use,
- when the content file itself should not be locked. -} - when the content file itself should not be locked. -}
type ContentLocker type ContentLocker
= RawFilePath = OsPath
-> Maybe LockFile -> Maybe LockFile
-> ->
( Annex (Maybe LockHandle) ( Annex (Maybe LockHandle)
@ -260,7 +259,7 @@ type ContentLocker
-- and prior to deleting the lock file, in order to -- and prior to deleting the lock file, in order to
-- ensure that no other processes also have a shared lock. -- ensure that no other processes also have a shared lock.
#else #else
, Maybe (RawFilePath -> Annex ()) , Maybe (OsPath -> Annex ())
-- ^ On Windows, this is called after the lock is dropped, -- ^ On Windows, this is called after the lock is dropped,
-- but before the lock file is cleaned up. -- but before the lock file is cleaned up.
#endif #endif
@ -278,7 +277,7 @@ winLocker takelock _ (Just lockfile) =
let lck = do let lck = do
modifyContentDir lockfile $ modifyContentDir lockfile $
void $ liftIO $ tryIO $ void $ liftIO $ tryIO $
writeFile (fromRawFilePath lockfile) "" writeFile (fromOsPath lockfile) ""
liftIO $ takelock lockfile liftIO $ takelock lockfile
in (lck, Nothing) in (lck, Nothing)
-- never reached; windows always uses a separate lock file -- never reached; windows always uses a separate lock file
@ -371,13 +370,13 @@ lockContentUsing contentlocker key fallback a = withContentLockFile key $ \mlock
cleanuplockfile lockfile = void $ tryNonAsync $ do cleanuplockfile lockfile = void $ tryNonAsync $ do
thawContentDir lockfile thawContentDir lockfile
liftIO $ removeWhenExistsWith R.removeLink lockfile liftIO $ removeWhenExistsWith R.removeLink $ fromOsPath lockfile
cleanObjectDirs lockfile cleanObjectDirs lockfile
{- Runs an action, passing it the temp file to get, {- Runs an action, passing it the temp file to get,
- and if the action succeeds, verifies the file matches - and if the action succeeds, verifies the file matches
- the key and moves the file into the annex as a key's content. -} - the key and moves the file into the annex as a key's content. -}
getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> Maybe FileSize -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> Maybe FileSize -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool
getViaTmp rsp v key af sz action = getViaTmp rsp v key af sz action =
checkDiskSpaceToGet key sz False $ checkDiskSpaceToGet key sz False $
getViaTmpFromDisk rsp v key af action getViaTmpFromDisk rsp v key af action
@ -385,10 +384,10 @@ getViaTmp rsp v key af sz action =
{- Like getViaTmp, but does not check that there is enough disk space {- Like getViaTmp, but does not check that there is enough disk space
- for the incoming key. For use when the key content is already on disk - for the incoming key. For use when the key content is already on disk
- and not being copied into place. -} - and not being copied into place. -}
getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (OsPath -> Annex (Bool, Verification)) -> Annex Bool
getViaTmpFromDisk rsp v key af action = checkallowed $ do getViaTmpFromDisk rsp v key af action = checkallowed $ do
tmpfile <- prepTmp key tmpfile <- prepTmp key
resuming <- liftIO $ R.doesPathExist tmpfile resuming <- liftIO $ R.doesPathExist $ fromOsPath tmpfile
(ok, verification) <- action tmpfile (ok, verification) <- action tmpfile
-- When the temp file already had content, we don't know if -- When the temp file already had content, we don't know if
-- that content is good or not, so only trust if it the action -- that content is good or not, so only trust if it the action
@ -434,11 +433,11 @@ getViaTmpFromDisk rsp v key af action = checkallowed $ do
- left off, and so if the bad content were not deleted, repeated downloads - left off, and so if the bad content were not deleted, repeated downloads
- would continue to fail. - would continue to fail.
-} -}
verificationOfContentFailed :: RawFilePath -> Annex () verificationOfContentFailed :: OsPath -> Annex ()
verificationOfContentFailed tmpfile = do verificationOfContentFailed tmpfile = do
warning "Verification of content failed" warning "Verification of content failed"
pruneTmpWorkDirBefore tmpfile pruneTmpWorkDirBefore tmpfile
(liftIO . removeWhenExistsWith R.removeLink) (liftIO . removeWhenExistsWith R.removeLink . fromOsPath)
{- Checks if there is enough free disk space to download a key {- Checks if there is enough free disk space to download a key
- to its temp file. - to its temp file.
@ -451,7 +450,7 @@ verificationOfContentFailed tmpfile = do
checkDiskSpaceToGet :: Key -> Maybe FileSize -> a -> Annex a -> Annex a checkDiskSpaceToGet :: Key -> Maybe FileSize -> a -> Annex a -> Annex a
checkDiskSpaceToGet key sz unabletoget getkey = do checkDiskSpaceToGet key sz unabletoget getkey = do
tmp <- fromRepo (gitAnnexTmpObjectLocation key) tmp <- fromRepo (gitAnnexTmpObjectLocation key)
e <- liftIO $ doesFileExist (fromRawFilePath tmp) e <- liftIO $ doesFileExist tmp
alreadythere <- liftIO $ if e alreadythere <- liftIO $ if e
then getFileSize tmp then getFileSize tmp
else return 0 else return 0
@ -463,7 +462,7 @@ checkDiskSpaceToGet key sz unabletoget getkey = do
, return unabletoget , return unabletoget
) )
prepTmp :: Key -> Annex RawFilePath prepTmp :: Key -> Annex OsPath
prepTmp key = do prepTmp key = do
tmp <- fromRepo $ gitAnnexTmpObjectLocation key tmp <- fromRepo $ gitAnnexTmpObjectLocation key
createAnnexDirectory (parentDir tmp) createAnnexDirectory (parentDir tmp)
@ -473,11 +472,11 @@ prepTmp key = do
- the temp file. If the action throws an exception, the temp file is - the temp file. If the action throws an exception, the temp file is
- left behind, which allows for resuming. - left behind, which allows for resuming.
-} -}
withTmp :: Key -> (RawFilePath -> Annex a) -> Annex a withTmp :: Key -> (OsPath -> Annex a) -> Annex a
withTmp key action = do withTmp key action = do
tmp <- prepTmp key tmp <- prepTmp key
res <- action tmp res <- action tmp
pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink . fromOsPath)
return res return res
{- Moves a key's content into .git/annex/objects/ {- Moves a key's content into .git/annex/objects/
@ -508,7 +507,7 @@ withTmp key action = do
- accepted into the repository. Will display a warning message in this - accepted into the repository. Will display a warning message in this
- case. May also throw exceptions in some cases. - case. May also throw exceptions in some cases.
-} -}
moveAnnex :: Key -> AssociatedFile -> RawFilePath -> Annex Bool moveAnnex :: Key -> AssociatedFile -> OsPath -> Annex Bool
moveAnnex key af src = ifM (checkSecureHashes' key) moveAnnex key af src = ifM (checkSecureHashes' key)
( do ( do
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
@ -522,7 +521,7 @@ moveAnnex key af src = ifM (checkSecureHashes' key)
, return False , return False
) )
where where
storeobject dest = ifM (liftIO $ R.doesPathExist dest) storeobject dest = ifM (liftIO $ R.doesPathExist $ fromOsPath dest)
( alreadyhave ( alreadyhave
, adjustedBranchRefresh af $ modifyContentDir dest $ do , adjustedBranchRefresh af $ modifyContentDir dest $ do
liftIO $ moveFile src dest liftIO $ moveFile src dest
@ -540,7 +539,7 @@ moveAnnex key af src = ifM (checkSecureHashes' key)
Database.Keys.addInodeCaches key Database.Keys.addInodeCaches key
(catMaybes (destic:ics)) (catMaybes (destic:ics))
) )
alreadyhave = liftIO $ R.removeLink src alreadyhave = liftIO $ R.removeLink $ fromOsPath src
checkSecureHashes :: Key -> Annex (Maybe String) checkSecureHashes :: Key -> Annex (Maybe String)
checkSecureHashes key = ifM (Backend.isCryptographicallySecureKey key) checkSecureHashes key = ifM (Backend.isCryptographicallySecureKey key)
@ -563,7 +562,7 @@ data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop
{- Populates the annex object file by hard linking or copying a source {- Populates the annex object file by hard linking or copying a source
- file to it. -} - file to it. -}
linkToAnnex :: Key -> RawFilePath -> Maybe InodeCache -> Annex LinkAnnexResult linkToAnnex :: Key -> OsPath -> Maybe InodeCache -> Annex LinkAnnexResult
linkToAnnex key src srcic = ifM (checkSecureHashes' key) linkToAnnex key src srcic = ifM (checkSecureHashes' key)
( do ( do
dest <- calcRepo (gitAnnexLocation key) dest <- calcRepo (gitAnnexLocation key)
@ -580,13 +579,13 @@ linkToAnnex key src srcic = ifM (checkSecureHashes' key)
- afterwards. Note that a consequence of this is that, if the file - afterwards. Note that a consequence of this is that, if the file
- already exists, it will be overwritten. - already exists, it will be overwritten.
-} -}
linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult linkFromAnnex :: Key -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult
linkFromAnnex key dest destmode = linkFromAnnex key dest destmode =
replaceFile' (const noop) dest (== LinkAnnexOk) $ \tmp -> replaceFile' (const noop) dest (== LinkAnnexOk) $ \tmp ->
linkFromAnnex' key tmp destmode linkFromAnnex' key tmp destmode
{- This is only safe to use when dest is not a worktree file. -} {- This is only safe to use when dest is not a worktree file. -}
linkFromAnnex' :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult linkFromAnnex' :: Key -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult
linkFromAnnex' key dest destmode = do linkFromAnnex' key dest destmode = do
src <- calcRepo (gitAnnexLocation key) src <- calcRepo (gitAnnexLocation key)
srcic <- withTSDelta (liftIO . genInodeCache src) srcic <- withTSDelta (liftIO . genInodeCache src)
@ -606,7 +605,7 @@ data FromTo = From | To
- -
- Nothing is done if the destination file already exists. - Nothing is done if the destination file already exists.
-} -}
linkAnnex :: FromTo -> Key -> RawFilePath -> Maybe InodeCache -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult linkAnnex :: FromTo -> Key -> OsPath -> Maybe InodeCache -> OsPath -> Maybe FileMode -> Annex LinkAnnexResult
linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed linkAnnex _ _ _ Nothing _ _ = return LinkAnnexFailed
linkAnnex fromto key src (Just srcic) dest destmode = linkAnnex fromto key src (Just srcic) dest destmode =
withTSDelta (liftIO . genInodeCache dest) >>= \case withTSDelta (liftIO . genInodeCache dest) >>= \case
@ -636,7 +635,7 @@ linkAnnex fromto key src (Just srcic) dest destmode =
catMaybes [destic, Just srcic] catMaybes [destic, Just srcic]
return LinkAnnexOk return LinkAnnexOk
_ -> do _ -> do
liftIO $ removeWhenExistsWith R.removeLink dest liftIO $ removeWhenExistsWith R.removeLink $ fromOsPath dest
failed failed
{- Removes the annex object file for a key. Lowlevel. -} {- Removes the annex object file for a key. Lowlevel. -}
@ -645,7 +644,7 @@ unlinkAnnex key = do
obj <- calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
modifyContentDir obj $ do modifyContentDir obj $ do
secureErase obj secureErase obj
liftIO $ removeWhenExistsWith R.removeLink obj liftIO $ removeWhenExistsWith R.removeLink $ fromOsPath obj
{- Runs an action to transfer an object's content. The action is also {- Runs an action to transfer an object's content. The action is also
- passed the size of the object. - passed the size of the object.
@ -680,7 +679,7 @@ sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o
prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool)) prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool))
prepSendAnnex key Nothing = withObjectLoc key $ \f -> do prepSendAnnex key Nothing = withObjectLoc key $ \f -> do
let retval c cs = return $ Just let retval c cs = return $ Just
( fromRawFilePath f ( fromOsPath f
, inodeCacheFileSize c , inodeCacheFileSize c
, sameInodeCache f cs , sameInodeCache f cs
) )
@ -705,7 +704,7 @@ prepSendAnnex key Nothing = withObjectLoc key $ \f -> do
Nothing -> return Nothing Nothing -> return Nothing
-- If the provided object file is the annex object file, handle as above. -- If the provided object file is the annex object file, handle as above.
prepSendAnnex key (Just o) = withObjectLoc key $ \aof -> prepSendAnnex key (Just o) = withObjectLoc key $ \aof ->
let o' = toRawFilePath o let o' = toOsPath o
in if aof == o' in if aof == o'
then prepSendAnnex key Nothing then prepSendAnnex key Nothing
else do else do
@ -751,7 +750,7 @@ cleanObjectLoc key cleaner = do
- -
- Does nothing if the object directory is not empty, and does not - Does nothing if the object directory is not empty, and does not
- throw an exception if it's unable to remove a directory. -} - throw an exception if it's unable to remove a directory. -}
cleanObjectDirs :: RawFilePath -> Annex () cleanObjectDirs :: OsPath -> Annex ()
cleanObjectDirs f = do cleanObjectDirs f = do
HashLevels n <- objectHashLevels <$> Annex.getGitConfig HashLevels n <- objectHashLevels <$> Annex.getGitConfig
liftIO $ go f (succ n) liftIO $ go f (succ n)
@ -761,14 +760,14 @@ cleanObjectDirs f = do
let dir = parentDir file let dir = parentDir file
maybe noop (const $ go dir (n-1)) maybe noop (const $ go dir (n-1))
<=< catchMaybeIO $ tryWhenExists $ <=< catchMaybeIO $ tryWhenExists $
removeDirectory (fromRawFilePath dir) removeDirectory dir
{- Removes a key's file from .git/annex/objects/ -} {- Removes a key's file from .git/annex/objects/ -}
removeAnnex :: ContentRemovalLock -> Annex () removeAnnex :: ContentRemovalLock -> Annex ()
removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
cleanObjectLoc key $ do cleanObjectLoc key $ do
secureErase file secureErase file
liftIO $ removeWhenExistsWith R.removeLink file liftIO $ removeWhenExistsWith R.removeLink $ fromOsPath file
g <- Annex.gitRepo g <- Annex.gitRepo
mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g) mapM_ (\f -> void $ tryIO $ resetpointer $ fromTopFilePath f g)
=<< Database.Keys.getAssociatedFiles key =<< Database.Keys.getAssociatedFiles key
@ -776,7 +775,7 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
where where
-- Check associated pointer file for modifications, and reset if -- Check associated pointer file for modifications, and reset if
-- it's unmodified. -- it's unmodified.
resetpointer file = unlessM (liftIO $ isSymbolicLink <$> R.getSymbolicLinkStatus file) $ resetpointer file = unlessM (liftIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath file)) $
ifM (isUnmodified key file) ifM (isUnmodified key file)
( adjustedBranchRefresh (AssociatedFile (Just file)) $ ( adjustedBranchRefresh (AssociatedFile (Just file)) $
depopulatePointerFile key file depopulatePointerFile key file
@ -789,11 +788,11 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file ->
{- Moves a key out of .git/annex/objects/ into .git/annex/bad, and {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and
- returns the file it was moved to. -} - returns the file it was moved to. -}
moveBad :: Key -> Annex RawFilePath moveBad :: Key -> Annex OsPath
moveBad key = do moveBad key = do
src <- calcRepo (gitAnnexLocation key) src <- calcRepo (gitAnnexLocation key)
bad <- fromRepo gitAnnexBadDir bad <- fromRepo gitAnnexBadDir
let dest = bad P.</> P.takeFileName src let dest = bad </> takeFileName src
createAnnexDirectory (parentDir dest) createAnnexDirectory (parentDir dest)
cleanObjectLoc key $ cleanObjectLoc key $
liftIO $ moveFile src dest liftIO $ moveFile src dest
@ -826,7 +825,7 @@ listKeys' keyloc want = do
then do then do
contents' <- filterM present contents contents' <- filterM present contents
keys <- filterM (Annex.eval s . want) $ keys <- filterM (Annex.eval s . want) $
mapMaybe (fileKey . P.takeFileName) contents' mapMaybe (fileKey . takeFileName) contents'
continue keys [] continue keys []
else do else do
let deeper = walk s (depth - 1) let deeper = walk s (depth - 1)
@ -844,8 +843,8 @@ listKeys' keyloc want = do
present _ | inanywhere = pure True present _ | inanywhere = pure True
present d = presentInAnnex d present d = presentInAnnex d
presentInAnnex = R.doesPathExist . contentfile presentInAnnex = R.doesPathExist . fromOsPath . contentfile
contentfile d = d P.</> P.takeFileName d contentfile d = d </> takeFileName d
{- Things to do to record changes to content when shutting down. {- Things to do to record changes to content when shutting down.
- -
@ -868,11 +867,11 @@ saveState nocommit = doSideAction $ do
- Otherwise, only displays one error message, from one of the urls - Otherwise, only displays one error message, from one of the urls
- that failed. - that failed.
-} -}
downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> FilePath -> Url.UrlOptions -> Annex Bool downloadUrl :: Bool -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> [Url.URLString] -> OsPath -> Url.UrlOptions -> Annex Bool
downloadUrl listfailedurls k p iv urls file uo = downloadUrl listfailedurls k p iv urls file uo =
-- Poll the file to handle configurations where an external -- Poll the file to handle configurations where an external
-- download command is used. -- download command is used.
meteredFile (toRawFilePath file) (Just p) k (go urls []) meteredFile file (Just p) k (go urls [])
where where
go (u:us) errs p' = Url.download' p' iv u file uo >>= \case go (u:us) errs p' = Url.download' p' iv u file uo >>= \case
Right () -> return True Right () -> return True
@ -898,18 +897,18 @@ downloadUrl listfailedurls k p iv urls file uo =
{- Copies a key's content, when present, to a temp file. {- Copies a key's content, when present, to a temp file.
- This is used to speed up some rsyncs. -} - This is used to speed up some rsyncs. -}
preseedTmp :: Key -> FilePath -> Annex Bool preseedTmp :: Key -> OsPath -> Annex Bool
preseedTmp key file = go =<< inAnnex key preseedTmp key file = go =<< inAnnex key
where where
go False = return False go False = return False
go True = do go True = do
ok <- copy ok <- copy
when ok $ thawContent (toRawFilePath file) when ok $ thawContent file
return ok return ok
copy = ifM (liftIO $ doesFileExist file) copy = ifM (liftIO $ doesFileExist file)
( return True ( return True
, do , do
s <- fromRawFilePath <$> (calcRepo $ gitAnnexLocation key) s <- calcRepo $ gitAnnexLocation key
liftIO $ ifM (doesFileExist s) liftIO $ ifM (doesFileExist s)
( copyFileExternal CopyTimeStamps s file ( copyFileExternal CopyTimeStamps s file
, return False , return False
@ -918,15 +917,15 @@ preseedTmp key file = go =<< inAnnex key
{- Finds files directly inside a directory like gitAnnexBadDir {- Finds files directly inside a directory like gitAnnexBadDir
- (not in subdirectories) and returns the corresponding keys. -} - (not in subdirectories) and returns the corresponding keys. -}
dirKeys :: (Git.Repo -> RawFilePath) -> Annex [Key] dirKeys :: (Git.Repo -> OsPath) -> Annex [Key]
dirKeys dirspec = do dirKeys dirspec = do
dir <- fromRawFilePath <$> fromRepo dirspec dir <- fromRepo dirspec
ifM (liftIO $ doesDirectoryExist dir) ifM (liftIO $ doesDirectoryExist dir)
( do ( do
contents <- liftIO $ getDirectoryContents dir contents <- liftIO $ getDirectoryContents dir
files <- liftIO $ filterM doesFileExist $ files <- liftIO $ filterM doesFileExist $
map (dir </>) contents map (dir </>) contents
return $ mapMaybe (fileKey . P.takeFileName . toRawFilePath) files return $ mapMaybe (fileKey . takeFileName) files
, return [] , return []
) )
@ -936,7 +935,7 @@ dirKeys dirspec = do
- Also, stale keys that can be proven to have no value - Also, stale keys that can be proven to have no value
- (ie, their content is already present) are deleted. - (ie, their content is already present) are deleted.
-} -}
staleKeysPrune :: (Git.Repo -> RawFilePath) -> Bool -> Annex [Key] staleKeysPrune :: (Git.Repo -> OsPath) -> Bool -> Annex [Key]
staleKeysPrune dirspec nottransferred = do staleKeysPrune dirspec nottransferred = do
contents <- dirKeys dirspec contents <- dirKeys dirspec
@ -945,8 +944,8 @@ staleKeysPrune dirspec nottransferred = do
dir <- fromRepo dirspec dir <- fromRepo dirspec
forM_ dups $ \k -> forM_ dups $ \k ->
pruneTmpWorkDirBefore (dir P.</> keyFile k) pruneTmpWorkDirBefore (dir </> keyFile k)
(liftIO . R.removeLink) (liftIO . R.removeLink . fromOsPath)
if nottransferred if nottransferred
then do then do
@ -961,9 +960,9 @@ staleKeysPrune dirspec nottransferred = do
- This preserves the invariant that the workdir never exists without - This preserves the invariant that the workdir never exists without
- the content file. - the content file.
-} -}
pruneTmpWorkDirBefore :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a pruneTmpWorkDirBefore :: OsPath -> (OsPath -> Annex a) -> Annex a
pruneTmpWorkDirBefore f action = do pruneTmpWorkDirBefore f action = do
let workdir = fromRawFilePath $ gitAnnexTmpWorkDir f let workdir = gitAnnexTmpWorkDir f
liftIO $ whenM (doesDirectoryExist workdir) $ liftIO $ whenM (doesDirectoryExist workdir) $
removeDirectoryRecursive workdir removeDirectoryRecursive workdir
action f action f
@ -978,22 +977,21 @@ pruneTmpWorkDirBefore f action = do
- the temporary work directory is retained (unless - the temporary work directory is retained (unless
- empty), so anything in it can be used on resume. - empty), so anything in it can be used on resume.
-} -}
withTmpWorkDir :: Key -> (RawFilePath -> Annex (Maybe a)) -> Annex (Maybe a) withTmpWorkDir :: Key -> (OsPath -> Annex (Maybe a)) -> Annex (Maybe a)
withTmpWorkDir key action = do withTmpWorkDir key action = do
-- Create the object file if it does not exist. This way, -- Create the object file if it does not exist. This way,
-- staleKeysPrune only has to look for object files, and can -- staleKeysPrune only has to look for object files, and can
-- clean up gitAnnexTmpWorkDir for those it finds. -- clean up gitAnnexTmpWorkDir for those it finds.
obj <- prepTmp key obj <- prepTmp key
let obj' = fromRawFilePath obj unlessM (liftIO $ doesFileExist obj) $ do
unlessM (liftIO $ doesFileExist obj') $ do liftIO $ writeFile (fromOsPath obj) ""
liftIO $ writeFile obj' ""
setAnnexFilePerm obj setAnnexFilePerm obj
let tmpdir = gitAnnexTmpWorkDir obj let tmpdir = gitAnnexTmpWorkDir obj
createAnnexDirectory tmpdir createAnnexDirectory tmpdir
res <- action tmpdir res <- action tmpdir
case res of case res of
Just _ -> liftIO $ removeDirectoryRecursive (fromRawFilePath tmpdir) Just _ -> liftIO $ removeDirectoryRecursive tmpdir
Nothing -> liftIO $ void $ tryIO $ removeDirectory (fromRawFilePath tmpdir) Nothing -> liftIO $ void $ tryIO $ removeDirectory tmpdir
return res return res
{- Finds items in the first, smaller list, that are not {- Finds items in the first, smaller list, that are not
@ -1028,12 +1026,12 @@ getKeyStatus :: Key -> Annex KeyStatus
getKeyStatus key = catchDefaultIO KeyMissing $ do getKeyStatus key = catchDefaultIO KeyMissing $ do
afs <- not . null <$> Database.Keys.getAssociatedFiles key afs <- not . null <$> Database.Keys.getAssociatedFiles key
obj <- calcRepo (gitAnnexLocation key) obj <- calcRepo (gitAnnexLocation key)
multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus obj)) multilink <- ((> 1) . linkCount <$> liftIO (R.getFileStatus (fromOsPath obj)))
return $ if multilink && afs return $ if multilink && afs
then KeyUnlockedThin then KeyUnlockedThin
else KeyPresent else KeyPresent
getKeyFileStatus :: Key -> RawFilePath -> Annex KeyStatus getKeyFileStatus :: Key -> OsPath -> Annex KeyStatus
getKeyFileStatus key file = do getKeyFileStatus key file = do
s <- getKeyStatus key s <- getKeyStatus key
case s of case s of
@ -1071,23 +1069,22 @@ contentSize key = catchDefaultIO Nothing $
- timestamp. The file is written atomically, so when it contained an - timestamp. The file is written atomically, so when it contained an
- earlier timestamp, a reader will always see one or the other timestamp. - earlier timestamp, a reader will always see one or the other timestamp.
-} -}
writeContentRetentionTimestamp :: Key -> RawFilePath -> POSIXTime -> Annex () writeContentRetentionTimestamp :: Key -> OsPath -> POSIXTime -> Annex ()
writeContentRetentionTimestamp key rt t = do writeContentRetentionTimestamp key rt t = do
lckfile <- calcRepo (gitAnnexContentRetentionTimestampLock key) lckfile <- calcRepo (gitAnnexContentRetentionTimestampLock key)
modifyContentDirWhenExists lckfile $ bracket (lock lckfile) unlock $ \_ -> modifyContentDirWhenExists lckfile $ bracket (lock lckfile) unlock $ \_ ->
readContentRetentionTimestamp rt >>= \case readContentRetentionTimestamp rt >>= \case
Just ts | ts >= t -> return () Just ts | ts >= t -> return ()
_ -> replaceFile (const noop) rt $ \tmp -> _ -> replaceFile (const noop) rt $ \tmp ->
liftIO $ writeFile (fromRawFilePath tmp) $ show t liftIO $ writeFile (fromOsPath tmp) $ show t
where where
lock = takeExclusiveLock lock = takeExclusiveLock
unlock = liftIO . dropLock unlock = liftIO . dropLock
{- Does not need locking because the file is written atomically. -} {- Does not need locking because the file is written atomically. -}
readContentRetentionTimestamp :: RawFilePath -> Annex (Maybe POSIXTime) readContentRetentionTimestamp :: OsPath -> Annex (Maybe POSIXTime)
readContentRetentionTimestamp rt = readContentRetentionTimestamp rt =
liftIO $ join <$> tryWhenExists liftIO $ join <$> tryWhenExists (parsePOSIXTime <$> F.readFile' rt)
(parsePOSIXTime <$> F.readFile' (toOsPath rt))
{- Checks if the retention timestamp is in the future, if so returns {- Checks if the retention timestamp is in the future, if so returns
- Nothing. - Nothing.
@ -1118,8 +1115,8 @@ checkRetentionTimestamp key locker = do
{- Remove the retention timestamp and its lock file. Another lock must {- Remove the retention timestamp and its lock file. Another lock must
- be held, that prevents anything else writing to the file at the same - be held, that prevents anything else writing to the file at the same
- time. -} - time. -}
removeRetentionTimeStamp :: Key -> RawFilePath -> Annex () removeRetentionTimeStamp :: Key -> OsPath -> Annex ()
removeRetentionTimeStamp key rt = modifyContentDirWhenExists rt $ do removeRetentionTimeStamp key rt = modifyContentDirWhenExists rt $ do
liftIO $ removeWhenExistsWith R.removeLink rt liftIO $ removeWhenExistsWith R.removeLink $ fromOsPath rt
rtl <- calcRepo (gitAnnexContentRetentionTimestampLock key) rtl <- calcRepo (gitAnnexContentRetentionTimestampLock key)
liftIO $ removeWhenExistsWith R.removeLink rtl liftIO $ removeWhenExistsWith R.removeLink $ fromOsPath rtl