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
parent
1faa3af9cd
commit
793ddecd4b
46 changed files with 235 additions and 178 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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')
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
-
|
||||
|
|
|
|||
32
Git/Hook.hs
32
Git/Hook.hs
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Git.Hook where
|
||||
|
||||
|
|
@ -14,15 +15,16 @@ import Git
|
|||
import Utility.Tmp
|
||||
import Utility.Shell
|
||||
import Utility.FileMode
|
||||
import qualified Utility.FileIO as F
|
||||
#ifndef mingw32_HOST_OS
|
||||
import qualified Utility.RawFilePath as R
|
||||
import System.PosixCompat.Files (fileMode)
|
||||
#endif
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
data Hook = Hook
|
||||
{ hookName :: FilePath
|
||||
{ hookName :: RawFilePath
|
||||
, hookScript :: String
|
||||
, hookOldScripts :: [String]
|
||||
}
|
||||
|
|
@ -31,8 +33,8 @@ data Hook = Hook
|
|||
instance Eq Hook where
|
||||
a == b = hookName a == hookName b
|
||||
|
||||
hookFile :: Hook -> Repo -> FilePath
|
||||
hookFile h r = fromRawFilePath (localGitDir r) </> "hooks" </> hookName h
|
||||
hookFile :: Hook -> Repo -> RawFilePath
|
||||
hookFile h r = localGitDir r P.</> "hooks" P.</> hookName h
|
||||
|
||||
{- Writes a hook. Returns False if the hook already exists with a different
|
||||
- content. Upgrades old scripts.
|
||||
|
|
@ -48,7 +50,7 @@ hookFile h r = fromRawFilePath (localGitDir r) </> "hooks" </> hookName h
|
|||
- is run with a bundled bash, so should start with #!/bin/sh
|
||||
-}
|
||||
hookWrite :: Hook -> Repo -> IO Bool
|
||||
hookWrite h r = ifM (doesFileExist f)
|
||||
hookWrite h r = ifM (doesFileExist (fromRawFilePath f))
|
||||
( expectedContent h r >>= \case
|
||||
UnexpectedContent -> return False
|
||||
ExpectedContent -> return True
|
||||
|
|
@ -58,15 +60,13 @@ hookWrite h r = ifM (doesFileExist f)
|
|||
where
|
||||
f = hookFile h r
|
||||
go = do
|
||||
-- On Windows, using B.writeFile here avoids
|
||||
-- the newline translation done by writeFile.
|
||||
-- On Windows, using a ByteString as the file content
|
||||
-- avoids the newline translation done by writeFile.
|
||||
-- Hook scripts on Windows could use CRLF endings, but
|
||||
-- they typically use unix newlines, which does work there
|
||||
-- and makes the repository more portable.
|
||||
viaTmp B.writeFile f (encodeBS (hookScript h))
|
||||
void $ tryIO $ modifyFileMode
|
||||
(toRawFilePath f)
|
||||
(addModes executeModes)
|
||||
viaTmp F.writeFile' (toOsPath f) (encodeBS (hookScript h))
|
||||
void $ tryIO $ modifyFileMode f (addModes executeModes)
|
||||
return True
|
||||
|
||||
{- Removes a hook. Returns False if the hook contained something else, and
|
||||
|
|
@ -81,7 +81,7 @@ hookUnWrite h r = ifM (doesFileExist f)
|
|||
, return True
|
||||
)
|
||||
where
|
||||
f = hookFile h r
|
||||
f = fromRawFilePath $ hookFile h r
|
||||
|
||||
data ExpectedContent = UnexpectedContent | ExpectedContent | OldExpectedContent
|
||||
|
||||
|
|
@ -91,7 +91,7 @@ expectedContent h r = do
|
|||
-- and so a hook file that has CRLF will be treated the same as one
|
||||
-- that has LF. That is intentional, since users may have a reason
|
||||
-- to prefer one or the other.
|
||||
content <- readFile $ hookFile h r
|
||||
content <- readFile $ fromRawFilePath $ hookFile h r
|
||||
return $ if content == hookScript h
|
||||
then ExpectedContent
|
||||
else if any (content ==) (hookOldScripts h)
|
||||
|
|
@ -103,13 +103,13 @@ hookExists h r = do
|
|||
let f = hookFile h r
|
||||
catchBoolIO $
|
||||
#ifndef mingw32_HOST_OS
|
||||
isExecutable . fileMode <$> R.getFileStatus (toRawFilePath f)
|
||||
isExecutable . fileMode <$> R.getFileStatus f
|
||||
#else
|
||||
doesFileExist f
|
||||
doesFileExist (fromRawFilePath f)
|
||||
#endif
|
||||
|
||||
runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a
|
||||
runHook runner h ps r = do
|
||||
let f = hookFile h r
|
||||
let f = fromRawFilePath $ hookFile h r
|
||||
(c, cps) <- findShellCommand f
|
||||
runner c (cps ++ ps)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
14
Logs/File.hs
14
Logs/File.hs
|
|
@ -37,11 +37,11 @@ import qualified Data.ByteString.Lazy.Char8 as L8
|
|||
-- making the new file have whatever permissions the git repository is
|
||||
-- configured to use. Creates the parent directory when necessary.
|
||||
writeLogFile :: RawFilePath -> String -> Annex ()
|
||||
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (fromRawFilePath f) c
|
||||
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog (toOsPath f) c
|
||||
where
|
||||
writelog tmp c' = do
|
||||
liftIO $ writeFile tmp c'
|
||||
setAnnexFilePerm (toRawFilePath tmp)
|
||||
liftIO $ writeFile (fromRawFilePath (fromOsPath tmp)) c'
|
||||
setAnnexFilePerm (fromOsPath tmp)
|
||||
|
||||
-- | Runs the action with a handle connected to a temp file.
|
||||
-- The temp file replaces the log file once the action succeeds.
|
||||
|
|
@ -77,16 +77,16 @@ appendLogFile f lck c =
|
|||
modifyLogFile :: RawFilePath -> RawFilePath -> ([L.ByteString] -> [L.ByteString]) -> Annex ()
|
||||
modifyLogFile f lck modf = withExclusiveLock lck $ do
|
||||
ls <- liftIO $ fromMaybe []
|
||||
<$> tryWhenExists (fileLines <$> L.readFile f')
|
||||
<$> tryWhenExists (fileLines <$> F.readFile f')
|
||||
let ls' = modf ls
|
||||
when (ls' /= ls) $
|
||||
createDirWhenNeeded f $
|
||||
viaTmp writelog f' (L8.unlines ls')
|
||||
where
|
||||
f' = fromRawFilePath f
|
||||
f' = toOsPath f
|
||||
writelog lf b = do
|
||||
liftIO $ L.writeFile lf b
|
||||
setAnnexFilePerm (toRawFilePath lf)
|
||||
liftIO $ F.writeFile lf b
|
||||
setAnnexFilePerm (fromOsPath lf)
|
||||
|
||||
-- | Checks the content of a log file to see if any line matches.
|
||||
checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
4
Test.hs
4
Test.hs
|
|
@ -563,7 +563,7 @@ test_magic = intmpclonerepo $ do
|
|||
#endif
|
||||
|
||||
test_import :: Assertion
|
||||
test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir "importtest" $ \importdir -> do
|
||||
test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "importtest")) $ \importdir -> do
|
||||
(toimport1, importf1, imported1) <- mktoimport importdir "import1"
|
||||
git_annex "import" [toimport1] "import"
|
||||
annexed_present_imported imported1
|
||||
|
|
@ -1894,7 +1894,7 @@ test_gpg_crypto = do
|
|||
testscheme "pubkey"
|
||||
where
|
||||
gpgcmd = Utility.Gpg.mkGpgCmd Nothing
|
||||
testscheme scheme = Utility.Tmp.Dir.withTmpDir "gpgtmp" $ \gpgtmp -> do
|
||||
testscheme scheme = Utility.Tmp.Dir.withTmpDir (toOsPath (toRawFilePath "gpgtmp")) $ \gpgtmp -> do
|
||||
-- Use the system temp directory as gpg temp directory because
|
||||
-- it needs to be able to store the agent socket there,
|
||||
-- which can be problematic when testing some filesystems.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 [] $
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]]
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue