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

bring back OsPath changes

Browse source 
I hope that the windows test suite failure on appveyor was fixed by
updating to a newer windows there. I have not been able to reproduce
that failure in a windows 11 VM run locally.
This commit is contained in:
Joey Hess 2025-01-30 14:34:21 -04:00
parent f0ab439c95
commit 84291b6014
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
119 changed files with 1003 additions and 647 deletions
Download patch file Download diff file Expand all files Collapse all files

11
Annex/AdjustedBranch.hs
View file

@ -70,6 +70,7 @@ import Logs.View (is_branchView)
import Logs.AdjustedBranchUpdate
import Utility.FileMode
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Data.Time.Clock.POSIX
import qualified Data.Map as M
@ -268,7 +269,7 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
-- origbranch.
_ <- propigateAdjustedCommits' True origbranch adj commitlck
origheadfile <- inRepo $ readFileStrict . Git.Ref.headFile
origheadfile <- inRepo $ F.readFile' . toOsPath . Git.Ref.headFile
origheadsha <- inRepo (Git.Ref.sha currbranch)
b <- adjustBranch adj origbranch
@ -280,8 +281,8 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
newheadfile <- case origheadsha of
Just s -> do
inRepo $ \r -> do
let newheadfile = fromRef s
writeFile (Git.Ref.headFile r) newheadfile
let newheadfile = fromRef' s
F.writeFile' (toOsPath (Git.Ref.headFile r)) newheadfile
return (Just newheadfile)
_ -> return Nothing
@ -295,9 +296,9 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
unless ok $ case newheadfile of
Nothing -> noop
Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do
v' <- readFileStrict (Git.Ref.headFile r)
v' <- F.readFile' (toOsPath (Git.Ref.headFile r))
when (v == v') $
writeFile (Git.Ref.headFile r) origheadfile
F.writeFile' (toOsPath (Git.Ref.headFile r)) origheadfile
return ok
| otherwise = preventCommits $ \commitlck -> do

22
Annex/AdjustedBranch/Merge.hs
View file

@ -29,8 +29,9 @@ import Annex.GitOverlay
import Utility.Tmp.Dir
import Utility.CopyFile
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool
@ -72,26 +73,25 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
-}
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
git_dir <- fromRepo Git.localGitDir
let git_dir' = fromRawFilePath git_dir
tmpwt <- fromRepo gitAnnexMergeDir
withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
let tmpgit' = toRawFilePath tmpgit
liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
-- Copy in refs and packed-refs, to work
-- around bug in git 2.13.0, which
-- causes it not to look in GIT_DIR for refs.
refs <- liftIO $ emptyWhenDoesNotExist $
dirContentsRecursive $
git_dir' </> "refs"
let refs' = (git_dir' </> "packed-refs") : refs
git_dir P.</> "refs"
let refs' = (git_dir P.</> "packed-refs") : refs
liftIO $ forM_ refs' $ \src -> do
let src' = toRawFilePath src
whenM (doesFileExist src) $ do
dest <- relPathDirToFile git_dir src'
let dest' = toRawFilePath tmpgit P.</> dest
whenM (R.doesPathExist src) $ do
dest <- relPathDirToFile git_dir src
let dest' = tmpgit' P.</> dest
createDirectoryUnder [git_dir]
(P.takeDirectory dest')
void $ createLinkOrCopy src' dest'
void $ createLinkOrCopy src dest'
-- This reset makes git merge not care
-- that the work tree is empty; otherwise
-- it will think that all the files have
@ -107,7 +107,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
if merged
then do
!mergecommit <- liftIO $ extractSha
<$> S.readFile (tmpgit </> "HEAD")
<$> F.readFile' (toOsPath (tmpgit' P.</> "HEAD"))
-- This is run after the commit lock is dropped.
return $ postmerge mergecommit
else return $ return False

13
Annex/AutoMerge.hs
View file

@ -35,10 +35,10 @@ import Annex.InodeSentinal
import Utility.InodeCache
import Utility.FileMode
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L
import System.PosixCompat.Files (isSymbolicLink)
{- Merges from a branch into the current branch (which may not exist yet),
@ -236,8 +236,9 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
| otherwise = pure f
makesymlink key dest = do
l <- calcRepo $ gitAnnexLink (toRawFilePath dest) key
unless inoverlay $ replacewithsymlink dest l
let rdest = toRawFilePath dest
l <- calcRepo $ gitAnnexLink rdest key
unless inoverlay $ replacewithsymlink rdest l
dest' <- toRawFilePath <$> stagefile dest
stageSymlink dest' =<< hashSymlink l
@ -265,9 +266,9 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
let replacefile isexecutable = case selectwant' (LsFiles.unmergedSha u) of
Nothing -> noop
Just sha -> replaceWorkTreeFile item $ \tmp -> do
Just sha -> replaceWorkTreeFile (toRawFilePath item) $ \tmp -> do
c <- catObject sha
liftIO $ L.writeFile (decodeBS tmp) c
liftIO $ F.writeFile (toOsPath tmp) c
when isexecutable $
liftIO $ void $ tryIO $
modifyFileMode tmp $
@ -280,7 +281,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
Nothing -> noop
Just sha -> do
link <- catSymLinkTarget sha
replacewithsymlink item link
replacewithsymlink (toRawFilePath item) link
(Just TreeFile, Just TreeSymlink) -> replacefile False
(Just TreeExecutable, Just TreeSymlink) -> replacefile True
_ -> ifM (liftIO $ doesDirectoryExist item)

3
Annex/Balanced.hs
View file

@ -11,11 +11,12 @@ import Key
import Types.UUID
import Utility.Hash
import Data.List
import Data.Maybe
import Data.Bits (shiftL)
import qualified Data.Set as S
import qualified Data.ByteArray as BA
import Data.List
import Prelude
-- The Int is how many UUIDs to pick.
type BalancedPicker = S.Set UUID -> Key -> Int -> [UUID]

25
Annex/Branch.hs
View file

@ -96,6 +96,7 @@ import Annex.Hook
import Utility.Directory.Stream
import Utility.Tmp
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
{- Name of the branch that is used to store git-annex's information. -}
name :: Git.Ref
@ -711,9 +712,9 @@ forceUpdateIndex jl branchref = do
{- Checks if the index needs to be updated. -}
needUpdateIndex :: Git.Ref -> Annex Bool
needUpdateIndex branchref = do
f <- fromRawFilePath <$> fromRepo gitAnnexIndexStatus
f <- toOsPath <$> fromRepo gitAnnexIndexStatus
committedref <- Git.Ref . firstLine' <$>
liftIO (catchDefaultIO mempty $ B.readFile f)
liftIO (catchDefaultIO mempty $ F.readFile' f)
return (committedref /= branchref)
{- Record that the branch's index has been updated to correspond to a
@ -741,7 +742,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
g <- gitRepo
st <- getState
let dir = gitAnnexJournalDir st g
(jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir)
(jlogf, jlogh) <- openjlog tmpdir
withHashObjectHandle $ \h ->
withJournalHandle gitAnnexJournalDir $ \jh ->
Git.UpdateIndex.streamUpdateIndex g
@ -752,12 +753,12 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
genstream dir h jh jlogh streamer = readDirectory jh >>= \case
Nothing -> return ()
Just file -> do
let path = dir P.</> toRawFilePath file
let path = dir P.</> file
unless (dirCruft file) $ whenM (isfile path) $ do
sha <- Git.HashObject.hashFile h path
hPutStrLn jlogh file
B.hPutStr jlogh (file <> "\n")
streamer $ Git.UpdateIndex.updateIndexLine
sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath file)
sha TreeFile (asTopFilePath $ fileJournal file)
genstream dir h jh jlogh streamer
isfile file = isRegularFile <$> R.getFileStatus file
-- Clean up the staged files, as listed in the temp log file.
@ -769,8 +770,8 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
stagedfs <- lines <$> hGetContents jlogh
mapM_ (removeFile . (dir </>)) stagedfs
hClose jlogh
removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf)
openjlog tmpdir = liftIO $ openTmpFileIn tmpdir "jlog"
removeWhenExistsWith (R.removeLink) (fromOsPath jlogf)
openjlog tmpdir = liftIO $ openTmpFileIn (toOsPath tmpdir) (toOsPath "jlog")
getLocalTransitions :: Annex Transitions
getLocalTransitions =
@ -931,8 +932,8 @@ getIgnoredRefs =
S.fromList . mapMaybe Git.Sha.extractSha . fileLines' <$> content
where
content = do
f <- fromRawFilePath <$> fromRepo gitAnnexIgnoredRefs
liftIO $ catchDefaultIO mempty $ B.readFile f
f <- toOsPath <$> fromRepo gitAnnexIgnoredRefs
liftIO $ catchDefaultIO mempty $ F.readFile' f
addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex ()
addMergedRefs [] = return ()
@ -949,8 +950,8 @@ getMergedRefs = S.fromList . map fst <$> getMergedRefs'
getMergedRefs' :: Annex [(Git.Sha, Git.Branch)]
getMergedRefs' = do
f <- fromRawFilePath <$> fromRepo gitAnnexMergedRefs
s <- liftIO $ catchDefaultIO mempty $ B.readFile f
f <- toOsPath <$> fromRepo gitAnnexMergedRefs
s <- liftIO $ catchDefaultIO mempty $ F.readFile' f
return $ map parse $ fileLines' s
where
parse l =

4
Annex/ChangedRefs.hs
View file

@ -23,11 +23,11 @@ import Utility.Directory.Create
import qualified Git
import Git.Sha
import qualified Utility.SimpleProtocol as Proto
import qualified Utility.FileIO as F
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TBMChan
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
newtype ChangedRefs = ChangedRefs [Git.Ref]
@ -104,7 +104,7 @@ notifyHook chan reffile _
| ".lock" `isSuffixOf` reffile = noop
| otherwise = void $ do
sha <- catchDefaultIO Nothing $
extractSha <$> S.readFile reffile
extractSha <$> F.readFile' (toOsPath (toRawFilePath reffile))
-- When the channel is full, there is probably no reader
-- running, or ref changes have been occurring very fast,
-- so it's ok to not write the change to it.

15
Annex/Content.hs
View file

@ -108,6 +108,7 @@ import Utility.HumanTime
import Utility.TimeStamp
import Utility.FileMode
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isSymbolicLink, linkCount)
@ -581,7 +582,7 @@ linkToAnnex key src srcic = ifM (checkSecureHashes' key)
-}
linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult
linkFromAnnex key dest destmode =
replaceFile' (const noop) (fromRawFilePath dest) (== LinkAnnexOk) $ \tmp ->
replaceFile' (const noop) dest (== LinkAnnexOk) $ \tmp ->
linkFromAnnex' key tmp destmode
{- This is only safe to use when dest is not a worktree file. -}
@ -817,7 +818,7 @@ listKeys' keyloc want = do
s <- Annex.getState id
r <- Annex.getRead id
depth <- gitAnnexLocationDepth <$> Annex.getGitConfig
liftIO $ walk (s, r) depth (fromRawFilePath dir)
liftIO $ walk (s, r) depth dir
where
walk s depth dir = do
contents <- catchDefaultIO [] (dirContents dir)
@ -825,7 +826,7 @@ listKeys' keyloc want = do
then do
contents' <- filterM present contents
keys <- filterM (Annex.eval s . want) $
mapMaybe (fileKey . P.takeFileName . toRawFilePath) contents'
mapMaybe (fileKey . P.takeFileName) contents'
continue keys []
else do
let deeper = walk s (depth - 1)
@ -843,8 +844,8 @@ listKeys' keyloc want = do
present _ | inanywhere = pure True
present d = presentInAnnex d
presentInAnnex = doesFileExist . contentfile
contentfile d = d </> takeFileName d
presentInAnnex = R.doesPathExist . contentfile
contentfile d = d P.</> P.takeFileName d
{- Things to do to record changes to content when shutting down.
-
@ -1076,7 +1077,7 @@ writeContentRetentionTimestamp key rt t = do
modifyContentDirWhenExists lckfile $ bracket (lock lckfile) unlock $ \_ ->
readContentRetentionTimestamp rt >>= \case
Just ts | ts >= t -> return ()
_ -> replaceFile (const noop) (fromRawFilePath rt) $ \tmp ->
_ -> replaceFile (const noop) rt $ \tmp ->
liftIO $ writeFile (fromRawFilePath tmp) $ show t
where
lock = takeExclusiveLock
@ -1086,7 +1087,7 @@ writeContentRetentionTimestamp key rt t = do
readContentRetentionTimestamp :: RawFilePath -> Annex (Maybe POSIXTime)
readContentRetentionTimestamp rt =
liftIO $ join <$> tryWhenExists
(parsePOSIXTime <$> readFile (fromRawFilePath rt))
(parsePOSIXTime <$> F.readFile' (toOsPath rt))
{- Checks if the retention timestamp is in the future, if so returns
- Nothing.

5
Annex/Content/PointerFile.hs
View file

@ -34,10 +34,9 @@ populatePointerFile :: Restage -> Key -> RawFilePath -> RawFilePath -> Annex (Ma
populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
where
go (Just k') | k == k' = do
let f' = fromRawFilePath f
destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f
liftIO $ removeWhenExistsWith R.removeLink f
(ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do
(ic, populated) <- replaceWorkTreeFile f $ \tmp -> do
ok <- linkOrCopy k obj tmp destmode >>= \case
Just _ -> thawContent tmp >> return True
Nothing -> liftIO (writePointerFile tmp k destmode) >> return False
@ -58,7 +57,7 @@ depopulatePointerFile key file = do
let mode = fmap fileMode st
secureErase file
liftIO $ removeWhenExistsWith R.removeLink file
ic <- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
ic <- replaceWorkTreeFile file $ \tmp -> do
liftIO $ writePointerFile tmp key mode
#if ! defined(mingw32_HOST_OS)
-- Don't advance mtime; this avoids unnecessary re-smudging

1
Annex/Fixup.hs
View file

@ -19,6 +19,7 @@ import Utility.Directory
import Utility.Exception
import Utility.Monad
import Utility.FileSystemEncoding
import Utility.SystemDirectory
import qualified Utility.RawFilePath as R
import Utility.PartialPrelude

7
Annex/Hook.hs
View file

@ -9,6 +9,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.Hook where
import Annex.Common
@ -85,7 +87,8 @@ hookWarning :: Git.Hook -> String -> Annex ()
hookWarning h msg = do
r <- gitRepo
warning $ UnquotedString $
Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
fromRawFilePath (Git.hookName h) ++
" hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg
{- To avoid checking if the hook exists every time, the existing hooks
- are cached. -}
@ -118,7 +121,7 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook)
( return Nothing
, do
h <- fromRepo (Git.hookFile hook)
commandfailed h
commandfailed (fromRawFilePath h)
)
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return Nothing

21
Annex/Ingest.hs
View file

@ -118,20 +118,21 @@ lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
withhardlink tmpdir = do
setperms
withTSDelta $ \delta -> liftIO $ do
(tmpfile, h) <- openTmpFileIn (fromRawFilePath tmpdir) $
relatedTemplate $ "ingest-" ++ takeFileName file
(tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $
relatedTemplate $ toRawFilePath $
"ingest-" ++ takeFileName file
hClose h
removeWhenExistsWith R.removeLink (toRawFilePath tmpfile)
withhardlink' delta tmpfile
let tmpfile' = fromOsPath tmpfile
removeWhenExistsWith R.removeLink tmpfile'
withhardlink' delta tmpfile'
`catchIO` const (nohardlink' delta)
withhardlink' delta tmpfile = do
let tmpfile' = toRawFilePath tmpfile
R.createLink file' tmpfile'
cache <- genInodeCache tmpfile' delta
R.createLink file' tmpfile
cache <- genInodeCache tmpfile delta
return $ LockedDown cfg $ KeySource
{ keyFilename = file'
, contentLocation = tmpfile'
, contentLocation = tmpfile
, inodeCache = cache
}
@ -308,7 +309,7 @@ restoreFile file key e = do
makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
l <- calcRepo $ gitAnnexLink file key
replaceWorkTreeFile file' $ makeAnnexLink l
replaceWorkTreeFile file $ makeAnnexLink l
-- touch symlink to have same time as the original file,
-- as provided in the InodeCache
@ -317,8 +318,6 @@ makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
Nothing -> noop
return l
where
file' = fromRawFilePath file
{- Creates the symlink to the annexed content, and stages it in git. -}
addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex ()

15
Annex/Journal.hs
View file

@ -27,6 +27,7 @@ import Annex.BranchState
import Types.BranchState
import Utility.Directory.Stream
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as L
@ -92,7 +93,7 @@ setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do
-- journal file is written atomically
let jfile = journalFile file
let tmpfile = tmp P.</> jfile
liftIO $ withFile (fromRawFilePath tmpfile) WriteMode $ \h ->
liftIO $ F.withFile (toOsPath tmpfile) WriteMode $ \h ->
writeJournalHandle h content
let dest = jd P.</> jfile
let mv = do
@ -133,7 +134,7 @@ checkCanAppendJournalFile _jl ru file = do
-}
appendJournalFile :: Journalable content => JournalLocked -> AppendableJournalFile -> content -> Annex ()
appendJournalFile _jl (AppendableJournalFile (jd, jfile)) content = do
let write = liftIO $ withFile (fromRawFilePath jfile) ReadWriteMode $ \h -> do
let write = liftIO $ F.withFile (toOsPath jfile) ReadWriteMode $ \h -> do
sz <- hFileSize h
when (sz /= 0) $ do
hSeek h SeekFromEnd (-1)
@ -204,7 +205,7 @@ getJournalFileStale (GetPrivate getprivate) file = do
jfile = journalFile file
getfrom d = catchMaybeIO $
discardIncompleteAppend . L.fromStrict
<$> B.readFile (fromRawFilePath (d P.</> jfile))
<$> F.readFile' (toOsPath (d P.</> jfile))
-- Note that this forces read of the whole lazy bytestring.
discardIncompleteAppend :: L.ByteString -> L.ByteString
@ -243,17 +244,15 @@ withJournalHandle getjournaldir a = do
where
-- avoid overhead of creating the journal directory when it already
-- exists
opendir d = liftIO (openDirectory (fromRawFilePath d))
opendir d = liftIO (openDirectory d)
`catchIO` (const (createAnnexDirectory d >> opendir d))
{- Checks if there are changes in the journal. -}
journalDirty :: (BranchState -> Git.Repo -> RawFilePath) -> Annex Bool
journalDirty getjournaldir = do
st <- getState
d <- fromRawFilePath <$> fromRepo (getjournaldir st)
liftIO $
(not <$> isDirectoryEmpty d)
`catchIO` (const $ doesDirectoryExist d)
d <- fromRepo (getjournaldir st)
liftIO $ isDirectoryPopulated d
{- Produces a filename to use in the journal for a file on the branch.
- The filename does not include the journal directory.

15
Annex/Link.hs
View file

@ -38,6 +38,7 @@ import Utility.Tmp.Dir
import Utility.CopyFile
import qualified Database.Keys.Handle
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@ -87,7 +88,7 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
probesymlink = R.readSymbolicLink file
probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do
probefilecontent = F.withFile (toOsPath file) ReadMode $ \h -> do
s <- S.hGet h maxSymlinkSz
-- If we got the full amount, the file is too large
-- to be a symlink target.
@ -117,7 +118,7 @@ makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
( liftIO $ do
void $ tryIO $ R.removeLink file
R.createSymbolicLink linktarget file
, liftIO $ S.writeFile (fromRawFilePath file) linktarget
, liftIO $ F.writeFile' (toOsPath file) linktarget
)
{- Creates a link on disk, and additionally stages it in git. -}
@ -152,7 +153,7 @@ stagePointerFile file mode sha =
writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO ()
writePointerFile file k mode = do
S.writeFile (fromRawFilePath file) (formatPointer k)
F.writeFile' (toOsPath file) (formatPointer k)
maybe noop (R.setFileMode file) mode
newtype Restage = Restage Bool
@ -245,7 +246,9 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do
when (numfiles > 0) $
bracket lockindex unlockindex go
where
withtmpdir = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex"
withtmpdir = withTmpDirIn
(fromRawFilePath $ Git.localGitDir r)
(toOsPath "annexindex")
isunmodified tsd f orig =
genInodeCache f tsd >>= return . \case
@ -434,7 +437,7 @@ maxSymlinkSz = 8192
isPointerFile :: RawFilePath -> IO (Maybe Key)
isPointerFile f = catchDefaultIO Nothing $
#if defined(mingw32_HOST_OS)
withFile (fromRawFilePath f) ReadMode readhandle
F.withFile (toOsPath f) ReadMode readhandle
#else
#if MIN_VERSION_unix(2,8,0)
let open = do
@ -445,7 +448,7 @@ isPointerFile f = catchDefaultIO Nothing $
#else
ifM (isSymbolicLink <$> R.getSymbolicLinkStatus f)
( return Nothing
, withFile (fromRawFilePath f) ReadMode readhandle
, F.withFile (toOsPath f) ReadMode readhandle
)
#endif
#endif

6
Annex/Proxy.hs
View file

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.Proxy where
@ -30,6 +31,7 @@ import Utility.Tmp.Dir
import Utility.Metered
import Git.Types
import qualified Database.Export as Export
import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import Utility.OpenFile
#endif
@ -173,7 +175,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
-- independently. Also, this key is not getting added into the
-- local annex objects.
withproxytmpfile k a = withOtherTmp $ \othertmpdir ->
withTmpDirIn (fromRawFilePath othertmpdir) "proxy" $ \tmpdir ->
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir ->
a (toRawFilePath tmpdir P.</> keyFile k)
proxyput af k = do
@ -184,7 +186,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
-- the client, to avoid bad content
-- being stored in the special remote.
iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k
h <- liftIO $ openFile (fromRawFilePath tmpfile) WriteMode
h <- liftIO $ F.openFile (toOsPath tmpfile) WriteMode
let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile)
gotall <- liftIO $ receivetofile iv h len
liftIO $ hClose h

39
Annex/ReplaceFile.hs
View file

@ -1,12 +1,10 @@
{- git-annex file replacing
-
- Copyright 2013-2021 Joey Hess <id@joeyh.name>
- Copyright 2013-2025 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Annex.ReplaceFile (
replaceGitAnnexDirFile,
replaceGitDirFile,
@ -19,24 +17,24 @@ import Annex.Common
import Annex.Tmp
import Annex.Perms
import Git
import Utility.Tmp
import Utility.Tmp.Dir
import Utility.Directory.Create
#ifndef mingw32_HOST_OS
import Utility.Path.Max
#endif
import qualified System.FilePath.ByteString as P
{- replaceFile on a file located inside the gitAnnexDir. -}
replaceGitAnnexDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
replaceGitAnnexDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceGitAnnexDirFile = replaceFile createAnnexDirectory
{- replaceFile on a file located inside the .git directory. -}
replaceGitDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
replaceGitDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceGitDirFile = replaceFile $ \dir -> do
top <- fromRepo localGitDir
liftIO $ createDirectoryUnder [top] dir
{- replaceFile on a worktree file. -}
replaceWorkTreeFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
replaceWorkTreeFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceWorkTreeFile = replaceFile createWorkTreeDirectory
{- Replaces a possibly already existing file with a new version,
@ -54,28 +52,17 @@ replaceWorkTreeFile = replaceFile createWorkTreeDirectory
- The createdirectory action is only run when moving the file into place
- fails, and can create any parent directory structure needed.
-}
replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (RawFilePath -> Annex a) -> Annex a
replaceFile :: (RawFilePath -> Annex ()) -> RawFilePath -> (RawFilePath -> Annex a) -> Annex a
replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action
replaceFile' :: (RawFilePath -> Annex ()) -> FilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
replaceFile' :: (RawFilePath -> Annex ()) -> RawFilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do
let othertmpdir' = fromRawFilePath othertmpdir
#ifndef mingw32_HOST_OS
-- Use part of the filename as the template for the temp
-- directory. This does not need to be unique, but it
-- makes it more clear what this temp directory is for.
filemax <- liftIO $ fileNameLengthLimit othertmpdir'
let basetmp = take (filemax `div` 2) (takeFileName file)
#else
-- Windows has limits on the whole path length, so keep
-- it short.
let basetmp = "t"
#endif
withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do
let tmpfile = toRawFilePath (tmpdir </> basetmp)
let basetmp = relatedTemplate' (P.takeFileName file)
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath basetmp) $ \tmpdir -> do
let tmpfile = toRawFilePath tmpdir P.</> basetmp
r <- action tmpfile
when (checkres r) $
replaceFileFrom tmpfile (toRawFilePath file) createdirectory
replaceFileFrom tmpfile file createdirectory
return r
replaceFileFrom :: RawFilePath -> RawFilePath -> (RawFilePath -> Annex ()) -> Annex ()

2
Annex/RepoSize/LiveUpdate.hs
View file

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

30
Annex/Ssh.hs
View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.Ssh (
@ -100,15 +101,16 @@ consumeStdinParams NoConsumeStdin = [Param "-n"]
{- Returns a filename to use for a ssh connection caching socket, and
- 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'
where
go (Right dir) =
liftIO (bestSocketPath $ dir P.</> hostport2socket host port) >>= return . \case
Nothing -> (Nothing, [])
Just socketfile ->
let socketfile' = fromRawFilePath socketfile
in (Just socketfile', sshConnectionCachingParams socketfile')
(Just socketfile
, sshConnectionCachingParams (fromRawFilePath socketfile)
)
-- No connection caching with concurrency is not a good
-- combination, so warn the user.
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
- stopping the ssh multiplexer on this socket.
-}
prepSocket :: FilePath -> SshHost -> [CommandParam] -> Annex ()
prepSocket :: RawFilePath -> SshHost -> [CommandParam] -> Annex ()
prepSocket socketfile sshhost sshparams = do
-- There could be stale ssh connections hanging around
-- 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
- file won't exist.
-}
enumSocketFiles :: Annex [FilePath]
enumSocketFiles :: Annex [RawFilePath]
enumSocketFiles = liftIO . go =<< sshCacheDir
where
go Nothing = return []
go (Just dir) = filterM (R.doesPathExist . socket2lock)
=<< filter (not . isLock)
<$> catchDefaultIO [] (dirContents (fromRawFilePath dir))
<$> catchDefaultIO [] (dirContents dir)
{- Stop any unused ssh connection caching processes. -}
sshCleanup :: Annex ()
@ -324,9 +326,9 @@ sshCleanup = mapM_ cleanup =<< enumSocketFiles
forceSshCleanup :: Annex ()
forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
forceStopSsh :: FilePath -> Annex ()
forceStopSsh :: RawFilePath -> Annex ()
forceStopSsh socketfile = withNullHandle $ \nullh -> do
let (dir, base) = splitFileName socketfile
let (dir, base) = splitFileName (fromRawFilePath socketfile)
let p = (proc "ssh" $ toCommand $
[ Param "-O", Param "stop" ] ++
sshConnectionCachingParams base ++
@ -338,7 +340,7 @@ forceStopSsh socketfile = withNullHandle $ \nullh -> do
}
void $ liftIO $ catchMaybeIO $ withCreateProcess 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
- of the path to a socket file. At the same time, it needs to be unique
@ -355,13 +357,13 @@ hostport2socket' s
where
lengthofmd5s = 32
socket2lock :: FilePath -> RawFilePath
socket2lock socket = toRawFilePath (socket ++ lockExt)
socket2lock :: RawFilePath -> RawFilePath
socket2lock socket = socket <> lockExt
isLock :: FilePath -> Bool
isLock f = lockExt `isSuffixOf` f
isLock :: RawFilePath -> Bool
isLock f = lockExt `S.isSuffixOf` f
lockExt :: String
lockExt :: S.ByteString
lockExt = ".lock"
{- 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
tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld
oldtmp <- fromRepo gitAnnexTmpOtherDirOld
liftIO $ mapM_ cleanold
=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty
-- remove when empty
liftIO $ void $ tryIO $
removeDirectory (fromRawFilePath oldtmp)
where
cleanold f = do
now <- liftIO getPOSIXTime
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 ->
void $ tryIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
void $ tryIO $ removeWhenExistsWith R.removeLink f
_ -> return ()

3
Annex/VectorClock.hs
View file

@ -21,6 +21,7 @@ import qualified Annex
import Utility.TimeStamp
import Data.ByteString.Builder
import qualified Data.ByteString as B
import qualified Data.Attoparsec.ByteString.Lazy as A
currentVectorClock :: Annex CandidateVectorClock
@ -76,7 +77,7 @@ formatVectorClock (VectorClock t) = show t
buildVectorClock :: VectorClock -> Builder
buildVectorClock = string7 . formatVectorClock
parseVectorClock :: String -> Maybe VectorClock
parseVectorClock :: B.ByteString -> Maybe VectorClock
parseVectorClock t = VectorClock <$> parsePOSIXTime t
vectorClockParser :: A.Parser VectorClock

3
Annex/VectorClock/Utility.hs
View file

@ -12,12 +12,13 @@ import Data.Time.Clock.POSIX
import Types.VectorClock
import Utility.Env
import Utility.TimeStamp
import Utility.FileSystemEncoding
startVectorClock :: IO (IO CandidateVectorClock)
startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"
where
go Nothing = timebased
go (Just s) = case parsePOSIXTime s of
go (Just s) = case parsePOSIXTime (encodeBS s) of
Just t -> return (pure (CandidateVectorClock t))
Nothing -> timebased
-- Avoid using fractional seconds in the CandidateVectorClock.

17
Annex/YoutubeDl.hs
View file

@ -30,6 +30,8 @@ import Utility.Metered
import Utility.Tmp
import Messages.Progress
import Logs.Transfer
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Network.URI
import Control.Concurrent.Async
@ -37,7 +39,6 @@ import Text.Read
import Data.Either
import qualified Data.Aeson as Aeson
import GHC.Generics
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
-- youtube-dl can follow redirects to anywhere, including potentially
@ -101,9 +102,9 @@ youtubeDl' url workdir p uo
| isytdlp cmd = liftIO $
(nub . lines <$> readFile filelistfile)
`catchIO` (pure . const [])
| otherwise = workdirfiles
workdirfiles = liftIO $ filter (/= filelistfile)
<$> (filterM (doesFileExist) =<< dirContents workdir)
| otherwise = map fromRawFilePath <$> workdirfiles
workdirfiles = liftIO $ filter (/= toRawFilePath filelistfile)
<$> (filterM R.doesPathExist =<< dirContents (toRawFilePath workdir))
filelistfile = workdir </> filelistfilebase
filelistfilebase = "git-annex-file-list-file"
isytdlp cmd = cmd == "yt-dlp"
@ -159,7 +160,7 @@ youtubeDlMaxSize workdir = ifM (Annex.getRead Annex.force)
Just have -> do
inprogress <- sizeOfDownloadsInProgress (const True)
partial <- liftIO $ sum
<$> (mapM (getFileSize . toRawFilePath) =<< dirContents workdir)
<$> (mapM getFileSize =<< dirContents (toRawFilePath workdir))
reserve <- annexDiskReserve <$> Annex.getGitConfig
let maxsize = have - reserve - inprogress + partial
if maxsize > 0
@ -352,7 +353,7 @@ youtubePlaylist url = do
else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd
youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem])
youtubePlaylist' url cmd = withTmpFile "yt-dlp" $ \tmpfile h -> do
youtubePlaylist' url cmd = withTmpFile (toOsPath (toRawFilePath "yt-dlp")) $ \tmpfile h -> do
hClose h
(outerr, ok) <- processTranscript cmd
[ "--simulate"
@ -362,14 +363,14 @@ youtubePlaylist' url cmd = withTmpFile "yt-dlp" $ \tmpfile h -> do
, "--print-to-file"
-- Write json with selected fields.
, "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j"
, tmpfile
, fromRawFilePath (fromOsPath tmpfile)
, url
]
Nothing
if ok
then flip catchIO (pure . Left . show) $ do
v <- map Aeson.eitherDecodeStrict . B8.lines
<$> B.readFile tmpfile
<$> F.readFile' tmpfile
return $ case partitionEithers v of
((parserr:_), _) ->
Left $ "yt-dlp json parse error: " ++ parserr

9
Assistant/DaemonStatus.hs
View file

@ -22,6 +22,7 @@ import qualified Remote
import qualified Types.Remote as Remote
import Config.DynamicConfig
import Annex.SpecialRemote.Config
import qualified Utility.FileIO as F
import Control.Concurrent.STM
import System.Posix.Types
@ -121,9 +122,9 @@ startDaemonStatus = do
- and parts of it are not relevant. -}
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
writeDaemonStatusFile file status =
viaTmp writeFile file =<< serialized <$> getPOSIXTime
viaTmp F.writeFile' (toOsPath (toRawFilePath file)) =<< serialized <$> getPOSIXTime
where
serialized now = unlines
serialized now = encodeBS $ unlines
[ "lastRunning:" ++ show now
, "scanComplete:" ++ show (scanComplete status)
, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
@ -135,13 +136,13 @@ readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
where
parse status = foldr parseline status . lines
parseline line status
| key == "lastRunning" = parseval parsePOSIXTime $ \v ->
| key == "lastRunning" = parseval (parsePOSIXTime . encodeBS) $ \v ->
status { lastRunning = Just v }
| key == "scanComplete" = parseval readish $ \v ->
status { scanComplete = v }
| key == "sanityCheckRunning" = parseval readish $ \v ->
status { sanityCheckRunning = v }
| key == "lastSanityCheck" = parseval parsePOSIXTime $ \v ->
| key == "lastSanityCheck" = parseval (parsePOSIXTime . encodeBS) $ \v ->
status { lastSanityCheck = Just v }
| otherwise = status -- unparsable line
where

30
Assistant/Install.hs
View file

@ -17,6 +17,7 @@ import Utility.Shell
import Utility.Tmp
import Utility.Env
import Utility.SshConfig
import qualified Utility.FileIO as F
#ifdef darwin_HOST_OS
import Utility.OSX
@ -28,6 +29,7 @@ import Utility.Android
#endif
import System.PosixCompat.Files (ownerExecuteMode)
import qualified Data.ByteString.Char8 as S8
standaloneAppBase :: IO (Maybe FilePath)
standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
@ -82,7 +84,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
let runshell var = "exec " ++ base </> "runshell " ++ var
let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
installWrapper (sshdir </> "git-annex-shell") $ unlines
installWrapper (toRawFilePath (sshdir </> "git-annex-shell")) $
[ shebang
, "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
@ -91,7 +93,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
, rungitannexshell "$@"
, "fi"
]
installWrapper (sshdir </> "git-annex-wrapper") $ unlines
installWrapper (toRawFilePath (sshdir </> "git-annex-wrapper")) $
[ shebang
, "set -e"
, runshell "\"$@\""
@ -99,14 +101,15 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
installFileManagerHooks program
installWrapper :: FilePath -> String -> IO ()
installWrapper :: RawFilePath -> [String] -> IO ()
installWrapper file content = do
curr <- catchDefaultIO "" $ readFileStrict file
when (curr /= content) $ do
createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file)))
viaTmp writeFile file content
modifyFileMode (toRawFilePath file) $
addModes [ownerExecuteMode]
let content' = map encodeBS content
curr <- catchDefaultIO [] $ fileLines' <$> F.readFile' (toOsPath file)
when (curr /= content') $ do
createDirectoryIfMissing True (fromRawFilePath (parentDir file))
viaTmp F.writeFile' (toOsPath file) $
linesFile' (S8.unlines content')
modifyFileMode file $ addModes [ownerExecuteMode]
installFileManagerHooks :: FilePath -> IO ()
#ifdef linux_HOST_OS
@ -127,17 +130,18 @@ installFileManagerHooks program = unlessM osAndroid $ do
(kdeDesktopFile actions)
where
genNautilusScript scriptdir action =
installscript (scriptdir </> scriptname action) $ unlines
installscript (toRawFilePath (scriptdir </> scriptname action)) $ unlines
[ shebang
, autoaddedcomment
, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\""
]
scriptname action = "git-annex " ++ action
installscript f c = whenM (safetoinstallscript f) $ do
writeFile f c
modifyFileMode (toRawFilePath f) $ addModes [ownerExecuteMode]
writeFile (fromRawFilePath f) c
modifyFileMode f $ addModes [ownerExecuteMode]
safetoinstallscript f = catchDefaultIO True $
elem autoaddedcomment . lines <$> readFileStrict f
elem (encodeBS autoaddedcomment) . fileLines'
<$> F.readFile' (toOsPath f)
autoaddedcomment = "# " ++ autoaddedmsg ++ " (To disable, chmod 600 this file.)"
autoaddedmsg = "Automatically added by git-annex, do not edit."

19
Assistant/Repair.hs
View file

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

7
Assistant/Ssh.hs
View file

@ -17,6 +17,7 @@ import Utility.SshConfig
import Git.Remote
import Utility.SshHost
import Utility.Process.Transcript
import qualified Utility.FileIO as F
import Data.Text (Text)
import qualified Data.Text as T
@ -158,8 +159,8 @@ removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir
let keyfile = sshdir </> "authorized_keys"
tryWhenExists (lines <$> readFileStrict keyfile) >>= \case
let keyfile = toOsPath $ toRawFilePath $ sshdir </> "authorized_keys"
tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case
Just ls -> viaTmp writeSshConfig keyfile $
unlines $ filter (/= keyline) ls
Nothing -> noop
@ -212,7 +213,7 @@ authorizedKeysLine gitannexshellonly dir pubkey
{- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair
genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do
ok <- boolSystem "ssh-keygen"
[ Param "-P", Param "" -- no password
, Param "-f", File $ dir </> "key"

2
Assistant/Threads/TransferPoller.hs
View file

@ -47,7 +47,7 @@ transferPollerThread = namedThread "TransferPoller" $ do
| otherwise = do
let (f, _, _) = transferFileAndLockFile t g
mi <- liftIO $ catchDefaultIO Nothing $
readTransferInfoFile Nothing (fromRawFilePath f)
readTransferInfoFile Nothing f
maybe noop (newsize t info . bytesComplete) mi
newsize t info sz

8
Assistant/Threads/TransferWatcher.hs
View file

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

2
Assistant/Threads/Watcher.hs
View file

@ -289,7 +289,7 @@ onAddSymlink' linktarget mk file filestatus = go mk
if linktarget == Just link
then ensurestaged (Just link) =<< getDaemonStatus
else do
liftAnnex $ replaceWorkTreeFile file $
liftAnnex $ replaceWorkTreeFile (toRawFilePath file) $
makeAnnexLink link
addLink file link (Just key)
-- other symlink, not git-annex

4
Assistant/Threads/WebApp.hs
View file

@ -89,9 +89,9 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
, return app
)
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex
then withTmpFile "webapp.html" $ \tmpfile h -> do
then withTmpFile (toOsPath "webapp.html") $ \tmpfile h -> do
hClose h
go tlssettings addr webapp tmpfile Nothing
go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing
else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile

23
Assistant/Upgrade.hs
View file

@ -41,9 +41,11 @@ import qualified Utility.Url as Url
import qualified Annex.Url as Url hiding (download)
import Utility.Tuple
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Data.Either
import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
{- Upgrade without interaction in the webapp. -}
unattendedUpgrade :: Assistant ()
@ -163,7 +165,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
{- OS X uses a dmg, so mount it, and copy the contents into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) "git-annex.upgrade" $ \tmpdir -> do
withTmpDirIn (fromRawFilePath (parentDir (toRawFilePath newdir))) (toOsPath (toRawFilePath "git-annex.upgrade")) $ \tmpdir -> do
void $ boolSystem "hdiutil"
[ Param "attach", File distributionfile
, Param "-mountpoint", File tmpdir
@ -188,7 +190,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
- into place. -}
unpack = liftIO $ do
olddir <- oldVersionLocation
withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) "git-annex.upgrade" $ \tmpdir -> do
withTmpDirIn (fromRawFilePath $ parentDir $ toRawFilePath newdir) (toOsPath $ toRawFilePath "git-annex.upgrade") $ \tmpdir -> do
let tarball = tmpdir </> "tar"
-- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent
@ -212,8 +214,8 @@ upgradeToDistribution newdir cleanup distributionfile = do
makeorigsymlink olddir
return (newdir </> "git-annex", deleteold)
installby a dstdir srcdir =
mapM_ (\x -> a (toRawFilePath x) (toRawFilePath (dstdir </> takeFileName x)))
=<< dirContents srcdir
mapM_ (\x -> a x (toRawFilePath dstdir P.</> P.takeFileName x))
=<< dirContents (toRawFilePath srcdir)
#endif
sanitycheck dir =
unlessM (doesDirectoryExist dir) $
@ -280,14 +282,14 @@ deleteFromManifest dir = do
fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs
removeWhenExistsWith R.removeLink (toRawFilePath manifest)
removeEmptyRecursive dir
removeEmptyRecursive (toRawFilePath dir)
where
manifest = dir </> "git-annex.MANIFEST"
removeEmptyRecursive :: FilePath -> IO ()
removeEmptyRecursive :: RawFilePath -> IO ()
removeEmptyRecursive dir = do
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
- detect when git-annex has been upgraded.
@ -322,13 +324,14 @@ downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
downloadDistributionInfo = do
uo <- liftAnnex Url.getUrlOptions
gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig
liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do
liftIO $ withTmpDir (toOsPath (toRawFilePath "git-annex.tmp")) $ \tmpdir -> do
let infof = tmpdir </> "info"
let sigf = infof ++ ".sig"
ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo
<&&> (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoSigUrl sigf uo)
<&&> verifyDistributionSig gpgcmd sigf)
( parseInfoFile <$> readFileStrict infof
( parseInfoFile . map decodeBS . fileLines'
<$> F.readFile' (toOsPath (toRawFilePath infof))
, return Nothing
)
@ -360,7 +363,7 @@ upgradeSupported = False
verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool
verifyDistributionSig gpgcmd sig = readProgramFile >>= \case
Just p | isAbsolute p ->
withUmask 0o0077 $ withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do
withUmask 0o0077 $ withTmpDir (toOsPath (toRawFilePath "git-annex-gpg.tmp")) $ \gpgtmp -> do
let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
boolGpgCmd gpgcmd
[ Param "--no-default-keyring"

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

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

6
Assistant/WebApp/Configurators/Ssh.hs
View file

@ -389,13 +389,13 @@ sshAuthTranscript sshinput opts sshhost cmd input = case inputAuthMethod sshinpu
v <- getCachedCred login
liftIO $ case v of
Nothing -> go [passwordprompts 0] Nothing
Just pass -> withTmpFile "ssh" $ \passfile h -> do
Just pass -> withTmpFile (toOsPath "ssh") $ \passfile h -> do
hClose h
writeFileProtected (toRawFilePath passfile) pass
writeFileProtected (fromOsPath passfile) pass
environ <- getEnvironment
let environ' = addEntries
[ ("SSH_ASKPASS", program)
, (sshAskPassEnv, passfile)
, (sshAskPassEnv, fromRawFilePath $ fromOsPath passfile)
, ("DISPLAY", ":0")
] environ
go [passwordprompts 1] (Just environ')

10
Backend/Utilities.hs
View file

@ -29,12 +29,12 @@ import Data.Word
genKeyName :: String -> S.ShortByteString
genKeyName s
-- Avoid making keys longer than the length of a SHA256 checksum.
| bytelen > sha256len = S.toShort $ encodeBS $
truncateFilePath (sha256len - md5len - 1) s' ++ "-" ++
show (md5 bl)
| otherwise = S.toShort $ encodeBS s'
| bytelen > sha256len = S.toShort $
truncateFilePath (sha256len - md5len - 1) s'
<> "-" <> encodeBS (show (md5 bl))
| otherwise = S.toShort s'
where
s' = preSanitizeKeyName s
s' = encodeBS $ preSanitizeKeyName s
bl = encodeBL s
bytelen = fromIntegral $ L.length bl

7
Build/LinuxMkLibs.hs
View file

@ -26,11 +26,12 @@ import Utility.Path.AbsRel
import Utility.FileMode
import Utility.CopyFile
import Utility.FileSystemEncoding
import Utility.SystemDirectory
mklibs :: FilePath -> a -> IO Bool
mklibs top _installedbins = do
fs <- dirContentsRecursive top
exes <- filterM checkExe fs
fs <- dirContentsRecursive (toRawFilePath top)
exes <- filterM checkExe (map fromRawFilePath fs)
libs <- runLdd exes
glibclibs <- glibcLibs
@ -80,7 +81,7 @@ consolidateUsrLib top libdirs = go [] libdirs
forM_ fs $ \f -> do
let src = inTop top (x </> f)
let dst = inTop top (d </> f)
unless (dirCruft f) $
unless (dirCruft (toRawFilePath f)) $
unlessM (doesDirectoryExist src) $
renameFile src dst
symlinkHwCapDirs top d

22
Build/Standalone.hs
View file

@ -25,6 +25,7 @@ import Utility.Path.AbsRel
import Utility.Directory
import Utility.Env
import Utility.FileSystemEncoding
import Utility.SystemDirectory
import Build.BundledPrograms
#ifdef darwin_HOST_OS
import System.IO
@ -71,14 +72,15 @@ installGitLibs topdir = do
-- install git-core programs; these are run by the git command
createDirectoryIfMissing True gitcoredestdir
execpath <- getgitpath "exec-path"
cfs <- dirContents execpath
cfs <- dirContents (toRawFilePath execpath)
forM_ cfs $ \f -> do
let f' = fromRawFilePath f
destf <- ((gitcoredestdir </>) . fromRawFilePath)
<$> relPathDirToFile
(toRawFilePath execpath)
(toRawFilePath f)
f
createDirectoryIfMissing True (takeDirectory destf)
issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f
issymlink <- isSymbolicLink <$> getSymbolicLinkStatus f'
if issymlink
then do
-- many git-core files may symlink to eg
@ -91,20 +93,20 @@ installGitLibs topdir = do
-- Other git-core files symlink to a file
-- beside them in the directory. Those
-- links can be copied as-is.
linktarget <- readSymbolicLink f
linktarget <- readSymbolicLink f'
if takeFileName linktarget == linktarget
then cp f destf
then cp f' destf
else do
let linktarget' = progDir topdir </> takeFileName linktarget
unlessM (doesFileExist linktarget') $ do
createDirectoryIfMissing True (takeDirectory linktarget')
L.readFile f >>= L.writeFile linktarget'
L.readFile f' >>= L.writeFile linktarget'
removeWhenExistsWith removeLink destf
rellinktarget <- relPathDirToFile
(toRawFilePath (takeDirectory destf))
(toRawFilePath linktarget')
createSymbolicLink (fromRawFilePath rellinktarget) destf
else cp f destf
else cp f' destf
-- install git's template files
-- git does not have an option to get the path of these,
@ -112,14 +114,14 @@ installGitLibs topdir = do
-- next to the --man-path, in eg /usr/share/git-core
manpath <- getgitpath "man-path"
let templatepath = manpath </> ".." </> "git-core" </> "templates"
tfs <- dirContents templatepath
tfs <- dirContents (toRawFilePath templatepath)
forM_ tfs $ \f -> do
destf <- ((templatedestdir </>) . fromRawFilePath)
<$> relPathDirToFile
(toRawFilePath templatepath)
(toRawFilePath f)
f
createDirectoryIfMissing True (takeDirectory destf)
cp f destf
cp (fromRawFilePath f) destf
where
gitcoredestdir = topdir </> "git-core"
templatedestdir = topdir </> "templates"

14
Build/Version.hs
View file

@ -1,6 +1,6 @@
{- Package version determination. -}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Build.Version where
@ -14,7 +14,9 @@ import Prelude
import Utility.Monad
import Utility.Exception
import Utility.Misc
import Utility.OsPath
import Utility.FileSystemEncoding
import qualified Utility.FileIO as F
type Version = String
@ -56,11 +58,11 @@ getChangelogVersion = do
middle = drop 1 . init
writeVersion :: Version -> IO ()
writeVersion ver = catchMaybeIO (readFileStrict f) >>= \case
writeVersion ver = catchMaybeIO (F.readFile' f) >>= \case
Just s | s == body -> return ()
_ -> writeFile f body
_ -> F.writeFile' f body
where
body = unlines $ concat
body = encodeBS $ unlines $ concat
[ header
, ["packageversion :: String"]
, ["packageversion = \"" ++ ver ++ "\""]
@ -71,4 +73,4 @@ writeVersion ver = catchMaybeIO (readFileStrict f) >>= \case
, ""
]
footer = []
f = "Build/Version"
f = toOsPath "Build/Version"

1
CHANGELOG
View file

@ -3,6 +3,7 @@ git-annex (10.20250116) UNRELEASED; urgency=medium
* Support help.autocorrect settings "prompt", "never", and "immediate".
* Allow setting remote.foo.annex-tracking-branch to a branch name
that contains "/", as long as it's not a remote tracking branch.
* Added OsPath build flag, which speeds up git-annex's operations on files.
-- Joey Hess <id@joeyh.name> Mon, 20 Jan 2025 10:24:51 -0400

40
CmdLine/GitRemoteAnnex.hs
View file

@ -57,6 +57,8 @@ import Utility.Tmp.Dir
import Utility.Env
import Utility.Metered
import Utility.FileMode
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Network.URI
import Data.Either
@ -65,7 +67,6 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.Map.Strict as M
import qualified System.FilePath.ByteString as P
import qualified Utility.RawFilePath as R
import qualified Data.Set as S
run :: [String] -> IO ()
@ -495,13 +496,16 @@ resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String)
resolveSpecialRemoteWebUrl url
| "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl =
Url.withUrlOptionsPromptingCreds $ \uo ->
withTmpFile "git-remote-annex" $ \tmp h -> do
withTmpFile (toOsPath "git-remote-annex") $ \tmp h -> do
liftIO $ hClose h
Url.download' nullMeterUpdate Nothing url tmp uo >>= \case
let tmp' = fromRawFilePath $ fromOsPath tmp
Url.download' nullMeterUpdate Nothing url tmp' uo >>= \case
Left err -> giveup $ url ++ " " ++ err
Right () -> liftIO $
(headMaybe . lines)
<$> readFileStrict tmp
fmap decodeBS
. headMaybe
. fileLines'
<$> F.readFile' tmp
| otherwise = return Nothing
where
lcurl = map toLower url
@ -724,10 +728,10 @@ downloadManifest rmt = get mkmain >>= maybe (get mkbak) (pure . Just)
-- it needs to re-download it fresh every time, and the object
-- file should not be stored locally.
gettotmp dl = withOtherTmp $ \othertmp ->
withTmpFileIn (fromRawFilePath othertmp) "GITMANIFEST" $ \tmp tmph -> do
withTmpFileIn (toOsPath othertmp) (toOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ hClose tmph
_ <- dl tmp
b <- liftIO (B.readFile tmp)
_ <- dl (fromRawFilePath (fromOsPath tmp))
b <- liftIO (F.readFile' tmp)
case parseManifest b of
Right m -> Just <$> verifyManifest rmt m
Left err -> giveup err
@ -774,7 +778,7 @@ uploadManifest rmt manifest = do
dropKey' rmt mk
put mk
put mk = withTmpFile "GITMANIFEST" $ \tmp tmph -> do
put mk = withTmpFile (toOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ B8.hPut tmph (formatManifest manifest)
liftIO $ hClose tmph
-- Uploading needs the key to be in the annex objects
@ -785,7 +789,7 @@ uploadManifest rmt manifest = do
-- keys, which it is not.
objfile <- calcRepo (gitAnnexLocation mk)
modifyContentDir objfile $
linkOrCopy mk (toRawFilePath tmp) objfile Nothing >>= \case
linkOrCopy mk (fromOsPath tmp) objfile Nothing >>= \case
-- Important to set the right perms even
-- though the object is only present
-- briefly, since sending objects may rely
@ -857,7 +861,7 @@ startPush' rmt manifest = do
f <- fromRepo (lastPushedManifestFile (Remote.uuid rmt))
oldmanifest <- liftIO $
fromRight mempty . parseManifest
<$> B.readFile (fromRawFilePath f)
<$> F.readFile' (toOsPath f)
`catchNonAsync` (const (pure mempty))
let oldmanifest' = mkManifest [] $
S.fromList (inManifest oldmanifest)
@ -973,14 +977,15 @@ generateGitBundle
-> Manifest
-> Annex (Key, Annex ())
generateGitBundle rmt bs manifest =
withTmpFile "GITBUNDLE" $ \tmp tmph -> do
withTmpFile (toOsPath "GITBUNDLE") $ \tmp tmph -> do
let tmp' = fromOsPath tmp
liftIO $ hClose tmph
inRepo $ Git.Bundle.create tmp bs
inRepo $ Git.Bundle.create (fromRawFilePath tmp') bs
bundlekey <- genGitBundleKey (Remote.uuid rmt)
(toRawFilePath tmp) nullMeterUpdate
tmp' nullMeterUpdate
if (bundlekey `notElem` inManifest manifest)
then do
unlessM (moveAnnex bundlekey (AssociatedFile Nothing) (toRawFilePath tmp)) $
unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp') $
giveup "Unable to push"
return (bundlekey, uploadaction bundlekey)
else return (bundlekey, noop)
@ -1122,7 +1127,7 @@ startAnnexBranch = ifM (null <$> Annex.Branch.siblingBranches)
-- journal writes to a temporary directory, so that all writes
-- to the git-annex branch by the action will be discarded.
specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a
specialRemoteFromUrl sab a = withTmpDir "journal" $ \tmpdir -> do
specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do
Annex.overrideGitConfig $ \c ->
c { annexAlwaysCommit = False }
Annex.BranchState.changeState $ \st ->
@ -1162,7 +1167,8 @@ specialRemoteFromUrl sab a = withTmpDir "journal" $ \tmpdir -> do
-- objects are deleted.
cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex ()
cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do
liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir
liftIO $ mapM_ R.removeLink
=<< dirContents (toRawFilePath alternatejournaldir)
case sab of
AnnexBranchExistedAlready _ -> noop
AnnexBranchCreatedEmpty r ->

6
CmdLine/Seek.hs
View file

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

21
Command/AddUrl.hs
View file

@ -200,12 +200,12 @@ checkUrl addunlockedmatcher r o si u = do
startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart
startRemote addunlockedmatcher r o si file uri sz = do
pathmax <- liftIO $ fileNameLengthLimit "."
let file' = joinPath $ map (truncateFilePath pathmax) $
splitDirectories file
let file' = P.joinPath $ map (truncateFilePath pathmax) $
P.splitDirectories (toRawFilePath file)
startingAddUrl si uri o $ do
showNote $ UnquotedString $ "from " ++ Remote.name r
showDestinationFile (toRawFilePath file')
performRemote addunlockedmatcher r o uri (toRawFilePath file') sz
showDestinationFile file'
performRemote addunlockedmatcher r o uri file' sz
performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform
performRemote addunlockedmatcher r o uri file sz = lookupKey file >>= \case
@ -279,7 +279,8 @@ sanitizeOrPreserveFilePath o f
return f
| otherwise = do
pathmax <- liftIO $ fileNameLengthLimit "."
return $ truncateFilePath pathmax $ sanitizeFilePath f
return $ fromRawFilePath $ truncateFilePath pathmax $
toRawFilePath $ sanitizeFilePath f
-- sanitizeFilePath avoids all these security problems
-- (and probably others, but at least this catches the most egrarious ones).
@ -353,7 +354,7 @@ downloadWeb addunlockedmatcher o url urlinfo file =
urlkey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing (verifiableOption o)
downloader f p = Url.withUrlOptions $ downloadUrl False urlkey p Nothing [url] f
go Nothing = return Nothing
go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile (fromRawFilePath tmp)))
go (Just (tmp, backend)) = ifM (useYoutubeDl o <&&> liftIO (isHtmlFile tmp))
( tryyoutubedl tmp backend
, normalfinish tmp backend
)
@ -567,7 +568,7 @@ nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd
url2file :: URI -> Maybe Int -> Int -> FilePath
url2file url pathdepth pathmax = case pathdepth of
Nothing -> truncateFilePath pathmax $ sanitizeFilePath fullurl
Nothing -> truncatesanitize fullurl
Just depth
| depth >= length urlbits -> frombits id
| depth > 0 -> frombits $ drop depth
@ -580,8 +581,12 @@ url2file url pathdepth pathmax = case pathdepth of
, uriQuery url
]
frombits a = intercalate "/" $ a urlbits
urlbits = map (truncateFilePath pathmax . sanitizeFilePath) $
urlbits = map truncatesanitize $
filter (not . null) $ splitc '/' fullurl
truncatesanitize = fromRawFilePath
. truncateFilePath pathmax
. toRawFilePath
. sanitizeFilePath
urlString2file :: URLString -> Maybe Int -> Int -> FilePath
urlString2file s pathdepth pathmax = case Url.parseURIRelaxed s of

4
Command/Export.hs
View file

@ -312,12 +312,12 @@ performExport r srcrs db ek af contentsha loc allfilledvar = do
sent <- tryNonAsync $ if not (isGitShaKey ek)
then tryrenameannexobject $ sendannexobject
-- Sending a non-annexed file.
else withTmpFile "export" $ \tmp h -> do
else withTmpFile (toOsPath "export") $ \tmp h -> do
b <- catObject contentsha
liftIO $ L.hPut h b
liftIO $ hClose h
Remote.action $
storer tmp ek loc nullMeterUpdate
storer (fromRawFilePath (fromOsPath tmp)) ek loc nullMeterUpdate
let failedsend = liftIO $ modifyMVar_ allfilledvar (pure . const (AllFilled False))
case sent of
Right True -> next $ cleanupExport r db ek loc True

6
Command/Fix.hs
View file

@ -72,7 +72,7 @@ start fixwhat si file key = do
breakHardLink :: RawFilePath -> Key -> RawFilePath -> CommandPerform
breakHardLink file key obj = do
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
unlessM (checkedCopyFile key obj tmp mode) $
giveup "unable to break hard link"
@ -83,7 +83,7 @@ breakHardLink file key obj = do
makeHardLink :: RawFilePath -> Key -> CommandPerform
makeHardLink file key = do
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
linkFromAnnex' key tmp mode >>= \case
LinkAnnexFailed -> giveup "unable to make hard link"
@ -97,7 +97,7 @@ fixSymlink file link = do
mtime <- liftIO $ catchMaybeIO $ Posix.modificationTimeHiRes
<$> R.getSymbolicLinkStatus file
#endif
replaceWorkTreeFile (fromRawFilePath file) $ \tmpfile -> do
replaceWorkTreeFile file $ \tmpfile -> do
liftIO $ R.createSymbolicLink link tmpfile
#if ! defined(mingw32_HOST_OS)
liftIO $ maybe noop (\t -> touch tmpfile t False) mtime

7
Command/Fsck.hs
View file

@ -45,6 +45,7 @@ import qualified Database.Fsck as FsckDb
import Types.CleanupActions
import Types.Key
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Data.Time.Clock.POSIX
import System.Posix.Types (EpochTime)
@ -417,7 +418,7 @@ verifyWorkTree key file = do
case mk of
Just k | k == key -> whenM (inAnnex key) $ do
showNote "fixing worktree content"
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
replaceWorkTreeFile file $ \tmp -> do
mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file
ifM (annexThin <$> Annex.getGitConfig)
( void $ linkFromAnnex' key tmp mode
@ -678,7 +679,7 @@ recordStartTime u = do
f <- fromRepo (gitAnnexFsckState u)
createAnnexDirectory $ parentDir f
liftIO $ removeWhenExistsWith R.removeLink f
liftIO $ withFile (fromRawFilePath f) WriteMode $ \h -> do
liftIO $ F.withFile (toOsPath f) WriteMode $ \h -> do
#ifndef mingw32_HOST_OS
t <- modificationTime <$> R.getFileStatus f
#else
@ -701,7 +702,7 @@ getStartTime u = do
liftIO $ catchDefaultIO Nothing $ do
timestamp <- modificationTime <$> R.getFileStatus f
let fromstatus = Just (realToFrac timestamp)
fromfile <- parsePOSIXTime <$> readFile (fromRawFilePath f)
fromfile <- parsePOSIXTime <$> F.readFile' (toOsPath f)
return $ if matchingtimestamp fromfile fromstatus
then Just timestamp
else Nothing

7
Command/ImportFeed.hs
View file

@ -158,10 +158,11 @@ getFeed o url st =
| scrapeOption o = scrape
| otherwise = get
get = withTmpFile "feed" $ \tmpf h -> do
get = withTmpFile (toOsPath "feed") $ \tmpf h -> do
let tmpf' = fromRawFilePath $ fromOsPath tmpf
liftIO $ hClose h
ifM (downloadFeed url tmpf)
( parse tmpf
ifM (downloadFeed url tmpf')
( parse tmpf'
, do
recordfail
next $ feedProblem url

2
Command/Lock.hs
View file

@ -78,7 +78,7 @@ perform file key = do
breakhardlink obj = whenM (catchBoolIO $ (> 1) . linkCount <$> liftIO (R.getFileStatus obj)) $ do
mfc <- withTSDelta (liftIO . genInodeCache file)
unlessM (sameInodeCache obj (maybeToList mfc)) $ do
modifyContentDir obj $ replaceGitAnnexDirFile (fromRawFilePath obj) $ \tmp -> do
modifyContentDir obj $ replaceGitAnnexDirFile obj $ \tmp -> do
unlessM (checkedCopyFile key obj tmp Nothing) $
giveup "unable to lock file"
Database.Keys.storeInodeCaches key [obj]

10
Command/Multicast.hs
View file

@ -130,7 +130,7 @@ send ups fs = do
-- the names of keys, and would have to be copied, which is too
-- expensive.
starting "sending files" (ActionItemOther Nothing) (SeekInput []) $
withTmpFile "send" $ \t h -> do
withTmpFile (toOsPath "send") $ \t h -> do
let ww = WarnUnmatchLsFiles "multicast"
(fs', cleanup) <- seekHelper id ww LsFiles.inRepo
=<< workTreeItems ww fs
@ -163,7 +163,7 @@ send ups fs = do
-- only allow clients on the authlist
, Param "-H", Param ("@"++authlist)
-- pass in list of files to send
, Param "-i", File t
, Param "-i", File (fromRawFilePath (fromOsPath t))
] ++ ups
liftIO (boolSystem "uftp" ps) >>= showEndResult
next $ return True
@ -178,7 +178,7 @@ receive ups = starting "receiving multicast files" ai si $ do
(callback, environ, statush) <- liftIO multicastCallbackEnv
tmpobjdir <- fromRepo gitAnnexTmpObjectDir
createAnnexDirectory tmpobjdir
withTmpDirIn (fromRawFilePath tmpobjdir) "multicast" $ \tmpdir -> withAuthList $ \authlist -> do
withTmpDirIn (fromRawFilePath tmpobjdir) (toOsPath "multicast") $ \tmpdir -> withAuthList $ \authlist -> do
abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir)
abscallback <- liftIO $ searchPath callback
let ps =
@ -245,10 +245,10 @@ uftpUID u = "0x" ++ (take 8 $ show $ sha2_256 $ B8.fromString (fromUUID u))
withAuthList :: (FilePath -> Annex a) -> Annex a
withAuthList a = do
m <- knownFingerPrints
withTmpFile "authlist" $ \t h -> do
withTmpFile (toOsPath "authlist") $ \t h -> do
liftIO $ hPutStr h (genAuthList m)
liftIO $ hClose h
a t
a (fromRawFilePath (fromOsPath t))
genAuthList :: M.Map UUID Fingerprint -> String
genAuthList = unlines . map fmt . M.toList

21
Command/P2P.hs
View file

@ -26,6 +26,7 @@ import Utility.FileMode
import Utility.ThreadScheduler
import Utility.SafeOutput
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Utility.MagicWormhole as Wormhole
import Control.Concurrent.Async
@ -193,12 +194,11 @@ serializePairData :: PairData -> String
serializePairData (PairData (HalfAuthToken ha) addrs) = unlines $
T.unpack ha : map formatP2PAddress addrs
deserializePairData :: String -> Maybe PairData
deserializePairData s = case lines s of
[] -> Nothing
(ha:l) -> do
addrs <- mapM unformatP2PAddress l
return (PairData (HalfAuthToken (T.pack ha)) addrs)
deserializePairData :: [String] -> Maybe PairData
deserializePairData [] = Nothing
deserializePairData (ha:l) = do
addrs <- mapM unformatP2PAddress l
return (PairData (HalfAuthToken (T.pack ha)) addrs)
data PairingResult
= PairSuccess
@ -220,7 +220,7 @@ wormholePairing remotename ouraddrs ui = do
-- files. Permissions of received files may allow others
-- to read them. So, set up a temp directory that only
-- we can read.
withTmpDir "pair" $ \tmp -> do
withTmpDir (toOsPath "pair") $ \tmp -> do
liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $
removeModes otherGroupModes
let sendf = tmp </> "send"
@ -245,13 +245,14 @@ wormholePairing remotename ouraddrs ui = do
then return ReceiveFailed
else do
r <- liftIO $ tryIO $
readFileStrict recvf
map decodeBS . fileLines' <$> F.readFile'
(toOsPath (toRawFilePath recvf))
case r of
Left _e -> return ReceiveFailed
Right s -> maybe
Right ls -> maybe
(return ReceiveFailed)
(finishPairing 100 remotename ourhalf)
(deserializePairData s)
(deserializePairData ls)
-- | Allow the peer we're pairing with to authenticate to us,
-- using an authtoken constructed from the two HalfAuthTokens.

4
Command/P2PHttp.hs
View file

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

2
Command/ReKey.hs
View file

@ -104,7 +104,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file)
st <- liftIO $ R.getFileStatus file
when (linkCount st > 1) $ do
freezeContent oldobj
replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
replaceWorkTreeFile file $ \tmp -> do
unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $
giveup "can't lock old key"
thawContent tmp

11
Command/ResolveMerge.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Command.ResolveMerge where
import Command
@ -12,8 +14,9 @@ import qualified Git
import Git.Sha
import qualified Git.Branch
import Annex.AutoMerge
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
cmd :: Command
cmd = command "resolvemerge" SectionPlumbing
@ -26,10 +29,10 @@ seek = withNothing (commandAction start)
start :: CommandStart
start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do
us <- fromMaybe nobranch <$> inRepo Git.Branch.current
d <- fromRawFilePath <$> fromRepo Git.localGitDir
let merge_head = d </> "MERGE_HEAD"
d <- fromRepo Git.localGitDir
let merge_head = toOsPath $ d P.</> "MERGE_HEAD"
them <- fromMaybe (giveup nomergehead) . extractSha
<$> liftIO (S.readFile merge_head)
<$> liftIO (F.readFile' merge_head)
ifM (resolveMerge (Just us) them False)
( do
void $ commitResolvedMerge Git.Branch.ManualCommit

23
Command/TestRemote.hs
View file

@ -32,6 +32,7 @@ import Annex.SpecialRemote.Config (exportTreeField)
import Remote.Helper.Chunked
import Remote.Helper.Encryptable (encryptionField, highRandomQualityField)
import Git.Types
import qualified Utility.FileIO as F
import Test.Tasty
import Test.Tasty.Runners
@ -255,18 +256,18 @@ test runannex mkr mkk =
get r k
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 0" $ \r k -> do
tmp <- fromRawFilePath <$> prepTmp k
liftIO $ writeFile tmp ""
tmp <- toOsPath <$> prepTmp k
liftIO $ F.writeFile' tmp mempty
lockContentForRemoval k noop removeAnnex
get r k
, check "fsck downloaded object" fsck
, check "retrieveKeyFile resume from 33%" $ \r k -> do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
tmp <- fromRawFilePath <$> prepTmp k
tmp <- toOsPath <$> prepTmp k
partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do
sz <- hFileSize h
L.hGet h $ fromInteger $ sz `div` 3
liftIO $ L.writeFile tmp partial
liftIO $ F.writeFile tmp partial
lockContentForRemoval k noop removeAnnex
get r k
, check "fsck downloaded object" fsck
@ -355,11 +356,11 @@ testExportTree runannex mkr mkk1 mkk2 =
storeexport ea k = do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
Remote.storeExport ea loc k testexportlocation nullMeterUpdate
retrieveexport ea k = withTmpFile "exported" $ \tmp h -> do
retrieveexport ea k = withTmpFile (toOsPath "exported") $ \tmp h -> do
liftIO $ hClose h
tryNonAsync (Remote.retrieveExport ea k testexportlocation tmp nullMeterUpdate) >>= \case
tryNonAsync (Remote.retrieveExport ea k testexportlocation (fromRawFilePath (fromOsPath tmp)) nullMeterUpdate) >>= \case
Left _ -> return False
Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (toRawFilePath tmp)
Right v -> verifyKeyContentPostRetrieval RetrievalAllKeysSecure AlwaysVerify v k (fromOsPath tmp)
checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation
removeexport ea k = Remote.removeExport ea k testexportlocation
removeexportdirectory ea = case Remote.removeExportDirectory ea of
@ -429,21 +430,21 @@ keySizes base fast = filter want
| otherwise = sz > 0
randKey :: Int -> Annex Key
randKey sz = withTmpFile "randkey" $ \f h -> do
randKey sz = withTmpFile (toOsPath "randkey") $ \f h -> do
gen <- liftIO (newGenIO :: IO SystemRandom)
case genBytes sz gen of
Left e -> giveup $ "failed to generate random key: " ++ show e
Right (rand, _) -> liftIO $ B.hPut h rand
liftIO $ hClose h
let ks = KeySource
{ keyFilename = toRawFilePath f
, contentLocation = toRawFilePath f
{ keyFilename = fromOsPath f
, contentLocation = fromOsPath f
, inodeCache = Nothing
}
k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of
Just a -> a ks nullMeterUpdate
Nothing -> giveup "failed to generate random key (backend problem)"
_ <- moveAnnex k (AssociatedFile Nothing) (toRawFilePath f)
_ <- moveAnnex k (AssociatedFile Nothing) (fromOsPath f)
return k
getReadonlyKey :: Remote -> RawFilePath -> Annex Key

10
Command/Uninit.hs
View file

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

2
Command/Unlock.hs
View file

@ -51,7 +51,7 @@ start si file key = ifM (isJust <$> isAnnexLink file)
perform :: RawFilePath -> Key -> CommandPerform
perform dest key = do
destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus dest
destic <- replaceWorkTreeFile (fromRawFilePath dest) $ \tmp -> do
destic <- replaceWorkTreeFile dest $ \tmp -> do
ifM (inAnnex key)
( do
r <- linkFromAnnex' key tmp destmode

10
Command/Vicfg.hs
View file

@ -35,6 +35,7 @@ import Remote
import Git.Types (fromConfigKey, fromConfigValue)
import Utility.DataUnits
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
cmd :: Command
cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch"
@ -60,7 +61,10 @@ vicfg curcfg f = do
-- Allow EDITOR to be processed by the shell, so it can contain options.
unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $
giveup $ vi ++ " exited nonzero; aborting"
r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f)
r <- liftIO $ parseCfg (defCfg curcfg)
. map decodeBS
. fileLines'
<$> F.readFile' (toOsPath (toRawFilePath f))
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
case r of
Left s -> do
@ -278,8 +282,8 @@ lcom = map (\l -> if "#" `isPrefixOf` l then l else '#' : l)
{- If there's a parse error, returns a new version of the file,
- with the problem lines noted. -}
parseCfg :: Cfg -> String -> Either String Cfg
parseCfg defcfg = go [] defcfg . lines
parseCfg :: Cfg -> [String] -> Either String Cfg
parseCfg defcfg = go [] defcfg
where
go c cfg []
| null (mapMaybe fst c) = Right cfg

2
Common.hs
View file

@ -24,6 +24,7 @@ import Utility.Process as X
import Utility.Path as X
import Utility.Path.AbsRel as X
import Utility.Directory as X
import Utility.SystemDirectory as X
import Utility.MoveFile as X
import Utility.Monad as X
import Utility.Data as X
@ -32,5 +33,6 @@ import Utility.FileSize as X
import Utility.Network as X
import Utility.Split as X
import Utility.FileSystemEncoding as X
import Utility.OsPath as X
import Utility.PartialPrelude as X

4
Config/Files/AutoStart.hs
View file

@ -31,7 +31,9 @@ modifyAutoStartFile func = do
f <- autoStartFile
createDirectoryIfMissing True $
fromRawFilePath (parentDir (toRawFilePath f))
viaTmp writeFile f $ unlines dirs'
viaTmp (writeFile . fromRawFilePath . fromOsPath)
(toOsPath (toRawFilePath f))
(unlines dirs')
{- Adds a directory to the autostart file. If the directory is already
- present, it's moved to the top, so it will be used as the default

16
Config/Smudge.hs
View file

@ -17,7 +17,9 @@ import Git.Types
import Config
import Utility.Directory.Create
import Annex.Version
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
configureSmudgeFilter :: Annex ()
@ -44,11 +46,12 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
lfs <- readattr lf
gfs <- readattr gf
gittop <- Git.localGitDir <$> gitRepo
liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do
liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do
createDirectoryUnder [gittop] (P.takeDirectory lf)
writeFile (fromRawFilePath lf) (lfs ++ "\n" ++ unlines stdattr)
F.writeFile' (toOsPath lf) $
linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr))
where
readattr = liftIO . catchDefaultIO "" . readFileStrict . fromRawFilePath
readattr = liftIO . catchDefaultIO mempty . F.readFile' . toOsPath
configureSmudgeFilterProcess :: Annex ()
configureSmudgeFilterProcess =
@ -65,9 +68,10 @@ stdattr =
-- git-annex does not commit that.
deconfigureSmudgeFilter :: Annex ()
deconfigureSmudgeFilter = do
lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal
ls <- liftIO $ catchDefaultIO [] $ lines <$> readFileStrict lf
liftIO $ writeFile lf $ unlines $
lf <- Annex.fromRepo Git.attributesLocal
ls <- liftIO $ catchDefaultIO [] $
map decodeBS . fileLines' <$> F.readFile' (toOsPath lf)
liftIO $ writeFile (fromRawFilePath lf) $ unlines $
filter (\l -> l `notElem` stdattr && not (null l)) ls
unsetConfig (ConfigKey "filter.annex.smudge")
unsetConfig (ConfigKey "filter.annex.clean")

16
Creds.hs
View file

@ -37,9 +37,10 @@ import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, Encry
import Utility.Env (getEnv)
import Utility.Base64
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Char8 as S8
import qualified Data.Map as M
import qualified System.FilePath.ByteString as P
@ -99,7 +100,7 @@ setRemoteCredPair' pc encsetup gc storage mcreds = case mcreds of
storeconfig creds key (Just cipher) = do
cmd <- gpgCmd <$> Annex.getGitConfig
s <- liftIO $ encrypt cmd (pc, gc) cipher
(feedBytes $ L.pack $ encodeCredPair creds)
(feedBytes $ L8.pack $ encodeCredPair creds)
(readBytesStrictly return)
storeconfig' key (Accepted (decodeBS (toB64 s)))
storeconfig creds key Nothing =
@ -135,8 +136,8 @@ getRemoteCredPair c gc storage = maybe fromcache (return . Just) =<< fromenv
fromenccreds enccreds cipher storablecipher = do
cmd <- gpgCmd <$> Annex.getGitConfig
mcreds <- liftIO $ catchMaybeIO $ decrypt cmd (c, gc) cipher
(feedBytes $ L.fromStrict $ fromB64 enccreds)
(readBytesStrictly $ return . S.unpack)
(feedBytes $ L8.fromStrict $ fromB64 enccreds)
(readBytesStrictly $ return . S8.unpack)
case mcreds of
Just creds -> fromcreds creds
Nothing -> do
@ -202,7 +203,10 @@ writeCreds creds file = do
liftIO $ writeFileProtected (d P.</> toRawFilePath file) creds
readCreds :: FilePath -> Annex (Maybe Creds)
readCreds f = liftIO . catchMaybeIO . readFileStrict =<< credsFile f
readCreds f = do
f' <- toOsPath . toRawFilePath <$> credsFile f
liftIO $ catchMaybeIO $ decodeBS . S8.unlines . fileLines'
<$> F.readFile' f'
credsFile :: FilePath -> Annex FilePath
credsFile basefile = do

4
Crypto.hs
View file

@ -211,7 +211,7 @@ encrypt gpgcmd c cipher feeder reader = case cipher of
Cipher{} ->
let passphrase = cipherPassphrase cipher
in case statelessOpenPGPCommand c of
Just sopcmd -> withTmpDir "sop" $ \d ->
Just sopcmd -> withTmpDir (toOsPath "sop") $ \d ->
SOP.encryptSymmetric sopcmd passphrase
(SOP.EmptyDirectory d)
(statelessOpenPGPProfile c)
@ -233,7 +233,7 @@ decrypt cmd c cipher feeder reader = case cipher of
Cipher{} ->
let passphrase = cipherPassphrase cipher
in case statelessOpenPGPCommand c of
Just sopcmd -> withTmpDir "sop" $ \d ->
Just sopcmd -> withTmpDir (toOsPath "sop") $ \d ->
SOP.decryptSymmetric sopcmd passphrase
(SOP.EmptyDirectory d)
feeder reader

2
Database/Benchmark.hs
View file

@ -31,7 +31,7 @@ import qualified System.FilePath.ByteString as P
benchmarkDbs :: CriterionMode -> Integer -> Annex ()
#ifdef WITH_BENCHMARK
benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do
benchmarkDbs mode n = withTmpDirIn "." (toOsPath "benchmark") $ \tmpdir -> do
db <- benchDb (toRawFilePath tmpdir) n
liftIO $ runMode mode
[ bgroup "keys database"

6
Git/HashObject.hs
View file

@ -5,7 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.HashObject where
@ -82,10 +82,10 @@ instance HashableBlob Builder where
{- Injects a blob into git. Unfortunately, the current git-hash-object
- interface does not allow batch hashing without using temp files. -}
hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha
hashBlob h b = withTmpFile "hash" $ \tmp tmph -> do
hashBlob h b = withTmpFile (toOsPath "hash") $ \tmp tmph -> do
hashableBlobToHandle tmph b
hClose tmph
hashFile h (toRawFilePath tmp)
hashFile h (fromOsPath tmp)
{- Injects some content into git, returning its Sha.
-

32
Git/Hook.hs
View file

@ -6,6 +6,7 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.Hook where
@ -14,15 +15,16 @@ import Git
import Utility.Tmp
import Utility.Shell
import Utility.FileMode
import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import qualified Utility.RawFilePath as R
import System.PosixCompat.Files (fileMode)
#endif
import qualified Data.ByteString as B
import qualified System.FilePath.ByteString as P
data Hook = Hook
{ hookName :: FilePath
{ hookName :: RawFilePath
, hookScript :: String
, hookOldScripts :: [String]
}
@ -31,8 +33,8 @@ data Hook = Hook
instance Eq Hook where
a == b = hookName a == hookName b
hookFile :: Hook -> Repo -> FilePath
hookFile h r = fromRawFilePath (localGitDir r) </> "hooks" </> hookName h
hookFile :: Hook -> Repo -> RawFilePath
hookFile h r = localGitDir r P.</> "hooks" P.</> hookName h
{- Writes a hook. Returns False if the hook already exists with a different
- content. Upgrades old scripts.
@ -48,7 +50,7 @@ hookFile h r = fromRawFilePath (localGitDir r) </> "hooks" </> hookName h
- is run with a bundled bash, so should start with #!/bin/sh
-}
hookWrite :: Hook -> Repo -> IO Bool
hookWrite h r = ifM (doesFileExist f)
hookWrite h r = ifM (doesFileExist (fromRawFilePath f))
( expectedContent h r >>= \case
UnexpectedContent -> return False
ExpectedContent -> return True
@ -58,15 +60,13 @@ hookWrite h r = ifM (doesFileExist f)
where
f = hookFile h r
go = do
-- On Windows, using B.writeFile here avoids
-- the newline translation done by writeFile.
-- On Windows, using a ByteString as the file content
-- avoids the newline translation done by writeFile.
-- Hook scripts on Windows could use CRLF endings, but
-- they typically use unix newlines, which does work there
-- and makes the repository more portable.
viaTmp B.writeFile f (encodeBS (hookScript h))
void $ tryIO $ modifyFileMode
(toRawFilePath f)
(addModes executeModes)
viaTmp F.writeFile' (toOsPath f) (encodeBS (hookScript h))
void $ tryIO $ modifyFileMode f (addModes executeModes)
return True
{- Removes a hook. Returns False if the hook contained something else, and
@ -81,7 +81,7 @@ hookUnWrite h r = ifM (doesFileExist f)
, return True
)
where
f = hookFile h r
f = fromRawFilePath $ hookFile h r
data ExpectedContent = UnexpectedContent | ExpectedContent | OldExpectedContent
@ -91,7 +91,7 @@ expectedContent h r = do
-- and so a hook file that has CRLF will be treated the same as one
-- that has LF. That is intentional, since users may have a reason
-- to prefer one or the other.
content <- readFile $ hookFile h r
content <- readFile $ fromRawFilePath $ hookFile h r
return $ if content == hookScript h
then ExpectedContent
else if any (content ==) (hookOldScripts h)
@ -103,13 +103,13 @@ hookExists h r = do
let f = hookFile h r
catchBoolIO $
#ifndef mingw32_HOST_OS
isExecutable . fileMode <$> R.getFileStatus (toRawFilePath f)
isExecutable . fileMode <$> R.getFileStatus f
#else
doesFileExist f
doesFileExist (fromRawFilePath f)
#endif
runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a
runHook runner h ps r = do
let f = hookFile h r
let f = fromRawFilePath $ hookFile h r
(c, cps) <- findShellCommand f
runner c (cps ++ ps)

2
Git/LsFiles.hs
View file

@ -373,4 +373,4 @@ inodeCaches locs repo = guardSafeForLsFiles repo $ do
mkInodeCache
<$> (readish =<< M.lookup "ino:" m)
<*> (readish =<< M.lookup "size:" m)
<*> (parsePOSIXTime =<< (replace ":" "." <$> M.lookup "mtime:" m))
<*> (parsePOSIXTime =<< (encodeBS . replace ":" "." <$> M.lookup "mtime:" m))

10
Git/Objects.hs
View file

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

9
Git/Ref.hs
View file

@ -15,19 +15,22 @@ import Git.Command
import Git.Sha
import Git.Types
import Git.FilePath
import qualified Utility.FileIO as F
import Data.Char (chr, ord)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified System.FilePath.ByteString as P
headRef :: Ref
headRef = Ref "HEAD"
headFile :: Repo -> FilePath
headFile r = fromRawFilePath (localGitDir r) </> "HEAD"
headFile :: Repo -> RawFilePath
headFile r = localGitDir r P.</> "HEAD"
setHeadRef :: Ref -> Repo -> IO ()
setHeadRef ref r = S.writeFile (headFile r) ("ref: " <> fromRef' ref)
setHeadRef ref r =
F.writeFile' (toOsPath (headFile r)) ("ref: " <> fromRef' ref)
{- Converts a fully qualified git ref into a user-visible string. -}
describe :: Ref -> String

44
Git/Repair.hs
View file

@ -44,8 +44,10 @@ import Utility.Tmp.Dir
import Utility.Rsync
import Utility.FileMode
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified Data.Set as S
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
@ -78,29 +80,28 @@ explodePacks :: Repo -> IO Bool
explodePacks r = go =<< listPackFiles r
where
go [] = return False
go packs = withTmpDir "packs" $ \tmpdir -> do
go packs = withTmpDir (toOsPath "packs") $ \tmpdir -> do
r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
-- Just in case permissions are messed up.
allowRead (toRawFilePath packfile)
allowRead packfile
-- May fail, if pack file is corrupt.
void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
L.hPut h =<< L.readFile packfile
objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir)
L.hPut h =<< F.readFile (toOsPath packfile)
objs <- emptyWhenDoesNotExist (dirContentsRecursive (toRawFilePath tmpdir))
forM_ objs $ \objfile -> do
f <- relPathDirToFile
(toRawFilePath tmpdir)
(toRawFilePath objfile)
objfile
let dest = objectsDir r P.</> f
createDirectoryIfMissing True
(fromRawFilePath (parentDir dest))
moveFile (toRawFilePath objfile) dest
moveFile objfile dest
forM_ packs $ \packfile -> do
let f = toRawFilePath packfile
removeWhenExistsWith R.removeLink f
removeWhenExistsWith R.removeLink (packIdxFile f)
removeWhenExistsWith R.removeLink packfile
removeWhenExistsWith R.removeLink (packIdxFile packfile)
return True
{- Try to retrieve a set of missing objects, from the remotes of a
@ -113,13 +114,13 @@ explodePacks r = go =<< listPackFiles r
retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
retrieveMissingObjects missing referencerepo r
| not (foundBroken missing) = return missing
| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
| otherwise = withTmpDir (toOsPath "tmprepo") $ \tmpdir -> do
unlessM (boolSystem "git" [Param "init", File tmpdir]) $
giveup $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)
let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config")
whenM (doesFileExist (repoconfig r)) $
L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr)
let repoconfig r' = toOsPath (localGitDir r' P.</> "config")
whenM (doesFileExist (fromRawFilePath (fromOsPath (repoconfig r)))) $
F.readFile (repoconfig r) >>= F.writeFile (repoconfig tmpr)
rs <- Construct.fromRemotes r
stillmissing <- pullremotes tmpr rs fetchrefstags missing
if S.null (knownMissing stillmissing)
@ -248,13 +249,14 @@ badBranches missing r = filterM isbad =<< getAllRefs r
- Relies on packed refs being exploded before it's called.
-}
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
let topsegs = length (splitPath refdir) - 1
let topsegs = length (P.splitPath refdir) - 1
let toref = Ref . toInternalGitPath . encodeBS
. joinPath . drop topsegs . splitPath
. decodeBS
map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
explodePackedRefsFile :: Repo -> IO ()
@ -262,7 +264,9 @@ explodePackedRefsFile r = do
let f = packedRefsFile r
let f' = toRawFilePath f
whenM (doesFileExist f) $ do
rs <- mapMaybe parsePacked . lines
rs <- mapMaybe parsePacked
. map decodeBS
. fileLines'
<$> catchDefaultIO "" (safeReadFile f')
forM_ rs makeref
removeWhenExistsWith R.removeLink f'
@ -473,7 +477,7 @@ displayList items header
-}
preRepair :: Repo -> IO ()
preRepair g = do
unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do
unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do
removeWhenExistsWith R.removeLink headfile
writeFile (fromRawFilePath headfile) "ref: refs/heads/master"
explodePackedRefsFile g
@ -651,7 +655,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do
successfulRepair :: (Bool, [Branch]) -> Bool
successfulRepair = fst
safeReadFile :: RawFilePath -> IO String
safeReadFile :: RawFilePath -> IO B.ByteString
safeReadFile f = do
allowRead f
readFileStrict (fromRawFilePath f)
F.readFile' (toOsPath f)

2
Logs/AdjustedBranchUpdate.hs
View file

@ -80,5 +80,5 @@ parseAdjustLog l =
"1" -> Just True
"0" -> Just False
_ -> Nothing
t <- parsePOSIXTime ts
t <- parsePOSIXTime (encodeBS ts)
return (b, t)

3
Logs/Export.hs
View file

@ -34,6 +34,7 @@ import Logs.File
import qualified Git.LsTree
import qualified Git.Tree
import Annex.UUID
import qualified Utility.FileIO as F
import qualified Data.Map as M
import qualified Data.ByteString as B
@ -129,7 +130,7 @@ getExportExcluded :: UUID -> Annex [Git.Tree.TreeItem]
getExportExcluded u = do
logf <- fromRepo $ gitAnnexExportExcludeLog u
liftIO $ catchDefaultIO [] $ exportExcludedParser
<$> L.readFile (fromRawFilePath logf)
<$> F.readFile (toOsPath logf)
where
exportExcludedParser :: L.ByteString -> [Git.Tree.TreeItem]

72
Logs/File.hs
View file

@ -26,9 +26,8 @@ import Annex.Perms
import Annex.LockFile
import Annex.ReplaceFile
import Utility.Tmp
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
@ -36,23 +35,23 @@ import qualified Data.ByteString.Lazy.Char8 as L8
-- making the new file have whatever permissions the git repository is
-- configured to use. Creates the parent directory when necessary.
writeLogFile :: RawFilePath -> String -> Annex ()
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (fromRawFilePath f) c
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (toOsPath f) c
where
writelog tmp c' = do
liftIO $ writeFile tmp c'
setAnnexFilePerm (toRawFilePath tmp)
liftIO $ writeFile (fromRawFilePath (fromOsPath tmp)) c'
setAnnexFilePerm (fromOsPath tmp)
-- | Runs the action with a handle connected to a temp file.
-- The temp file replaces the log file once the action succeeds.
withLogHandle :: RawFilePath -> (Handle -> Annex a) -> Annex a
withLogHandle f a = do
createAnnexDirectory (parentDir f)
replaceGitAnnexDirFile (fromRawFilePath f) $ \tmp ->
replaceGitAnnexDirFile f $ \tmp ->
bracket (setup tmp) cleanup a
where
setup tmp = do
setAnnexFilePerm tmp
liftIO $ openFile (fromRawFilePath tmp) WriteMode
liftIO $ F.openFile (toOsPath tmp) WriteMode
cleanup h = liftIO $ hClose h
-- | Appends a line to a log file, first locking it to prevent
@ -61,11 +60,9 @@ appendLogFile :: RawFilePath -> RawFilePath -> L.ByteString -> Annex ()
appendLogFile f lck c =
createDirWhenNeeded f $
withExclusiveLock lck $ do
liftIO $ withFile f' AppendMode $
liftIO $ F.withFile (toOsPath f) AppendMode $
\h -> L8.hPutStrLn h c
setAnnexFilePerm (toRawFilePath f')
where
f' = fromRawFilePath f
setAnnexFilePerm f
-- | Modifies a log file.
--
@ -78,29 +75,28 @@ appendLogFile f lck c =
modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
modifyLogFile f lck modf = withExclusiveLock lck $ do
ls <- liftIO $ fromMaybe []
<$> tryWhenExists (fileLines <$> L.readFile f')
<$> tryWhenExists (fileLines <$> F.readFile f')
let ls' = modf ls
when (ls' /= ls) $
createDirWhenNeeded f $
viaTmp writelog f' (L8.unlines ls')
where
f' = fromRawFilePath f
f' = toOsPath f
writelog lf b = do
liftIO $ L.writeFile lf b
setAnnexFilePerm (toRawFilePath lf)
liftIO $ F.writeFile lf b
setAnnexFilePerm (fromOsPath lf)
-- | Checks the content of a log file to see if any line matches.
checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool
checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go
where
setup = liftIO $ tryWhenExists $ openFile f' ReadMode
setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = return False
go (Just h) = do
!r <- liftIO (any matchf . fileLines <$> L.hGetContents h)
return r
f' = fromRawFilePath f
-- | Folds a function over lines of a log file to calculate a value.
calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
@ -111,7 +107,7 @@ calcLogFile f lck start update =
calcLogFileUnsafe :: RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t
calcLogFileUnsafe f start update = bracket setup cleanup go
where
setup = liftIO $ tryWhenExists $ openFile f' ReadMode
setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = return start
@ -120,7 +116,6 @@ calcLogFileUnsafe f start update = bracket setup cleanup go
go' v (l:ls) = do
let !v' = update l v
go' v' ls
f' = fromRawFilePath f
-- | Streams lines from a log file, passing each line to the processor,
-- and then empties the file at the end.
@ -134,19 +129,19 @@ calcLogFileUnsafe f start update = bracket setup cleanup go
--
-- Locking is used to prevent writes to to the log file while this
-- is running.
streamLogFile :: FilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFile :: RawFilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFile f lck finalizer processor =
withExclusiveLock lck $ do
streamLogFileUnsafe f finalizer processor
liftIO $ writeFile f ""
setAnnexFilePerm (toRawFilePath f)
liftIO $ F.writeFile' (toOsPath f) mempty
setAnnexFilePerm f
-- Unsafe version that does not do locking, and does not empty the file
-- at the end.
streamLogFileUnsafe :: FilePath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFileUnsafe :: RawFilePath -> Annex () -> (String -> Annex ()) -> Annex ()
streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go
where
setup = liftIO $ tryWhenExists $ openFile f ReadMode
setup = liftIO $ tryWhenExists $ F.openFile (toOsPath f) ReadMode
cleanup Nothing = noop
cleanup (Just h) = liftIO $ hClose h
go Nothing = finalizer
@ -161,32 +156,3 @@ createDirWhenNeeded f a = a `catchNonAsync` \_e -> do
-- done if writing the file fails.
createAnnexDirectory (parentDir f)
a
-- On windows, readFile does NewlineMode translation,
-- stripping CR before LF. When converting to ByteString,
-- use this to emulate that.
fileLines :: L.ByteString -> [L.ByteString]
#ifdef mingw32_HOST_OS
fileLines = map stripCR . L8.lines
where
stripCR b = case L8.unsnoc b of
Nothing -> b
Just (b', e)
| e == '\r' -> b'
| otherwise -> b
#else
fileLines = L8.lines
#endif
fileLines' :: S.ByteString -> [S.ByteString]
#ifdef mingw32_HOST_OS
fileLines' = map stripCR . S8.lines
where
stripCR b = case S8.unsnoc b of
Nothing -> b
Just (b', e)
| e == '\r' -> b'
| otherwise -> b
#else
fileLines' = S8.lines
#endif

2
Logs/Migrate.hs
View file

@ -79,7 +79,7 @@ logMigration old new = do
-- | Commits a migration to the git-annex branch.
commitMigration :: Annex ()
commitMigration = do
logf <- fromRawFilePath <$> fromRepo gitAnnexMigrateLog
logf <- fromRepo gitAnnexMigrateLog
lckf <- fromRepo gitAnnexMigrateLock
nv <- liftIO $ newTVarIO (0 :: Integer)
g <- Annex.gitRepo

6
Logs/Restage.hs
View file

@ -14,6 +14,7 @@ import Git.FilePath
import Logs.File
import Utility.InodeCache
import Annex.LockFile
import qualified Utility.FileIO as F
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
@ -48,21 +49,20 @@ streamRestageLog :: Annex () -> (TopFilePath -> InodeCache -> Annex ()) -> Annex
streamRestageLog finalizer processor = do
logf <- fromRepo gitAnnexRestageLog
oldf <- fromRepo gitAnnexRestageLogOld
let oldf' = fromRawFilePath oldf
lckf <- fromRepo gitAnnexRestageLock
withExclusiveLock lckf $ liftIO $
whenM (R.doesPathExist logf) $
ifM (R.doesPathExist oldf)
( do
h <- openFile oldf' AppendMode
h <- F.openFile (toOsPath oldf) AppendMode
hPutStr h =<< readFile (fromRawFilePath logf)
hClose h
liftIO $ removeWhenExistsWith R.removeLink logf
, moveFile logf oldf
)
streamLogFileUnsafe oldf' finalizer $ \l ->
streamLogFileUnsafe oldf finalizer $ \l ->
case parseRestageLog l of
Just (f, ic) -> processor f ic
Nothing -> noop

2
Logs/Smudge.hs
View file

@ -34,7 +34,7 @@ streamSmudged :: (Key -> TopFilePath -> Annex ()) -> Annex ()
streamSmudged a = do
logf <- fromRepo gitAnnexSmudgeLog
lckf <- fromRepo gitAnnexSmudgeLock
streamLogFile (fromRawFilePath logf) lckf noop $ \l ->
streamLogFile logf lckf noop $ \l ->
case parse l of
Nothing -> noop
Just (k, f) -> a k f

30
Logs/Transfer.hs
View file

@ -22,6 +22,7 @@ import Annex.LockPool
import Utility.TimeStamp
import Logs.File
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import Annex.Perms
#endif
@ -29,6 +30,7 @@ import Annex.Perms
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Control.Concurrent.STM
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified System.FilePath.ByteString as P
@ -118,7 +120,7 @@ checkTransfer t = debugLocks $ do
(Just oldlck, _) -> getLockStatus oldlck
case v' of
StatusLockedBy pid -> liftIO $ catchDefaultIO Nothing $
readTransferInfoFile (Just pid) (fromRawFilePath tfile)
readTransferInfoFile (Just pid) tfile
_ -> do
mode <- annexFileMode
-- Ignore failure due to permissions, races, etc.
@ -139,7 +141,7 @@ checkTransfer t = debugLocks $ do
v <- liftIO $ lockShared lck
liftIO $ case v of
Nothing -> catchDefaultIO Nothing $
readTransferInfoFile Nothing (fromRawFilePath tfile)
readTransferInfoFile Nothing tfile
Just lockhandle -> do
dropLock lockhandle
deletestale
@ -157,7 +159,7 @@ getTransfers' dirs wanted = do
infos <- mapM checkTransfer transfers
return $ mapMaybe running $ zip transfers infos
where
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . transferDir) dirs
running (t, Just i) = Just (t, i)
running (_, Nothing) = Nothing
@ -184,7 +186,7 @@ getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles
return $ case (mt, mi) of
(Just t, Just i) -> Just (t, i)
_ -> Nothing
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]
clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
@ -244,17 +246,17 @@ failedTransferFile (Transfer direction u kd) r =
P.</> keyFile (mkKey (const kd))
{- Parses a transfer information filename to a Transfer. -}
parseTransferFile :: FilePath -> Maybe Transfer
parseTransferFile :: RawFilePath -> Maybe Transfer
parseTransferFile file
| "lck." `isPrefixOf` takeFileName file = Nothing
| "lck." `B.isPrefixOf` P.takeFileName file = Nothing
| otherwise = case drop (length bits - 3) bits of
[direction, u, key] -> Transfer
<$> parseDirection direction
<*> pure (toUUID u)
<*> fmap (fromKey id) (fileKey (toRawFilePath key))
<*> fmap (fromKey id) (fileKey key)
_ -> Nothing
where
bits = splitDirectories file
bits = P.splitDirectories file
writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex ()
writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
@ -284,9 +286,9 @@ writeTransferInfo info = unlines
in maybe "" fromRawFilePath afile
]
readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo)
readTransferInfoFile :: Maybe PID -> RawFilePath -> IO (Maybe TransferInfo)
readTransferInfoFile mpid tfile = catchDefaultIO Nothing $
readTransferInfo mpid <$> readFileStrict tfile
readTransferInfo mpid . decodeBS <$> F.readFile' (toOsPath tfile)
readTransferInfo :: Maybe PID -> String -> Maybe TransferInfo
readTransferInfo mpid s = TransferInfo
@ -303,8 +305,10 @@ readTransferInfo mpid s = TransferInfo
<*> pure False
where
#ifdef mingw32_HOST_OS
(firstline, otherlines) = separate (== '\n') s
(secondline, rest) = separate (== '\n') otherlines
(firstliner, otherlines) = separate (== '\n') s
(secondliner, rest) = separate (== '\n') otherlines
firstline = dropWhileEnd (== '\r') firstliner
secondline = dropWhileEnd (== '\r') secondliner
mpid' = readish secondline
#else
(firstline, rest) = separate (== '\n') s
@ -315,7 +319,7 @@ readTransferInfo mpid s = TransferInfo
bits = splitc ' ' firstline
numbits = length bits
time = if numbits > 0
then Just <$> parsePOSIXTime =<< headMaybe bits
then Just <$> parsePOSIXTime . encodeBS =<< headMaybe bits
else pure Nothing -- not failure
bytes = if numbits > 1
then Just <$> readish =<< headMaybe (drop 1 bits)

11
Logs/Unused.hs
View file

@ -32,6 +32,7 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.Time.Clock.POSIX
import Data.Time
import qualified Utility.FileIO as F
import Annex.Common
import qualified Annex
@ -73,14 +74,14 @@ writeUnusedLog prefix l = do
readUnusedLog :: RawFilePath -> Annex UnusedLog
readUnusedLog prefix = do
f <- fromRawFilePath <$> fromRepo (gitAnnexUnusedLog prefix)
ifM (liftIO $ doesFileExist f)
( M.fromList . mapMaybe parse . lines
<$> liftIO (readFileStrict f)
f <- fromRepo (gitAnnexUnusedLog prefix)
ifM (liftIO $ doesFileExist (fromRawFilePath f))
( M.fromList . mapMaybe (parse . decodeBS) . fileLines'
<$> liftIO (F.readFile' (toOsPath f))
, return M.empty
)
where
parse line = case (readish sint, deserializeKey skey, parsePOSIXTime ts) of
parse line = case (readish sint, deserializeKey skey, parsePOSIXTime (encodeBS ts)) of
(Just int, Just key, mtimestamp) -> Just (key, (int, mtimestamp))
_ -> Nothing
where

11
Logs/Upgrade.hs
View file

@ -19,6 +19,7 @@ import Annex.Common
import Utility.TimeStamp
import Logs.File
import Types.RepoVersion
import qualified Utility.FileIO as F
import Data.Time.Clock.POSIX
@ -31,14 +32,14 @@ writeUpgradeLog v t = do
readUpgradeLog :: Annex [(RepoVersion, POSIXTime)]
readUpgradeLog = do
logfile <- fromRawFilePath <$> fromRepo gitAnnexUpgradeLog
ifM (liftIO $ doesFileExist logfile)
( mapMaybe parse . lines
<$> liftIO (readFileStrict logfile)
logfile <- fromRepo gitAnnexUpgradeLog
ifM (liftIO $ doesFileExist (fromRawFilePath logfile))
( mapMaybe (parse . decodeBS) . fileLines'
<$> liftIO (F.readFile' (toOsPath logfile))
, return []
)
where
parse line = case (readish sint, parsePOSIXTime ts) of
parse line = case (readish sint, parsePOSIXTime (encodeBS ts)) of
(Just v, Just t) -> Just (RepoVersion v, t)
_ -> Nothing
where

25
Remote/BitTorrent.hs
View file

@ -35,10 +35,11 @@ import qualified Utility.RawFilePath as R
import Network.URI
import qualified System.FilePath.ByteString as P
import qualified Data.ByteString as S
#ifdef WITH_TORRENTPARSER
import Data.Torrent
import qualified Data.ByteString.Lazy as B
import qualified Utility.FileIO as F
#endif
remote :: RemoteType
@ -208,31 +209,29 @@ downloadTorrentFile u = do
let metadir = othertmp P.</> "torrentmeta" P.</> kf
createAnnexDirectory metadir
showOutput
ok <- downloadMagnetLink u
(fromRawFilePath metadir)
(fromRawFilePath torrent)
ok <- downloadMagnetLink u metadir torrent
liftIO $ removeDirectoryRecursive
(fromRawFilePath metadir)
return ok
else withOtherTmp $ \othertmp -> do
withTmpFileIn (fromRawFilePath othertmp) "torrent" $ \f h -> do
withTmpFileIn (toOsPath othertmp) (toOsPath "torrent") $ \f h -> do
liftIO $ hClose h
resetAnnexFilePerm (toRawFilePath f)
resetAnnexFilePerm (fromOsPath f)
ok <- Url.withUrlOptions $
Url.download nullMeterUpdate Nothing u f
Url.download nullMeterUpdate Nothing u (fromRawFilePath (fromOsPath f))
when ok $
liftIO $ moveFile (toRawFilePath f) torrent
liftIO $ moveFile (fromOsPath f) torrent
return ok
)
downloadMagnetLink :: URLString -> FilePath -> FilePath -> Annex Bool
downloadMagnetLink :: URLString -> RawFilePath -> RawFilePath -> Annex Bool
downloadMagnetLink u metadir dest = ifM download
( liftIO $ do
ts <- filter (".torrent" `isSuffixOf`)
ts <- filter (".torrent" `S.isSuffixOf`)
<$> dirContents metadir
case ts of
(t:[]) -> do
moveFile (toRawFilePath t) (toRawFilePath dest)
moveFile t dest
return True
_ -> return False
, return False
@ -245,7 +244,7 @@ downloadMagnetLink u metadir dest = ifM download
, Param "--seed-time=0"
, Param "--summary-interval=0"
, Param "-d"
, File metadir
, File (fromRawFilePath metadir)
]
downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool
@ -367,7 +366,7 @@ torrentFileSizes :: RawFilePath -> IO [(FilePath, Integer)]
torrentFileSizes torrent = do
#ifdef WITH_TORRENTPARSER
let mkfile = joinPath . map (scrub . decodeBL)
b <- B.readFile (fromRawFilePath torrent)
b <- F.readFile (toOsPath torrent)
return $ case readTorrent b of
Left e -> giveup $ "failed to parse torrent: " ++ e
Right t -> case tInfo t of

47
Remote/Directory.hs
View file

@ -15,7 +15,6 @@ module Remote.Directory (
removeDirGeneric,
) where
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import qualified Data.List.NonEmpty as NE
import qualified System.FilePath.ByteString as P
@ -52,6 +51,7 @@ import Utility.InodeCache
import Utility.FileMode
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
#ifndef mingw32_HOST_OS
import Utility.OpenFd
#endif
@ -241,12 +241,12 @@ checkDiskSpaceDirectory d k = do
- down. -}
finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO ()
finalizeStoreGeneric d tmp dest = do
removeDirGeneric False (fromRawFilePath d) dest'
removeDirGeneric False d dest
createDirectoryUnder [d] (parentDir dest)
renameDirectory (fromRawFilePath tmp) dest'
-- may fail on some filesystems
void $ tryIO $ do
mapM_ (preventWrite . toRawFilePath) =<< dirContents dest'
mapM_ preventWrite =<< dirContents dest
preventWrite dest
where
dest' = fromRawFilePath dest
@ -257,7 +257,7 @@ retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do
src <- liftIO $ fromRawFilePath <$> getLocation d k
void $ liftIO $ fileCopier cow src (fromRawFilePath dest) p iv
retrieveKeyFileM d _ _ = byteRetriever $ \k sink ->
sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k)
sink =<< liftIO (F.readFile . toOsPath =<< getLocation d k)
retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ())
-- no cheap retrieval possible for chunks
@ -275,9 +275,7 @@ retrieveKeyFileCheapM _ _ = Nothing
#endif
removeKeyM :: RawFilePath -> Remover
removeKeyM d _proof k = liftIO $ removeDirGeneric True
(fromRawFilePath d)
(fromRawFilePath (storeDir d k))
removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k)
{- Removes the directory, which must be located under the topdir.
-
@ -293,28 +291,30 @@ removeKeyM d _proof k = liftIO $ removeDirGeneric True
- can also be removed. Failure to remove such a directory is not treated
- as an error.
-}
removeDirGeneric :: Bool -> FilePath -> FilePath -> IO ()
removeDirGeneric :: Bool -> RawFilePath -> RawFilePath -> IO ()
removeDirGeneric removeemptyparents topdir dir = do
void $ tryIO $ allowWrite (toRawFilePath dir)
void $ tryIO $ allowWrite dir
#ifdef mingw32_HOST_OS
{- Windows needs the files inside the directory to be writable
- before it can delete them. -}
void $ tryIO $ mapM_ (allowWrite . toRawFilePath) =<< dirContents dir
void $ tryIO $ mapM_ allowWrite =<< dirContents dir
#endif
tryNonAsync (removeDirectoryRecursive dir) >>= \case
tryNonAsync (removeDirectoryRecursive dir') >>= \case
Right () -> return ()
Left e ->
unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
unlessM (doesDirectoryExist topdir' <&&> (not <$> doesDirectoryExist dir')) $
throwM e
when removeemptyparents $ do
subdir <- relPathDirToFile (toRawFilePath topdir) (P.takeDirectory (toRawFilePath dir))
subdir <- relPathDirToFile topdir (P.takeDirectory dir)
goparents (Just (P.takeDirectory subdir)) (Right ())
where
goparents _ (Left _e) = return ()
goparents Nothing _ = return ()
goparents (Just subdir) _ = do
let d = topdir </> fromRawFilePath subdir
let d = topdir' </> fromRawFilePath subdir
goparents (upFrom subdir) =<< tryIO (removeDirectory d)
dir' = fromRawFilePath dir
topdir' = fromRawFilePath topdir
checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent
checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k
@ -338,10 +338,10 @@ storeExportM d cow src _k loc p = do
liftIO $ createDirectoryUnder [d] (P.takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored.
viaTmp go (fromRawFilePath dest) ()
viaTmp go (toOsPath dest) ()
where
dest = exportPath d loc
go tmp () = void $ liftIO $ fileCopier cow src tmp p Nothing
go tmp () = void $ liftIO $ fileCopier cow src (fromRawFilePath (fromOsPath tmp)) p Nothing
retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
retrieveExportM d cow k loc dest p =
@ -389,8 +389,7 @@ removeExportLocation topdir loc =
listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
listImportableContentsM ii dir = liftIO $ do
l <- dirContentsRecursiveSkipping (const False) False (fromRawFilePath dir)
l' <- mapM (go . toRawFilePath) l
l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir
return $ Just $ ImportableContentsComplete $
ImportableContents (catMaybes l') []
where
@ -542,11 +541,11 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
liftIO $ createDirectoryUnder [dir] (toRawFilePath destdir)
withTmpFileIn destdir template $ \tmpf tmph -> do
liftIO $ createDirectoryUnder [dir] destdir
withTmpFileIn (toOsPath destdir) template $ \tmpf tmph -> do
let tmpf' = fromOsPath tmpf
liftIO $ hClose tmph
void $ liftIO $ fileCopier cow src tmpf p Nothing
let tmpf' = toRawFilePath tmpf
void $ liftIO $ fileCopier cow src (fromRawFilePath tmpf') p Nothing
resetAnnexFilePerm tmpf'
liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case
Nothing -> giveup "unable to generate content identifier"
@ -558,8 +557,8 @@ storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
return newcid
where
dest = exportPath dir loc
(destdir, base) = splitFileName (fromRawFilePath dest)
template = relatedTemplate (base ++ ".tmp")
(destdir, base) = P.splitFileName dest
template = relatedTemplate (base <> ".tmp")
removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
removeExportWithContentIdentifierM ii dir k loc removeablecids =

7
Remote/Directory/LegacyChunked.hs
View file

@ -24,6 +24,7 @@ import Annex.Tmp
import Utility.Metered
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withCheckedFiles _ [] _locations _ _ = return False
@ -101,13 +102,13 @@ retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever
retrieve locations d basek p _dest miv c = withOtherTmp $ \tmpdir -> do
showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow."
let tmp = tmpdir P.</> keyFile basek <> ".directorylegacy.tmp"
let tmp' = fromRawFilePath tmp
let tmp' = toOsPath tmp
let go = \k sink -> do
liftIO $ void $ withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ \fs -> do
forM_ fs $
S.appendFile tmp' <=< S.readFile
F.appendFile' tmp' <=< S.readFile
return True
b <- liftIO $ L.readFile tmp'
b <- liftIO $ F.readFile tmp'
liftIO $ removeWhenExistsWith R.removeLink tmp
sink b
byteRetriever go basek p tmp miv c

11
Remote/GCrypt.hs
View file

@ -439,8 +439,8 @@ remove' :: Git.Repo -> Remote -> Remote.Rsync.RsyncOpts -> AccessMethod -> Remov
remove' repo r rsyncopts accessmethod proof k
| not $ Git.repoIsUrl repo = guardUsable repo (giveup "cannot access remote") $
liftIO $ Remote.Directory.removeDirGeneric True
(gCryptTopDir repo)
(fromRawFilePath (parentDir (toRawFilePath (gCryptLocation repo k))))
(toRawFilePath (gCryptTopDir repo))
(parentDir (toRawFilePath (gCryptLocation repo k)))
| Git.repoIsSsh repo = shellOrRsync r removeshell removersync
| accessmethod == AccessRsyncOverSsh = removersync
| otherwise = unsupportedUrl
@ -529,9 +529,10 @@ getConfigViaRsync r gc = do
let (rsynctransport, rsyncurl, _) = rsyncTransport r gc
opts <- rsynctransport
liftIO $ do
withTmpFile "tmpconfig" $ \tmpconfig _ -> do
withTmpFile (toOsPath "tmpconfig") $ \tmpconfig _ -> do
let tmpconfig' = fromRawFilePath $ fromOsPath tmpconfig
void $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config"
, Param tmpconfig
, Param tmpconfig'
]
Git.Config.fromFile r tmpconfig
Git.Config.fromFile r tmpconfig'

7
Remote/Git.hs
View file

@ -324,9 +324,10 @@ tryGitConfigRead autoinit r hasuuid
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
let url = Git.repoLocation r ++ "/config"
v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do
v <- withTmpFile (toOsPath "git-annex.tmp") $ \tmpfile h -> do
liftIO $ hClose h
Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case
let tmpfile' = fromRawFilePath $ fromOsPath tmpfile
Url.download' nullMeterUpdate Nothing url tmpfile' uo >>= \case
Right () ->
pipedconfig Git.Config.ConfigNullList
False url "git"
@ -334,7 +335,7 @@ tryGitConfigRead autoinit r hasuuid
, Param "--null"
, Param "--list"
, Param "--file"
, File tmpfile
, File tmpfile'
] >>= return . \case
Right r' -> Right r'
Left exitcode -> Left $ "git config exited " ++ show exitcode

9
Remote/Helper/Git.hs
View file

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

2
Remote/Rsync.hs
View file

@ -374,7 +374,7 @@ sendParams = ifM crippledFileSystem
withRsyncScratchDir :: (FilePath -> Annex a) -> Annex a
withRsyncScratchDir a = do
t <- fromRawFilePath <$> fromRepo gitAnnexTmpObjectDir
withTmpDirIn t "rsynctmp" a
withTmpDirIn t (toOsPath "rsynctmp") a
rsyncRetrieve :: RsyncOpts -> [RsyncUrl] -> FilePath -> Maybe MeterUpdate -> Annex ()
rsyncRetrieve o rsyncurls dest meterupdate =

4
Test.hs
View file

@ -563,7 +563,7 @@ test_magic = intmpclonerepo $ do
#endif
test_import :: Assertion
test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir "importtest" $ \importdir -> do
test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "importtest")) $ \importdir -> do
(toimport1, importf1, imported1) <- mktoimport importdir "import1"
git_annex "import" [toimport1] "import"
annexed_present_imported imported1
@ -1894,7 +1894,7 @@ test_gpg_crypto = do
testscheme "pubkey"
where
gpgcmd = Utility.Gpg.mkGpgCmd Nothing
testscheme scheme = Utility.Tmp.Dir.withTmpDir "gpgtmp" $ \gpgtmp -> do
testscheme scheme = Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "gpgtmp")) $ \gpgtmp -> do
-- Use the system temp directory as gpg temp directory because
-- it needs to be able to store the agent socket there,
-- which can be problematic when testing some filesystems.

8
Test/Framework.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Framework where
import Test.Tasty
@ -302,7 +304,7 @@ ensuredir d = do
- happen concurrently with a test case running, and would be a problem
- since setEnv is not thread safe. This is run before tasty. -}
setTestEnv :: IO a -> IO a
setTestEnv a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do
setTestEnv a = Utility.Tmp.Dir.withTmpDir (toOsPath "testhome") $ \tmphome -> do
tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome)
{- Prevent global git configs from affecting the test suite. -}
Utility.Env.Set.setEnv "HOME" tmphomeabs True
@ -339,14 +341,14 @@ removeDirectoryForCleanup = removePathForcibly
cleanup :: FilePath -> IO ()
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
-- subprocess.
void $ tryIO $ removeDirectoryForCleanup dir
finalCleanup :: IO ()
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
Command.Uninit.prepareRemoveAnnexDir' tmpdir
Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir)
catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do
print e
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 Download = "download"
parseDirection :: String -> Maybe Direction
parseDirection :: B.ByteString -> Maybe Direction
parseDirection "upload" = Just Upload
parseDirection "download" = Just Download
parseDirection _ = Nothing

7
Types/Distribution.hs
View file

@ -40,10 +40,9 @@ formatInfoFile :: GitAnnexDistribution -> String
formatInfoFile d = replace "keyVariant = " "keyBackendName = " (show d) ++
"\n" ++ formatGitAnnexDistribution d
parseInfoFile :: String -> Maybe GitAnnexDistribution
parseInfoFile s = case lines s of
(_oldformat:rest) -> parseGitAnnexDistribution (unlines rest)
_ -> Nothing
parseInfoFile :: [String] -> Maybe GitAnnexDistribution
parseInfoFile (_oldformat:rest) = parseGitAnnexDistribution (unlines rest)
parseInfoFile _ = Nothing
formatGitAnnexDistribution :: GitAnnexDistribution -> String
formatGitAnnexDistribution d = unlines

8
Upgrade/V1.hs
View file

@ -15,7 +15,6 @@ import Data.Default
import Data.ByteString.Builder
import qualified Data.ByteString as S
import qualified Data.ByteString.Short as S (toShort, fromShort)
import qualified Data.ByteString.Lazy as L
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isRegularFile)
import Text.Read
@ -35,6 +34,7 @@ import Utility.FileMode
import Utility.Tmp
import qualified Upgrade.V2
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
-- v2 adds hashing of filenames of content and location log files.
-- Key information is encoded in filenames differently, so
@ -198,11 +198,13 @@ fileKey1 file = readKey1 $
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
writeLog1 :: FilePath -> [LogLine] -> IO ()
writeLog1 file ls = viaTmp L.writeFile file (toLazyByteString $ buildLog ls)
writeLog1 file ls = viaTmp F.writeFile
(toOsPath (toRawFilePath file))
(toLazyByteString $ buildLog ls)
readLog1 :: FilePath -> IO [LogLine]
readLog1 file = catchDefaultIO [] $
parseLog . encodeBL <$> readFileStrict file
parseLog <$> F.readFile (toOsPath (toRawFilePath file))
lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend))
lookupKey1 file = do

22
Upgrade/V2.hs
View file

@ -20,6 +20,7 @@ import Annex.Content
import Utility.Tmp
import Logs
import Messages.Progress
import qualified Utility.FileIO as F
olddir :: Git.Repo -> FilePath
olddir g
@ -73,14 +74,14 @@ locationLogs = do
config <- Annex.getGitConfig
dir <- fromRepo gitStateDir
liftIO $ do
levela <- dirContents dir
levela <- dirContents (toRawFilePath dir)
levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb)
return $ mapMaybe (islogfile config) (concat files)
where
tryDirContents d = catchDefaultIO [] $ dirContents d
islogfile config f = maybe Nothing (\k -> Just (k, f)) $
locationLogFileKey config (toRawFilePath f)
islogfile config f = maybe Nothing (\k -> Just (k, fromRawFilePath f)) $
locationLogFileKey config f
inject :: FilePath -> FilePath -> Annex ()
inject source dest = do
@ -135,12 +136,15 @@ attrLines =
gitAttributesUnWrite :: Git.Repo -> IO ()
gitAttributesUnWrite repo = do
let attributes = fromRawFilePath (Git.attributes repo)
whenM (doesFileExist attributes) $ do
c <- readFileStrict attributes
liftIO $ viaTmp writeFile attributes $ unlines $
filter (`notElem` attrLines) $ lines c
Git.Command.run [Param "add", File attributes] repo
let attributes = Git.attributes repo
let attributes' = fromRawFilePath attributes
whenM (doesFileExist attributes') $ do
c <- map decodeBS . fileLines'
<$> F.readFile' (toOsPath attributes)
liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath)
(toOsPath attributes)
(unlines $ filter (`notElem` attrLines) c)
Git.Command.run [Param "add", File attributes'] repo
stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex"

9
Upgrade/V5.hs
View file

@ -34,8 +34,7 @@ import Utility.InodeCache
import Utility.DottedVersion
import Annex.AdjustedBranch
import qualified Utility.RawFilePath as R
import qualified Data.ByteString as S
import qualified Utility.FileIO as F
upgrade :: Bool -> Annex UpgradeResult
upgrade automatic = flip catchNonAsync onexception $ do
@ -130,7 +129,7 @@ upgradeDirectWorkTree = do
Just k -> do
stagePointerFile f Nothing =<< hashPointerFile k
ifM (isJust <$> getAnnexLinkTarget f)
( writepointer (fromRawFilePath f) k
( writepointer f k
, fromdirect (fromRawFilePath f) k
)
Database.Keys.addAssociatedFile k
@ -158,8 +157,8 @@ upgradeDirectWorkTree = do
)
writepointer f k = liftIO $ do
removeWhenExistsWith R.removeLink (toRawFilePath f)
S.writeFile f (formatPointer k)
removeWhenExistsWith R.removeLink f
F.writeFile' (toOsPath f) (formatPointer k)
{- Remove all direct mode bookkeeping files. -}
removeDirectCruft :: Annex ()

9
Upgrade/V5/Direct.hs
View file

@ -29,6 +29,7 @@ import Annex.Perms
import Utility.InodeCache
import Annex.InodeSentinal
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
setIndirect :: Annex ()
setIndirect = do
@ -88,8 +89,8 @@ associatedFiles key = do
- the top of the repo. -}
associatedFilesRelative :: Key -> Annex [FilePath]
associatedFilesRelative key = do
mapping <- fromRawFilePath <$> calcRepo (gitAnnexMapping key)
liftIO $ catchDefaultIO [] $ withFile mapping ReadMode $ \h ->
mapping <- calcRepo (gitAnnexMapping key)
liftIO $ catchDefaultIO [] $ F.withFile (toOsPath mapping) ReadMode $ \h ->
-- Read strictly to ensure the file is closed promptly
lines <$> hGetContentsStrict h
@ -118,8 +119,8 @@ goodContent key file =
recordedInodeCache :: Key -> Annex [InodeCache]
recordedInodeCache key = withInodeCacheFile key $ \f ->
liftIO $ catchDefaultIO [] $
mapMaybe readInodeCache . lines
<$> readFileStrict (fromRawFilePath f)
mapMaybe (readInodeCache . decodeBS) . fileLines'
<$> F.readFile' (toOsPath f)
{- Removes an inode cache. -}
removeInodeCache :: Key -> Annex ()

8
Upgrade/V7.hs
View file

@ -22,6 +22,7 @@ import qualified Git
import Git.FilePath
import Config
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import qualified System.FilePath.ByteString as P
import System.PosixCompat.Files (isSymbolicLink)
@ -127,11 +128,12 @@ populateKeysDb = unlessM isBareRepo $ do
-- checked into the repository.
updateSmudgeFilter :: Annex ()
updateSmudgeFilter = do
lf <- fromRawFilePath <$> Annex.fromRepo Git.attributesLocal
ls <- liftIO $ lines <$> catchDefaultIO "" (readFileStrict lf)
lf <- Annex.fromRepo Git.attributesLocal
ls <- liftIO $ map decodeBS . fileLines'
<$> catchDefaultIO "" (F.readFile' (toOsPath lf))
let ls' = removedotfilter ls
when (ls /= ls') $
liftIO $ writeFile lf (unlines ls')
liftIO $ writeFile (fromRawFilePath lf) (unlines ls')
where
removedotfilter ("* filter=annex":".* !filter":rest) =
"* filter=annex" : removedotfilter rest

2
Utility/Daemon.hs
View file

@ -189,6 +189,6 @@ winLockFile pid pidfile = do
prefix = pidfile ++ "."
suffix = ".lck"
cleanstale = mapM_ (void . tryIO . removeFile) =<<
(filter iswinlockfile <$> dirContents (fromRawFilePath (parentDir (toRawFilePath pidfile))))
(filter iswinlockfile . map fromRawFilePath <$> dirContents (parentDir (toRawFilePath pidfile)))
iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f
#endif

3
Utility/DirWatcher/FSEvents.hs
View file

@ -70,7 +70,8 @@ watchDir dir ignored scanevents hooks = do
scan d = unless (ignoredPath ignored d) $
-- Do not follow symlinks when scanning.
-- This mirrors the inotify startup scan behavior.
mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist
(dirContentsRecursiveSkipping (const False) False (toRawFilePath d))
where
go f
| ignoredPath ignored f = noop

2
Utility/DirWatcher/INotify.hs
View file

@ -59,7 +59,7 @@ watchDir i dir ignored scanevents hooks
void (addWatch i watchevents (toInternalFilePath dir) handler)
`catchIO` failedaddwatch
withLock lock $
mapM_ scan =<< filter (not . dirCruft) <$>
mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$>
getDirectoryContents dir
where
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 dir = do
l <- filter (not . dirCruft) <$> getDirectoryContents dir
l <- filter (not . dirCruft . toRawFilePath) <$> getDirectoryContents dir
contents <- S.fromList . catMaybes <$> mapM getDirEnt l
return $ DirInfo dir contents
where

3
Utility/DirWatcher/Win32Notify.hs
View file

@ -43,7 +43,8 @@ watchDir dir ignored scanevents hooks = do
runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks)
scan d = unless (ignoredPath ignored d) $
mapM_ go =<< emptyWhenDoesNotExist (dirContentsRecursiveSkipping (const False) False d)
mapM_ (go . fromRawFilePath) =<< emptyWhenDoesNotExist
(dirContentsRecursiveSkipping (const False) False (toRawFilePath d))
where
go f
| ignoredPath ignored f = noop

48
Utility/Directory.hs
View file

@ -1,42 +1,48 @@
{- directory traversal and manipulation
-
- Copyright 2011-2023 Joey Hess <id@joeyh.name>
- Copyright 2011-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory (
module Utility.Directory,
module Utility.SystemDirectory
) where
module Utility.Directory where
#ifdef WITH_OSPATH
import System.Directory.OsPath
#else
import Utility.SystemDirectory
#endif
import Control.Monad
import System.FilePath
import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified System.FilePath.ByteString as P
import Data.Maybe
import Prelude
import Utility.SystemDirectory
import Utility.OsPath
import Utility.Exception
import Utility.Monad
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
dirCruft :: FilePath -> Bool
dirCruft :: R.RawFilePath -> Bool
dirCruft "." = True
dirCruft ".." = True
dirCruft _ = False
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: FilePath -> IO [FilePath]
dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
dirContents :: RawFilePath -> IO [RawFilePath]
dirContents d =
map (\p -> d P.</> fromOsPath p)
. filter (not . dirCruft . fromOsPath)
<$> getDirectoryContents (toOsPath d)
{- Gets files in a directory, and then its subdirectories, recursively,
- and lazily.
@ -48,13 +54,13 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
dirContentsRecursive :: FilePath -> IO [FilePath]
dirContentsRecursive :: RawFilePath -> IO [RawFilePath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- 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
| skipdir (takeFileName topdir) = return []
| skipdir (P.takeFileName topdir) = return []
| otherwise = do
-- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if
@ -66,24 +72,26 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
where
go [] = return []
go (dir:dirs)
| skipdir (takeFileName dir) = go dirs
| skipdir (P.takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs)
return (files ++ files')
collect :: [RawFilePath] -> [RawFilePath] -> [RawFilePath] -> IO ([RawFilePath], [RawFilePath])
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
ms <- catchMaybeIO $ R.getSymbolicLinkStatus (toRawFilePath entry)
ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry
case ms of
(Just s)
| isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks ->
ifM (doesDirectoryExist entry)
ifM (doesDirectoryExist (toOsPath entry))
( recurse
, skip
)
@ -98,22 +106,22 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath]
dirTreeRecursiveSkipping skipdir topdir
| skipdir (takeFileName topdir) = return []
| skipdir (P.takeFileName topdir) = return []
| otherwise = do
subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs
where
go c [] = return c
go c (dir:dirs)
| skipdir (takeFileName dir) = go c dirs
| skipdir (P.takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
subdirs <- go []
=<< filterM isdir
=<< catchDefaultIO [] (dirContents dir)
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 []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a]

34
Utility/Directory/Stream.hs
View file

@ -1,6 +1,6 @@
{- streaming directory traversal
{- streaming directory reading
-
- Copyright 2011-2018 Joey Hess <id@joeyh.name>
- Copyright 2011-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
@ -14,23 +14,25 @@ module Utility.Directory.Stream (
openDirectory,
closeDirectory,
readDirectory,
isDirectoryEmpty,
isDirectoryPopulated,
) where
import Control.Monad
import System.FilePath
import Control.Concurrent
import Data.Maybe
import Prelude
#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32
import System.FilePath
#else
import qualified System.Posix as Posix
import qualified Data.ByteString as B
import qualified System.Posix.Directory.ByteString as Posix
#endif
import Utility.Directory
import Utility.Exception
import Utility.FileSystemEncoding
#ifndef mingw32_HOST_OS
data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
@ -40,14 +42,14 @@ data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar
type IsOpen = MVar () -- full when the handle is open
openDirectory :: FilePath -> IO DirectoryHandle
openDirectory :: RawFilePath -> IO DirectoryHandle
openDirectory path = do
#ifndef mingw32_HOST_OS
dirp <- Posix.openDirStream path
isopen <- newMVar ()
return (DirectoryHandle isopen dirp)
#else
(h, fdat) <- Win32.findFirstFile (path </> "*")
(h, fdat) <- Win32.findFirstFile (fromRawFilePath path </> "*")
-- Indicate that the fdat contains a filename that readDirectory
-- has not yet returned, by making the MVar be full.
-- (There's always at least a "." entry.)
@ -75,11 +77,11 @@ closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
-- | Reads the next entry from the handle. Once the end of the directory
-- is reached, returns Nothing and automatically closes the handle.
readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
readDirectory :: DirectoryHandle -> IO (Maybe RawFilePath)
#ifndef mingw32_HOST_OS
readDirectory hdl@(DirectoryHandle _ dirp) = do
e <- Posix.readDirStream dirp
if null e
if B.null e
then do
closeDirectory hdl
return Nothing
@ -102,18 +104,18 @@ readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
where
getfn = do
filename <- Win32.getFindDataFileName fdat
return (Just filename)
return (Just (toRawFilePath filename))
#endif
-- | True only when directory exists and contains nothing.
-- Throws exception if directory does not exist.
isDirectoryEmpty :: FilePath -> IO Bool
isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
-- | True only when directory exists and is not empty.
isDirectoryPopulated :: RawFilePath -> IO Bool
isDirectoryPopulated d = bracket (openDirectory d) closeDirectory check
`catchIO` const (return False)
where
check h = do
v <- readDirectory h
case v of
Nothing -> return True
Nothing -> return False
Just f
| not (dirCruft f) -> return False
| not (dirCruft f) -> return True
| otherwise -> check h

107
Utility/FileIO.hs Normal file
View file

@ -0,0 +1,107 @@
{- File IO on OsPaths.
-
- Since Prelude exports many of these as well, this needs to be imported
- qualified.
-
- Copyright 2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Utility.FileIO
(
withFile,
openFile,
readFile,
readFile',
writeFile,
writeFile',
appendFile,
appendFile',
openTempFile,
) where
#ifdef WITH_OSPATH
#ifndef mingw32_HOST_OS
import System.File.OsPath
#else
-- On Windows, System.File.OsPath does not handle UNC-style conversion itself,
-- so that has to be done when calling it. See
-- https://github.com/haskell/file-io/issues/39
import Utility.Path.Windows
import Utility.OsPath
import System.IO (IO, Handle, IOMode)
import qualified System.File.OsPath as O
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Control.Applicative
withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
withFile f m a = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.withFile f' m a
openFile :: OsPath -> IOMode -> IO Handle
openFile f m = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.openFile f' m
readFile :: OsPath -> IO L.ByteString
readFile f = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.readFile f'
readFile' :: OsPath -> IO B.ByteString
readFile' f = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.readFile' f'
writeFile :: OsPath -> L.ByteString -> IO ()
writeFile f b = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.writeFile f' b
writeFile' :: OsPath -> B.ByteString -> IO ()
writeFile' f b = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.writeFile' f' b
appendFile :: OsPath -> L.ByteString -> IO ()
appendFile f b = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.appendFile f' b
appendFile' :: OsPath -> B.ByteString -> IO ()
appendFile' f b = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.appendFile' f' b
openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle)
openTempFile p s = do
p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p)
O.openTempFile p' s
#endif
#else
-- When not building with OsPath, export FilePath versions
-- instead. However, functions still use ByteString for the
-- file content in that case, unlike the Strings used by the Prelude.
import Utility.OsPath
import System.IO (withFile, openFile, openTempFile, IO)
import Data.ByteString.Lazy (readFile, writeFile, appendFile)
import qualified Data.ByteString as B
readFile' :: OsPath -> IO B.ByteString
readFile' = B.readFile
writeFile' :: OsPath -> B.ByteString -> IO ()
writeFile' = B.writeFile
appendFile' :: OsPath -> B.ByteString -> IO ()
appendFile' = B.appendFile
#endif

4
Utility/FileMode.hs
View file

@ -27,6 +27,8 @@ import Control.Monad.Catch
import Utility.Exception
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Utility.OsPath
{- Applies a conversion function to a file's mode. -}
modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO ()
@ -178,7 +180,7 @@ writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO ()
writeFileProtected' file writer = bracket setup cleanup writer
where
setup = do
h <- protectedOutput $ openFile (fromRawFilePath file) WriteMode
h <- protectedOutput $ F.openFile (toOsPath file) WriteMode
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
return h
cleanup = hClose

Some files were not shown because too many files have changed in this diff Show more