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]]