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

use openTempFile from file-io

Browse source 
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
This commit is contained in:
Joey Hess 2025-01-21 17:00:37 -04:00
parent 1faa3af9cd
commit 793ddecd4b
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
46 changed files with 235 additions and 178 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Annex/AdjustedBranch/Merge.hs
View file

@ -74,7 +74,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
git_dir <- fromRepo Git.localGitDir git_dir <- fromRepo Git.localGitDir
tmpwt <- fromRepo gitAnnexMergeDir 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 withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig) liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
-- Copy in refs and packed-refs, to work -- Copy in refs and packed-refs, to work

6
Annex/Branch.hs
View file

@ -741,7 +741,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
g <- gitRepo g <- gitRepo
st <- getState st <- getState
let dir = gitAnnexJournalDir st g let dir = gitAnnexJournalDir st g
(jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir) (jlogf, jlogh) <- openjlog tmpdir
withHashObjectHandle $ \h -> withHashObjectHandle $ \h ->
withJournalHandle gitAnnexJournalDir $ \jh -> withJournalHandle gitAnnexJournalDir $ \jh ->
Git.UpdateIndex.streamUpdateIndex g Git.UpdateIndex.streamUpdateIndex g
@ -769,8 +769,8 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
stagedfs <- lines <$> hGetContents jlogh stagedfs <- lines <$> hGetContents jlogh
mapM_ (removeFile . (dir </>)) stagedfs mapM_ (removeFile . (dir </>)) stagedfs
hClose jlogh hClose jlogh
removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf) removeWhenExistsWith (R.removeLink) (fromOsPath jlogf)
openjlog tmpdir = liftIO $ openTmpFileIn tmpdir "jlog" openjlog tmpdir = liftIO $ openTmpFileIn (toOsPath tmpdir) (toOsPath "jlog")
getLocalTransitions :: Annex Transitions getLocalTransitions :: Annex Transitions
getLocalTransitions = getLocalTransitions =

7
Annex/Hook.hs
View file

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

17
Annex/Ingest.hs
View file

@ -118,20 +118,21 @@ lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
withhardlink tmpdir = do withhardlink tmpdir = do
setperms setperms
withTSDelta $ \delta -> liftIO $ do withTSDelta $ \delta -> liftIO $ do
(tmpfile, h) <- openTmpFileIn (fromRawFilePath tmpdir) $ (tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $
relatedTemplate $ "ingest-" ++ takeFileName file relatedTemplate $ toRawFilePath $
"ingest-" ++ takeFileName file
hClose h hClose h
removeWhenExistsWith R.removeLink (toRawFilePath tmpfile) let tmpfile' = fromOsPath tmpfile
withhardlink' delta tmpfile removeWhenExistsWith R.removeLink tmpfile'
withhardlink' delta tmpfile'
`catchIO` const (nohardlink' delta) `catchIO` const (nohardlink' delta)
withhardlink' delta tmpfile = do withhardlink' delta tmpfile = do
let tmpfile' = toRawFilePath tmpfile R.createLink file' tmpfile
R.createLink file' tmpfile' cache <- genInodeCache tmpfile delta
cache <- genInodeCache tmpfile' delta
return $ LockedDown cfg $ KeySource return $ LockedDown cfg $ KeySource
{ keyFilename = file' { keyFilename = file'
, contentLocation = tmpfile' , contentLocation = tmpfile
, inodeCache = cache , inodeCache = cache
} }

4
Annex/Link.hs
View file

@ -246,7 +246,9 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do
when (numfiles > 0) $ when (numfiles > 0) $
bracket lockindex unlockindex go bracket lockindex unlockindex go
where where
withtmpdir = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex" withtmpdir = withTmpDirIn
(fromRawFilePath $ Git.localGitDir r)
(toOsPath "annexindex")
isunmodified tsd f orig = isunmodified tsd f orig =
genInodeCache f tsd >>= return . \case genInodeCache f tsd >>= return . \case

3
Annex/Proxy.hs
View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Annex.Proxy where 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 -- independently. Also, this key is not getting added into the
-- local annex objects. -- local annex objects.
withproxytmpfile k a = withOtherTmp $ \othertmpdir -> withproxytmpfile k a = withOtherTmp $ \othertmpdir ->
withTmpDirIn (fromRawFilePath othertmpdir) "proxy" $ \tmpdir -> withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir ->
a (toRawFilePath tmpdir P.</> keyFile k) a (toRawFilePath tmpdir P.</> keyFile k)
proxyput af k = do proxyput af k = do

2
Annex/ReplaceFile.hs
View file

@ -71,7 +71,7 @@ replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir
-- it short. -- it short.
let basetmp = "t" let basetmp = "t"
#endif #endif
withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do withTmpDirIn othertmpdir' (toOsPath (toRawFilePath basetmp)) $ \tmpdir -> do
let tmpfile = toRawFilePath (tmpdir </> basetmp) let tmpfile = toRawFilePath (tmpdir </> basetmp)
r <- action tmpfile r <- action tmpfile
when (checkres r) $ when (checkres r) $

8
Annex/YoutubeDl.hs
View file

@ -31,6 +31,7 @@ import Utility.Tmp
import Messages.Progress import Messages.Progress
import Logs.Transfer import Logs.Transfer
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Network.URI import Network.URI
import Control.Concurrent.Async import Control.Concurrent.Async
@ -38,7 +39,6 @@ import Text.Read
import Data.Either import Data.Either
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import GHC.Generics import GHC.Generics
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
-- youtube-dl can follow redirects to anywhere, including potentially -- 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 else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd
youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem]) 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 hClose h
(outerr, ok) <- processTranscript cmd (outerr, ok) <- processTranscript cmd
[ "--simulate" [ "--simulate"
@ -363,14 +363,14 @@ youtubePlaylist' url cmd = withTmpFile "yt-dlp" $ \tmpfile h -> do
, "--print-to-file" , "--print-to-file"
-- Write json with selected fields. -- Write json with selected fields.
, "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j" , "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j"
, tmpfile , fromRawFilePath (fromOsPath tmpfile)
, url , url
] ]
Nothing Nothing
if ok if ok
then flip catchIO (pure . Left . show) $ do then flip catchIO (pure . Left . show) $ do
v <- map Aeson.eitherDecodeStrict . B8.lines v <- map Aeson.eitherDecodeStrict . B8.lines
<$> B.readFile tmpfile <$> F.readFile' tmpfile
return $ case partitionEithers v of return $ case partitionEithers v of
((parserr:_), _) -> ((parserr:_), _) ->
Left $ "yt-dlp json parse error: " ++ parserr Left $ "yt-dlp json parse error: " ++ parserr

5
Assistant/DaemonStatus.hs
View file

@ -22,6 +22,7 @@ import qualified Remote
import qualified Types.Remote as Remote import qualified Types.Remote as Remote
import Config.DynamicConfig import Config.DynamicConfig
import Annex.SpecialRemote.Config import Annex.SpecialRemote.Config
import qualified Utility.FileIO as F
import Control.Concurrent.STM import Control.Concurrent.STM
import System.Posix.Types import System.Posix.Types
@ -121,9 +122,9 @@ startDaemonStatus = do
- and parts of it are not relevant. -} - and parts of it are not relevant. -}
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO () writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
writeDaemonStatusFile file status = writeDaemonStatusFile file status =
viaTmp writeFile file =<< serialized <$> getPOSIXTime viaTmp F.writeFile' (toOsPath (toRawFilePath file)) =<< serialized <$> getPOSIXTime
where where
serialized now = unlines serialized now = encodeBS $ unlines
[ "lastRunning:" ++ show now [ "lastRunning:" ++ show now
, "scanComplete:" ++ show (scanComplete status) , "scanComplete:" ++ show (scanComplete status)
, "sanityCheckRunning:" ++ show (sanityCheckRunning status) , "sanityCheckRunning:" ++ show (sanityCheckRunning status)

16
Assistant/Install.hs
View file

@ -17,6 +17,7 @@ import Utility.Shell
import Utility.Tmp import Utility.Tmp
import Utility.Env import Utility.Env
import Utility.SshConfig import Utility.SshConfig
import qualified Utility.FileIO as F
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
import Utility.OSX import Utility.OSX
@ -82,7 +83,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
let runshell var = "exec " ++ base </> "runshell " ++ var let runshell var = "exec " ++ base </> "runshell " ++ var
let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\"" let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""
installWrapper (sshdir </> "git-annex-shell") $ unlines installWrapper (toRawFilePath (sshdir </> "git-annex-shell")) $ unlines
[ shebang [ shebang
, "set -e" , "set -e"
, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" , "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then"
@ -91,7 +92,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
, rungitannexshell "$@" , rungitannexshell "$@"
, "fi" , "fi"
] ]
installWrapper (sshdir </> "git-annex-wrapper") $ unlines installWrapper (toRawFilePath (sshdir </> "git-annex-wrapper")) $ unlines
[ shebang [ shebang
, "set -e" , "set -e"
, runshell "\"$@\"" , runshell "\"$@\""
@ -99,14 +100,13 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
installFileManagerHooks program installFileManagerHooks program
installWrapper :: FilePath -> String -> IO () installWrapper :: RawFilePath -> String -> IO ()
installWrapper file content = do installWrapper file content = do
curr <- catchDefaultIO "" $ readFileStrict file curr <- catchDefaultIO "" $ readFileStrict (fromRawFilePath file)
when (curr /= content) $ do when (curr /= content) $ do
createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath file))) createDirectoryIfMissing True (fromRawFilePath (parentDir file))
viaTmp writeFile file content viaTmp F.writeFile' (toOsPath file) (encodeBS content)
modifyFileMode (toRawFilePath file) $ modifyFileMode file $ addModes [ownerExecuteMode]
addModes [ownerExecuteMode]
installFileManagerHooks :: FilePath -> IO () installFileManagerHooks :: FilePath -> IO ()
#ifdef linux_HOST_OS #ifdef linux_HOST_OS

4
Assistant/Ssh.hs
View file

@ -160,7 +160,7 @@ removeAuthorizedKeys gitannexshellonly dir pubkey = do
sshdir <- sshDir sshdir <- sshDir
let keyfile = sshdir </> "authorized_keys" let keyfile = sshdir </> "authorized_keys"
tryWhenExists (lines <$> readFileStrict keyfile) >>= \case tryWhenExists (lines <$> readFileStrict keyfile) >>= \case
Just ls -> viaTmp writeSshConfig keyfile $ Just ls -> viaTmp writeSshConfig (toOsPath (toRawFilePath keyfile)) $
unlines $ filter (/= keyline) ls unlines $ filter (/= keyline) ls
Nothing -> noop Nothing -> noop
@ -212,7 +212,7 @@ authorizedKeysLine gitannexshellonly dir pubkey
{- Generates a ssh key pair. -} {- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair genSshKeyPair :: IO SshKeyPair
genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do
ok <- boolSystem "ssh-keygen" ok <- boolSystem "ssh-keygen"
[ Param "-P", Param "" -- no password [ Param "-P", Param "" -- no password
, Param "-f", File $ dir </> "key" , Param "-f", File $ dir </> "key"

4
Assistant/Threads/WebApp.hs
View file

@ -89,9 +89,9 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
, return app , return app
) )
runWebApp tlssettings listenhost' listenport' app' $ \addr -> if noannex 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 hClose h
go tlssettings addr webapp tmpfile Nothing go tlssettings addr webapp (fromRawFilePath (fromOsPath tmpfile)) Nothing
else do else do
htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim htmlshim <- getAnnex' $ fromRepo gitAnnexHtmlShim
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile

6
Assistant/Upgrade.hs
View file

@ -189,7 +189,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
- into place. -} - into place. -}
unpack = liftIO $ do unpack = liftIO $ do
olddir <- oldVersionLocation 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" let tarball = tmpdir </> "tar"
-- Cannot rely on filename extension, and this also -- Cannot rely on filename extension, and this also
-- avoids problems if tar doesn't support transparent -- avoids problems if tar doesn't support transparent
@ -323,7 +323,7 @@ downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution)
downloadDistributionInfo = do downloadDistributionInfo = do
uo <- liftAnnex Url.getUrlOptions uo <- liftAnnex Url.getUrlOptions
gpgcmd <- liftAnnex $ gpgCmd <$> Annex.getGitConfig 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 infof = tmpdir </> "info"
let sigf = infof ++ ".sig" let sigf = infof ++ ".sig"
ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo ifM (isRight <$> Url.download nullMeterUpdate Nothing distributionInfoUrl infof uo
@ -361,7 +361,7 @@ upgradeSupported = False
verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool verifyDistributionSig :: GpgCmd -> FilePath -> IO Bool
verifyDistributionSig gpgcmd sig = readProgramFile >>= \case verifyDistributionSig gpgcmd sig = readProgramFile >>= \case
Just p | isAbsolute p -> 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" let trustedkeys = takeDirectory p </> "trustedkeys.gpg"
boolGpgCmd gpgcmd boolGpgCmd gpgcmd
[ Param "--no-default-keyring" [ Param "--no-default-keyring"

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

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

29
CmdLine/GitRemoteAnnex.hs
View file

@ -58,6 +58,7 @@ import Utility.Env
import Utility.Metered import Utility.Metered
import Utility.FileMode import Utility.FileMode
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F
import Network.URI import Network.URI
import Data.Either import Data.Either
@ -495,13 +496,14 @@ resolveSpecialRemoteWebUrl :: String -> Annex (Maybe String)
resolveSpecialRemoteWebUrl url resolveSpecialRemoteWebUrl url
| "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl = | "http://" `isPrefixOf` lcurl || "https://" `isPrefixOf` lcurl =
Url.withUrlOptionsPromptingCreds $ \uo -> Url.withUrlOptionsPromptingCreds $ \uo ->
withTmpFile "git-remote-annex" $ \tmp h -> do withTmpFile (toOsPath "git-remote-annex") $ \tmp h -> do
liftIO $ hClose h 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 Left err -> giveup $ url ++ " " ++ err
Right () -> liftIO $ Right () -> liftIO $
(headMaybe . lines) (headMaybe . lines)
<$> readFileStrict tmp <$> readFileStrict tmp'
| otherwise = return Nothing | otherwise = return Nothing
where where
lcurl = map toLower url 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 -- it needs to re-download it fresh every time, and the object
-- file should not be stored locally. -- file should not be stored locally.
gettotmp dl = withOtherTmp $ \othertmp -> gettotmp dl = withOtherTmp $ \othertmp ->
withTmpFileIn (fromRawFilePath othertmp) "GITMANIFEST" $ \tmp tmph -> do withTmpFileIn (toOsPath othertmp) (toOsPath "GITMANIFEST") $ \tmp tmph -> do
liftIO $ hClose tmph liftIO $ hClose tmph
_ <- dl tmp _ <- dl (fromRawFilePath (fromOsPath tmp))
b <- liftIO (B.readFile tmp) b <- liftIO (F.readFile' tmp)
case parseManifest b of case parseManifest b of
Right m -> Just <$> verifyManifest rmt m Right m -> Just <$> verifyManifest rmt m
Left err -> giveup err Left err -> giveup err
@ -774,7 +776,7 @@ uploadManifest rmt manifest = do
dropKey' rmt mk dropKey' rmt mk
put 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 $ B8.hPut tmph (formatManifest manifest)
liftIO $ hClose tmph liftIO $ hClose tmph
-- Uploading needs the key to be in the annex objects -- Uploading needs the key to be in the annex objects
@ -785,7 +787,7 @@ uploadManifest rmt manifest = do
-- keys, which it is not. -- keys, which it is not.
objfile <- calcRepo (gitAnnexLocation mk) objfile <- calcRepo (gitAnnexLocation mk)
modifyContentDir objfile $ modifyContentDir objfile $
linkOrCopy mk (toRawFilePath tmp) objfile Nothing >>= \case linkOrCopy mk (fromOsPath tmp) objfile Nothing >>= \case
-- Important to set the right perms even -- Important to set the right perms even
-- though the object is only present -- though the object is only present
-- briefly, since sending objects may rely -- briefly, since sending objects may rely
@ -973,14 +975,15 @@ generateGitBundle
-> Manifest -> Manifest
-> Annex (Key, Annex ()) -> Annex (Key, Annex ())
generateGitBundle rmt bs manifest = generateGitBundle rmt bs manifest =
withTmpFile "GITBUNDLE" $ \tmp tmph -> do withTmpFile (toOsPath "GITBUNDLE") $ \tmp tmph -> do
let tmp' = fromOsPath tmp
liftIO $ hClose tmph liftIO $ hClose tmph
inRepo $ Git.Bundle.create tmp bs inRepo $ Git.Bundle.create (fromRawFilePath tmp') bs
bundlekey <- genGitBundleKey (Remote.uuid rmt) bundlekey <- genGitBundleKey (Remote.uuid rmt)
(toRawFilePath tmp) nullMeterUpdate tmp' nullMeterUpdate
if (bundlekey `notElem` inManifest manifest) if (bundlekey `notElem` inManifest manifest)
then do then do
unlessM (moveAnnex bundlekey (AssociatedFile Nothing) (toRawFilePath tmp)) $ unlessM (moveAnnex bundlekey (AssociatedFile Nothing) tmp') $
giveup "Unable to push" giveup "Unable to push"
return (bundlekey, uploadaction bundlekey) return (bundlekey, uploadaction bundlekey)
else return (bundlekey, noop) else return (bundlekey, noop)
@ -1122,7 +1125,7 @@ startAnnexBranch = ifM (null <$> Annex.Branch.siblingBranches)
-- journal writes to a temporary directory, so that all writes -- journal writes to a temporary directory, so that all writes
-- to the git-annex branch by the action will be discarded. -- to the git-annex branch by the action will be discarded.
specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a specialRemoteFromUrl :: StartAnnexBranch -> Annex a -> Annex a
specialRemoteFromUrl sab a = withTmpDir "journal" $ \tmpdir -> do specialRemoteFromUrl sab a = withTmpDir (toOsPath "journal") $ \tmpdir -> do
Annex.overrideGitConfig $ \c -> Annex.overrideGitConfig $ \c ->
c { annexAlwaysCommit = False } c { annexAlwaysCommit = False }
Annex.BranchState.changeState $ \st -> Annex.BranchState.changeState $ \st ->

4
Command/Export.hs
View file

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

7
Command/ImportFeed.hs
View file

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

10
Command/Multicast.hs
View file

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

2
Command/P2P.hs
View file

@ -220,7 +220,7 @@ wormholePairing remotename ouraddrs ui = do
-- files. Permissions of received files may allow others -- files. Permissions of received files may allow others
-- to read them. So, set up a temp directory that only -- to read them. So, set up a temp directory that only
-- we can read. -- we can read.
withTmpDir "pair" $ \tmp -> do withTmpDir (toOsPath "pair") $ \tmp -> do
liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $ liftIO $ void $ tryIO $ modifyFileMode (toRawFilePath tmp) $
removeModes otherGroupModes removeModes otherGroupModes
let sendf = tmp </> "send" let sendf = tmp </> "send"

14
Command/TestRemote.hs
View file

@ -355,11 +355,11 @@ testExportTree runannex mkr mkk1 mkk2 =
storeexport ea k = do storeexport ea k = do
loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k)
Remote.storeExport ea loc k testexportlocation nullMeterUpdate 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 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 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 checkpresentexport ea k = Remote.checkPresentExport ea k testexportlocation
removeexport ea k = Remote.removeExport ea k testexportlocation removeexport ea k = Remote.removeExport ea k testexportlocation
removeexportdirectory ea = case Remote.removeExportDirectory ea of removeexportdirectory ea = case Remote.removeExportDirectory ea of
@ -429,21 +429,21 @@ keySizes base fast = filter want
| otherwise = sz > 0 | otherwise = sz > 0
randKey :: Int -> Annex Key randKey :: Int -> Annex Key
randKey sz = withTmpFile "randkey" $ \f h -> do randKey sz = withTmpFile (toOsPath "randkey") $ \f h -> do
gen <- liftIO (newGenIO :: IO SystemRandom) gen <- liftIO (newGenIO :: IO SystemRandom)
case genBytes sz gen of case genBytes sz gen of
Left e -> giveup $ "failed to generate random key: " ++ show e Left e -> giveup $ "failed to generate random key: " ++ show e
Right (rand, _) -> liftIO $ B.hPut h rand Right (rand, _) -> liftIO $ B.hPut h rand
liftIO $ hClose h liftIO $ hClose h
let ks = KeySource let ks = KeySource
{ keyFilename = toRawFilePath f { keyFilename = fromOsPath f
, contentLocation = toRawFilePath f , contentLocation = fromOsPath f
, inodeCache = Nothing , inodeCache = Nothing
} }
k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of
Just a -> a ks nullMeterUpdate Just a -> a ks nullMeterUpdate
Nothing -> giveup "failed to generate random key (backend problem)" Nothing -> giveup "failed to generate random key (backend problem)"
_ <- moveAnnex k (AssociatedFile Nothing) (toRawFilePath f) _ <- moveAnnex k (AssociatedFile Nothing) (fromOsPath f)
return k return k
getReadonlyKey :: Remote -> RawFilePath -> Annex Key getReadonlyKey :: Remote -> RawFilePath -> Annex Key

4
Config/Files/AutoStart.hs
View file

@ -31,7 +31,9 @@ modifyAutoStartFile func = do
f <- autoStartFile f <- autoStartFile
createDirectoryIfMissing True $ createDirectoryIfMissing True $
fromRawFilePath (parentDir (toRawFilePath f)) 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 {- 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 - present, it's moved to the top, so it will be used as the default

4
Crypto.hs
View file

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

2
Database/Benchmark.hs
View file

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

5
Git/HashObject.hs
View file

@ -6,6 +6,7 @@
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Git.HashObject where module Git.HashObject where
@ -82,10 +83,10 @@ instance HashableBlob Builder where
{- Injects a blob into git. Unfortunately, the current git-hash-object {- Injects a blob into git. Unfortunately, the current git-hash-object
- interface does not allow batch hashing without using temp files. -} - interface does not allow batch hashing without using temp files. -}
hashBlob :: HashableBlob b => HashObjectHandle -> b -> IO Sha 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 hashableBlobToHandle tmph b
hClose tmph hClose tmph
hashFile h (toRawFilePath tmp) hashFile h (fromOsPath tmp)
{- Injects some content into git, returning its Sha. {- Injects some content into git, returning its Sha.
- -

32
Git/Hook.hs
View file

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

4
Git/Repair.hs
View file

@ -78,7 +78,7 @@ explodePacks :: Repo -> IO Bool
explodePacks r = go =<< listPackFiles r explodePacks r = go =<< listPackFiles r
where where
go [] = return False go [] = return False
go packs = withTmpDir "packs" $ \tmpdir -> do go packs = withTmpDir (toOsPath "packs") $ \tmpdir -> do
r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir
putStrLn "Unpacking all pack files." putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
@ -112,7 +112,7 @@ explodePacks r = go =<< listPackFiles r
retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
retrieveMissingObjects missing referencerepo r retrieveMissingObjects missing referencerepo r
| not (foundBroken missing) = return missing | not (foundBroken missing) = return missing
| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do | otherwise = withTmpDir (toOsPath "tmprepo") $ \tmpdir -> do
unlessM (boolSystem "git" [Param "init", File tmpdir]) $ unlessM (boolSystem "git" [Param "init", File tmpdir]) $
giveup $ "failed to create temp repository in " ++ tmpdir giveup $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir)

14
Logs/File.hs
View file

@ -37,11 +37,11 @@ import qualified Data.ByteString.Lazy.Char8 as L8
-- making the new file have whatever permissions the git repository is -- making the new file have whatever permissions the git repository is
-- configured to use. Creates the parent directory when necessary. -- configured to use. Creates the parent directory when necessary.
writeLogFile :: RawFilePath -> String -> Annex () 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 where
writelog tmp c' = do writelog tmp c' = do
liftIO $ writeFile tmp c' liftIO $ writeFile (fromRawFilePath (fromOsPath tmp)) c'
setAnnexFilePerm (toRawFilePath tmp) setAnnexFilePerm (fromOsPath tmp)
-- | Runs the action with a handle connected to a temp file. -- | Runs the action with a handle connected to a temp file.
-- The temp file replaces the log file once the action succeeds. -- 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 :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
modifyLogFile f lck modf = withExclusiveLock lck $ do modifyLogFile f lck modf = withExclusiveLock lck $ do
ls <- liftIO $ fromMaybe [] ls <- liftIO $ fromMaybe []
<$> tryWhenExists (fileLines <$> L.readFile f') <$> tryWhenExists (fileLines <$> F.readFile f')
let ls' = modf ls let ls' = modf ls
when (ls' /= ls) $ when (ls' /= ls) $
createDirWhenNeeded f $ createDirWhenNeeded f $
viaTmp writelog f' (L8.unlines ls') viaTmp writelog f' (L8.unlines ls')
where where
f' = fromRawFilePath f f' = toOsPath f
writelog lf b = do writelog lf b = do
liftIO $ L.writeFile lf b liftIO $ F.writeFile lf b
setAnnexFilePerm (toRawFilePath lf) setAnnexFilePerm (fromOsPath lf)
-- | Checks the content of a log file to see if any line matches. -- | Checks the content of a log file to see if any line matches.
checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool

8
Remote/BitTorrent.hs
View file

@ -214,13 +214,13 @@ downloadTorrentFile u = do
(fromRawFilePath metadir) (fromRawFilePath metadir)
return ok return ok
else withOtherTmp $ \othertmp -> do else withOtherTmp $ \othertmp -> do
withTmpFileIn (fromRawFilePath othertmp) "torrent" $ \f h -> do withTmpFileIn (toOsPath othertmp) (toOsPath "torrent") $ \f h -> do
liftIO $ hClose h liftIO $ hClose h
resetAnnexFilePerm (toRawFilePath f) resetAnnexFilePerm (fromOsPath f)
ok <- Url.withUrlOptions $ ok <- Url.withUrlOptions $
Url.download nullMeterUpdate Nothing u f Url.download nullMeterUpdate Nothing u (fromRawFilePath (fromOsPath f))
when ok $ when ok $
liftIO $ moveFile (toRawFilePath f) torrent liftIO $ moveFile (fromOsPath f) torrent
return ok return ok
) )

16
Remote/Directory.hs
View file

@ -338,10 +338,10 @@ storeExportM d cow src _k loc p = do
liftIO $ createDirectoryUnder [d] (P.takeDirectory dest) liftIO $ createDirectoryUnder [d] (P.takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not -- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored. -- see it until it's fully stored.
viaTmp go (fromRawFilePath dest) () viaTmp go (toOsPath dest) ()
where where
dest = exportPath d loc 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 :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification
retrieveExportM d cow k loc dest p = 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 :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
liftIO $ createDirectoryUnder [dir] (toRawFilePath destdir) liftIO $ createDirectoryUnder [dir] destdir
withTmpFileIn destdir template $ \tmpf tmph -> do withTmpFileIn (toOsPath destdir) template $ \tmpf tmph -> do
let tmpf' = fromOsPath tmpf
liftIO $ hClose tmph liftIO $ hClose tmph
void $ liftIO $ fileCopier cow src tmpf p Nothing void $ liftIO $ fileCopier cow src (fromRawFilePath tmpf') p Nothing
let tmpf' = toRawFilePath tmpf
resetAnnexFilePerm tmpf' resetAnnexFilePerm tmpf'
liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case
Nothing -> giveup "unable to generate content identifier" Nothing -> giveup "unable to generate content identifier"
@ -557,8 +557,8 @@ storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
return newcid return newcid
where where
dest = exportPath dir loc dest = exportPath dir loc
(destdir, base) = splitFileName (fromRawFilePath dest) (destdir, base) = P.splitFileName dest
template = relatedTemplate (base ++ ".tmp") template = relatedTemplate (base <> ".tmp")
removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
removeExportWithContentIdentifierM ii dir k loc removeablecids = removeExportWithContentIdentifierM ii dir k loc removeablecids =

7
Remote/GCrypt.hs
View file

@ -529,9 +529,10 @@ getConfigViaRsync r gc = do
let (rsynctransport, rsyncurl, _) = rsyncTransport r gc let (rsynctransport, rsyncurl, _) = rsyncTransport r gc
opts <- rsynctransport opts <- rsynctransport
liftIO $ do liftIO $ do
withTmpFile "tmpconfig" $ \tmpconfig _ -> do withTmpFile (toOsPath "tmpconfig") $ \tmpconfig _ -> do
let tmpconfig' = fromRawFilePath $ fromOsPath tmpconfig
void $ rsync $ opts ++ void $ rsync $ opts ++
[ Param $ rsyncurl ++ "/config" [ Param $ rsyncurl ++ "/config"
, Param tmpconfig , Param tmpconfig'
] ]
Git.Config.fromFile r tmpconfig Git.Config.fromFile r tmpconfig'

7
Remote/Git.hs
View file

@ -324,9 +324,10 @@ tryGitConfigRead autoinit r hasuuid
geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do
let url = Git.repoLocation r ++ "/config" 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 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 () -> Right () ->
pipedconfig Git.Config.ConfigNullList pipedconfig Git.Config.ConfigNullList
False url "git" False url "git"
@ -334,7 +335,7 @@ tryGitConfigRead autoinit r hasuuid
, Param "--null" , Param "--null"
, Param "--list" , Param "--list"
, Param "--file" , Param "--file"
, File tmpfile , File tmpfile'
] >>= return . \case ] >>= return . \case
Right r' -> Right r' Right r' -> Right r'
Left exitcode -> Left $ "git config exited " ++ show exitcode Left exitcode -> Left $ "git config exited " ++ show exitcode

2
Remote/Rsync.hs
View file

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

4
Test.hs
View file

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

4
Test/Framework.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Test.Framework where module Test.Framework where
import Test.Tasty import Test.Tasty
@ -302,7 +304,7 @@ ensuredir d = do
- happen concurrently with a test case running, and would be a problem - happen concurrently with a test case running, and would be a problem
- since setEnv is not thread safe. This is run before tasty. -} - since setEnv is not thread safe. This is run before tasty. -}
setTestEnv :: IO a -> IO a 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) tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome)
{- Prevent global git configs from affecting the test suite. -} {- Prevent global git configs from affecting the test suite. -}
Utility.Env.Set.setEnv "HOME" tmphomeabs True Utility.Env.Set.setEnv "HOME" tmphomeabs True

4
Upgrade/V1.hs
View file

@ -198,7 +198,9 @@ fileKey1 file = readKey1 $
replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file replace "&a" "&" $ replace "&s" "%" $ replace "%" "/" file
writeLog1 :: FilePath -> [LogLine] -> IO () 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 :: FilePath -> IO [LogLine]
readLog1 file = catchDefaultIO [] $ readLog1 file = catchDefaultIO [] $

14
Upgrade/V2.hs
View file

@ -135,12 +135,14 @@ attrLines =
gitAttributesUnWrite :: Git.Repo -> IO () gitAttributesUnWrite :: Git.Repo -> IO ()
gitAttributesUnWrite repo = do gitAttributesUnWrite repo = do
let attributes = fromRawFilePath (Git.attributes repo) let attributes = Git.attributes repo
whenM (doesFileExist attributes) $ do let attributes' = fromRawFilePath attributes
c <- readFileStrict attributes whenM (doesFileExist attributes') $ do
liftIO $ viaTmp writeFile attributes $ unlines $ c <- readFileStrict attributes'
filter (`notElem` attrLines) $ lines c liftIO $ viaTmp (writeFile . fromRawFilePath . fromOsPath)
Git.Command.run [Param "add", File attributes] repo (toOsPath attributes)
(unlines $ filter (`notElem` attrLines) $ lines c)
Git.Command.run [Param "add", File attributes'] repo
stateDir :: FilePath stateDir :: FilePath
stateDir = addTrailingPathSeparator ".git-annex" stateDir = addTrailingPathSeparator ".git-annex"

8
Utility/FileIO.hs
View file

@ -22,6 +22,7 @@ module Utility.FileIO
writeFile', writeFile',
appendFile, appendFile,
appendFile', appendFile',
openTempFile,
) where ) where
#ifdef WITH_OSPATH #ifdef WITH_OSPATH
@ -81,6 +82,10 @@ appendFile' f b = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.appendFile' f' b O.appendFile' f' b
openTempFile :: OsPath -> OsPath -> IO (OsPath, Handle)
openTempFile p s = do
p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p)
O.openTempFile p' s
#endif #endif
#else #else
@ -88,7 +93,8 @@ appendFile' f b = do
-- instead. However, functions still use ByteString for the -- instead. However, functions still use ByteString for the
-- file content in that case, unlike the Strings used by the Prelude. -- file content in that case, unlike the Strings used by the Prelude.
import Utility.OsPath 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 Data.ByteString.Lazy (readFile, writeFile, appendFile)
import qualified Data.ByteString as B import qualified Data.ByteString as B

8
Utility/LockFile/PidLock.hs
View file

@ -40,6 +40,7 @@ import Utility.Env
import Utility.Env.Set import Utility.Env.Set
import Utility.Tmp import Utility.Tmp
import Utility.RawFilePath import Utility.RawFilePath
import Utility.OsPath
import qualified Utility.LockFile.Posix as Posix import qualified Utility.LockFile.Posix as Posix
import System.IO import System.IO
@ -149,9 +150,10 @@ tryLock lockfile = do
_ -> return (Just ParentLocked) _ -> return (Just ParentLocked)
where where
go abslockfile sidelock = do go abslockfile sidelock = do
let abslockfile' = fromRawFilePath abslockfile (tmp, h) <- openTmpFileIn
(tmp, h) <- openTmpFileIn (takeDirectory abslockfile') "locktmp" (toOsPath (P.takeDirectory abslockfile))
let tmp' = toRawFilePath tmp (toOsPath "locktmp")
let tmp' = fromOsPath tmp
setFileMode tmp' (combineModes readModes) setFileMode tmp' (combineModes readModes)
hPutStr h . show =<< mkPidLock hPutStr h . show =<< mkPidLock
hClose h hClose h

10
Utility/MoveFile.hs
View file

@ -28,6 +28,7 @@ import Utility.Tmp
import Utility.Exception import Utility.Exception
import Utility.Monad import Utility.Monad
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Utility.OsPath
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import Author import Author
@ -40,11 +41,12 @@ moveFile src dest = tryIO (R.rename src dest) >>= onrename
onrename (Left e) onrename (Left e)
| isPermissionError e = rethrow | isPermissionError e = rethrow
| isDoesNotExistError e = rethrow | isDoesNotExistError e = rethrow
| otherwise = viaTmp mv (fromRawFilePath dest) () | otherwise = viaTmp mv (toOsPath dest) ()
where where
rethrow = throwM e rethrow = throwM e
mv tmp () = do mv tmp () = do
let tmp' = fromRawFilePath (fromOsPath tmp)
-- copyFile is likely not as optimised as -- copyFile is likely not as optimised as
-- the mv command, so we'll use the command. -- 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" ok <- copyright =<< boolSystem "mv"
[ Param "-f" [ Param "-f"
, Param (fromRawFilePath src) , Param (fromRawFilePath src)
, Param tmp , Param tmp'
] ]
let e' = e let e' = e
#else #else
r <- tryIO $ copyFile (fromRawFilePath src) tmp r <- tryIO $ copyFile (fromRawFilePath src) tmp'
let (ok, e') = case r of let (ok, e') = case r of
Left err -> (False, err) Left err -> (False, err)
Right _ -> (True, e) Right _ -> (True, e)
#endif #endif
unless ok $ do unless ok $ do
-- delete any partial -- delete any partial
_ <- tryIO $ removeFile tmp _ <- tryIO $ removeFile tmp'
throwM e' throwM e'
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS

12
Utility/OsPath.hs
View file

@ -9,7 +9,12 @@
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -fno-warn-tabs #-} {-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.OsPath where module Utility.OsPath (
OsPath,
OsString,
toOsPath,
fromOsPath,
) where
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
@ -39,8 +44,11 @@ fromOsPath = S.fromShort . getPosixString . getOsString
{- When not building with WITH_OSPATH, use FilePath. This allows {- When not building with WITH_OSPATH, use FilePath. This allows
- using functions from legacy FilePath libraries interchangeably with - using functions from legacy FilePath libraries interchangeably with
- newer OsPath libraries. - newer OsPath libraries.
- -} -}
type OsPath = FilePath type OsPath = FilePath
type OsString = String
toOsPath :: RawFilePath -> OsPath toOsPath :: RawFilePath -> OsPath
toOsPath = fromRawFilePath toOsPath = fromRawFilePath

9
Utility/SshConfig.hs
View file

@ -28,6 +28,7 @@ import Common
import Utility.UserInfo import Utility.UserInfo
import Utility.Tmp import Utility.Tmp
import Utility.FileMode import Utility.FileMode
import qualified Utility.FileIO as F
import Data.Char import Data.Char
import Data.Ord import Data.Ord
@ -140,12 +141,12 @@ changeUserSshConfig modifier = do
-- If it's a symlink, replace the file it -- If it's a symlink, replace the file it
-- points to. -- points to.
f <- catchDefaultIO configfile (canonicalizePath configfile) 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 writeSshConfig f s = do
writeFile f s F.writeFile' f (encodeBS s)
setSshConfigMode (toRawFilePath f) setSshConfigMode (fromOsPath f)
{- Ensure that the ssh config file lacks any group or other write bits, {- 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 - since ssh is paranoid about not working if other users can write

5
Utility/StatelessOpenPGP.hs
View file

@ -27,6 +27,7 @@ import System.Posix.Types
import System.Posix.IO import System.Posix.IO
#else #else
import Utility.Tmp import Utility.Tmp
import Utility.OsPath
#endif #endif
import Utility.Tmp.Dir import Utility.Tmp.Dir
import Author import Author
@ -112,7 +113,7 @@ decryptSymmetric sopcmd password emptydirectory feeder reader =
{- Test a value round-trips through symmetric encryption and decryption. -} {- 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 :: SOPCmd -> SOPCmd -> Password -> Armoring -> B.ByteString -> IO Bool
test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $ test_encrypt_decrypt_Symmetric a b password armoring v = catchBoolIO $
withTmpDir "test" $ \d -> do withTmpDir (toOsPath "test") $ \d -> do
let ed = EmptyDirectory d let ed = EmptyDirectory d
enc <- encryptSymmetric a password ed Nothing armoring enc <- encryptSymmetric a password ed Nothing armoring
(`B.hPutStr` v) B.hGetContents (`B.hPutStr` v) B.hGetContents
@ -159,7 +160,7 @@ feedRead cmd subcmd params password emptydirectory feeder reader = do
go (Just emptydirectory) (passwordfd ++ params) go (Just emptydirectory) (passwordfd ++ params)
#else #else
-- store the password in a temp file -- store the password in a temp file
withTmpFile "sop" $ \tmpfile h -> do withTmpFile (toOsPath "sop") $ \tmpfile h -> do
liftIO $ B.hPutStr h password liftIO $ B.hPutStr h password
liftIO $ hClose h liftIO $ hClose h
let passwordfile = [Param $ "--with-password="++tmpfile] let passwordfile = [Param $ "--with-password="++tmpfile]

54
Utility/Tmp.hs
View file

@ -5,7 +5,7 @@
- License: BSD-2-clause - License: BSD-2-clause
-} -}
{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-} {-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Tmp ( module Utility.Tmp (
@ -18,28 +18,31 @@ module Utility.Tmp (
) where ) where
import System.IO import System.IO
import System.FilePath
import System.Directory import System.Directory
import Control.Monad.IO.Class import Control.Monad.IO.Class
import System.IO.Error import System.IO.Error
import qualified Data.ByteString as B
import qualified System.FilePath.ByteString as P
import Utility.Exception import Utility.Exception
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Utility.FileMode import Utility.FileMode
import qualified Utility.RawFilePath as R 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 {- This is the same as openTempFile, except when there is an
- error, it displays the template as well as the directory, - error, it displays the template as well as the directory,
- to help identify what call was responsible. - to help identify what call was responsible.
-} -}
openTmpFileIn :: FilePath -> String -> IO (FilePath, Handle) openTmpFileIn :: OsPath -> Template -> IO (OsPath, Handle)
openTmpFileIn dir template = openTempFile dir template openTmpFileIn dir template = F.openTempFile dir template
`catchIO` decoraterrror `catchIO` decoraterrror
where where
decoraterrror e = throwM $ decoraterrror e = throwM $
let loc = ioeGetLocation e ++ " template " ++ template let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template)
in annotateIOError e loc Nothing Nothing in annotateIOError e loc Nothing Nothing
{- Runs an action like writeFile, writing to a temp file first and {- 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 - mode as it would when using writeFile, unless the writer action changes
- it. - 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 viaTmp a file content = bracketIO setup cleanup use
where where
(dir, base) = splitFileName file (dir, base) = P.splitFileName (fromOsPath file)
template = relatedTemplate (base ++ ".tmp") template = relatedTemplate (base <> ".tmp")
setup = do setup = do
createDirectoryIfMissing True dir createDirectoryIfMissing True (fromRawFilePath dir)
openTmpFileIn dir template openTmpFileIn (toOsPath dir) template
cleanup (tmpfile, h) = do cleanup (tmpfile, h) = do
_ <- tryIO $ hClose h _ <- tryIO $ hClose h
tryIO $ removeFile tmpfile tryIO $ R.removeLink (fromOsPath tmpfile)
use (tmpfile, h) = do use (tmpfile, h) = do
let tmpfile' = toRawFilePath tmpfile let tmpfile' = fromOsPath tmpfile
-- Make mode the same as if the file were created usually, -- Make mode the same as if the file were created usually,
-- not as a temp file. (This may fail on some filesystems -- not as a temp file. (This may fail on some filesystems
-- that don't support file modes well, so ignore -- that don't support file modes well, so ignore
-- exceptions.) -- exceptions.)
_ <- liftIO $ tryIO $ R.setFileMode tmpfile' =<< defaultFileMode _ <- liftIO $ tryIO $
R.setFileMode (fromOsPath tmpfile)
=<< defaultFileMode
liftIO $ hClose h liftIO $ hClose h
a tmpfile content 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 {- Runs an action with a tmp file located in the system's tmp directory
- (or in "." if there is none) then removes the file. -} - (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 withTmpFile template a = do
tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory 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, {- Runs an action with a tmp file located in the specified directory,
- then removes the file. - 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 - Note that the tmp file will have a file mode that only allows the
- current user to access it. - 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 withTmpFileIn tmpdir template a = bracket create remove use
where where
create = liftIO $ openTmpFileIn tmpdir template create = liftIO $ openTmpFileIn tmpdir template
remove (name, h) = liftIO $ do remove (name, h) = liftIO $ do
hClose h hClose h
catchBoolIO (removeFile name >> return True) tryIO $ R.removeLink (fromOsPath name)
use (name, h) = a name h use (name, h) = a name h
{- It's not safe to use a FilePath of an existing file as the template {- 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 - anyway, which is enough for the current implementation and any
- likely implementation.) - likely implementation.)
-} -}
relatedTemplate :: FilePath -> FilePath relatedTemplate :: RawFilePath -> Template
relatedTemplate f relatedTemplate f
| len > 20 = | len > 20 =
{- Some filesystems like FAT have issues with filenames {- Some filesystems like FAT have issues with filenames
- ending in ".", so avoid truncating a filename to end - ending in ".", so avoid truncating a filename to end
- that way. -} - that way. -}
reverse $ dropWhile (== '.') $ reverse $ toOsPath $ toRawFilePath $
truncateFilePath (len - 20) f reverse $ dropWhile (== '.') $ reverse $
| otherwise = f truncateFilePath (len - 20) (fromRawFilePath f)
| otherwise = toOsPath f
where where
len = length f len = B.length f

6
Utility/Tmp/Dir.hs
View file

@ -23,6 +23,8 @@ import System.Posix.Temp (mkdtemp)
import Utility.Exception import Utility.Exception
import Utility.Tmp (Template) import Utility.Tmp (Template)
import Utility.OsPath
import Utility.FileSystemEncoding
{- Runs an action with a tmp directory located within the system's tmp {- Runs an action with a tmp directory located within the system's tmp
- directory (or within "." if there is none), then removes the tmp - directory (or within "." if there is none), then removes the tmp
@ -33,7 +35,7 @@ withTmpDir template a = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
-- Use mkdtemp to create a temp directory securely in /tmp. -- Use mkdtemp to create a temp directory securely in /tmp.
bracket bracket
(liftIO $ mkdtemp $ topleveltmpdir </> template) (liftIO $ mkdtemp $ topleveltmpdir </> fromRawFilePath (fromOsPath template))
removeTmpDir removeTmpDir
a a
#else #else
@ -47,7 +49,7 @@ withTmpDirIn tmpdir template = bracketIO create removeTmpDir
where where
create = do create = do
createDirectoryIfMissing True tmpdir createDirectoryIfMissing True tmpdir
makenewdir (tmpdir </> template) (0 :: Int) makenewdir (tmpdir </> fromRawFilePath (fromOsPath template)) (0 :: Int)
makenewdir t n = do makenewdir t n = do
let dir = t ++ "." ++ show n let dir = t ++ "." ++ show n
catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do

4
Utility/WebApp.hs
View file

@ -187,7 +187,9 @@ insertAuthToken extractAuthToken predicate webapp root pathbits params =
- to avoid exposing the secret token when launching the web browser. -} - to avoid exposing the secret token when launching the web browser. -}
writeHtmlShim :: String -> String -> FilePath -> IO () writeHtmlShim :: String -> String -> FilePath -> IO ()
writeHtmlShim title url file = 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 :: String -> String -> String
genHtmlShim title url = unlines genHtmlShim title url = unlines

10
doc/todo/RawFilePath_conversion.mdwn
View file

@ -13,11 +13,15 @@ status.
* filepath-1.4.100 implements support for OSPath. It is bundled with * 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 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 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 * Utility.FileIO is used for most withFile and openFile, but not yet for
readFile, writeFile, and appendFile. Including versions of those from readFile, writeFile, and appendFile. Including versions of those from
bytestring. bytestring. Also readFileStrict should be replaced with Utility.FileIO.readFile'
* 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]] [[!tag confirmed]]