use openTempFile from file-io

And follow-on changes.

Note that relatedTemplate was changed to operate on a RawFilePath, and
so when it counts the length, it is now the number of bytes, not the
number of code points. This will just make it truncate shorter strings
in some cases, the truncation is still unicode aware.

When not building with the OsPath flag, toOsPath . fromRawFilePath and
fromRawFilePath . fromOsPath do extra conversions back and forth between
String and ByteString. That overhead could be avoided, but that's the
non-optimised build mode, so didn't bother.

Sponsored-by: unqueued
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

View file

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

View file

@ -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 =

View file

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

View file

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

View file

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

View file

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

View file

@ -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) $

View file

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

View file

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

View file

@ -17,6 +17,7 @@ import Utility.Shell
import Utility.Tmp
import Utility.Env
import Utility.SshConfig
import qualified Utility.FileIO as F
#ifdef darwin_HOST_OS
import Utility.OSX
@ -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

View file

@ -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"

View file

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

View file

@ -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"

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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"

View file

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

View file

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

View file

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

View file

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

View file

@ -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.
-

View file

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

View file

@ -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)

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

View file

@ -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
)

View file

@ -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 =

View file

@ -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'

View file

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

View file

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

View file

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

View file

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

View file

@ -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 [] $

View file

@ -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"

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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