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

RawFilePath conversion of System.Directory

Browse source 
By using System.Directory.OsPath, which takes and returns OsString,
which is a ShortByteString. So, things like dirContents currently have the
overhead of copying that to a ByteString, but that should be less than
the overhead of using Strings which often in turn were converted to
RawFilePaths.

Added Utility.OsString and the OsString build flag. That flag is turned
on in the stack.yaml, and will be turned on automatically by cabal when
built with new enough libraries. The stack.yaml change is a bit ugly,
and that could be reverted for now if it causes any problems.

Note that Utility.OsString.toOsString on windows is avoiding only a
check of encoding that is documented as being unlikely to fail. I don't
think it can fail in git-annex; if it could, git-annex didn't contain
such an encoding check before, so at worst that should be a wash.
This commit is contained in:
Joey Hess 2025-01-20 18:03:26 -04:00
parent e5be81f8d4
commit 1ceece3108
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
34 changed files with 222 additions and 138 deletions
Download patch file Download diff file Expand all files Collapse all files

13
Annex/AdjustedBranch/Merge.hs
View file

@ -29,6 +29,7 @@ import Annex.GitOverlay
import Utility.Tmp.Dir import Utility.Tmp.Dir
import Utility.CopyFile import Utility.CopyFile
import Utility.Directory.Create import Utility.Directory.Create
import qualified Utility.RawFilePath as R
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
@ -72,7 +73,6 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
-} -}
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
git_dir <- fromRepo Git.localGitDir git_dir <- fromRepo Git.localGitDir
let git_dir' = fromRawFilePath git_dir
tmpwt <- fromRepo gitAnnexMergeDir tmpwt <- fromRepo gitAnnexMergeDir
withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
@ -82,16 +82,15 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
-- causes it not to look in GIT_DIR for refs. -- causes it not to look in GIT_DIR for refs.
refs <- liftIO $ emptyWhenDoesNotExist $ refs <- liftIO $ emptyWhenDoesNotExist $
dirContentsRecursive $ dirContentsRecursive $
git_dir' </> "refs" git_dir P.</> "refs"
let refs' = (git_dir' </> "packed-refs") : refs let refs' = (git_dir P.</> "packed-refs") : refs
liftIO $ forM_ refs' $ \src -> do liftIO $ forM_ refs' $ \src -> do
let src' = toRawFilePath src whenM (R.doesPathExist src) $ do
whenM (doesFileExist src) $ do dest <- relPathDirToFile git_dir src
dest <- relPathDirToFile git_dir src'
let dest' = toRawFilePath tmpgit P.</> dest let dest' = toRawFilePath tmpgit P.</> dest
createDirectoryUnder [git_dir] createDirectoryUnder [git_dir]
(P.takeDirectory dest') (P.takeDirectory dest')
void $ createLinkOrCopy src' dest' void $ createLinkOrCopy src dest'
-- This reset makes git merge not care -- This reset makes git merge not care
-- that the work tree is empty; otherwise -- that the work tree is empty; otherwise
-- it will think that all the files have -- it will think that all the files have

2
Annex/Branch.hs
View file

@ -753,7 +753,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
Nothing -> return () Nothing -> return ()
Just file -> do Just file -> do
let path = dir P.</> toRawFilePath file let path = dir P.</> toRawFilePath file
unless (dirCruft file) $ whenM (isfile path) $ do unless (dirCruft (toRawFilePath file)) $ whenM (isfile path) $ do
sha <- Git.HashObject.hashFile h path sha <- Git.HashObject.hashFile h path
hPutStrLn jlogh file hPutStrLn jlogh file
streamer $ Git.UpdateIndex.updateIndexLine streamer $ Git.UpdateIndex.updateIndexLine

8
Annex/Content.hs
View file

@ -817,7 +817,7 @@ listKeys' keyloc want = do
s <- Annex.getState id s <- Annex.getState id
r <- Annex.getRead id r <- Annex.getRead id
depth <- gitAnnexLocationDepth <$> Annex.getGitConfig depth <- gitAnnexLocationDepth <$> Annex.getGitConfig
liftIO $ walk (s, r) depth (fromRawFilePath dir) liftIO $ walk (s, r) depth dir
where where
walk s depth dir = do walk s depth dir = do
contents <- catchDefaultIO [] (dirContents dir) contents <- catchDefaultIO [] (dirContents dir)
@ -825,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 . toRawFilePath) contents' mapMaybe (fileKey . P.takeFileName) contents'
continue keys [] continue keys []
else do else do
let deeper = walk s (depth - 1) let deeper = walk s (depth - 1)
@ -843,8 +843,8 @@ listKeys' keyloc want = do
present _ | inanywhere = pure True present _ | inanywhere = pure True
present d = presentInAnnex d present d = presentInAnnex d
presentInAnnex = doesFileExist . contentfile presentInAnnex = R.doesPathExist . contentfile
contentfile d = d </> takeFileName d contentfile d = d P.</> P.takeFileName d
{- Things to do to record changes to content when shutting down. {- Things to do to record changes to content when shutting down.
- -

2
Annex/RepoSize/LiveUpdate.hs
View file

@ -161,7 +161,7 @@ checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do
where where
go livedir lck pidlockfile now = do go livedir lck pidlockfile now = do
void $ tryNonAsync $ do void $ tryNonAsync $ do
lockfiles <- liftIO $ filter (not . dirCruft) lockfiles <- liftIO $ filter (not . dirCruft . toRawFilePath)
<$> getDirectoryContents (fromRawFilePath livedir) <$> getDirectoryContents (fromRawFilePath livedir)
stale <- forM lockfiles $ \lockfile -> stale <- forM lockfiles $ \lockfile ->
if (lockfile /= pidlockfile) if (lockfile /= pidlockfile)

30
Annex/Ssh.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 Annex.Ssh ( module Annex.Ssh (
@ -100,15 +101,16 @@ consumeStdinParams NoConsumeStdin = [Param "-n"]
{- Returns a filename to use for a ssh connection caching socket, and {- Returns a filename to use for a ssh connection caching socket, and
- parameters to enable ssh connection caching. -} - parameters to enable ssh connection caching. -}
sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam]) sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe RawFilePath, [CommandParam])
sshCachingInfo (host, port) = go =<< sshCacheDir' sshCachingInfo (host, port) = go =<< sshCacheDir'
where where
go (Right dir) = go (Right dir) =
liftIO (bestSocketPath $ dir P.</> hostport2socket host port) >>= return . \case liftIO (bestSocketPath $ dir P.</> hostport2socket host port) >>= return . \case
Nothing -> (Nothing, []) Nothing -> (Nothing, [])
Just socketfile -> Just socketfile ->
let socketfile' = fromRawFilePath socketfile (Just socketfile
in (Just socketfile', sshConnectionCachingParams socketfile') , sshConnectionCachingParams (fromRawFilePath socketfile)
)
-- No connection caching with concurrency is not a good -- No connection caching with concurrency is not a good
-- combination, so warn the user. -- combination, so warn the user.
go (Left whynocaching) = do go (Left whynocaching) = do
@ -214,7 +216,7 @@ portParams (Just port) = [Param "-p", Param $ show port]
- Locks the socket lock file to prevent other git-annex processes from - Locks the socket lock file to prevent other git-annex processes from
- stopping the ssh multiplexer on this socket. - stopping the ssh multiplexer on this socket.
-} -}
prepSocket :: FilePath -> SshHost -> [CommandParam] -> Annex () prepSocket :: RawFilePath -> SshHost -> [CommandParam] -> Annex ()
prepSocket socketfile sshhost sshparams = do prepSocket socketfile sshhost sshparams = do
-- There could be stale ssh connections hanging around -- There could be stale ssh connections hanging around
-- from a previous git-annex run that was interrupted. -- from a previous git-annex run that was interrupted.
@ -286,13 +288,13 @@ prepSocket socketfile sshhost sshparams = do
- and this check makes such files be skipped since the corresponding lock - and this check makes such files be skipped since the corresponding lock
- file won't exist. - file won't exist.
-} -}
enumSocketFiles :: Annex [FilePath] enumSocketFiles :: Annex [RawFilePath]
enumSocketFiles = liftIO . go =<< sshCacheDir enumSocketFiles = liftIO . go =<< sshCacheDir
where where
go Nothing = return [] go Nothing = return []
go (Just dir) = filterM (R.doesPathExist . socket2lock) go (Just dir) = filterM (R.doesPathExist . socket2lock)
=<< filter (not . isLock) =<< filter (not . isLock)
<$> catchDefaultIO [] (dirContents (fromRawFilePath dir)) <$> catchDefaultIO [] (dirContents dir)
{- Stop any unused ssh connection caching processes. -} {- Stop any unused ssh connection caching processes. -}
sshCleanup :: Annex () sshCleanup :: Annex ()
@ -324,9 +326,9 @@ sshCleanup = mapM_ cleanup =<< enumSocketFiles
forceSshCleanup :: Annex () forceSshCleanup :: Annex ()
forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
forceStopSsh :: FilePath -> Annex () forceStopSsh :: RawFilePath -> Annex ()
forceStopSsh socketfile = withNullHandle $ \nullh -> do forceStopSsh socketfile = withNullHandle $ \nullh -> do
let (dir, base) = splitFileName socketfile let (dir, base) = splitFileName (fromRawFilePath socketfile)
let p = (proc "ssh" $ toCommand $ let p = (proc "ssh" $ toCommand $
[ Param "-O", Param "stop" ] ++ [ Param "-O", Param "stop" ] ++
sshConnectionCachingParams base ++ sshConnectionCachingParams base ++
@ -338,7 +340,7 @@ forceStopSsh socketfile = withNullHandle $ \nullh -> do
} }
void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid -> void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid ->
forceSuccessProcess p pid forceSuccessProcess p pid
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath socketfile) liftIO $ removeWhenExistsWith R.removeLink socketfile
{- This needs to be as short as possible, due to limitations on the length {- This needs to be as short as possible, due to limitations on the length
- of the path to a socket file. At the same time, it needs to be unique - of the path to a socket file. At the same time, it needs to be unique
@ -355,13 +357,13 @@ hostport2socket' s
where where
lengthofmd5s = 32 lengthofmd5s = 32
socket2lock :: FilePath -> RawFilePath socket2lock :: RawFilePath -> RawFilePath
socket2lock socket = toRawFilePath (socket ++ lockExt) socket2lock socket = socket <> lockExt
isLock :: FilePath -> Bool isLock :: RawFilePath -> Bool
isLock f = lockExt `isSuffixOf` f isLock f = lockExt `S.isSuffixOf` f
lockExt :: String lockExt :: S.ByteString
lockExt = ".lock" lockExt = ".lock"
{- This is the size of the sun_path component of sockaddr_un, which {- This is the size of the sun_path component of sockaddr_un, which

10
Annex/Tmp.hs
View file

@ -60,15 +60,17 @@ cleanupOtherTmp = do
void $ tryIO $ tryExclusiveLock tmplck $ do void $ tryIO $ tryExclusiveLock tmplck $ do
tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld oldtmp <- fromRepo gitAnnexTmpOtherDirOld
liftIO $ mapM_ cleanold liftIO $ mapM_ cleanold
=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp) =<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty -- remove when empty
liftIO $ void $ tryIO $
removeDirectory (fromRawFilePath oldtmp)
where where
cleanold f = do cleanold f = do
now <- liftIO getPOSIXTime now <- liftIO getPOSIXTime
let oldenough = now - (60 * 60 * 24 * 7) let oldenough = now - (60 * 60 * 24 * 7)
catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus (toRawFilePath f)) >>= \case catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus f) >>= \case
Just mtime | realToFrac mtime <= oldenough -> Just mtime | realToFrac mtime <= oldenough ->
void $ tryIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) void $ tryIO $ removeWhenExistsWith R.removeLink f
_ -> return () _ -> return ()

9
Annex/YoutubeDl.hs
View file

@ -30,6 +30,7 @@ import Utility.Metered
import Utility.Tmp import Utility.Tmp
import Messages.Progress import Messages.Progress
import Logs.Transfer import Logs.Transfer
import qualified Utility.RawFilePath as R
import Network.URI import Network.URI
import Control.Concurrent.Async import Control.Concurrent.Async
@ -101,9 +102,9 @@ youtubeDl' url workdir p uo
| isytdlp cmd = liftIO $ | isytdlp cmd = liftIO $
(nub . lines <$> readFile filelistfile) (nub . lines <$> readFile filelistfile)
`catchIO` (pure . const []) `catchIO` (pure . const [])
| otherwise = workdirfiles | otherwise = map fromRawFilePath <$> workdirfiles
workdirfiles = liftIO $ filter (/= filelistfile) workdirfiles = liftIO $ filter (/= toRawFilePath filelistfile)
<$> (filterM (doesFileExist) =<< dirContents workdir) <$> (filterM R.doesPathExist =<< dirContents (toRawFilePath workdir))
filelistfile = workdir </> filelistfilebase filelistfile = workdir </> filelistfilebase
filelistfilebase = "git-annex-file-list-file" filelistfilebase = "git-annex-file-list-file"
isytdlp cmd = cmd == "yt-dlp" isytdlp cmd = cmd == "yt-dlp"
@ -159,7 +160,7 @@ youtubeDlMaxSize workdir = ifM (Annex.getRead Annex.force)
Just have -> do Just have -> do
inprogress <- sizeOfDownloadsInProgress (const True) inprogress <- sizeOfDownloadsInProgress (const True)
partial <- liftIO $ sum partial <- liftIO $ sum
<$> (mapM (getFileSize . toRawFilePath) =<< dirContents workdir) <$> (mapM getFileSize =<< dirContents (toRawFilePath workdir))
reserve <- annexDiskReserve <$> Annex.getGitConfig reserve <- annexDiskReserve <$> Annex.getGitConfig
let maxsize = have - reserve - inprogress + partial let maxsize = have - reserve - inprogress + partial
if maxsize > 0 if maxsize > 0

19
Assistant/Repair.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 Assistant.Repair where module Assistant.Repair where
@ -33,6 +34,8 @@ import Utility.ThreadScheduler
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import Control.Concurrent.Async import Control.Concurrent.Async
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
{- When the FsckResults require a repair, tries to do a non-destructive {- When the FsckResults require a repair, tries to do a non-destructive
- repair. If that fails, pops up an alert. -} - repair. If that fails, pops up an alert. -}
@ -132,26 +135,26 @@ repairStaleGitLocks r = do
repairStaleLocks lockfiles repairStaleLocks lockfiles
return $ not $ null lockfiles return $ not $ null lockfiles
where where
findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator (fromRawFilePath annexDir)) True . fromRawFilePath . Git.localGitDir findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir
islock f islock f
| "gc.pid" `isInfixOf` f = False | "gc.pid" `S.isInfixOf` f = False
| ".lock" `isSuffixOf` f = True | ".lock" `S.isSuffixOf` f = True
| takeFileName f == "MERGE_HEAD" = True | P.takeFileName f == "MERGE_HEAD" = True
| otherwise = False | otherwise = False
repairStaleLocks :: [FilePath] -> Assistant () repairStaleLocks :: [RawFilePath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes repairStaleLocks lockfiles = go =<< getsizes
where where
getsize lf = catchMaybeIO $ (\s -> (lf, s)) getsize lf = catchMaybeIO $ (\s -> (lf, s))
<$> getFileSize (toRawFilePath lf) <$> getFileSize lf
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return () go [] = return ()
go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l)) go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromRawFilePath . fst) l))
( do ( do
waitforit "to check stale git lock file" waitforit "to check stale git lock file"
l' <- getsizes l' <- getsizes
if l' == l if l' == l
then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath . fst) l then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l
else go l' else go l'
, do , do
waitforit "for git lock file writer" waitforit "for git lock file writer"

6
Assistant/Threads/TransferWatcher.hs
View file

@ -57,7 +57,7 @@ onErr = giveup
{- Called when a new transfer information file is written. -} {- Called when a new transfer information file is written. -}
onAdd :: Handler onAdd :: Handler
onAdd file = case parseTransferFile file of onAdd file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t) Just t -> go t =<< liftAnnex (checkTransfer t)
where where
@ -73,7 +73,7 @@ onAdd file = case parseTransferFile file of
- The only thing that should change in the transfer info is the - The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -} - bytesComplete, so that's the only thing updated in the DaemonStatus. -}
onModify :: Handler onModify :: Handler
onModify file = case parseTransferFile file of onModify file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop Nothing -> noop
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file) Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
where where
@ -88,7 +88,7 @@ watchesTransferSize = modifyTracked
{- Called when a transfer information file is removed. -} {- Called when a transfer information file is removed. -}
onDel :: Handler onDel :: Handler
onDel file = case parseTransferFile file of onDel file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop Nothing -> noop
Just t -> do Just t -> do
debug [ "transfer finishing:", show t] debug [ "transfer finishing:", show t]

11
Assistant/Upgrade.hs
View file

@ -41,6 +41,7 @@ import qualified Utility.Url as Url
import qualified Annex.Url as Url hiding (download) import qualified Annex.Url as Url hiding (download)
import Utility.Tuple import Utility.Tuple
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified System.FilePath.ByteString as P
import Data.Either import Data.Either
import qualified Data.Map as M import qualified Data.Map as M
@ -212,8 +213,8 @@ upgradeToDistribution newdir cleanup distributionfile = do
makeorigsymlink olddir makeorigsymlink olddir
return (newdir </> "git-annex", deleteold) return (newdir </> "git-annex", deleteold)
installby a dstdir srcdir = installby a dstdir srcdir =
mapM_ (\x -> a (toRawFilePath x) (toRawFilePath (dstdir </> takeFileName x))) mapM_ (\x -> a x (toRawFilePath dstdir P.</> P.takeFileName x))
=<< dirContents srcdir =<< dirContents (toRawFilePath srcdir)
#endif #endif
sanitycheck dir = sanitycheck dir =
unlessM (doesDirectoryExist dir) $ unlessM (doesDirectoryExist dir) $
@ -280,14 +281,14 @@ deleteFromManifest dir = do
fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest) fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs
removeWhenExistsWith R.removeLink (toRawFilePath manifest) removeWhenExistsWith R.removeLink (toRawFilePath manifest)
removeEmptyRecursive dir removeEmptyRecursive (toRawFilePath dir)
where where
manifest = dir </> "git-annex.MANIFEST" manifest = dir </> "git-annex.MANIFEST"
removeEmptyRecursive :: FilePath -> IO () removeEmptyRecursive :: RawFilePath -> IO ()
removeEmptyRecursive dir = do removeEmptyRecursive dir = do
mapM_ removeEmptyRecursive =<< dirContents dir mapM_ removeEmptyRecursive =<< dirContents dir
void $ tryIO $ removeDirectory dir void $ tryIO $ removeDirectory (fromRawFilePath dir)
{- This is a file that the UpgradeWatcher can watch for modifications to {- This is a file that the UpgradeWatcher can watch for modifications to
- detect when git-annex has been upgraded. - detect when git-annex has been upgraded.

2
Assistant/WebApp/Configurators/Delete.hs
View file

@ -89,7 +89,7 @@ deleteCurrentRepository = dangerPage $ do
rs <- syncRemotes <$> getDaemonStatus rs <- syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs mapM_ (\r -> changeSyncable (Just r) False) rs
liftAnnex $ prepareRemoveAnnexDir dir liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir)
liftIO $ removeDirectoryRecursive . fromRawFilePath liftIO $ removeDirectoryRecursive . fromRawFilePath
=<< absPath (toRawFilePath dir) =<< absPath (toRawFilePath dir)

2
Build/LinuxMkLibs.hs
View file

@ -80,7 +80,7 @@ consolidateUsrLib top libdirs = go [] libdirs
forM_ fs $ \f -> do forM_ fs $ \f -> do
let src = inTop top (x </> f) let src = inTop top (x </> f)
let dst = inTop top (d </> f) let dst = inTop top (d </> f)
unless (dirCruft f) $ unless (dirCruft (toRawFilePath f)) $
unlessM (doesDirectoryExist src) $ unlessM (doesDirectoryExist src) $
renameFile src dst renameFile src dst
symlinkHwCapDirs top d symlinkHwCapDirs top d

5
CmdLine/GitRemoteAnnex.hs
View file

@ -57,6 +57,7 @@ import Utility.Tmp.Dir
import Utility.Env import Utility.Env
import Utility.Metered import Utility.Metered
import Utility.FileMode import Utility.FileMode
import qualified Utility.RawFilePath as R
import Network.URI import Network.URI
import Data.Either import Data.Either
@ -65,7 +66,6 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
import qualified Utility.RawFilePath as R
import qualified Data.Set as S import qualified Data.Set as S
run :: [String] -> IO () run :: [String] -> IO ()
@ -1162,7 +1162,8 @@ specialRemoteFromUrl sab a = withTmpDir "journal" $ \tmpdir -> do
-- objects are deleted. -- objects are deleted.
cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex () cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex ()
cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do
liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir liftIO $ mapM_ R.removeLink
=<< dirContents (toRawFilePath alternatejournaldir)
case sab of case sab of
AnnexBranchExistedAlready _ -> noop AnnexBranchExistedAlready _ -> noop
AnnexBranchCreatedEmpty r -> AnnexBranchCreatedEmpty r ->

6
CmdLine/Seek.hs
View file

@ -56,6 +56,7 @@ import Data.IORef
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID) import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID)
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
import qualified Data.ByteString as S
data AnnexedFileSeeker = AnnexedFileSeeker data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart { startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart
@ -122,9 +123,8 @@ withPathContents a params = do
-- exist. -- exist.
get p = ifM (isDirectory <$> R.getFileStatus p') get p = ifM (isDirectory <$> R.getFileStatus p')
( map (\f -> ( map (\f ->
let f' = toRawFilePath f (f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f))
in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f')) <$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p'
<$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) False p
, return [(p', P.takeFileName p')] , return [(p', P.takeFileName p')]
) )
where where

4
Command/P2PHttp.hs
View file

@ -266,8 +266,8 @@ getAuthEnv = do
findRepos :: Options -> IO [Git.Repo] findRepos :: Options -> IO [Git.Repo]
findRepos o = do findRepos o = do
files <- map toRawFilePath . concat files <- concat
<$> mapM dirContents (directoryOption o) <$> mapM (dirContents . toRawFilePath) (directoryOption o)
map Git.Construct.newFrom . catMaybes map Git.Construct.newFrom . catMaybes
<$> mapM Git.Construct.checkForRepo files <$> mapM Git.Construct.checkForRepo files

10
Command/Uninit.hs
View file

@ -102,14 +102,14 @@ startCheckIncomplete recordnotok file key =
removeAnnexDir :: CommandCleanup -> CommandStart removeAnnexDir :: CommandCleanup -> CommandStart
removeAnnexDir recordok = do removeAnnexDir recordok = do
Annex.Queue.flush Annex.Queue.flush
annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir annexdir <- fromRepo gitAnnexDir
annexobjectdir <- fromRepo gitAnnexObjectDir annexobjectdir <- fromRepo gitAnnexObjectDir
starting ("uninit objects") (ActionItemOther Nothing) (SeekInput []) $ do starting ("uninit objects") (ActionItemOther Nothing) (SeekInput []) $ do
leftovers <- removeUnannexed =<< listKeys InAnnex leftovers <- removeUnannexed =<< listKeys InAnnex
prepareRemoveAnnexDir annexdir prepareRemoveAnnexDir annexdir
if null leftovers if null leftovers
then do then do
liftIO $ removeDirectoryRecursive annexdir liftIO $ removeDirectoryRecursive (fromRawFilePath annexdir)
next recordok next recordok
else giveup $ unlines else giveup $ unlines
[ "Not fully uninitialized" [ "Not fully uninitialized"
@ -134,15 +134,15 @@ removeAnnexDir recordok = do
- -
- Also closes sqlite databases that might be in the directory, - Also closes sqlite databases that might be in the directory,
- to avoid later failure to write any cached changes to them. -} - to avoid later failure to write any cached changes to them. -}
prepareRemoveAnnexDir :: FilePath -> Annex () prepareRemoveAnnexDir :: RawFilePath -> Annex ()
prepareRemoveAnnexDir annexdir = do prepareRemoveAnnexDir annexdir = do
Database.Keys.closeDb Database.Keys.closeDb
liftIO $ prepareRemoveAnnexDir' annexdir liftIO $ prepareRemoveAnnexDir' annexdir
prepareRemoveAnnexDir' :: FilePath -> IO () prepareRemoveAnnexDir' :: RawFilePath -> IO ()
prepareRemoveAnnexDir' annexdir = prepareRemoveAnnexDir' annexdir =
emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir) emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir)
>>= mapM_ (void . tryIO . allowWrite . toRawFilePath) >>= mapM_ (void . tryIO . allowWrite)
{- Keys that were moved out of the annex have a hard link still in the {- Keys that were moved out of the annex have a hard link still in the
- annex, with > 1 link count, and those can be removed. - annex, with > 1 link count, and those can be removed.

10
Git/Objects.hs
View file

@ -25,14 +25,14 @@ packDir r = objectsDir r P.</> "pack"
packIdxFile :: RawFilePath -> RawFilePath packIdxFile :: RawFilePath -> RawFilePath
packIdxFile = flip P.replaceExtension "idx" packIdxFile = flip P.replaceExtension "idx"
listPackFiles :: Repo -> IO [FilePath] listPackFiles :: Repo -> IO [RawFilePath]
listPackFiles r = filter (".pack" `isSuffixOf`) listPackFiles r = filter (".pack" `B.isSuffixOf`)
<$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r) <$> catchDefaultIO [] (dirContents $ packDir r)
listLooseObjectShas :: Repo -> IO [Sha] listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $ listLooseObjectShas r = catchDefaultIO [] $
mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories) mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories . decodeBS)
<$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r))) <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (objectsDir r))
looseObjectFile :: Repo -> Sha -> RawFilePath looseObjectFile :: Repo -> Sha -> RawFilePath
looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest

24
Git/Repair.hs
View file

@ -83,24 +83,23 @@ explodePacks r = go =<< listPackFiles r
putStrLn "Unpacking all pack files." putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
-- Just in case permissions are messed up. -- Just in case permissions are messed up.
allowRead (toRawFilePath packfile) allowRead packfile
-- May fail, if pack file is corrupt. -- May fail, if pack file is corrupt.
void $ tryIO $ void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
L.hPut h =<< L.readFile packfile L.hPut h =<< L.readFile (fromRawFilePath packfile)
objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir) objs <- emptyWhenDoesNotExist (dirContentsRecursive (toRawFilePath tmpdir))
forM_ objs $ \objfile -> do forM_ objs $ \objfile -> do
f <- relPathDirToFile f <- relPathDirToFile
(toRawFilePath tmpdir) (toRawFilePath tmpdir)
(toRawFilePath objfile) objfile
let dest = objectsDir r P.</> f let dest = objectsDir r P.</> f
createDirectoryIfMissing True createDirectoryIfMissing True
(fromRawFilePath (parentDir dest)) (fromRawFilePath (parentDir dest))
moveFile (toRawFilePath objfile) dest moveFile objfile dest
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
let f = toRawFilePath packfile removeWhenExistsWith R.removeLink packfile
removeWhenExistsWith R.removeLink f removeWhenExistsWith R.removeLink (packIdxFile packfile)
removeWhenExistsWith R.removeLink (packIdxFile f)
return True return True
{- Try to retrieve a set of missing objects, from the remotes of a {- Try to retrieve a set of missing objects, from the remotes of a
@ -248,13 +247,14 @@ badBranches missing r = filterM isbad =<< getAllRefs r
- Relies on packed refs being exploded before it's called. - Relies on packed refs being exploded before it's called.
-} -}
getAllRefs :: Repo -> IO [Ref] getAllRefs :: Repo -> IO [Ref]
getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs") getAllRefs r = getAllRefs' (localGitDir r P.</> "refs")
getAllRefs' :: FilePath -> IO [Ref] getAllRefs' :: RawFilePath -> IO [Ref]
getAllRefs' refdir = do getAllRefs' refdir = do
let topsegs = length (splitPath refdir) - 1 let topsegs = length (P.splitPath refdir) - 1
let toref = Ref . toInternalGitPath . encodeBS let toref = Ref . toInternalGitPath . encodeBS
. joinPath . drop topsegs . splitPath . joinPath . drop topsegs . splitPath
. decodeBS
map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir) map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile :: Repo -> IO ()

15
Logs/Transfer.hs
View file

@ -29,6 +29,7 @@ import Annex.Perms
import Data.Time.Clock import Data.Time.Clock
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
@ -157,7 +158,7 @@ getTransfers' dirs wanted = do
infos <- mapM checkTransfer transfers infos <- mapM checkTransfer transfers
return $ mapMaybe running $ zip transfers infos return $ mapMaybe running $ zip transfers infos
where where
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath) findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . transferDir) dirs =<< mapM (fromRepo . transferDir) dirs
running (t, Just i) = Just (t, i) running (t, Just i) = Just (t, i)
running (_, Nothing) = Nothing running (_, Nothing) = Nothing
@ -180,11 +181,11 @@ getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles
where where
getpairs = mapM $ \f -> do getpairs = mapM $ \f -> do
let mt = parseTransferFile f let mt = parseTransferFile f
mi <- readTransferInfoFile Nothing f mi <- readTransferInfoFile Nothing (fromRawFilePath f)
return $ case (mt, mi) of return $ case (mt, mi) of
(Just t, Just i) -> Just (t, i) (Just t, Just i) -> Just (t, i)
_ -> Nothing _ -> Nothing
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath) findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . failedTransferDir u) [Download, Upload] =<< mapM (fromRepo . failedTransferDir u) [Download, Upload]
clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)] clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
@ -244,17 +245,17 @@ failedTransferFile (Transfer direction u kd) r =
P.</> keyFile (mkKey (const kd)) P.</> keyFile (mkKey (const kd))
{- Parses a transfer information filename to a Transfer. -} {- Parses a transfer information filename to a Transfer. -}
parseTransferFile :: FilePath -> Maybe Transfer parseTransferFile :: RawFilePath -> Maybe Transfer
parseTransferFile file parseTransferFile file
| "lck." `isPrefixOf` takeFileName file = Nothing | "lck." `B.isPrefixOf` P.takeFileName file = Nothing
| otherwise = case drop (length bits - 3) bits of | otherwise = case drop (length bits - 3) bits of
[direction, u, key] -> Transfer [direction, u, key] -> Transfer
<$> parseDirection direction <$> parseDirection direction
<*> pure (toUUID u) <*> pure (toUUID u)
<*> fmap (fromKey id) (fileKey (toRawFilePath key)) <*> fmap (fromKey id) (fileKey key)
_ -> Nothing _ -> Nothing
where where
bits = splitDirectories file bits = P.splitDirectories file
writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex () writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex ()
writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info

13
Remote/BitTorrent.hs
View file

@ -35,6 +35,7 @@ import qualified Utility.RawFilePath as R
import Network.URI import Network.URI
import qualified System.FilePath.ByteString as P import qualified System.FilePath.ByteString as P
import qualified Data.ByteString as S
#ifdef WITH_TORRENTPARSER #ifdef WITH_TORRENTPARSER
import Data.Torrent import Data.Torrent
@ -208,9 +209,7 @@ downloadTorrentFile u = do
let metadir = othertmp P.</> "torrentmeta" P.</> kf let metadir = othertmp P.</> "torrentmeta" P.</> kf
createAnnexDirectory metadir createAnnexDirectory metadir
showOutput showOutput
ok <- downloadMagnetLink u ok <- downloadMagnetLink u metadir torrent
(fromRawFilePath metadir)
(fromRawFilePath torrent)
liftIO $ removeDirectoryRecursive liftIO $ removeDirectoryRecursive
(fromRawFilePath metadir) (fromRawFilePath metadir)
return ok return ok
@ -225,14 +224,14 @@ downloadTorrentFile u = do
return ok return ok
) )
downloadMagnetLink :: URLString -> FilePath -> FilePath -> Annex Bool downloadMagnetLink :: URLString -> RawFilePath -> RawFilePath -> Annex Bool
downloadMagnetLink u metadir dest = ifM download downloadMagnetLink u metadir dest = ifM download
( liftIO $ do ( liftIO $ do
ts <- filter (".torrent" `isSuffixOf`) ts <- filter (".torrent" `S.isSuffixOf`)
<$> dirContents metadir <$> dirContents metadir
case ts of case ts of
(t:[]) -> do (t:[]) -> do
moveFile (toRawFilePath t) (toRawFilePath dest) moveFile t dest
return True return True
_ -> return False _ -> return False
, return False , return False
@ -245,7 +244,7 @@ downloadMagnetLink u metadir dest = ifM download
, Param "--seed-time=0" , Param "--seed-time=0"
, Param "--summary-interval=0" , Param "--summary-interval=0"
, Param "-d" , Param "-d"
, File metadir , File (fromRawFilePath metadir)
] ]
downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool

5
Remote/Directory.hs
View file

@ -246,7 +246,7 @@ finalizeStoreGeneric d tmp dest = do
renameDirectory (fromRawFilePath tmp) dest' renameDirectory (fromRawFilePath tmp) dest'
-- may fail on some filesystems -- may fail on some filesystems
void $ tryIO $ do void $ tryIO $ do
mapM_ (preventWrite . toRawFilePath) =<< dirContents dest' mapM_ preventWrite =<< dirContents dest
preventWrite dest preventWrite dest
where where
dest' = fromRawFilePath dest dest' = fromRawFilePath dest
@ -389,8 +389,7 @@ removeExportLocation topdir loc =
listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
listImportableContentsM ii dir = liftIO $ do listImportableContentsM ii dir = liftIO $ do
l <- dirContentsRecursiveSkipping (const False) False (fromRawFilePath dir) l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir
l' <- mapM (go . toRawFilePath) l
return $ Just $ ImportableContentsComplete $ return $ Just $ ImportableContentsComplete $
ImportableContents (catMaybes l') [] ImportableContents (catMaybes l') []
where where

9
Remote/Helper/Git.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Remote.Helper.Git where module Remote.Helper.Git where
import Annex.Common import Annex.Common
@ -21,6 +23,7 @@ import Data.Time.Clock.POSIX
import System.PosixCompat.Files (modificationTime) import System.PosixCompat.Files (modificationTime)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S import qualified Data.Set as S
import qualified System.FilePath.ByteString as P
repoCheap :: Git.Repo -> Bool repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl repoCheap = not . Git.repoIsUrl
@ -59,9 +62,9 @@ guardUsable r fallback a
gitRepoInfo :: Remote -> Annex [(String, String)] gitRepoInfo :: Remote -> Annex [(String, String)]
gitRepoInfo r = do gitRepoInfo r = do
d <- fromRawFilePath <$> fromRepo Git.localGitDir d <- fromRepo Git.localGitDir
mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (toRawFilePath p)) mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus p)
=<< emptyWhenDoesNotExist (dirContentsRecursive (d </> "refs" </> "remotes" </> Remote.name r)) =<< emptyWhenDoesNotExist (dirContentsRecursive (d P.</> "refs" P.</> "remotes" P.</> encodeBS (Remote.name r)))
let lastsynctime = case mtimes of let lastsynctime = case mtimes of
[] -> "never" [] -> "never"
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes _ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes

4
Test/Framework.hs
View file

@ -339,14 +339,14 @@ removeDirectoryForCleanup = removePathForcibly
cleanup :: FilePath -> IO () cleanup :: FilePath -> IO ()
cleanup dir = whenM (doesDirectoryExist dir) $ do cleanup dir = whenM (doesDirectoryExist dir) $ do
Command.Uninit.prepareRemoveAnnexDir' dir Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath dir)
-- This can fail if files in the directory are still open by a -- This can fail if files in the directory are still open by a
-- subprocess. -- subprocess.
void $ tryIO $ removeDirectoryForCleanup dir void $ tryIO $ removeDirectoryForCleanup dir
finalCleanup :: IO () finalCleanup :: IO ()
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
Command.Uninit.prepareRemoveAnnexDir' tmpdir Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir)
catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do
print e print e
putStrLn "sleeping 10 seconds and will retry directory cleanup" putStrLn "sleeping 10 seconds and will retry directory cleanup"

2
Types/Direction.hs
View file

@ -18,7 +18,7 @@ formatDirection :: Direction -> B.ByteString
formatDirection Upload = "upload" formatDirection Upload = "upload"
formatDirection Download = "download" formatDirection Download = "download"
parseDirection :: String -> Maybe Direction parseDirection :: B.ByteString -> Maybe Direction
parseDirection "upload" = Just Upload parseDirection "upload" = Just Upload
parseDirection "download" = Just Download parseDirection "download" = Just Download
parseDirection _ = Nothing parseDirection _ = Nothing

6
Upgrade/V2.hs
View file

@ -73,14 +73,14 @@ locationLogs = do
config <- Annex.getGitConfig config <- Annex.getGitConfig
dir <- fromRepo gitStateDir dir <- fromRepo gitStateDir
liftIO $ do liftIO $ do
levela <- dirContents dir levela <- dirContents (toRawFilePath dir)
levelb <- mapM tryDirContents levela levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb) files <- mapM tryDirContents (concat levelb)
return $ mapMaybe (islogfile config) (concat files) return $ mapMaybe (islogfile config) (concat files)
where where
tryDirContents d = catchDefaultIO [] $ dirContents d tryDirContents d = catchDefaultIO [] $ dirContents d
islogfile config f = maybe Nothing (\k -> Just (k, f)) $ islogfile config f = maybe Nothing (\k -> Just (k, fromRawFilePath f)) $
locationLogFileKey config (toRawFilePath f) locationLogFileKey config f
inject :: FilePath -> FilePath -> Annex () inject :: FilePath -> FilePath -> Annex ()
inject source dest = do inject source dest = do

2
Utility/DirWatcher/INotify.hs
View file

@ -59,7 +59,7 @@ watchDir i dir ignored scanevents hooks
void (addWatch i watchevents (toInternalFilePath dir) handler) void (addWatch i watchevents (toInternalFilePath dir) handler)
`catchIO` failedaddwatch `catchIO` failedaddwatch
withLock lock $ withLock lock $
mapM_ scan =<< filter (not . dirCruft) <$> mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$>
getDirectoryContents dir getDirectoryContents dir
where where
recurse d = watchDir i d ignored scanevents hooks recurse d = watchDir i d ignored scanevents hooks

2
Utility/DirWatcher/Kqueue.hs
View file

@ -77,7 +77,7 @@ data DirInfo = DirInfo
getDirInfo :: FilePath -> IO DirInfo getDirInfo :: FilePath -> IO DirInfo
getDirInfo dir = do getDirInfo dir = do
l <- filter (not . dirCruft) <$> getDirectoryContents dir l <- filter (not . dirCruft . toRawFilePath) <$> getDirectoryContents dir
contents <- S.fromList . catMaybes <$> mapM getDirEnt l contents <- S.fromList . catMaybes <$> mapM getDirEnt l
return $ DirInfo dir contents return $ DirInfo dir contents
where where

51
Utility/Directory.hs
View file

@ -7,33 +7,48 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-} {-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory where module Utility.Directory where
import Control.Monad import Control.Monad
import System.FilePath
import System.PosixCompat.Files (isDirectory, isSymbolicLink) import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Unsafe (unsafeInterleaveIO)
import qualified System.FilePath.ByteString as P
import Data.Maybe import Data.Maybe
import Prelude import Prelude
import Utility.SystemDirectory
import Utility.Exception import Utility.Exception
import Utility.Monad import Utility.Monad
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
dirCruft :: FilePath -> Bool #ifdef WITH_OSSTRING
import Utility.OsString
import qualified System.Directory.OsPath as OP
#else
import Utility.SystemDirectory
#endif
dirCruft :: R.RawFilePath -> Bool
dirCruft "." = True dirCruft "." = True
dirCruft ".." = True dirCruft ".." = True
dirCruft _ = False dirCruft _ = False
{- Lists the contents of a directory. {- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -} - Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: FilePath -> IO [FilePath] dirContents :: RawFilePath -> IO [RawFilePath]
dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d #ifdef WITH_OSSTRING
dirContents d = map (\p -> d P.</> fromOsString p)
<$> OP.listDirectory (toOsString d)
#else
dirContents d =
map (\p -> d P.</> toRawFilePath p)
. filter (not . dirCruft . toRawFilePath)
<$> getDirectoryContents (fromRawFilePath d)
#endif
{- Gets files in a directory, and then its subdirectories, recursively, {- Gets files in a directory, and then its subdirectories, recursively,
- and lazily. - and lazily.
@ -45,13 +60,13 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
- be accessed (the use of unsafeInterleaveIO would make it difficult to - be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions). - trap such exceptions).
-} -}
dirContentsRecursive :: FilePath -> IO [FilePath] dirContentsRecursive :: RawFilePath -> IO [RawFilePath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -} {- Skips directories whose basenames match the skipdir. -}
dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] dirContentsRecursiveSkipping :: (RawFilePath -> Bool) -> Bool -> RawFilePath -> IO [RawFilePath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
| skipdir (takeFileName topdir) = return [] | skipdir (P.takeFileName topdir) = return []
| otherwise = do | otherwise = do
-- Get the contents of the top directory outside of -- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if -- unsafeInterleaveIO, which allows throwing exceptions if
@ -63,24 +78,30 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
where where
go [] = return [] go [] = return []
go (dir:dirs) go (dir:dirs)
| skipdir (takeFileName dir) = go dirs | skipdir (P.takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do | otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] (files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir) =<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs) files' <- go (dirs' ++ dirs)
return (files ++ files') return (files ++ files')
collect :: [RawFilePath] -> [RawFilePath] -> [RawFilePath] -> IO ([RawFilePath], [RawFilePath])
collect files dirs' [] = return (reverse files, reverse dirs') collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries) collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries | dirCruft entry = collect files dirs' entries
| otherwise = do | otherwise = do
let skip = collect (entry:files) dirs' entries let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries let recurse = collect files (entry:dirs') entries
ms <- catchMaybeIO $ R.getSymbolicLinkStatus (toRawFilePath entry) ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry
case ms of case ms of
(Just s) (Just s)
| isDirectory s -> recurse | isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks -> | isSymbolicLink s && followsubdirsymlinks ->
ifM (doesDirectoryExist entry) #ifdef WITH_OSSTRING
ifM (OP.doesDirectoryExist (toOsString entry))
#else
ifM (doesDirectoryExist (fromRawFilePath entry))
#endif
( recurse ( recurse
, skip , skip
) )
@ -95,22 +116,22 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
- be accessed (the use of unsafeInterleaveIO would make it difficult to - be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions). - trap such exceptions).
-} -}
dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath]
dirTreeRecursiveSkipping skipdir topdir dirTreeRecursiveSkipping skipdir topdir
| skipdir (takeFileName topdir) = return [] | skipdir (P.takeFileName topdir) = return []
| otherwise = do | otherwise = do
subdirs <- filterM isdir =<< dirContents topdir subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs go [] subdirs
where where
go c [] = return c go c [] = return c
go c (dir:dirs) go c (dir:dirs)
| skipdir (takeFileName dir) = go c dirs | skipdir (P.takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do | otherwise = unsafeInterleaveIO $ do
subdirs <- go [] subdirs <- go []
=<< filterM isdir =<< filterM isdir
=<< catchDefaultIO [] (dirContents dir) =<< catchDefaultIO [] (dirContents dir)
go (subdirs++dir:c) dirs go (subdirs++dir:c) dirs
isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p) isdir p = isDirectory <$> R.getSymbolicLinkStatus p
{- When the action fails due to the directory not existing, returns []. -} {- When the action fails due to the directory not existing, returns []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a] emptyWhenDoesNotExist :: IO [a] -> IO [a]

3
Utility/Directory/Stream.hs
View file

@ -31,6 +31,7 @@ import qualified System.Posix as Posix
import Utility.Directory import Utility.Directory
import Utility.Exception import Utility.Exception
import Utility.FileSystemEncoding
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
@ -115,5 +116,5 @@ isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
case v of case v of
Nothing -> return True Nothing -> return True
Just f Just f
| not (dirCruft f) -> return False | not (dirCruft (toRawFilePath f)) -> return False
| otherwise -> check h | otherwise -> check h

8
Utility/LockFile/PidLock.hs
View file

@ -39,6 +39,7 @@ import Utility.FileSystemEncoding
import Utility.Env import Utility.Env
import Utility.Env.Set import Utility.Env.Set
import Utility.Tmp import Utility.Tmp
import Utility.RawFilePath
import qualified Utility.LockFile.Posix as Posix import qualified Utility.LockFile.Posix as Posix
import System.IO import System.IO
@ -242,15 +243,14 @@ linkToLock (Just _) src dest = do
-- with the SAME FILENAME exist. -- with the SAME FILENAME exist.
checkInsaneLustre :: RawFilePath -> IO Bool checkInsaneLustre :: RawFilePath -> IO Bool
checkInsaneLustre dest = do checkInsaneLustre dest = do
let dest' = fromRawFilePath dest fs <- dirContents (P.takeDirectory dest)
fs <- dirContents (takeDirectory dest') case length (filter (== dest) fs) of
case length (filter (== dest') fs) of
1 -> return False -- whew! 1 -> return False -- whew!
0 -> return True -- wtf? 0 -> return True -- wtf?
_ -> do _ -> do
-- Try to clean up the extra copy we made -- Try to clean up the extra copy we made
-- that has the same name. Egads. -- that has the same name. Egads.
_ <- tryIO $ removeFile dest' _ <- tryIO $ removeLink dest
return True return True
-- | Waits as necessary to take a lock. -- | Waits as necessary to take a lock.

38
Utility/OsString.hs Normal file
View file

@ -0,0 +1,38 @@
{- OsString utilities
-
- Copyright 2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.OsString where
#ifdef WITH_OSSTRING
import Utility.RawFilePath
import "os-string" System.OsString.Internal.Types
import qualified Data.ByteString.Short as S
{- Unlike System.OsString.fromBytes, on Windows this does not ensure a
- valid USC-2LE encoding. The input ByteString must be in a valid encoding
- already or uses of the OsString will fail. -}
toOsString :: RawFilePath -> OsString
#if defined(mingw32_HOST_OS)
toOsString = OsString . WindowsString . S.toShort
#else
toOsString = OsString . PosixString . S.toShort
#endif
fromOsString :: OsString -> RawFilePath
#if defined(mingw32_HOST_OS)
fromOsString = S.fromShort . getWindowsString . getOsString
#else
fromOsString = S.fromShort . getPosixString . getOsString
#endif
#endif /* WITH_OSSTRING */

7
doc/todo/RawFilePath_conversion.mdwn
View file

@ -8,13 +8,6 @@ Some commands like `git-annex find` use RawFilePath end-to-end.
But this conversion is not yet complete. This is a todo to keep track of the But this conversion is not yet complete. This is a todo to keep track of the
status. status.
* The Abstract FilePath proposal (AFPP) has been implemented, and so a number of
libraries like directory now have versions that operate on
OSPath. That could be used in git-annex eg for things like
getDirectoryContents, when built against those versions.
(OSPath uses ShortByteString, while RawFilePath is ByteString, so
conversion still entails a copy, eg using
`System.OsString.Internal.fromBytes`)
* unix has modules that operate on RawFilePath but no OSPath versions yet. * unix has modules that operate on RawFilePath but no OSPath versions yet.
See https://github.com/haskell/unix/issues/240 See https://github.com/haskell/unix/issues/240
* filepath-1.4.100 implements support for OSPath. It is bundled with * filepath-1.4.100 implements support for OSPath. It is bundled with

11
git-annex.cabal
View file

@ -175,6 +175,9 @@ Flag Crypton
Flag Servant Flag Servant
Description: Use the servant library, enabling using annex+http urls and git-annex p2phttp Description: Use the servant library, enabling using annex+http urls and git-annex p2phttp
Flag OsString
Description: Use the os-string library
Flag Benchmark Flag Benchmark
Description: Enable benchmarking Description: Enable benchmarking
Default: True Default: True
@ -329,6 +332,13 @@ Executable git-annex
P2P.Http.Server P2P.Http.Server
P2P.Http.State P2P.Http.State
if flag(OsString)
Build-Depends:
os-string (>= 2.0.0),
directory (>= 1.3.8.3),
filepath (>= 1.5.2.0)
CPP-Options: -DWITH_OSSTRING
if (os(windows)) if (os(windows))
Build-Depends: Build-Depends:
Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0), Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0),
@ -1094,6 +1104,7 @@ Executable git-annex
Utility.OpenFile Utility.OpenFile
Utility.OptParse Utility.OptParse
Utility.OSX Utility.OSX
Utility.OsString
Utility.PID Utility.PID
Utility.PartialPrelude Utility.PartialPrelude
Utility.Path Utility.Path

11
stack.yaml
View file

@ -11,8 +11,17 @@ flags:
benchmark: true benchmark: true
crypton: true crypton: true
servant: true servant: true
osstring: true
packages: packages:
- '.' - '.'
resolver: lts-23.2 resolver: nightly-2025-01-20
extra-deps: extra-deps:
- filepath-bytestring-1.4.100.3.2 - filepath-bytestring-1.4.100.3.2
- aws-0.24.3
- feed-1.3.2.1
- git-lfs-1.2.2
allow-newer: true
allow-newer-deps:
- filepath-bytestring
- aws
- feed