From 793ddecd4b72a5e4746b3b426d3bca400737118b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 21 Jan 2025 17:00:37 -0400 Subject: [PATCH] use openTempFile from file-io And follow-on changes. Note that relatedTemplate was changed to operate on a RawFilePath, and so when it counts the length, it is now the number of bytes, not the number of code points. This will just make it truncate shorter strings in some cases, the truncation is still unicode aware. When not building with the OsPath flag, toOsPath . fromRawFilePath and fromRawFilePath . fromOsPath do extra conversions back and forth between String and ByteString. That overhead could be avoided, but that's the non-optimised build mode, so didn't bother. Sponsored-by: unqueued --- Annex/AdjustedBranch/Merge.hs | 2 +- Annex/Branch.hs | 6 +-- Annex/Hook.hs | 7 +++- Annex/Ingest.hs | 17 +++++---- Annex/Link.hs | 4 +- Annex/Proxy.hs | 3 +- Annex/ReplaceFile.hs | 2 +- Annex/YoutubeDl.hs | 8 ++-- Assistant/DaemonStatus.hs | 5 ++- Assistant/Install.hs | 16 ++++---- Assistant/Ssh.hs | 4 +- Assistant/Threads/WebApp.hs | 4 +- Assistant/Upgrade.hs | 6 +-- Assistant/WebApp/Configurators/Ssh.hs | 6 +-- CmdLine/GitRemoteAnnex.hs | 29 +++++++------- Command/Export.hs | 4 +- Command/ImportFeed.hs | 7 ++-- Command/Multicast.hs | 10 ++--- Command/P2P.hs | 2 +- Command/TestRemote.hs | 14 +++---- Config/Files/AutoStart.hs | 4 +- Crypto.hs | 4 +- Database/Benchmark.hs | 2 +- Git/HashObject.hs | 5 ++- Git/Hook.hs | 32 ++++++++-------- Git/Repair.hs | 4 +- Logs/File.hs | 14 +++---- Remote/BitTorrent.hs | 8 ++-- Remote/Directory.hs | 16 ++++---- Remote/GCrypt.hs | 7 ++-- Remote/Git.hs | 7 ++-- Remote/Rsync.hs | 2 +- Test.hs | 4 +- Test/Framework.hs | 4 +- Upgrade/V1.hs | 4 +- Upgrade/V2.hs | 14 ++++--- Utility/FileIO.hs | 8 +++- Utility/LockFile/PidLock.hs | 8 ++-- Utility/MoveFile.hs | 10 +++-- Utility/OsPath.hs | 12 +++++- Utility/SshConfig.hs | 9 +++-- Utility/StatelessOpenPGP.hs | 5 ++- Utility/Tmp.hs | 54 +++++++++++++++------------ Utility/Tmp/Dir.hs | 6 ++- Utility/WebApp.hs | 4 +- doc/todo/RawFilePath_conversion.mdwn | 10 +++-- 46 files changed, 235 insertions(+), 178 deletions(-) diff --git a/Annex/AdjustedBranch/Merge.hs b/Annex/AdjustedBranch/Merge.hs index 5a88a8e79f..8a3d3b3be9 100644 --- a/Annex/AdjustedBranch/Merge.hs +++ b/Annex/AdjustedBranch/Merge.hs @@ -74,7 +74,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do git_dir <- fromRepo Git.localGitDir 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 liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) -- Copy in refs and packed-refs, to work diff --git a/Annex/Branch.hs b/Annex/Branch.hs index bf81830001..eca1ea778d 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -741,7 +741,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 @@ -769,8 +769,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 = 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..2a1a6c7aff 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 } diff --git a/Annex/Link.hs b/Annex/Link.hs index 72b0d3afff..8a5352e99e 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -246,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 diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs index 6ac652c642..6fb739b30c 100644 --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Annex.Proxy where @@ -174,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 diff --git a/Annex/ReplaceFile.hs b/Annex/ReplaceFile.hs index 21735eba14..980750860d 100644 --- a/Annex/ReplaceFile.hs +++ b/Annex/ReplaceFile.hs @@ -71,7 +71,7 @@ replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -- it short. let basetmp = "t" #endif - withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do + withTmpDirIn othertmpdir' (toOsPath (toRawFilePath basetmp)) $ \tmpdir -> do let tmpfile = toRawFilePath (tmpdir basetmp) r <- action tmpfile when (checkres r) $ diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs index 04ab1091ed..6544f3d1f5 100644 --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -31,6 +31,7 @@ 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 @@ -38,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 @@ -353,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" @@ -363,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..dde5010f8c 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) diff --git a/Assistant/Install.hs b/Assistant/Install.hs index c11b6d5585..da33b16842 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 @@ -82,7 +83,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")) $ unlines [ shebang , "set -e" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" @@ -91,7 +92,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL") , rungitannexshell "$@" , "fi" ] - installWrapper (sshdir "git-annex-wrapper") $ unlines + installWrapper (toRawFilePath (sshdir "git-annex-wrapper")) $ unlines [ shebang , "set -e" , runshell "\"$@\"" @@ -99,14 +100,13 @@ 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 + curr <- catchDefaultIO "" $ readFileStrict (fromRawFilePath file) when (curr /= content) $ do - createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file))) - viaTmp writeFile file content - modifyFileMode (toRawFilePath file) $ - addModes [ownerExecuteMode] + createDirectoryIfMissing True (fromRawFilePath (parentDir file)) + viaTmp F.writeFile' (toOsPath file) (encodeBS content) + modifyFileMode file $ addModes [ownerExecuteMode] installFileManagerHooks :: FilePath -> IO () #ifdef linux_HOST_OS diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 3f472a5332..a85b294577 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -160,7 +160,7 @@ removeAuthorizedKeys gitannexshellonly dir pubkey = do sshdir <- sshDir let keyfile = sshdir "authorized_keys" tryWhenExists (lines <$> readFileStrict keyfile) >>= \case - Just ls -> viaTmp writeSshConfig keyfile $ + Just ls -> viaTmp writeSshConfig (toOsPath (toRawFilePath keyfile)) $ unlines $ filter (/= keyline) ls Nothing -> noop @@ -212,7 +212,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/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 8e299b5271..075ce57286 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -189,7 +189,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 @@ -323,7 +323,7 @@ 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 @@ -361,7 +361,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/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/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs index 0702bbd3f0..f1421815ad 100644 --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -58,6 +58,7 @@ 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 @@ -495,13 +496,14 @@ 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 + <$> readFileStrict tmp' | otherwise = return Nothing where lcurl = map toLower url @@ -724,10 +726,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 +776,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 +787,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 @@ -973,14 +975,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 +1125,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 -> 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/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/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..cef725bf43 100644 --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -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" diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index 2d96f7b1f7..d0250a48c0 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -355,11 +355,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 +429,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/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/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..35031f20ae 100644 --- a/Git/HashObject.hs +++ b/Git/HashObject.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Git.HashObject where @@ -82,10 +83,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/Repair.hs b/Git/Repair.hs index 332bb5d50a..78fe2ea505 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -78,7 +78,7 @@ 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 @@ -112,7 +112,7 @@ 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) diff --git a/Logs/File.hs b/Logs/File.hs index 08203121ef..97efb58ec1 100644 --- a/Logs/File.hs +++ b/Logs/File.hs @@ -37,11 +37,11 @@ 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. @@ -77,16 +77,16 @@ 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 diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 29e19e5f8b..b8435a6502 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -214,13 +214,13 @@ downloadTorrentFile u = do (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 ) diff --git a/Remote/Directory.hs b/Remote/Directory.hs index ac0e4cbeec..4fb8503867 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -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 = @@ -541,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" @@ -557,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/GCrypt.hs b/Remote/GCrypt.hs index 8a3852c6b1..8103622580 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -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/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 dbf13af054..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 diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index bad2cfbc07..f7440463d4 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -198,7 +198,9 @@ 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 (L.writeFile . fromRawFilePath . fromOsPath) + (toOsPath (toRawFilePath file)) + (toLazyByteString $ buildLog ls) readLog1 :: FilePath -> IO [LogLine] readLog1 file = catchDefaultIO [] $ diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs index bbe5d8431d..db6add236b 100644 --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -135,12 +135,14 @@ 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 <- readFileStrict attributes' + liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath) + (toOsPath attributes) + (unlines $ filter (`notElem` attrLines) $ lines c) + Git.Command.run [Param "add", File attributes'] repo stateDir :: FilePath stateDir = addTrailingPathSeparator ".git-annex" diff --git a/Utility/FileIO.hs b/Utility/FileIO.hs index 04c926d606..5a8f661ce5 100644 --- a/Utility/FileIO.hs +++ b/Utility/FileIO.hs @@ -22,6 +22,7 @@ module Utility.FileIO writeFile', appendFile, appendFile', + openTempFile, ) where #ifdef WITH_OSPATH @@ -81,6 +82,10 @@ 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 @@ -88,7 +93,8 @@ appendFile' f b = do -- 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, IO) +import System.IO (withFile, openFile, openTempFile, IO) +import qualified System.IO import Data.ByteString.Lazy (readFile, writeFile, appendFile) import qualified Data.ByteString as B diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs index b3a3b0e2cc..4ed730ccff 100644 --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -40,6 +40,7 @@ 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 @@ -149,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 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 index f05267524b..5a62e61004 100644 --- a/Utility/OsPath.hs +++ b/Utility/OsPath.hs @@ -9,7 +9,12 @@ {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-tabs #-} -module Utility.OsPath where +module Utility.OsPath ( + OsPath, + OsString, + toOsPath, + fromOsPath, +) where import Utility.FileSystemEncoding @@ -39,8 +44,11 @@ fromOsPath = S.fromShort . getPosixString . getOsString {- 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 diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index 83c63fcd3d..d43347d7f1 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -28,6 +28,7 @@ import Common import Utility.UserInfo import Utility.Tmp import Utility.FileMode +import qualified Utility.FileIO as F import Data.Char import Data.Ord @@ -140,12 +141,12 @@ changeUserSshConfig modifier = 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 (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..6150bce633 100644 --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -27,6 +27,7 @@ import System.Posix.Types import System.Posix.IO #else import Utility.Tmp +import Utility.OsPath #endif import Utility.Tmp.Dir import Author @@ -112,7 +113,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,7 +160,7 @@ 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] diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index a23a2a37f5..21b6fed9de 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Tmp ( @@ -18,28 +18,31 @@ module Utility.Tmp ( ) where import System.IO -import System.FilePath import System.Directory import Control.Monad.IO.Class import System.IO.Error +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 +53,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 +90,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 @@ -103,14 +108,15 @@ withTmpFileIn tmpdir template a = bracket create remove use - anyway, which is enough for the current implementation and any - likely implementation.) -} -relatedTemplate :: FilePath -> FilePath +relatedTemplate :: RawFilePath -> Template relatedTemplate f | len > 20 = {- 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 - | otherwise = f + toOsPath $ toRawFilePath $ + reverse $ dropWhile (== '.') $ reverse $ + truncateFilePath (len - 20) (fromRawFilePath f) + | otherwise = toOsPath f where - len = length f + len = B.length f 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/doc/todo/RawFilePath_conversion.mdwn b/doc/todo/RawFilePath_conversion.mdwn index 5232f2a390..cef9ffbd7a 100644 --- a/doc/todo/RawFilePath_conversion.mdwn +++ b/doc/todo/RawFilePath_conversion.mdwn @@ -13,11 +13,15 @@ status. * filepath-1.4.100 implements support for OSPath. It is bundled with ghc-9.6.1 and above. Will need to switch from filepath-bytestring to this, and to avoid a lot of ifdefs, probably only after git-annex no - longers supports building with older ghc versions. + longers supports building with older ghc versions. This will entail + replacing all the RawFilePath with OsPath, which should be pretty + mechanical, with only some wrapper functions in Utility.FileIO and + Utility.RawFilePath needing to be changed. * Utility.FileIO is used for most withFile and openFile, but not yet for readFile, writeFile, and appendFile. Including versions of those from - bytestring. -* readFileStrict should be replaced with Utility.FileIO.readFile' + bytestring. Also readFileStrict should be replaced with Utility.FileIO.readFile' + Note that the String versions can do newline translation, which has to be + handled when converting to the Utility.FileIO ones. [[!tag confirmed]]