diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs index 56a617db44..5d5458fa82 100644 --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -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 diff --git a/Annex/AdjustedBranch/Merge.hs b/Annex/AdjustedBranch/Merge.hs index 904f4ee412..7817bdbeca 100644 --- a/Annex/AdjustedBranch/Merge.hs +++ b/Annex/AdjustedBranch/Merge.hs @@ -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 diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs index bb43d0593b..0c0c203688 100644 --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -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) diff --git a/Annex/Balanced.hs b/Annex/Balanced.hs index ab643287d6..e114c1f893 100644 --- a/Annex/Balanced.hs +++ b/Annex/Balanced.hs @@ -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] diff --git a/Annex/Branch.hs b/Annex/Branch.hs index ce4c3ad85e..dd7dc03255 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -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 = diff --git a/Annex/ChangedRefs.hs b/Annex/ChangedRefs.hs index 7a9ce8a34f..073686fb01 100644 --- a/Annex/ChangedRefs.hs +++ b/Annex/ChangedRefs.hs @@ -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. diff --git a/Annex/Content.hs b/Annex/Content.hs index aba53add7b..3f26c0f0a8 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -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. diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs index c2acc9ab93..5dc4d0210b 100644 --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -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 diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs index a60e4baa0b..112c55224a 100644 --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -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 diff --git a/Annex/Hook.hs b/Annex/Hook.hs index 0496094be8..3241d3b556 100644 --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -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 diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs index ae430dc89b..ed7479526f 100644 --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -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 () diff --git a/Annex/Journal.hs b/Annex/Journal.hs index 8eb1dc880f..cfa582c65e 100644 --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -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. diff --git a/Annex/Link.hs b/Annex/Link.hs index 4961499f62..4c2a76ffc2 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -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 diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs index 4f11f617c9..6fb739b30c 100644 --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -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 diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs index 21735eba14..5cb46b17dd 100644 --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -1,12 +1,10 @@ {- git-annex file replacing - - - Copyright 2013-2021 Joey Hess + - Copyright 2013-2025 Joey Hess - - 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 () diff --git a/Annex/RepoSize/LiveUpdate.hs b/Annex/RepoSize/LiveUpdate.hs index a792b42597..8710282999 100644 --- a/Annex/RepoSize/LiveUpdate.hs +++ b/Annex/RepoSize/LiveUpdate.hs @@ -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) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 90d462f7be..6cdfba7b02 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -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 diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs index 2bbebd6388..6f9f28b8b6 100644 --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -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 () diff --git a/Annex/VectorClock.hs b/Annex/VectorClock.hs index db2c63c0bd..792f6e6e82 100644 --- a/Annex/VectorClock.hs +++ b/Annex/VectorClock.hs @@ -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 diff --git a/Annex/VectorClock/Utility.hs b/Annex/VectorClock/Utility.hs index 76b74d9cd5..2c9f40f16e 100644 --- a/Annex/VectorClock/Utility.hs +++ b/Annex/VectorClock/Utility.hs @@ -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. diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 3a4dd051bc..6544f3d1f5 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -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 diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 68edd95c47..eeb40605ea 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -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 diff --git a/Assistant/Install.hs b/Assistant/Install.hs index c11b6d5585..db34000672 100644 --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -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." diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs index 02ebab3cae..4c37227c8d 100644 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -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" diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 3f472a5332..3a9235c76d 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -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" diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index 067bd0b022..f5e9cff7da 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -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 diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index d692a3ffd0..bff9263fb6 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -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] diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 04c5f97b25..37ac9b876e 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -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 diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 3fdd12d05f..ad7cd13d47 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -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 diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 81d7f70b23..1440af10d0 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -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" diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs index 333e13656a..31b5b19d14 100644 --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -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) diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index 04ac8ceb1d..4edfee9fca 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -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') diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs index 304cfaac16..244ded29e5 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -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 diff --git a/Build/LinuxMkLibs.hs b/Build/LinuxMkLibs.hs index 6a5f8dea01..fad73c4c76 100644 --- a/Build/LinuxMkLibs.hs +++ b/Build/LinuxMkLibs.hs @@ -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 diff --git a/Build/Standalone.hs b/Build/Standalone.hs index 367527430a..36a4d5a002 100644 --- a/Build/Standalone.hs +++ b/Build/Standalone.hs @@ -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" diff --git a/Build/Version.hs b/Build/Version.hs index 0d95dc7b26..e3b905919d 100644 --- a/Build/Version.hs +++ b/Build/Version.hs @@ -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" diff --git a/CHANGELOG b/CHANGELOG index fa11259b2b..f720bf9850 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -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 Mon, 20 Jan 2025 10:24:51 -0400 diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs index da2a61b34b..91bdc0b263 100644 --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -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 -> diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs index 07818dcda5..a25c6b083b 100644 --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -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 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 7feb0b19eb..d464dbd048 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -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,8 +568,8 @@ 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 - Just depth + Nothing -> truncatesanitize fullurl + Just depth | depth >= length urlbits -> frombits id | depth > 0 -> frombits $ drop depth | depth < 0 -> frombits $ reverse . take (negate depth) . reverse @@ -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 diff --git a/Command/Export.hs b/Command/Export.hs index 4e87323bf3..a8bdfab5ab 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -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 diff --git a/Command/Fix.hs b/Command/Fix.hs index 862853a861..eb8f6383e3 100644 --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -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 diff --git a/Command/Fsck.hs b/Command/Fsck.hs index bb2b1258a3..f0f833117d 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -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 diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index bdb16c9841..8adeb9a487 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -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 diff --git a/Command/Lock.hs b/Command/Lock.hs index 7dbcffbbd9..96aebaab23 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -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] diff --git a/Command/Multicast.hs b/Command/Multicast.hs index 201fe7a6c9..abb589e205 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -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 diff --git a/Command/P2P.hs b/Command/P2P.hs index 414ffa7610..14f6d24fa4 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -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. diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index 31ee330f4d..ac72c7053d 100644 --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -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 diff --git a/Command/ReKey.hs b/Command/ReKey.hs index f092e85a84..a7a547b719 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -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 diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs index aaa5c25ad2..2d003547b2 100644 --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -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 diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 2d96f7b1f7..eb643d7aad 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -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 diff --git a/Command/Uninit.hs b/Command/Uninit.hs index a38ac9a7e6..d883467787 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -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. diff --git a/Command/Unlock.hs b/Command/Unlock.hs index c8faa7532f..e0f7ccb29a 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -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 diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs index 806b5e5df0..426177ec69 100644 --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -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 diff --git a/Common.hs b/Common.hs index c430163063..71681275f9 100644 --- a/Common.hs +++ b/Common.hs @@ -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 diff --git a/Config/Files/AutoStart.hs b/Config/Files/AutoStart.hs index 5c89bd2066..8b20644901 100644 --- a/Config/Files/AutoStart.hs +++ b/Config/Files/AutoStart.hs @@ -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 diff --git a/Config/Smudge.hs b/Config/Smudge.hs index da198096fe..aa89990c0a 100644 --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -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") diff --git a/Creds.hs b/Creds.hs index e429d796cf..3bbf6f7b28 100644 --- a/Creds.hs +++ b/Creds.hs @@ -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 diff --git a/Crypto.hs b/Crypto.hs index 192c19bc78..b28814f0ea 100644 --- a/Crypto.hs +++ b/Crypto.hs @@ -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 diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs index 81f3531891..552236df95 100644 --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -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" diff --git a/Git/HashObject.hs b/Git/HashObject.hs index 620c095141..704d310c9d 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -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. - diff --git a/Git/Hook.hs b/Git/Hook.hs index 1163f1effe..c2e5a8125e 100644 --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -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) diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 4eea39541a..08c98b7fda 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -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)) diff --git a/Git/Objects.hs b/Git/Objects.hs index 1390209e97..b66b0b5e19 100644 --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -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 diff --git a/Git/Ref.hs b/Git/Ref.hs index 2767ae339c..c6b2027280 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -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 diff --git a/Git/Repair.hs b/Git/Repair.hs index ace7ae89af..ed46161cfe 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -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 + . 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) diff --git a/Logs/AdjustedBranchUpdate.hs b/Logs/AdjustedBranchUpdate.hs index c7f2822945..5b2ea9648a 100644 --- a/Logs/AdjustedBranchUpdate.hs +++ b/Logs/AdjustedBranchUpdate.hs @@ -80,5 +80,5 @@ parseAdjustLog l = "1" -> Just True "0" -> Just False _ -> Nothing - t <- parsePOSIXTime ts + t <- parsePOSIXTime (encodeBS ts) return (b, t) diff --git a/Logs/Export.hs b/Logs/Export.hs index 7f2242ea14..a3cf823d53 100644 --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -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] diff --git a/Logs/File.hs b/Logs/File.hs index e129da0553..93aef17f97 100644 --- a/Logs/File.hs +++ b/Logs/File.hs @@ -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 diff --git a/Logs/Migrate.hs b/Logs/Migrate.hs index b60b21cfcb..63ace2f92e 100644 --- a/Logs/Migrate.hs +++ b/Logs/Migrate.hs @@ -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 diff --git a/Logs/Restage.hs b/Logs/Restage.hs index 5d4e2e0910..dc9a35940c 100644 --- a/Logs/Restage.hs +++ b/Logs/Restage.hs @@ -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 diff --git a/Logs/Smudge.hs b/Logs/Smudge.hs index 7b0f5ff5f6..5a667ec826 100644 --- a/Logs/Smudge.hs +++ b/Logs/Smudge.hs @@ -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 diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 88c2f947cc..387311b219 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -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) diff --git a/Logs/Unused.hs b/Logs/Unused.hs index 6bb1011e84..fa2b2ce3cc 100644 --- a/Logs/Unused.hs +++ b/Logs/Unused.hs @@ -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 diff --git a/Logs/Upgrade.hs b/Logs/Upgrade.hs index f1ff0bd56c..bc63e0021f 100644 --- a/Logs/Upgrade.hs +++ b/Logs/Upgrade.hs @@ -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 diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index c9c15d75ed..6d3599764f 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -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 diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 1086e7cf64..d2f03e0735 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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 = diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs index 2268dc998a..b1b2438b7d 100644 --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -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 diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 8a3852c6b1..ce8564bd76 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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' diff --git a/Remote/Git.hs b/Remote/Git.hs index 2dc132501e..c9108700e4 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/Helper/Git.hs b/Remote/Helper/Git.hs index 1567e7ae6a..a8f6798662 100644 --- a/Remote/Helper/Git.hs +++ b/Remote/Helper/Git.hs @@ -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 diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index cea6cd3566..5a908f9c67 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -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 = diff --git a/Test.hs b/Test.hs index 77a4029bbc..6c231c9859 100644 --- a/Test.hs +++ b/Test.hs @@ -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. diff --git a/Test/Framework.hs b/Test/Framework.hs index b9b8bcde79..94354eb521 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -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" diff --git a/Types/Direction.hs b/Types/Direction.hs index a18b83697d..814b66f72b 100644 --- a/Types/Direction.hs +++ b/Types/Direction.hs @@ -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 diff --git a/Types/Distribution.hs b/Types/Distribution.hs index 3a7aca1f2e..7616efc9e7 100644 --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -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 diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index bad2cfbc07..5540844a70 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -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 diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index f467fa2596..7690921232 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -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" diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs index e6cb22a6d4..708c838977 100644 --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -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 () diff --git a/Upgrade/V5/Direct.hs b/Upgrade/V5/Direct.hs index c807b29d9e..f03d7b3780 100644 --- a/Upgrade/V5/Direct.hs +++ b/Upgrade/V5/Direct.hs @@ -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 () diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs index cad16f1854..0e301bd09d 100644 --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -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 diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index c2a3d1bde7..38f8d09aee 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -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 diff --git a/Utility/DirWatcher/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs index 7b6be6f13b..da2b3194bc 100644 --- a/Utility/DirWatcher/FSEvents.hs +++ b/Utility/DirWatcher/FSEvents.hs @@ -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 diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs index 700bff5773..4b14e85bd2 100644 --- a/Utility/DirWatcher/INotify.hs +++ b/Utility/DirWatcher/INotify.hs @@ -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 diff --git a/Utility/DirWatcher/Kqueue.hs b/Utility/DirWatcher/Kqueue.hs index dc9fed31c2..b793eee58b 100644 --- a/Utility/DirWatcher/Kqueue.hs +++ b/Utility/DirWatcher/Kqueue.hs @@ -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 diff --git a/Utility/DirWatcher/Win32Notify.hs b/Utility/DirWatcher/Win32Notify.hs index e5ce316ce6..5f53c13bf5 100644 --- a/Utility/DirWatcher/Win32Notify.hs +++ b/Utility/DirWatcher/Win32Notify.hs @@ -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 diff --git a/Utility/Directory.hs b/Utility/Directory.hs index bf997b8606..3648a4454d 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,42 +1,48 @@ {- directory traversal and manipulation - - - Copyright 2011-2023 Joey Hess + - Copyright 2011-2025 Joey Hess - - 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] diff --git a/Utility/Directory/Stream.hs b/Utility/Directory/Stream.hs index 3a6222c561..a74416d2f8 100644 --- a/Utility/Directory/Stream.hs +++ b/Utility/Directory/Stream.hs @@ -1,6 +1,6 @@ -{- streaming directory traversal +{- streaming directory reading - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2025 Joey Hess - - 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 diff --git a/Utility/FileIO.hs b/Utility/FileIO.hs new file mode 100644 index 0000000000..4b12b2ba0e --- /dev/null +++ b/Utility/FileIO.hs @@ -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 + - + - 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 diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index eb25c526d1..95e5d570ef 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -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 diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs index 3d216f2be4..4858b0bdff 100644 --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -17,7 +17,8 @@ module Utility.FileSize ( #ifdef mingw32_HOST_OS import Control.Exception (bracket) import System.IO -import Utility.FileSystemEncoding +import qualified Utility.FileIO as F +import Utility.OsPath #else import System.PosixCompat.Files (fileSize) #endif @@ -36,7 +37,7 @@ getFileSize :: R.RawFilePath -> IO FileSize #ifndef mingw32_HOST_OS getFileSize f = fmap (fromIntegral . fileSize) (R.getFileStatus f) #else -getFileSize f = bracket (openFile (fromRawFilePath f) ReadMode) hClose hFileSize +getFileSize f = bracket (F.openFile (toOsPath f) ReadMode) hClose hFileSize #endif {- Gets the size of the file, when its FileStatus is already known. diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 10c87ca2f3..b4497f30af 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -33,6 +33,8 @@ import qualified Data.ByteString.Lazy.UTF8 as L8 import qualified GHC.Foreign as GHC import System.IO.Unsafe import Data.ByteString.Unsafe (unsafePackMallocCStringLen) +import Data.Char +import Data.List #endif {- Makes all subsequent Handles that are opened, as well as stdio Handles, @@ -125,26 +127,40 @@ toRawFilePath = encodeFilePath - Avoids returning an invalid part of a unicode byte sequence, at the - cost of efficiency when running on a large FilePath. -} -truncateFilePath :: Int -> FilePath -> FilePath +truncateFilePath :: Int -> RawFilePath -> RawFilePath #ifndef mingw32_HOST_OS -truncateFilePath n = go . reverse +{- On unix, do not assume a unicode locale, but does assume ascii + - characters are a single byte. -} +truncateFilePath n b = + let blen = S.length b + in if blen <= n + then b + else go blen (reverse (fromRawFilePath b)) where - go f = - let b = encodeBS f - in if S.length b <= n - then reverse f - else go (drop 1 f) + go blen f = case uncons f of + Just (c, f') + | isAscii c -> + let blen' = blen - 1 + in if blen' <= n + then toRawFilePath (reverse f') + else go blen' f' + | otherwise -> + let blen' = S.length (toRawFilePath f') + in if blen' <= n + then toRawFilePath (reverse f') + else go blen' f' + Nothing -> toRawFilePath (reverse f) #else {- On Windows, count the number of bytes used by each utf8 character. -} -truncateFilePath n = reverse . go [] n . L8.fromString +truncateFilePath n = toRawFilePath . reverse . go [] n where go coll cnt bs | cnt <= 0 = coll - | otherwise = case L8.decode bs of - Just (c, x) | c /= L8.replacement_char -> + | otherwise = case S8.decode bs of + Just (c, x) | c /= S8.replacement_char -> let x' = fromIntegral x in if cnt - x' < 0 then coll - else go (c:coll) (cnt - x') (L8.drop 1 bs) + else go (c:coll) (cnt - x') (S8.drop 1 bs) _ -> coll #endif diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 19dd7f5395..5fe911528d 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -179,10 +179,10 @@ feedRead cmd params passphrase feeder reader = do go (passphrasefd ++ params) #else -- store the passphrase in a temp file for gpg - withTmpFile "gpg" $ \tmpfile h -> do + withTmpFile (toOsPath "gpg") $ \tmpfile h -> do liftIO $ B.hPutStr h passphrase liftIO $ hClose h - let passphrasefile = [Param "--passphrase-file", File tmpfile] + let passphrasefile = [Param "--passphrase-file", File (fromRawFilePath (fromOsPath tmpfile))] go $ passphrasefile ++ params #endif where diff --git a/Utility/HtmlDetect.hs b/Utility/HtmlDetect.hs index fd5ad2ef06..cf83e52f08 100644 --- a/Utility/HtmlDetect.hs +++ b/Utility/HtmlDetect.hs @@ -13,6 +13,9 @@ module Utility.HtmlDetect ( ) where import Author +import qualified Utility.FileIO as F +import Utility.RawFilePath +import Utility.OsPath import Text.HTML.TagSoup import System.IO @@ -57,8 +60,8 @@ isHtmlBs = isHtml . B8.unpack -- It would be equivalent to use isHtml <$> readFile file, -- but since that would not read all of the file, the handle -- would remain open until it got garbage collected sometime later. -isHtmlFile :: FilePath -> IO Bool -isHtmlFile file = withFile file ReadMode $ \h -> +isHtmlFile :: RawFilePath -> IO Bool +isHtmlFile file = F.withFile (toOsPath file) ReadMode $ \h -> isHtmlBs <$> B.hGet h htmlPrefixLength -- | How much of the beginning of a html document is needed to detect it. diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs index 3828bc645a..6f8008dd5f 100644 --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -185,7 +185,7 @@ readInodeCache s = case words s of (inode:size:mtime:mtimedecimal:_) -> do i <- readish inode sz <- readish size - t <- parsePOSIXTime $ mtime ++ '.' : mtimedecimal + t <- parsePOSIXTime $ encodeBS $ mtime ++ '.' : mtimedecimal return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) _ -> Nothing diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs index 55f6998e5e..ec482a1465 100644 --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -18,6 +18,7 @@ module Utility.LinuxMkLibs ( import Utility.PartialPrelude import Utility.Directory +import Utility.SystemDirectory import Utility.Process import Utility.Monad import Utility.Path diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index be4548b0b6..4ed730ccff 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -27,6 +27,7 @@ import Utility.PartialPrelude import Utility.Exception import Utility.Applicative import Utility.Directory +import Utility.SystemDirectory import Utility.Monad import Utility.Path.AbsRel import Utility.FileMode @@ -38,6 +39,8 @@ import Utility.FileSystemEncoding import Utility.Env import Utility.Env.Set import Utility.Tmp +import Utility.RawFilePath +import Utility.OsPath import qualified Utility.LockFile.Posix as Posix import System.IO @@ -147,9 +150,10 @@ tryLock lockfile = do _ -> return (Just ParentLocked) where go abslockfile sidelock = do - let abslockfile' = fromRawFilePath abslockfile - (tmp, h) <- openTmpFileIn (takeDirectory abslockfile') "locktmp" - let tmp' = toRawFilePath tmp + (tmp, h) <- openTmpFileIn + (toOsPath (P.takeDirectory abslockfile)) + (toOsPath "locktmp") + let tmp' = fromOsPath tmp setFileMode tmp' (combineModes readModes) hPutStr h . show =<< mkPidLock hClose h @@ -241,15 +245,14 @@ linkToLock (Just _) src dest = do -- with the SAME FILENAME exist. checkInsaneLustre :: RawFilePath -> IO Bool checkInsaneLustre dest = do - let dest' = fromRawFilePath dest - fs <- dirContents (takeDirectory dest') - case length (filter (== dest') fs) of + fs <- dirContents (P.takeDirectory dest) + case length (filter (== dest) fs) of 1 -> return False -- whew! 0 -> return True -- wtf? _ -> do -- Try to clean up the extra copy we made -- that has the same name. Egads. - _ <- tryIO $ removeFile dest' + _ <- tryIO $ removeLink dest return True -- | Waits as necessary to take a lock. diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs index c8e7c1bf52..9f35ec1129 100644 --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -75,9 +75,9 @@ openLock sharemode f = do return $ if h == iNVALID_HANDLE_VALUE then Nothing else Just h -#endif where security_attributes = maybePtr Nothing +#endif dropLock :: LockHandle -> IO () dropLock = closeHandle diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 7c00a184f4..ac98873ab1 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -1,20 +1,24 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2025 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Misc ( hGetContentsStrict, - readFileStrict, separate, separate', separateEnd', firstLine, firstLine', + fileLines, + fileLines', + linesFile, + linesFile', segment, segmentDelim, massReplace, @@ -32,6 +36,9 @@ import Data.List import System.Exit import Control.Applicative 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 import Prelude {- A version of hgetContents that is not lazy. Ensures file is @@ -39,10 +46,6 @@ import Prelude hGetContentsStrict :: Handle -> IO String hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s -{- A version of readFile that is not lazy. -} -readFileStrict :: FilePath -> IO String -readFileStrict = readFile >=> \s -> length s `seq` return s - {- Like break, but the item matching the condition is not included - in the second result list. - @@ -78,6 +81,51 @@ firstLine' = S.takeWhile (/= nl) where nl = fromIntegral (ord '\n') +-- 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 + +-- One windows, writeFile does NewlineMode translation, +-- adding CR before LF. When converting to ByteString, use this to emulate that. +linesFile :: L.ByteString -> L.ByteString +#ifndef mingw32_HOST_OS +linesFile = id +#else +linesFile = L8.concat . concatMap (\x -> [x, L8.pack "\r\n"]) . fileLines +#endif + +linesFile' :: S.ByteString -> S.ByteString +#ifndef mingw32_HOST_OS +linesFile' = id +#else +linesFile' = S8.concat . concatMap (\x -> [x, S8.pack "\r\n"]) . fileLines' +#endif + {- Splits a list into segments that are delimited by items matching - a predicate. (The delimiters are not included in the segments.) - Segments may be empty. -} diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs index 1609c85109..d80c9203f8 100644 --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -28,6 +28,7 @@ import Utility.Tmp import Utility.Exception import Utility.Monad import Utility.FileSystemEncoding +import Utility.OsPath import qualified Utility.RawFilePath as R import Author @@ -40,11 +41,12 @@ moveFile src dest = tryIO (R.rename src dest) >>= onrename onrename (Left e) | isPermissionError e = rethrow | isDoesNotExistError e = rethrow - | otherwise = viaTmp mv (fromRawFilePath dest) () + | otherwise = viaTmp mv (toOsPath dest) () where rethrow = throwM e mv tmp () = do + let tmp' = fromRawFilePath (fromOsPath tmp) -- copyFile is likely not as optimised as -- the mv command, so we'll use the command. -- @@ -57,18 +59,18 @@ moveFile src dest = tryIO (R.rename src dest) >>= onrename ok <- copyright =<< boolSystem "mv" [ Param "-f" , Param (fromRawFilePath src) - , Param tmp + , Param tmp' ] let e' = e #else - r <- tryIO $ copyFile (fromRawFilePath src) tmp + r <- tryIO $ copyFile (fromRawFilePath src) tmp' let (ok, e') = case r of Left err -> (False, err) Right _ -> (True, e) #endif unless ok $ do -- delete any partial - _ <- tryIO $ removeFile tmp + _ <- tryIO $ removeFile tmp' throwM e' #ifndef mingw32_HOST_OS diff --git a/Utility/OsPath.hs b/Utility/OsPath.hs new file mode 100644 index 0000000000..59302cd53e --- /dev/null +++ b/Utility/OsPath.hs @@ -0,0 +1,65 @@ +{- OsPath utilities + - + - Copyright 2025 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.OsPath ( + OsPath, + OsString, + toOsPath, + fromOsPath, +) where + +import Utility.FileSystemEncoding + +#ifdef WITH_OSPATH +import System.OsPath +import "os-string" System.OsString.Internal.Types +import qualified Data.ByteString.Short as S +#if defined(mingw32_HOST_OS) +import GHC.IO (unsafePerformIO) +import System.OsString.Encoding.Internal (cWcharsToChars_UCS2) +import qualified System.OsString.Data.ByteString.Short.Word16 as BS16 +#endif + +toOsPath :: RawFilePath -> OsPath +#if defined(mingw32_HOST_OS) +-- On Windows, OsString contains a ShortByteString that is +-- utf-16 encoded. So have to convert the input to that. +-- This is relatively expensive. +toOsPath = unsafePerformIO . encodeFS . fromRawFilePath +#else +toOsPath = OsString . PosixString . S.toShort +#endif + +fromOsPath :: OsPath -> RawFilePath +#if defined(mingw32_HOST_OS) +-- On Windows, OsString contains a ShortByteString that is +-- utf-16 encoded. So have to convert the input from that. +-- This is relatively expensive. +fromOsPath = toRawFilePath . cWcharsToChars_UCS2 . BS16.unpack . getWindowsString . getOsString +#else +fromOsPath = S.fromShort . getPosixString . getOsString +#endif + +#else +{- When not building with WITH_OSPATH, use FilePath. This allows + - using functions from legacy FilePath libraries interchangeably with + - newer OsPath libraries. + -} +type OsPath = FilePath + +type OsString = String + +toOsPath :: RawFilePath -> OsPath +toOsPath = fromRawFilePath + +fromOsPath :: OsPath -> RawFilePath +fromOsPath = toRawFilePath +#endif diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index 83c63fcd3d..fb7a6b95ac 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -28,11 +28,13 @@ import Common import Utility.UserInfo import Utility.Tmp import Utility.FileMode +import qualified Utility.FileIO as F import Data.Char import Data.Ord import Data.Either import System.PosixCompat.Files (groupWriteMode, otherWriteMode) +import qualified Data.ByteString.Char8 as S8 data SshConfig = GlobalConfig SshSetting @@ -134,18 +136,19 @@ changeUserSshConfig modifier = do sshdir <- sshDir let configfile = sshdir "config" whenM (doesFileExist configfile) $ do - c <- readFileStrict configfile + c <- decodeBS . S8.unlines . fileLines' + <$> F.readFile' (toOsPath (toRawFilePath configfile)) let c' = modifier c when (c /= c') $ do -- If it's a symlink, replace the file it -- points to. f <- catchDefaultIO configfile (canonicalizePath configfile) - viaTmp writeSshConfig f c' + viaTmp writeSshConfig (toOsPath (toRawFilePath f)) c' -writeSshConfig :: FilePath -> String -> IO () +writeSshConfig :: OsPath -> String -> IO () writeSshConfig f s = do - writeFile f s - setSshConfigMode (toRawFilePath f) + F.writeFile' f (linesFile' (encodeBS s)) + setSshConfigMode (fromOsPath f) {- Ensure that the ssh config file lacks any group or other write bits, - since ssh is paranoid about not working if other users can write diff --git a/Utility/StatelessOpenPGP.hs b/Utility/StatelessOpenPGP.hs index 2915d51015..205fa91ff8 100644 --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -112,7 +112,7 @@ decryptSymmetric sopcmd password emptydirectory feeder reader = {- Test a value round-trips through symmetric encryption and decryption. -} test_encrypt_decrypt_Symmetric :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $ - withTmpDir "test" $ \d -> do + withTmpDir (toOsPath "test") $ \d -> do let ed = EmptyDirectory d enc <- encryptSymmetric a password ed Nothing armoring (`B.hPutStr` v) B.hGetContents @@ -159,10 +159,10 @@ feedRead cmd subcmd params password emptydirectory feeder reader = do go (Just emptydirectory) (passwordfd ++ params) #else -- store the password in a temp file - withTmpFile "sop" $ \tmpfile h -> do + withTmpFile (toOsPath "sop") $ \tmpfile h -> do liftIO $ B.hPutStr h password liftIO $ hClose h - let passwordfile = [Param $ "--with-password="++tmpfile] + let passwordfile = [Param $ "--with-password=" ++ fromRawFilePath (fromOsPath tmpfile)] -- Don't need to pass emptydirectory since @FD is not used, -- and so tmpfile also does not need to be made absolute. case emptydirectory of diff --git a/Utility/TimeStamp.hs b/Utility/TimeStamp.hs index 878d6f7299..1175034e91 100644 --- a/Utility/TimeStamp.hs +++ b/Utility/TimeStamp.hs @@ -19,7 +19,6 @@ import Data.Time import Data.Ratio import Control.Applicative import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 import qualified Data.Attoparsec.ByteString as A import Data.Attoparsec.ByteString.Char8 (char, decimal, signed, isDigit_w8) @@ -41,9 +40,9 @@ parserPOSIXTime = mkPOSIXTime A.parseOnly (decimal <* A.endOfInput) b return (d, len) -parsePOSIXTime :: String -> Maybe POSIXTime -parsePOSIXTime s = eitherToMaybe $ - A.parseOnly (parserPOSIXTime <* A.endOfInput) (B8.pack s) +parsePOSIXTime :: B.ByteString -> Maybe POSIXTime +parsePOSIXTime b = eitherToMaybe $ + A.parseOnly (parserPOSIXTime <* A.endOfInput) b {- This implementation allows for higher precision in a POSIXTime than - supported by the system's Double, and avoids the complications of diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index a23a2a37f5..8e0ca10755 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -1,11 +1,11 @@ {- Temporary files. - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2025 Joey Hess - - License: BSD-2-clause -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Tmp ( @@ -13,33 +13,38 @@ module Utility.Tmp ( viaTmp, withTmpFile, withTmpFileIn, - relatedTemplate, openTmpFileIn, + relatedTemplate, + relatedTemplate', ) where import System.IO -import System.FilePath import System.Directory import Control.Monad.IO.Class import System.IO.Error +import Data.Char +import qualified Data.ByteString as B +import qualified System.FilePath.ByteString as P import Utility.Exception import Utility.FileSystemEncoding import Utility.FileMode import qualified Utility.RawFilePath as R +import qualified Utility.FileIO as F +import Utility.OsPath -type Template = String +type Template = OsString {- This is the same as openTempFile, except when there is an - error, it displays the template as well as the directory, - to help identify what call was responsible. -} -openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle) -openTmpFileIn dir template = openTempFile dir template +openTmpFileIn :: OsPath -> Template -> IO (OsPath, Handle) +openTmpFileIn dir template = F.openTempFile dir template `catchIO` decoraterrror where decoraterrror e = throwM $ - let loc = ioeGetLocation e ++ " template " ++ template + let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template) in annotateIOError e loc Nothing Nothing {- Runs an action like writeFile, writing to a temp file first and @@ -50,34 +55,36 @@ openTmpFileIn dir template = openTempFile dir template - mode as it would when using writeFile, unless the writer action changes - it. -} -viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m () +viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m () viaTmp a file content = bracketIO setup cleanup use where - (dir, base) = splitFileName file - template = relatedTemplate (base ++ ".tmp") + (dir, base) = P.splitFileName (fromOsPath file) + template = relatedTemplate (base <> ".tmp") setup = do - createDirectoryIfMissing True dir - openTmpFileIn dir template + createDirectoryIfMissing True (fromRawFilePath dir) + openTmpFileIn (toOsPath dir) template cleanup (tmpfile, h) = do _ <- tryIO $ hClose h - tryIO $ removeFile tmpfile + tryIO $ R.removeLink (fromOsPath tmpfile) use (tmpfile, h) = do - let tmpfile' = toRawFilePath tmpfile + let tmpfile' = fromOsPath tmpfile -- Make mode the same as if the file were created usually, -- not as a temp file. (This may fail on some filesystems -- that don't support file modes well, so ignore -- exceptions.) - _ <- liftIO $ tryIO $ R.setFileMode tmpfile' =<< defaultFileMode + _ <- liftIO $ tryIO $ + R.setFileMode (fromOsPath tmpfile) + =<< defaultFileMode liftIO $ hClose h a tmpfile content - liftIO $ R.rename tmpfile' (toRawFilePath file) + liftIO $ R.rename tmpfile' (fromOsPath file) {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} -withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a +withTmpFile :: (MonadIO m, MonadMask m) => Template -> (OsPath -> Handle -> m a) -> m a withTmpFile template a = do tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory - withTmpFileIn tmpdir template a + withTmpFileIn (toOsPath (toRawFilePath tmpdir)) template a {- Runs an action with a tmp file located in the specified directory, - then removes the file. @@ -85,13 +92,13 @@ withTmpFile template a = do - Note that the tmp file will have a file mode that only allows the - current user to access it. -} -withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a +withTmpFileIn :: (MonadIO m, MonadMask m) => OsPath -> Template -> (OsPath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where create = liftIO $ openTmpFileIn tmpdir template remove (name, h) = liftIO $ do hClose h - catchBoolIO (removeFile name >> return True) + tryIO $ R.removeLink (fromOsPath name) use (name, h) = a name h {- It's not safe to use a FilePath of an existing file as the template @@ -99,18 +106,29 @@ withTmpFileIn tmpdir template a = bracket create remove use - will be longer, and may exceed the maximum filename length. - - This generates a template that is never too long. - - (Well, it allocates 20 characters for use in making a unique temp file, - - anyway, which is enough for the current implementation and any - - likely implementation.) -} -relatedTemplate :: FilePath -> FilePath -relatedTemplate f - | len > 20 = +relatedTemplate :: RawFilePath -> Template +relatedTemplate = toOsPath . relatedTemplate' + +relatedTemplate' :: RawFilePath -> RawFilePath +relatedTemplate' f + | len > templateAddedLength = {- Some filesystems like FAT have issues with filenames - ending in ".", so avoid truncating a filename to end - that way. -} - reverse $ dropWhile (== '.') $ reverse $ - truncateFilePath (len - 20) f + B.dropWhileEnd (== dot) $ + truncateFilePath (len - templateAddedLength) f | otherwise = f where - len = length f + len = B.length f + dot = fromIntegral (ord '.') + +{- When a Template is used to create a temporary file, some random bytes + - are appended to it. This is how many such bytes can be added, maximum. + - + - This needs to be as long or longer than the current implementation + - of openTempFile, and some extra has been added to make it longer + - than any likely implementation. + -} +templateAddedLength :: Int +templateAddedLength = 20 diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs index 904b65a526..c359b9d82d 100644 --- a/Utility/Tmp/Dir.hs +++ b/Utility/Tmp/Dir.hs @@ -23,6 +23,8 @@ import System.Posix.Temp (mkdtemp) import Utility.Exception import Utility.Tmp (Template) +import Utility.OsPath +import Utility.FileSystemEncoding {- Runs an action with a tmp directory located within the system's tmp - directory (or within "." if there is none), then removes the tmp @@ -33,7 +35,7 @@ withTmpDir template a = do #ifndef mingw32_HOST_OS -- Use mkdtemp to create a temp directory securely in /tmp. bracket - (liftIO $ mkdtemp $ topleveltmpdir template) + (liftIO $ mkdtemp $ topleveltmpdir fromRawFilePath (fromOsPath template)) removeTmpDir a #else @@ -47,7 +49,7 @@ withTmpDirIn tmpdir template = bracketIO create removeTmpDir where create = do createDirectoryIfMissing True tmpdir - makenewdir (tmpdir template) (0 :: Int) + makenewdir (tmpdir fromRawFilePath (fromOsPath template)) (0 :: Int) makenewdir t n = do let dir = t ++ "." ++ show n catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs index 987d67cbd6..937b3bad5a 100644 --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -187,7 +187,9 @@ insertAuthToken extractAuthToken predicate webapp root pathbits params = - to avoid exposing the secret token when launching the web browser. -} writeHtmlShim :: String -> String -> FilePath -> IO () writeHtmlShim title url file = - viaTmp (writeFileProtected . toRawFilePath) file $ genHtmlShim title url + viaTmp (writeFileProtected . fromOsPath) + (toOsPath $ toRawFilePath file) + (genHtmlShim title url) genHtmlShim :: String -> String -> String genHtmlShim title url = unlines diff --git a/git-annex.cabal b/git-annex.cabal index 864efa527e..b610cdf65c 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -175,6 +175,9 @@ Flag Crypton Flag Servant Description: Use the servant library, enabling using annex+http urls and git-annex p2phttp +Flag OsPath + Description: Use the os-string library and related libraries, for faster filename manipulation + Flag Benchmark Description: Enable benchmarking Default: True @@ -329,6 +332,16 @@ Executable git-annex P2P.Http.Server P2P.Http.State + if flag(OsPath) + -- Currently this build flag does not pass the test suite on Windows + if (! os(windows)) + Build-Depends: + os-string (>= 2.0.0), + directory (>= 1.3.8.3), + filepath (>= 1.5.2.0), + file-io (>= 0.1.3) + CPP-Options: -DWITH_OSPATH + if (os(windows)) Build-Depends: Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0), @@ -1094,6 +1107,7 @@ Executable git-annex Utility.OpenFile Utility.OptParse Utility.OSX + Utility.OsPath Utility.PID Utility.PartialPrelude Utility.Path @@ -1123,6 +1137,7 @@ Executable git-annex Utility.STM Utility.Su Utility.SystemDirectory + Utility.FileIO Utility.Terminal Utility.TimeStamp Utility.TList diff --git a/stack.yaml b/stack.yaml index d46045734f..5ff6f33d09 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,8 +11,15 @@ flags: benchmark: true crypton: true servant: true + ospath: true packages: - '.' -resolver: lts-23.2 +resolver: nightly-2025-01-20 extra-deps: -- filepath-bytestring-1.4.100.3.2 +- filepath-bytestring-1.5.2.0.2 +- aws-0.24.4 +- git-lfs-1.2.3 +- feed-1.3.2.1 +allow-newer: true +allow-newer-deps: +- feed