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

convert all readFile, writeFile, and appendFile to close-on-exec safe versions

Browse source 
Even in the Build system. This allows grepping to make sure that there
are none left un-converted:

git grep "writeFile" |grep -v F\\.| grep -v doc/|grep -v writeFileString | grep -v writeFileProtected |grep -v Utility/FileIO
git grep "readFile" |grep -v F\\.| grep -v doc/|grep -v readFileString |grep -v Utility/FileIO
git grep "appendFile" |grep -v F\\.| grep -v doc/|grep -v appendFileString |grep -v Utility/FileIO

Might be nice to automate that to prevent future mistakes...

Sponsored-by: the NIH-funded NICEMAN (ReproNim TR&D3) project
This commit is contained in:
Joey Hess 2025-09-05 15:37:13 -04:00
commit 6f9a9c81f6
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
58 changed files with 150 additions and 152 deletions
Download patch file Download diff file Expand all files Collapse all files

7
Annex/Content.hs
View file

@ -276,8 +276,7 @@ winLocker :: (LockFile -> IO (Maybe LockHandle)) -> ContentLocker
winLocker takelock _ (Just lockfile) = winLocker takelock _ (Just lockfile) =
let lck = do let lck = do
modifyContentDir lockfile $ modifyContentDir lockfile $
void $ liftIO $ tryIO $ void $ liftIO $ tryIO $ writeFileString lockfile ""
writeFile (fromOsPath lockfile) ""
liftIO $ takelock lockfile liftIO $ takelock lockfile
in (lck, Nothing) in (lck, Nothing)
-- never reached; windows always uses a separate lock file -- never reached; windows always uses a separate lock file
@ -991,7 +990,7 @@ withTmpWorkDir key action = do
-- clean up gitAnnexTmpWorkDir for those it finds. -- clean up gitAnnexTmpWorkDir for those it finds.
obj <- prepTmp key obj <- prepTmp key
unlessM (liftIO $ doesFileExist obj) $ do unlessM (liftIO $ doesFileExist obj) $ do
liftIO $ writeFile (fromOsPath obj) "" liftIO $ writeFileString obj ""
setAnnexFilePerm obj setAnnexFilePerm obj
let tmpdir = gitAnnexTmpWorkDir obj let tmpdir = gitAnnexTmpWorkDir obj
createAnnexDirectory tmpdir createAnnexDirectory tmpdir
@ -1083,7 +1082,7 @@ writeContentRetentionTimestamp key rt t = do
readContentRetentionTimestamp rt >>= \case readContentRetentionTimestamp rt >>= \case
Just ts | ts >= t -> return () Just ts | ts >= t -> return ()
_ -> replaceFile (const noop) rt $ \tmp -> _ -> replaceFile (const noop) rt $ \tmp ->
liftIO $ writeFile (fromOsPath tmp) $ show t liftIO $ writeFileString tmp $ show t
where where
lock = takeExclusiveLock lock = takeExclusiveLock
unlock = liftIO . dropLock unlock = liftIO . dropLock

23
Annex/Fixup.hs
View file

@ -1,6 +1,6 @@
{- git-annex repository fixups {- git-annex repository fixups
- -
- Copyright 2013-2020 Joey Hess <id@joeyh.name> - Copyright 2013-2025 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -9,29 +9,14 @@
module Annex.Fixup where module Annex.Fixup where
import Common
import Git.Types import Git.Types
import Git.Config import Git.Config
import Types.GitConfig import Types.GitConfig
import Utility.Path
import Utility.Path.AbsRel
import Utility.SafeCommand
import Utility.Directory
import Utility.Exception
import Utility.Monad
import Utility.SystemDirectory
import Utility.OsPath
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import Utility.PartialPrelude
import qualified Utility.OsString as OS import qualified Utility.OsString as OS
import System.IO
import Data.List
import Data.Maybe
import Control.Monad
import Control.Monad.IfElse
import qualified Data.Map as M import qualified Data.Map as M
import Control.Applicative
import Prelude
fixupRepo :: Repo -> GitConfig -> IO Repo fixupRepo :: Repo -> GitConfig -> IO Repo
fixupRepo r c = do fixupRepo r c = do
@ -132,11 +117,11 @@ fixupUnusualRepos r@(Repo { location = Local { worktree = Just w, gitdir = d } }
-- git-worktree sets up a "commondir" file that contains -- git-worktree sets up a "commondir" file that contains
-- the path to the main git directory. -- the path to the main git directory.
-- Using --separate-git-dir does not. -- Using --separate-git-dir does not.
commondirfile = fromOsPath (d </> literalOsPath "commondir") commondirfile = d </> literalOsPath "commondir"
readcommondirfile = catchDefaultIO Nothing $ readcommondirfile = catchDefaultIO Nothing $
fmap toOsPath . headMaybe . lines fmap toOsPath . headMaybe . lines
<$> readFile commondirfile <$> readFileString commondirfile
setworktreepath r' = readcommondirfile >>= \case setworktreepath r' = readcommondirfile >>= \case
Just gd -> return $ r' Just gd -> return $ r'

2
Annex/Path.hs
View file

@ -65,7 +65,7 @@ programPath = go =<< getEnv "GIT_ANNEX_DIR"
readProgramFile :: IO (Maybe OsPath) readProgramFile :: IO (Maybe OsPath)
readProgramFile = catchDefaultIO Nothing $ do readProgramFile = catchDefaultIO Nothing $ do
programfile <- programFile programfile <- programFile
fmap toOsPath . headMaybe . lines <$> readFile (fromOsPath programfile) fmap toOsPath . headMaybe . lines <$> readFileString programfile
cannotFindProgram :: IO a cannotFindProgram :: IO a
cannotFindProgram = do cannotFindProgram = do

9
Annex/Sim.hs
View file

@ -1356,16 +1356,15 @@ suspendSim st = do
let st'' = st' let st'' = st'
{ simRepoState = M.map freeze (simRepoState st') { simRepoState = M.map freeze (simRepoState st')
} }
let statefile = fromOsPath $ let statefile = toOsPath (simRootDirectory st'') </> literalOsPath "state"
toOsPath (simRootDirectory st'') </> literalOsPath "state" writeFileString statefile (show st'')
writeFile statefile (show st'')
where where
freeze :: SimRepoState SimRepo -> SimRepoState () freeze :: SimRepoState SimRepo -> SimRepoState ()
freeze rst = rst { simRepo = Nothing } freeze rst = rst { simRepo = Nothing }
restoreSim :: OsPath -> IO (Either String (SimState SimRepo)) restoreSim :: OsPath -> IO (Either String (SimState SimRepo))
restoreSim rootdir = restoreSim rootdir =
tryIO (readFile statefile) >>= \case tryIO (readFileString statefile) >>= \case
Left err -> return (Left (show err)) Left err -> return (Left (show err))
Right c -> case readMaybe c :: Maybe (SimState ()) of Right c -> case readMaybe c :: Maybe (SimState ()) of
Nothing -> return (Left "unable to parse sim state file") Nothing -> return (Left "unable to parse sim state file")
@ -1379,7 +1378,7 @@ restoreSim rootdir =
} }
return (Right st'') return (Right st'')
where where
statefile = fromOsPath $ rootdir </> literalOsPath "state" statefile = rootdir </> literalOsPath "state"
thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case
Left _ -> (u, rst { simRepo = Nothing }) Left _ -> (u, rst { simRepo = Nothing })
Right r -> (u, rst { simRepo = Just r }) Right r -> (u, rst { simRepo = Just r })

2
Annex/Ssh.hs
View file

@ -484,4 +484,4 @@ sshAskPassEnv :: String
sshAskPassEnv = "GIT_ANNEX_SSHASKPASS" sshAskPassEnv = "GIT_ANNEX_SSHASKPASS"
runSshAskPass :: FilePath -> IO () runSshAskPass :: FilePath -> IO ()
runSshAskPass passfile = putStrLn =<< readFile passfile runSshAskPass passfile = putStrLn =<< readFileString (toOsPath passfile)

2
Annex/YoutubeDl.hs
View file

@ -94,7 +94,7 @@ youtubeDl' url workdir p uo
nofiles = Left $ youtubeDlCommand ++ " did not put any media in its work directory, perhaps it's been configured to store files somewhere else?" nofiles = Left $ youtubeDlCommand ++ " did not put any media in its work directory, perhaps it's been configured to store files somewhere else?"
toomanyfiles fs = Left $ youtubeDlCommand ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs toomanyfiles fs = Left $ youtubeDlCommand ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs
downloadedfiles = liftIO $ downloadedfiles = liftIO $
(nub . lines <$> readFile (fromOsPath filelistfile)) (nub . lines <$> readFileString filelistfile)
`catchIO` (pure . const []) `catchIO` (pure . const [])
workdirfiles = liftIO $ filter (/= filelistfile) workdirfiles = liftIO $ filter (/= filelistfile)
<$> (filterM doesFileExist =<< dirContents workdir) <$> (filterM doesFileExist =<< dirContents workdir)

2
Assistant/DaemonStatus.hs
View file

@ -132,7 +132,7 @@ writeDaemonStatusFile file status =
] ]
readDaemonStatusFile :: FilePath -> IO DaemonStatus readDaemonStatusFile :: FilePath -> IO DaemonStatus
readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFileString (toOsPath file)
where where
parse status = foldr parseline status . lines parse status = foldr parseline status . lines
parseline line status parseline line status

8
Assistant/Install.hs
View file

@ -57,7 +57,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
let program = base </> literalOsPath "git-annex" let program = base </> literalOsPath "git-annex"
programfile <- programFile programfile <- programFile
createDirectoryIfMissing True (parentDir programfile) createDirectoryIfMissing True (parentDir programfile)
writeFile (fromOsPath programfile) (fromOsPath program) writeFileString programfile (fromOsPath program)
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
autostartfile <- userAutoStart osxAutoStartLabel autostartfile <- userAutoStart osxAutoStartLabel
@ -70,7 +70,7 @@ ensureInstalled = ifM (isJust <$> getEnv "GIT_ANNEX_PACKAGE_INSTALL")
let bootfile = toOsPath home </> literalOsPath ".termux" </> literalOsPath "boot" </> literalOsPath "git-annex" let bootfile = toOsPath home </> literalOsPath ".termux" </> literalOsPath "boot" </> literalOsPath "git-annex"
unlessM (doesFileExist bootfile) $ do unlessM (doesFileExist bootfile) $ do
createDirectoryIfMissing True (takeDirectory bootfile) createDirectoryIfMissing True (takeDirectory bootfile)
writeFile (fromOsPath bootfile) "git-annex assistant --autostart" writeFileString bootfile "git-annex assistant --autostart"
, do , do
menufile <- desktopMenuFilePath "git-annex" <$> userDataDir menufile <- desktopMenuFilePath "git-annex" <$> userDataDir
icondir <- iconDir <$> userDataDir icondir <- iconDir <$> userDataDir
@ -125,7 +125,7 @@ installFileManagerHooks program = unlessM osAndroid $ do
userdata <- userDataDir userdata <- userDataDir
let kdeServiceMenusdir = userdata </> literalOsPath "kservices5" </> literalOsPath "ServiceMenus" let kdeServiceMenusdir = userdata </> literalOsPath "kservices5" </> literalOsPath "ServiceMenus"
createDirectoryIfMissing True kdeServiceMenusdir createDirectoryIfMissing True kdeServiceMenusdir
writeFile (fromOsPath (kdeServiceMenusdir </> literalOsPath "git-annex.desktop")) writeFileString (kdeServiceMenusdir </> literalOsPath "git-annex.desktop")
(kdeDesktopFile actions) (kdeDesktopFile actions)
where where
genNautilusScript scriptdir action = genNautilusScript scriptdir action =
@ -136,7 +136,7 @@ installFileManagerHooks program = unlessM osAndroid $ do
] ]
scriptname action = "git-annex " ++ action scriptname action = "git-annex " ++ action
installscript f c = whenM (safetoinstallscript f) $ do installscript f c = whenM (safetoinstallscript f) $ do
writeFile (fromOsPath f) c writeFileString f c
modifyFileMode f $ addModes [ownerExecuteMode] modifyFileMode f $ addModes [ownerExecuteMode]
safetoinstallscript f = catchDefaultIO True $ safetoinstallscript f = catchDefaultIO True $
elem (encodeBS autoaddedcomment) . fileLines' elem (encodeBS autoaddedcomment) . fileLines'

2
Assistant/Install/AutoStart.hs
View file

@ -23,7 +23,7 @@ installAutoStart :: String -> OsPath -> IO ()
installAutoStart command file = do installAutoStart command file = do
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
createDirectoryIfMissing True (parentDir file) createDirectoryIfMissing True (parentDir file)
writeFile (fromOsPath file) $ genOSXAutoStartFile osxAutoStartLabel command writeFileString file $ genOSXAutoStartFile osxAutoStartLabel command
["assistant", "--autostart"] ["assistant", "--autostart"]
#else #else
writeDesktopMenuFile (fdoAutostart command) file writeDesktopMenuFile (fdoAutostart command) file

2
Assistant/Restart.hs
View file

@ -79,7 +79,7 @@ newAssistantUrl repo = do
r <- Git.Config.read =<< Git.Construct.fromPath repo r <- Git.Config.read =<< Git.Construct.fromPath repo
waiturl $ gitAnnexUrlFile r waiturl $ gitAnnexUrlFile r
waiturl urlfile = do waiturl urlfile = do
v <- tryIO $ readFile (fromOsPath urlfile) v <- tryIO $ readFileString urlfile
case v of case v of
Left _ -> delayed $ waiturl urlfile Left _ -> delayed $ waiturl urlfile
Right url -> ifM (assistantListening url) Right url -> ifM (assistantListening url)

20
Assistant/Ssh.hs
View file

@ -224,8 +224,8 @@ genSshKeyPair = withTmpDir (literalOsPath "git-annex-keygen") $ \dir -> do
unless ok $ unless ok $
giveup "ssh-keygen failed" giveup "ssh-keygen failed"
SshKeyPair SshKeyPair
<$> readFile (fromOsPath (dir </> literalOsPath "key.pub")) <$> readFileString (dir </> literalOsPath "key.pub")
<*> readFile (fromOsPath (dir </> literalOsPath "key")) <*> readFileString (dir </> literalOsPath "key")
{- Installs a ssh key pair, and sets up ssh config with a mangled hostname {- Installs a ssh key pair, and sets up ssh config with a mangled hostname
- that will enable use of the key. This way we avoid changing the user's - that will enable use of the key. This way we avoid changing the user's
@ -255,7 +255,7 @@ installSshKeyPair sshkeypair sshdata = do
writeFileProtected (sshdir </> sshPrivKeyFile sshdata) writeFileProtected (sshdir </> sshPrivKeyFile sshdata)
(sshPrivKey sshkeypair) (sshPrivKey sshkeypair)
unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $ unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $
writeFile (fromOsPath (sshdir </> sshPubKeyFile sshdata)) writeFileString (sshdir </> sshPubKeyFile sshdata)
(sshPubKey sshkeypair) (sshPubKey sshkeypair)
setSshConfig sshdata setSshConfig sshdata
@ -277,8 +277,10 @@ sshPubKeyFile sshdata = sshPrivKeyFile sshdata <> literalOsPath ".pub"
setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair) setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair)
setupSshKeyPair sshdata = do setupSshKeyPair sshdata = do
sshdir <- sshDir sshdir <- sshDir
mprivkey <- catchMaybeIO $ readFile (fromOsPath (sshdir </> sshPrivKeyFile sshdata)) mprivkey <- catchMaybeIO $ readFileString
mpubkey <- catchMaybeIO $ readFile (fromOsPath (sshdir </> sshPubKeyFile sshdata)) (sshdir </> sshPrivKeyFile sshdata)
mpubkey <- catchMaybeIO $ readFileString
(sshdir </> sshPubKeyFile sshdata)
keypair <- case (mprivkey, mpubkey) of keypair <- case (mprivkey, mpubkey) of
(Just privkey, Just pubkey) -> return $ SshKeyPair (Just privkey, Just pubkey) -> return $ SshKeyPair
{ sshPubKey = pubkey { sshPubKey = pubkey
@ -330,15 +332,15 @@ setSshConfig :: SshData -> [(String, String)] -> IO SshData
setSshConfig sshdata config = do setSshConfig sshdata config = do
sshdir <- sshDir sshdir <- sshDir
createDirectoryIfMissing True sshdir createDirectoryIfMissing True sshdir
let configfile = fromOsPath (sshdir </> literalOsPath "config") let configfile = sshdir </> literalOsPath "config"
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFileString configfile) $ do
appendFile configfile $ unlines $ appendFileString configfile $ unlines $
[ "" [ ""
, "# Added automatically by git-annex" , "# Added automatically by git-annex"
, "Host " ++ mangledhost , "Host " ++ mangledhost
] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
(settings ++ config) (settings ++ config)
setSshConfigMode (toOsPath configfile) setSshConfigMode configfile
return $ sshdata return $ sshdata
{ sshHostName = T.pack mangledhost { sshHostName = T.pack mangledhost

4
Assistant/Upgrade.hs
View file

@ -160,7 +160,7 @@ upgradeToDistribution newdir cleanup distributionfile = do
unlessM (boolSystem (fromOsPath program) [Param "version"]) $ unlessM (boolSystem (fromOsPath program) [Param "version"]) $
giveup "New git-annex program failed to run! Not using." giveup "New git-annex program failed to run! Not using."
pf <- programFile pf <- programFile
liftIO $ writeFile (fromOsPath pf) (fromOsPath program) liftIO $ writeFileString pf (fromOsPath program)
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
{- OS X uses a dmg, so mount it, and copy the contents into place. -} {- OS X uses a dmg, so mount it, and copy the contents into place. -}
@ -281,7 +281,7 @@ installBase = "git-annex." ++
deleteFromManifest :: OsPath -> IO () deleteFromManifest :: OsPath -> IO ()
deleteFromManifest dir = do deleteFromManifest dir = do
fs <- map (\f -> dir </> toOsPath f) . lines fs <- map (\f -> dir </> toOsPath f) . lines
<$> catchDefaultIO "" (readFile (fromOsPath manifest)) <$> catchDefaultIO "" (readFileString manifest)
mapM_ (removeWhenExistsWith removeFile) fs mapM_ (removeWhenExistsWith removeFile) fs
removeWhenExistsWith removeFile manifest removeWhenExistsWith removeFile manifest
removeEmptyRecursive dir removeEmptyRecursive dir

2
Assistant/WebApp/Configurators/Local.hs
View file

@ -185,7 +185,7 @@ getAndroidCameraRepositoryR = do
where where
addignore = do addignore = do
liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $ liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $
writeFile ".gitignore" ".thumbnails" writeFileString (literalOsPath ".gitignore") ".thumbnails"
void $ inRepo $ void $ inRepo $
Git.Command.runBool [Param "add", File ".gitignore"] Git.Command.runBool [Param "add", File ".gitignore"]

2
Assistant/WebApp/Control.hs
View file

@ -74,5 +74,5 @@ getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs (fromOsPath logfile) logs <- liftIO $ listLogs (fromOsPath logfile)
logcontent <- liftIO $ concat <$> mapM readFile logs logcontent <- liftIO $ concat <$> mapM (readFileString . toOsPath) logs
$(widgetFile "control/log") $(widgetFile "control/log")

2
Assistant/WebApp/Documentation.hs
View file

@ -34,7 +34,7 @@ getLicenseR = do
Just f -> customPage (Just About) $ do Just f -> customPage (Just About) $ do
-- no sidebar, just pages of legalese.. -- no sidebar, just pages of legalese..
setTitle "License" setTitle "License"
license <- liftIO $ readFile (fromOsPath f) license <- liftIO $ readFileString f
$(widgetFile "documentation/license") $(widgetFile "documentation/license")
getRepoGroupR :: Handler Html getRepoGroupR :: Handler Html

3
Build/Configure.hs
View file

@ -12,6 +12,7 @@ import Utility.Env.Basic
import qualified Git.Version import qualified Git.Version
import Utility.SystemDirectory import Utility.SystemDirectory
import Utility.OsPath import Utility.OsPath
import qualified Utility.FileIO as F
import Control.Monad import Control.Monad
import Control.Applicative import Control.Applicative
@ -93,7 +94,7 @@ getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$>
setup :: IO () setup :: IO ()
setup = do setup = do
createDirectoryIfMissing True (toOsPath tmpDir) createDirectoryIfMissing True (toOsPath tmpDir)
writeFile testFile "test file contents" F.writeFileString (toOsPath testFile) "test file contents"
cleanup :: IO () cleanup :: IO ()
cleanup = removeDirectoryRecursive (toOsPath tmpDir) cleanup = removeDirectoryRecursive (toOsPath tmpDir)

2
Build/DesktopFile.hs
View file

@ -74,7 +74,7 @@ install command = do
, do , do
programfile <- inDestDir =<< programFile programfile <- inDestDir =<< programFile
createDirectoryIfMissing True (parentDir programfile) createDirectoryIfMissing True (parentDir programfile)
writeFile (fromOsPath programfile) command writeFileString programfile command
) )
installUser :: FilePath -> IO () installUser :: FilePath -> IO ()

4
Build/DistributionUpdate.hs
View file

@ -148,7 +148,7 @@ makeinfos updated changelogversion = do
, distributionReleasedate = now , distributionReleasedate = now
, distributionUrgentUpgrade = Just "6.20180626" , distributionUrgentUpgrade = Just "6.20180626"
} }
liftIO $ writeFile (fromOsPath infofile) $ formatInfoFile d liftIO $ writeFileString infofile $ formatInfoFile d
void $ inRepo $ runBool [Param "add", File (fromOsPath infofile)] void $ inRepo $ runBool [Param "add", File (fromOsPath infofile)]
signFile infofile signFile infofile
signFile f signFile f
@ -173,7 +173,7 @@ makeinfos updated changelogversion = do
-- Check for out of date info files. -- Check for out of date info files.
infos <- liftIO $ filter (literalOsPath ".info" `OS.isSuffixOf`) infos <- liftIO $ filter (literalOsPath ".info" `OS.isSuffixOf`)
<$> emptyWhenDoesNotExist (dirContentsRecursive $ literalOsPath "git-annex") <$> emptyWhenDoesNotExist (dirContentsRecursive $ literalOsPath "git-annex")
ds <- liftIO $ forM infos (readish <$$> readFile . fromOsPath) ds <- liftIO $ forM infos (readish <$$> readFileString)
let dis = zip infos ds let dis = zip infos ds
let ood = filter outofdate dis let ood = filter outofdate dis
return ood return ood

7
Build/LinuxMkLibs.hs
View file

@ -29,6 +29,7 @@ import Utility.FileMode
import Utility.CopyFile import Utility.CopyFile
import Utility.SystemDirectory import Utility.SystemDirectory
import qualified Utility.OsString as OS import qualified Utility.OsString as OS
import qualified Utility.FileIO as F
mklibs :: OsPath -> a -> IO Bool mklibs :: OsPath -> a -> IO Bool
mklibs top _installedbins = do mklibs top _installedbins = do
@ -47,9 +48,9 @@ mklibs top _installedbins = do
-- Various files used by runshell to set up env vars used by the -- Various files used by runshell to set up env vars used by the
-- linker shims. -- linker shims.
writeFile (fromOsPath (top </> literalOsPath "libdirs")) F.writeFileString (top </> literalOsPath "libdirs")
(unlines (map fromOsPath libdirs')) (unlines (map fromOsPath libdirs'))
writeFile (fromOsPath (top </> literalOsPath "gconvdir")) $ F.writeFileString (top </> literalOsPath "gconvdir") $
case gconvlibs of case gconvlibs of
[] -> "" [] -> ""
(p:_) -> fromOsPath (parentDir p) (p:_) -> fromOsPath (parentDir p)
@ -171,7 +172,7 @@ installLinkerShim top linker exe = do
link <- relPathDirToFile (top </> exedir) (top <> linker) link <- relPathDirToFile (top </> exedir) (top <> linker)
unlessM (doesFileExist (top </> exelink)) $ unlessM (doesFileExist (top </> exelink)) $
createSymbolicLink (fromOsPath link) (fromOsPath (top </> exelink)) createSymbolicLink (fromOsPath link) (fromOsPath (top </> exelink))
writeFile (fromOsPath exe) $ unlines F.writeFileString exe $ unlines
[ "#!/bin/sh" [ "#!/bin/sh"
, "exec \"$GIT_ANNEX_DIR/" ++ fromOsPath exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ fromOsPath base ++ "/" ++ fromOsPath base ++ "\" \"$@\"" , "exec \"$GIT_ANNEX_DIR/" ++ fromOsPath exelink ++ "\" --library-path \"$GIT_ANNEX_LD_LIBRARY_PATH\" \"$GIT_ANNEX_DIR/shimmed/" ++ fromOsPath base ++ "/" ++ fromOsPath base ++ "\" \"$@\""
] ]

17
Build/NullSoftInstaller.hs
View file

@ -43,6 +43,7 @@ import Utility.Exception
import Utility.Directory import Utility.Directory
import Utility.SystemDirectory import Utility.SystemDirectory
import Utility.OsPath import Utility.OsPath
import qualified Utility.FileIO as F
import Build.BundledPrograms import Build.BundledPrograms
main = do main = do
@ -55,11 +56,11 @@ main = do
mustSucceed "sh" [Param "-c", Param $ "zcat standalone/licences.gz > '" ++ license ++ "'"] mustSucceed "sh" [Param "-c", Param $ "zcat standalone/licences.gz > '" ++ license ++ "'"]
webappscript <- vbsLauncher tmpdir "git-annex-webapp" "git annex webapp" webappscript <- vbsLauncher tmpdir "git-annex-webapp" "git annex webapp"
autostartscript <- vbsLauncher tmpdir "git-annex-autostart" "git annex assistant --autostart" autostartscript <- vbsLauncher tmpdir "git-annex-autostart" "git annex assistant --autostart"
let htmlhelp = fromOsPath $ tmpdir </> literalOsPath "git-annex.html" let htmlhelp = tmpdir </> literalOsPath "git-annex.html"
writeFile htmlhelp htmlHelpText F.writeFileString htmlhelp htmlHelpText
let gitannexcmd = fromOsPath $ tmpdir </> literalOsPath "git-annex.cmd" let gitannexcmd = tmpdir </> literalOsPath "git-annex.cmd"
writeFile gitannexcmd "git annex %*" F.writeFileString gitannexcmd "git annex %*"
writeFile nsifile $ makeInstaller F.writeFileString (toOsPath nsifile) $ makeInstaller
gitannex gitannexcmd license htmlhelp (winPrograms ++ magicDLLs') magicShare' gitannex gitannexcmd license htmlhelp (winPrograms ++ magicDLLs') magicShare'
[ webappscript, autostartscript ] [ webappscript, autostartscript ]
mustSucceed "makensis" [File nsifile] mustSucceed "makensis" [File nsifile]
@ -85,13 +86,13 @@ main = do
- box. It expects to be passed the directory where git-annex is installed. -} - box. It expects to be passed the directory where git-annex is installed. -}
vbsLauncher :: OsPath -> String -> String -> IO String vbsLauncher :: OsPath -> String -> String -> IO String
vbsLauncher tmpdir basename cmd = do vbsLauncher tmpdir basename cmd = do
let f = fromOsPath $ tmpdir </> toOsPath (basename ++ ".vbs") let f = tmpdir </> toOsPath (basename ++ ".vbs")
writeFile f $ unlines F.writeFileString f $ unlines
[ "Set objshell=CreateObject(\"Wscript.Shell\")" [ "Set objshell=CreateObject(\"Wscript.Shell\")"
, "objShell.CurrentDirectory = Wscript.Arguments.item(0)" , "objShell.CurrentDirectory = Wscript.Arguments.item(0)"
, "objShell.Run(\"" ++ cmd ++ "\"), 0, False" , "objShell.Run(\"" ++ cmd ++ "\"), 0, False"
] ]
return f return (fromOsPath f)
gitannexprogram :: FilePath gitannexprogram :: FilePath
gitannexprogram = "git-annex.exe" gitannexprogram = "git-annex.exe"

8
Build/Standalone.hs
View file

@ -180,19 +180,19 @@ installSkel topdir _basedir = do
installSkelRest :: OsPath -> OsPath -> Bool -> IO () installSkelRest :: OsPath -> OsPath -> Bool -> IO ()
#ifdef darwin_HOST_OS #ifdef darwin_HOST_OS
installSkelRest _topdir basedir _hwcaplibs = do installSkelRest _topdir basedir _hwcaplibs = do
plist <- lines <$> readFile "standalone/osx/Info.plist.template" plist <- lines <$> F.readFileString (literalOsPath "standalone/osx/Info.plist.template")
version <- getVersion version <- getVersion
writeFile (fromOsPath (basedir </> literalOsPath "Contents" </> literalOsPath "Info.plist")) F.writeFileString (basedir </> literalOsPath "Contents" </> literalOsPath "Info.plist")
(unlines (map (expandversion version) plist)) (unlines (map (expandversion version) plist))
where where
expandversion v l = replace "GIT_ANNEX_VERSION" v l expandversion v l = replace "GIT_ANNEX_VERSION" v l
#else #else
installSkelRest topdir _basedir hwcaplibs = do installSkelRest topdir _basedir hwcaplibs = do
runshell <- lines <$> readFile "standalone/linux/skel/runshell" runshell <- lines <$> F.readFileString (literalOsPath "standalone/linux/skel/runshell")
-- GIT_ANNEX_PACKAGE_INSTALL can be set by a distributor and -- GIT_ANNEX_PACKAGE_INSTALL can be set by a distributor and
-- runshell will be modified -- runshell will be modified
gapi <- getEnv "GIT_ANNEX_PACKAGE_INSTALL" gapi <- getEnv "GIT_ANNEX_PACKAGE_INSTALL"
writeFile (fromOsPath (topdir </> literalOsPath "runshell")) F.writeFileString (topdir </> literalOsPath "runshell")
(unlines (map (expandrunshell gapi) runshell)) (unlines (map (expandrunshell gapi) runshell))
modifyFileMode modifyFileMode
(topdir </> literalOsPath "runshell") (topdir </> literalOsPath "runshell")

12
Build/TestConfig.hs
View file

@ -1,6 +1,7 @@
{- Tests the system and generates SysConfig. -} {- Tests the system and generates SysConfig. -}
{-# OPTIONS_GHC -fno-warn-tabs #-} {-# OPTIONS_GHC -fno-warn-tabs #-}
{-# LANGUAGE OverloadedStrings #-}
module Build.TestConfig where module Build.TestConfig where
@ -9,6 +10,7 @@ import Utility.Monad
import Utility.SafeCommand import Utility.SafeCommand
import Utility.SystemDirectory import Utility.SystemDirectory
import Utility.OsPath import Utility.OsPath
import qualified Utility.FileIO as F
import System.IO import System.IO
@ -42,7 +44,7 @@ instance Show Config where
valuetype (MaybeBoolConfig _) = "Maybe Bool" valuetype (MaybeBoolConfig _) = "Maybe Bool"
writeSysConfig :: [Config] -> IO () writeSysConfig :: [Config] -> IO ()
writeSysConfig config = writeFile "Build/SysConfig" body writeSysConfig config = F.writeFileString (literalOsPath "Build/SysConfig") body
where where
body = unlines $ header ++ map show config ++ footer body = unlines $ header ++ map show config ++ footer
header = [ header = [
@ -100,12 +102,16 @@ findCmdPath k command = do
ifM (inSearchPath command) ifM (inSearchPath command)
( return $ Config k $ MaybeStringConfig $ Just command ( return $ Config k $ MaybeStringConfig $ Just command
, do , do
r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"] r <- getM find
[ literalOsPath "/usr/sbin"
, literalOsPath "/sbin"
, literalOsPath "/usr/local/sbin"
]
return $ Config k $ MaybeStringConfig r return $ Config k $ MaybeStringConfig r
) )
where where
find d = find d =
let f = toOsPath d </> toOsPath command let f = d </> toOsPath command
in ifM (doesFileExist f) in ifM (doesFileExist f)
( return (Just (fromOsPath f)) ( return (Just (fromOsPath f))
, return Nothing , return Nothing

2
Build/Version.hs
View file

@ -51,7 +51,7 @@ getVersion = do
getChangelogVersion :: IO Version getChangelogVersion :: IO Version
getChangelogVersion = do getChangelogVersion = do
changelog <- readFile "CHANGELOG" changelog <- F.readFileString (literalOsPath "CHANGELOG")
let verline = takeWhile (/= '\n') changelog let verline = takeWhile (/= '\n') changelog
return $ middle (words verline !! 1) return $ middle (words verline !! 1)
where where

2
Command/FuzzTest.hs
View file

@ -178,7 +178,7 @@ runFuzzAction :: FuzzAction -> Annex ()
runFuzzAction (FuzzAdd (FuzzFile f)) = do runFuzzAction (FuzzAdd (FuzzFile f)) = do
createWorkTreeDirectory (parentDir (toOsPath f)) createWorkTreeDirectory (parentDir (toOsPath f))
n <- liftIO (getStdRandom random :: IO Int) n <- liftIO (getStdRandom random :: IO Int)
liftIO $ writeFile f $ show n ++ "\n" liftIO $ writeFileString (toOsPath f) $ show n ++ "\n"
runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $
removeWhenExistsWith removeFile (toOsPath f) removeWhenExistsWith removeFile (toOsPath f)
runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $

4
Command/ImportFeed.hs
View file

@ -183,7 +183,7 @@ getFeed o url st =
next $ return True next $ return True
debugfeedcontent tmpf msg = do debugfeedcontent tmpf msg = do
feedcontent <- liftIO $ readFile tmpf feedcontent <- liftIO $ readFileString (toOsPath tmpf)
fastDebug "Command.ImportFeed" $ unlines fastDebug "Command.ImportFeed" $ unlines
[ "start of feed content" [ "start of feed content"
, feedcontent , feedcontent
@ -611,7 +611,7 @@ checkFeedBroken url = checkFeedBroken' url =<< feedState url
checkFeedBroken' :: URLString -> OsPath -> Annex Bool checkFeedBroken' :: URLString -> OsPath -> Annex Bool
checkFeedBroken' url f = do checkFeedBroken' url f = do
prev <- maybe Nothing readish prev <- maybe Nothing readish
<$> liftIO (catchMaybeIO $ readFile (fromOsPath f)) <$> liftIO (catchMaybeIO $ readFileString f)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
case prev of case prev of
Nothing -> do Nothing -> do

2
Command/Map.hs
View file

@ -55,7 +55,7 @@ start = startingNoMessage (ActionItemOther Nothing) $ do
<$> fromRepo gitAnnexDir <$> fromRepo gitAnnexDir
<*> pure (literalOsPath "map.dot") <*> pure (literalOsPath "map.dot")
liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap) liftIO $ writeFileString file (drawMap rs trustmap umap)
next $ next $
ifM (Annex.getRead Annex.fast) ifM (Annex.getRead Annex.fast)
( runViewer file [] ( runViewer file []

2
Command/Sim.hs
View file

@ -70,7 +70,7 @@ startsim' simfile = do
let st = emptySimState rng (fromOsPath simdir) let st = emptySimState rng (fromOsPath simdir)
case simfile of case simfile of
Nothing -> startup simdir st [] Nothing -> startup simdir st []
Just f -> liftIO (readFile f) >>= \c -> Just f -> liftIO (readFileString (toOsPath f)) >>= \c ->
case parseSimFile c of case parseSimFile c of
Left err -> giveup err Left err -> giveup err
Right cs -> startup simdir st cs Right cs -> startup simdir st cs

4
Command/Vicfg.hs
View file

@ -49,7 +49,7 @@ start = do
createAnnexDirectory $ parentDir f createAnnexDirectory $ parentDir f
cfg <- getCfg cfg <- getCfg
descs <- uuidDescriptions descs <- uuidDescriptions
liftIO $ writeFile (fromOsPath f) $ genCfg cfg descs liftIO $ writeFileString f $ genCfg cfg descs
vicfg cfg f vicfg cfg f
stop stop
@ -65,7 +65,7 @@ vicfg curcfg f = do
liftIO $ removeWhenExistsWith removeFile f liftIO $ removeWhenExistsWith removeFile f
case r of case r of
Left s -> do Left s -> do
liftIO $ writeFile (fromOsPath f) s liftIO $ writeFileString f s
vicfg curcfg f vicfg curcfg f
Right newcfg -> setCfg curcfg newcfg Right newcfg -> setCfg curcfg newcfg
where where

2
Command/WebApp.hs
View file

@ -90,7 +90,7 @@ start' allowauto o = do
( if isJust (listenAddress o) || isJust (listenPort o) ( if isJust (listenAddress o) || isJust (listenPort o)
then giveup "The assistant is already running, so --listen and --port cannot be used." then giveup "The assistant is already running, so --listen and --port cannot be used."
else do else do
url <- liftIO . readFile . fromOsPath url <- liftIO . readFileString
=<< fromRepo gitAnnexUrlFile =<< fromRepo gitAnnexUrlFile
liftIO $ if isJust listenAddress' liftIO $ if isJust listenAddress'
then putStrLn url then putStrLn url

2
Config/Files.hs
View file

@ -32,4 +32,4 @@ programFile = userConfigFile (literalOsPath "program")
noAnnexFileContent :: Maybe OsPath -> IO (Maybe String) noAnnexFileContent :: Maybe OsPath -> IO (Maybe String)
noAnnexFileContent repoworktree = case repoworktree of noAnnexFileContent repoworktree = case repoworktree of
Nothing -> return Nothing Nothing -> return Nothing
Just wt -> catchMaybeIO (readFile (fromOsPath (wt </> literalOsPath ".noannex"))) Just wt -> catchMaybeIO (readFileString (wt </> literalOsPath ".noannex"))

4
Config/Files/AutoStart.hs
View file

@ -18,7 +18,7 @@ readAutoStartFile :: IO [OsPath]
readAutoStartFile = do readAutoStartFile = do
f <- autoStartFile f <- autoStartFile
filter valid . nub . map (dropTrailingPathSeparator . toOsPath) . lines filter valid . nub . map (dropTrailingPathSeparator . toOsPath) . lines
<$> catchDefaultIO "" (readFile (fromOsPath f)) <$> catchDefaultIO "" (readFileString f)
where where
-- Ignore any relative paths; some old buggy versions added eg "." -- Ignore any relative paths; some old buggy versions added eg "."
valid = isAbsolute valid = isAbsolute
@ -30,7 +30,7 @@ modifyAutoStartFile func = do
when (dirs' /= dirs) $ do when (dirs' /= dirs) $ do
f <- autoStartFile f <- autoStartFile
createDirectoryIfMissing True (parentDir f) createDirectoryIfMissing True (parentDir f)
viaTmp (writeFile . fromRawFilePath . fromOsPath) f viaTmp writeFileString f
(unlines (map fromOsPath dirs')) (unlines (map fromOsPath dirs'))
{- Adds a directory to the autostart file. If the directory is already {- Adds a directory to the autostart file. If the directory is already

2
Config/Smudge.hs
View file

@ -70,7 +70,7 @@ deconfigureSmudgeFilter = do
lf <- Annex.fromRepo Git.attributesLocal lf <- Annex.fromRepo Git.attributesLocal
ls <- liftIO $ catchDefaultIO [] $ ls <- liftIO $ catchDefaultIO [] $
map decodeBS . fileLines' <$> F.readFile' lf map decodeBS . fileLines' <$> F.readFile' lf
liftIO $ writeFile (fromOsPath lf) $ unlines $ liftIO $ writeFileString lf $ unlines $
filter (\l -> l `notElem` stdattr && not (null l)) ls filter (\l -> l `notElem` stdattr && not (null l)) ls
unsetConfig (ConfigKey "filter.annex.smudge") unsetConfig (ConfigKey "filter.annex.smudge")
unsetConfig (ConfigKey "filter.annex.clean") unsetConfig (ConfigKey "filter.annex.clean")

6
Database/Keys.hs
View file

@ -264,7 +264,7 @@ reconcileStaged dbisnew qh = ifM isBareRepo
( return mempty ( return mempty
, do , do
gitindex <- inRepo currentIndexFile gitindex <- inRepo currentIndexFile
indexcache <- fromOsPath <$> calcRepo' gitAnnexKeysDbIndexCache indexcache <- calcRepo' gitAnnexKeysDbIndexCache
withTSDelta (liftIO . genInodeCache gitindex) >>= \case withTSDelta (liftIO . genInodeCache gitindex) >>= \case
Just cur -> readindexcache indexcache >>= \case Just cur -> readindexcache indexcache >>= \case
Nothing -> go cur indexcache =<< getindextree Nothing -> go cur indexcache =<< getindextree
@ -278,7 +278,7 @@ reconcileStaged dbisnew qh = ifM isBareRepo
lastindexref = Ref "refs/annex/last-index" lastindexref = Ref "refs/annex/last-index"
readindexcache indexcache = liftIO $ maybe Nothing readInodeCache readindexcache indexcache = liftIO $ maybe Nothing readInodeCache
<$> catchMaybeIO (readFile indexcache) <$> catchMaybeIO (readFileString indexcache)
getoldtree = fromMaybe emptyTree <$> inRepo (Git.Ref.sha lastindexref) getoldtree = fromMaybe emptyTree <$> inRepo (Git.Ref.sha lastindexref)
@ -292,7 +292,7 @@ reconcileStaged dbisnew qh = ifM isBareRepo
(Just (fromRef oldtree)) (Just (fromRef oldtree))
(fromRef newtree) (fromRef newtree)
(procdiff mdfeeder) (procdiff mdfeeder)
liftIO $ writeFile indexcache $ showInodeCache cur liftIO $ writeFileString indexcache $ showInodeCache cur
-- Storing the tree in a ref makes sure it does not -- Storing the tree in a ref makes sure it does not
-- get garbage collected, and is available to diff -- get garbage collected, and is available to diff
-- against next time. -- against next time.

2
Git/Construct.hs
View file

@ -280,7 +280,7 @@ adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc
adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)
adjustGitDirFile' loc@(Local {}) = do adjustGitDirFile' loc@(Local {}) = do
let gd = gitdir loc let gd = gitdir loc
c <- firstLine <$> catchDefaultIO "" (readFile (fromOsPath gd)) c <- firstLine <$> catchDefaultIO "" (readFileString gd)
if gitdirprefix `isPrefixOf` c if gitdirprefix `isPrefixOf` c
then do then do
top <- takeDirectory <$> absPath gd top <- takeDirectory <$> absPath gd

6
Git/Hook.hs
View file

@ -59,7 +59,7 @@ hookWrite h r = ifM (doesFileExist f)
f = hookFile h r f = hookFile h r
go = do go = do
-- On Windows, using a ByteString as the file content -- On Windows, using a ByteString as the file content
-- avoids the newline translation done by writeFile. -- avoids the newline translation done by writeFileString.
-- Hook scripts on Windows could use CRLF endings, but -- Hook scripts on Windows could use CRLF endings, but
-- they typically use unix newlines, which does work there -- they typically use unix newlines, which does work there
-- and makes the repository more portable. -- and makes the repository more portable.
@ -85,11 +85,11 @@ data ExpectedContent = UnexpectedContent | ExpectedContent | OldExpectedContent
expectedContent :: Hook -> Repo -> IO ExpectedContent expectedContent :: Hook -> Repo -> IO ExpectedContent
expectedContent h r = do expectedContent h r = do
-- Note that on windows, this readFile does newline translation, -- Note that on windows, this readFileString does newline translation,
-- and so a hook file that has CRLF will be treated the same as one -- and so a hook file that has CRLF will be treated the same as one
-- that has LF. That is intentional, since users may have a reason -- that has LF. That is intentional, since users may have a reason
-- to prefer one or the other. -- to prefer one or the other.
content <- readFile $ fromOsPath $ hookFile h r content <- readFileString $ hookFile h r
return $ if content == hookScript h return $ if content == hookScript h
then ExpectedContent then ExpectedContent
else if any (content ==) (hookOldScripts h) else if any (content ==) (hookOldScripts h)

2
Git/Objects.hs
View file

@ -50,7 +50,7 @@ looseObjectFile r sha = objectsDir r </> toOsPath prefix </> toOsPath rest
listAlternates :: Repo -> IO [FilePath] listAlternates :: Repo -> IO [FilePath]
listAlternates r = catchDefaultIO [] $ listAlternates r = catchDefaultIO [] $
lines <$> readFile (fromOsPath alternatesfile) lines <$> readFileString alternatesfile
where where
alternatesfile = objectsDir r </> literalOsPath "info" </> literalOsPath "alternates" alternatesfile = objectsDir r </> literalOsPath "info" </> literalOsPath "alternates"

4
Git/Repair.hs
View file

@ -269,7 +269,7 @@ explodePackedRefsFile r = do
let dest = gitd </> toOsPath (fromRef' ref) let dest = gitd </> toOsPath (fromRef' ref)
createDirectoryUnder [gitd] (parentDir dest) createDirectoryUnder [gitd] (parentDir dest)
unlessM (doesFileExist dest) $ unlessM (doesFileExist dest) $
writeFile (fromOsPath dest) (fromRef sha) writeFileString dest (fromRef sha)
packedRefsFile :: Repo -> OsPath packedRefsFile :: Repo -> OsPath
packedRefsFile r = localGitDir r </> literalOsPath "packed-refs" packedRefsFile r = localGitDir r </> literalOsPath "packed-refs"
@ -472,7 +472,7 @@ preRepair :: Repo -> IO ()
preRepair g = do preRepair g = do
unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do
removeWhenExistsWith removeFile headfile removeWhenExistsWith removeFile headfile
writeFile (fromOsPath headfile) "ref: refs/heads/master" writeFileString headfile "ref: refs/heads/master"
explodePackedRefsFile g explodePackedRefsFile g
unless (repoIsLocalBare g) $ unless (repoIsLocalBare g) $
void $ tryIO $ allowWrite $ indexFile g void $ tryIO $ allowWrite $ indexFile g

2
Logs/File.hs
View file

@ -38,7 +38,7 @@ writeLogFile :: OsPath -> String -> Annex ()
writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c
where where
writelog tmp c' = do writelog tmp c' = do
liftIO $ writeFile (fromOsPath tmp) c' liftIO $ writeFileString tmp c'
setAnnexFilePerm tmp setAnnexFilePerm tmp
-- | Runs the action with a handle connected to a temp file. -- | Runs the action with a handle connected to a temp file.

2
Logs/FsckResults.hs
View file

@ -45,7 +45,7 @@ readFsckResults :: UUID -> Annex FsckResults
readFsckResults u = do readFsckResults u = do
logfile <- fromRepo $ gitAnnexFsckResultsLog u logfile <- fromRepo $ gitAnnexFsckResultsLog u
liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $ liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $
deserializeFsckResults <$> readFile (fromOsPath logfile) deserializeFsckResults <$> readFileString logfile
deserializeFsckResults :: String -> FsckResults deserializeFsckResults :: String -> FsckResults
deserializeFsckResults = deserialize . lines deserializeFsckResults = deserialize . lines

2
Logs/Restage.hs
View file

@ -55,7 +55,7 @@ streamRestageLog finalizer processor = do
ifM (doesPathExist oldf) ifM (doesPathExist oldf)
( do ( do
h <- F.openFile oldf AppendMode h <- F.openFile oldf AppendMode
hPutStr h =<< readFile (fromOsPath logf) hPutStr h =<< readFileString logf
hClose h hClose h
liftIO $ removeWhenExistsWith removeFile logf liftIO $ removeWhenExistsWith removeFile logf
, moveFile logf oldf , moveFile logf oldf

4
Logs/Schedule.hs
View file

@ -63,9 +63,9 @@ scheduleChange u a = scheduleSet u . S.toList . a =<< scheduleGet u
getLastRunTimes :: Annex (M.Map ScheduledActivity LocalTime) getLastRunTimes :: Annex (M.Map ScheduledActivity LocalTime)
getLastRunTimes = do getLastRunTimes = do
f <- fromOsPath <$> fromRepo gitAnnexScheduleState f <- fromRepo gitAnnexScheduleState
liftIO $ fromMaybe M.empty liftIO $ fromMaybe M.empty
<$> catchDefaultIO Nothing (readish <$> readFile f) <$> catchDefaultIO Nothing (readish <$> readFileString f)
setLastRunTime :: ScheduledActivity -> LocalTime -> Annex () setLastRunTime :: ScheduledActivity -> LocalTime -> Annex ()
setLastRunTime activity lastrun = do setLastRunTime activity lastrun = do

2
Logs/Transfer.hs
View file

@ -263,7 +263,7 @@ writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
-- after it's been created with the right perms by writeTransferInfoFile. -- after it's been created with the right perms by writeTransferInfoFile.
updateTransferInfoFile :: TransferInfo -> OsPath -> IO () updateTransferInfoFile :: TransferInfo -> OsPath -> IO ()
updateTransferInfoFile info tfile = updateTransferInfoFile info tfile =
writeFile (fromOsPath tfile) $ writeTransferInfo info writeFileString tfile $ writeTransferInfo info
{- File format is a header line containing the startedTime and any {- File format is a header line containing the startedTime and any
- bytesComplete value. Followed by a newline and the associatedFile. - bytesComplete value. Followed by a newline and the associatedFile.

4
Logs/View.hs
View file

@ -54,8 +54,8 @@ removeView v = writeViews =<< filter (/= v) <$> recentViews
recentViews :: Annex [View] recentViews :: Annex [View]
recentViews = do recentViews = do
f <- fromOsPath <$> fromRepo gitAnnexViewLog f <- fromRepo gitAnnexViewLog
liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f) liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFileString f)
{- Gets the currently checked out view, if there is one. {- Gets the currently checked out view, if there is one.
- -

4
Remote/Directory/LegacyChunked.hs
View file

@ -33,7 +33,7 @@ withCheckedFiles check d locations k a = go $ locations d k
let chunkcount = f ++ Legacy.chunkCount let chunkcount = f ++ Legacy.chunkCount
ifM (check chunkcount) ifM (check chunkcount)
( do ( do
chunks <- Legacy.listChunks f <$> readFile chunkcount chunks <- Legacy.listChunks f <$> readFileString (toOsPath chunkcount)
ifM (allM check chunks) ifM (allM check chunks)
( a chunks , return False ) ( a chunks , return False )
, do , do
@ -85,7 +85,7 @@ storeHelper repotop finalizer key storer tmpdir destdir = do
recorder f s = do recorder f s = do
let f' = toOsPath f let f' = toOsPath f
void $ tryIO $ allowWrite f' void $ tryIO $ allowWrite f'
writeFile f s writeFileString f' s
void $ tryIO $ preventWrite f' void $ tryIO $ preventWrite f'
store :: FilePath -> ChunkSize -> (OsPath -> OsPath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO () store :: FilePath -> ChunkSize -> (OsPath -> OsPath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO ()

8
Remote/Tahoe.hs
View file

@ -213,7 +213,7 @@ createClient configdir furl = do
writeSharedConvergenceSecret :: TahoeConfigDir -> SharedConvergenceSecret -> IO () writeSharedConvergenceSecret :: TahoeConfigDir -> SharedConvergenceSecret -> IO ()
writeSharedConvergenceSecret configdir scs = writeSharedConvergenceSecret configdir scs =
writeFile (fromOsPath (convergenceFile configdir)) writeFileString (convergenceFile configdir)
(unlines [scs]) (unlines [scs])
{- The tahoe daemon writes the convergenceFile shortly after it starts {- The tahoe daemon writes the convergenceFile shortly after it starts
@ -223,11 +223,11 @@ writeSharedConvergenceSecret configdir scs =
getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret
getSharedConvergenceSecret configdir = go (60 :: Int) getSharedConvergenceSecret configdir = go (60 :: Int)
where where
f = fromOsPath $ convergenceFile configdir f = convergenceFile configdir
go n go n
| n == 0 = giveup $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?" | n == 0 = giveup $ "tahoe did not write " ++ fromOsPath f ++ " after 1 minute. Perhaps the daemon failed to start?"
| otherwise = do | otherwise = do
v <- catchMaybeIO (readFile f) v <- catchMaybeIO (readFileString f)
case v of case v of
Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s -> Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s ->
return $ takeWhile (`notElem` ("\n\r" :: String)) s return $ takeWhile (`notElem` ("\n\r" :: String)) s

30
Test.hs
View file

@ -556,8 +556,8 @@ test_magic = intmpclonerepo $ do
#ifdef WITH_MAGICMIME #ifdef WITH_MAGICMIME
git "config" ["annex.largefiles", "mimeencoding=binary"] git "config" ["annex.largefiles", "mimeencoding=binary"]
"git config annex.largefiles" "git config annex.largefiles"
writeFile "binary" "\127" writeFileString (literalOsPath "binary") "\127"
writeFile "text" "test\n" writeFileString (literalOsPath "text") "test\n"
git_annex "add" ["binary", "text"] git_annex "add" ["binary", "text"]
"git-annex add with mimeencoding in largefiles" "git-annex add with mimeencoding in largefiles"
git_annex "sync" ["--no-content"] git_annex "sync" ["--no-content"]
@ -879,7 +879,7 @@ test_lock = intmpclonerepo $ do
changecontent annexedfile changecontent annexedfile
git "add" [annexedfile] "add of modified file" git "add" [annexedfile] "add of modified file"
runchecks [checkregularfile, checkwritable] annexedfile runchecks [checkregularfile, checkwritable] annexedfile
c <- readFile annexedfile c <- readFileString (toOsPath annexedfile)
assertEqual "content of modified file" c (changedcontent annexedfile) assertEqual "content of modified file" c (changedcontent annexedfile)
git_annex_shouldfail "drop" [annexedfile] git_annex_shouldfail "drop" [annexedfile]
"drop with no known copy of modified file should not be allowed" "drop with no known copy of modified file should not be allowed"
@ -921,7 +921,7 @@ test_edit' precommit = intmpclonerepo $ do
then git_annex "pre-commit" [] "pre-commit" then git_annex "pre-commit" [] "pre-commit"
else git "commit" ["-q", "-m", "contentchanged"] "git commit of edited file" else git "commit" ["-q", "-m", "contentchanged"] "git commit of edited file"
runchecks [checkregularfile, checkwritable] annexedfile runchecks [checkregularfile, checkwritable] annexedfile
c <- readFile annexedfile c <- readFileString (toOsPath annexedfile)
assertEqual "content of modified file" c (changedcontent annexedfile) assertEqual "content of modified file" c (changedcontent annexedfile)
git_annex_shouldfail "drop" [annexedfile] "drop no known copy of modified file should not be allowed" git_annex_shouldfail "drop" [annexedfile] "drop no known copy of modified file should not be allowed"
@ -947,7 +947,7 @@ test_fix = intmpclonerepo $ unlessM (hasUnlockedFiles <$> getTestMode) $ do
git "mv" [annexedfile, subdir] "git mv" git "mv" [annexedfile, subdir] "git mv"
git_annex "fix" [newfile] "fix of moved file" git_annex "fix" [newfile] "fix of moved file"
runchecks [checklink, checkunwritable] newfile runchecks [checklink, checkunwritable] newfile
c <- readFile newfile c <- readFileString (toOsPath newfile)
assertEqual "content of moved file" c (content annexedfile) assertEqual "content of moved file" c (content annexedfile)
where where
subdir = "s" subdir = "s"
@ -1069,7 +1069,8 @@ test_migrate' usegitattributes = intmpclonerepo $ do
annexed_present sha1annexedfile annexed_present sha1annexedfile
if usegitattributes if usegitattributes
then do then do
writeFile ".gitattributes" "* annex.backend=SHA1" writeFileString (literalOsPath ".gitattributes")
"* annex.backend=SHA1"
git_annex "migrate" [sha1annexedfile] git_annex "migrate" [sha1annexedfile]
"migrate sha1annexedfile" "migrate sha1annexedfile"
git_annex "migrate" [annexedfile] git_annex "migrate" [annexedfile]
@ -1085,7 +1086,8 @@ test_migrate' usegitattributes = intmpclonerepo $ do
checkbackend sha1annexedfile backendSHA1 checkbackend sha1annexedfile backendSHA1
-- check that reversing a migration works -- check that reversing a migration works
writeFile ".gitattributes" "* annex.backend=SHA256" writeFileString (literalOsPath ".gitattributes")
"* annex.backend=SHA256"
git_annex "migrate" [sha1annexedfile] "migrate sha1annexedfile" git_annex "migrate" [sha1annexedfile] "migrate sha1annexedfile"
git_annex "migrate" [annexedfile] "migrate annexedfile" git_annex "migrate" [annexedfile] "migrate annexedfile"
annexed_present annexedfile annexed_present annexedfile
@ -1531,7 +1533,7 @@ test_nonannexed_file_conflict_resolution = do
length v == 1 length v == 1
@? (what ++ " too many variant files in: " ++ show v) @? (what ++ " too many variant files in: " ++ show v)
conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l) conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l)
s <- catchMaybeIO $ readFile $ fromOsPath $ s <- catchMaybeIO $ readFileString $
toOsPath d </> toOsPath conflictor toOsPath d </> toOsPath conflictor
s == Just nonannexed_content s == Just nonannexed_content
@? (what ++ " wrong content for nonannexed file: " ++ show s) @? (what ++ " wrong content for nonannexed file: " ++ show s)
@ -2074,9 +2076,9 @@ test_export_import = intmpclonerepo $ do
dircontains "import" (content "newimport3") dircontains "import" (content "newimport3")
where where
dircontains f v = do dircontains f v = do
let df = fromOsPath (literalOsPath "dir" </> stringToOsPath f) let df = literalOsPath "dir" </> stringToOsPath f
((v==) <$> readFile df) ((v==) <$> readFileString df)
@? ("did not find expected content of " ++ df) @? ("did not find expected content of " ++ fromOsPath df)
writedir f = writecontent (fromOsPath (literalOsPath "dir" </> stringToOsPath f)) writedir f = writecontent (fromOsPath (literalOsPath "dir" </> stringToOsPath f))
-- When on an adjusted branch, this updates the master branch -- When on an adjusted branch, this updates the master branch
-- to match it, which is necessary since the master branch is going -- to match it, which is necessary since the master branch is going
@ -2111,9 +2113,9 @@ test_export_import_subdir = intmpclonerepo $ do
testexport testexport
where where
dircontains f v = do dircontains f v = do
let df = fromOsPath (literalOsPath "dir" </> toOsPath f) let df = literalOsPath "dir" </> toOsPath f
((v==) <$> readFile df) ((v==) <$> readFileString df)
@? ("did not find expected content of " ++ df) @? ("did not find expected content of " ++ fromOsPath df)
subdir = "subdir" subdir = "subdir"
subannexedfile = fromOsPath $ subannexedfile = fromOsPath $

11
Test/Framework.hs
View file

@ -391,7 +391,7 @@ checkexists f =
checkcontent :: FilePath -> Assertion checkcontent :: FilePath -> Assertion
checkcontent f = do checkcontent f = do
c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f c <- Utility.Exception.catchDefaultIO "could not read file" $ readFileString (toOsPath f)
assertEqual ("checkcontent " ++ f) (content f) c assertEqual ("checkcontent " ++ f) (content f) c
checkunwritable :: FilePath -> Assertion checkunwritable :: FilePath -> Assertion
@ -415,7 +415,7 @@ checkdangling :: FilePath -> Assertion
checkdangling f = ifM (annexeval Config.crippledFileSystem) checkdangling f = ifM (annexeval Config.crippledFileSystem)
( return () -- probably no real symlinks to test ( return () -- probably no real symlinks to test
, do , do
r <- tryIO $ readFile f r <- tryIO $ readFileString (toOsPath f)
case r of case r of
Left _ -> return () -- expected; dangling link Left _ -> return () -- expected; dangling link
Right _ -> assertFailure $ f ++ " was not a dangling link as expected" Right _ -> assertFailure $ f ++ " was not a dangling link as expected"
@ -675,9 +675,10 @@ writecontent :: FilePath -> String -> IO ()
writecontent f c = go (10000000 :: Integer) writecontent f c = go (10000000 :: Integer)
where where
go ticsleft = do go ticsleft = do
oldmtime <- catchMaybeIO $ getModificationTime (toOsPath f) let f' = toOsPath f
writeFile f c oldmtime <- catchMaybeIO $ getModificationTime f'
newmtime <- getModificationTime (toOsPath f) writeFileString f' c
newmtime <- getModificationTime f'
if Just newmtime == oldmtime if Just newmtime == oldmtime
then do then do
threadDelay 100000 threadDelay 100000

4
Upgrade/V2.hs
View file

@ -87,7 +87,7 @@ locationLogs = do
inject :: OsPath -> OsPath -> Annex () inject :: OsPath -> OsPath -> Annex ()
inject source dest = do inject source dest = do
old <- fromRepo olddir old <- fromRepo olddir
new <- liftIO (readFile $ fromOsPath $ old </> source) new <- liftIO $ readFileString (old </> source)
Annex.Branch.change (Annex.Branch.RegardingUUID []) dest $ \prev -> Annex.Branch.change (Annex.Branch.RegardingUUID []) dest $ \prev ->
encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new
@ -141,7 +141,7 @@ gitAttributesUnWrite repo = do
whenM (doesFileExist attributes) $ do whenM (doesFileExist attributes) $ do
c <- map decodeBS . fileLines' c <- map decodeBS . fileLines'
<$> F.readFile' attributes <$> F.readFile' attributes
liftIO $ viaTmp (writeFile . fromOsPath) attributes liftIO $ viaTmp writeFileString attributes
(unlines $ filter (`notElem` attrLines) c) (unlines $ filter (`notElem` attrLines) c)
Git.Command.run [Param "add", File (fromOsPath attributes)] repo Git.Command.run [Param "add", File (fromOsPath attributes)] repo

2
Upgrade/V7.hs
View file

@ -136,7 +136,7 @@ updateSmudgeFilter = do
<$> catchDefaultIO "" (F.readFile' lf) <$> catchDefaultIO "" (F.readFile' lf)
let ls' = removedotfilter ls let ls' = removedotfilter ls
when (ls /= ls') $ when (ls /= ls') $
liftIO $ writeFile (fromOsPath lf) (unlines ls') liftIO $ writeFileString lf (unlines ls')
where where
removedotfilter ("* filter=annex":".* !filter":rest) = removedotfilter ("* filter=annex":".* !filter":rest) =
"* filter=annex" : removedotfilter rest "* filter=annex" : removedotfilter rest

8
Utility/Daemon.hs
View file

@ -121,9 +121,9 @@ lockPidFile pidfile = do
unlessM (isNothing <$> checkDaemon pidfile) unlessM (isNothing <$> checkDaemon pidfile)
alreadyRunning alreadyRunning
pid <- getPID pid <- getPID
writeFile (fromOsPath pidfile) (show pid) writeFileString pidfile (show pid)
lckfile <- winLockFile pid pidfile lckfile <- winLockFile pid pidfile
writeFile (fromOsPath lckfile) "" writeFileString lckfile ""
void $ lockExclusive lckfile void $ lockExclusive lckfile
#endif #endif
@ -147,7 +147,7 @@ checkDaemon pidfile = bracket setup cleanup go
cleanup Nothing = return () cleanup Nothing = return ()
go (Just fd) = catchDefaultIO Nothing $ do go (Just fd) = catchDefaultIO Nothing $ do
locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0)
p <- readish <$> readFile (fromOsPath pidfile) p <- readish <$> readFileString pidfile
return (check locked p) return (check locked p)
go Nothing = return Nothing go Nothing = return Nothing
@ -161,7 +161,7 @@ checkDaemon pidfile = bracket setup cleanup go
"; expected " ++ show pid ++ " )" "; expected " ++ show pid ++ " )"
#else #else
checkDaemon pidfile = maybe (return Nothing) (check . readish) checkDaemon pidfile = maybe (return Nothing) (check . readish)
=<< catchMaybeIO (readFile (fromOsPath pidfile)) =<< catchMaybeIO (readFileString pidfile)
where where
check Nothing = return Nothing check Nothing = return Nothing
check (Just pid) = do check (Just pid) = do

2
Utility/FileMode.hs
View file

@ -171,7 +171,7 @@ setSticky f = modifyFileMode f $ addModes [stickyMode]
- When possible, this is done using the umask. - When possible, this is done using the umask.
- -
- On a filesystem that does not support file permissions, this is the same - On a filesystem that does not support file permissions, this is the same
- as writeFile. - as writeFileString.
-} -}
writeFileProtected :: OsPath -> String -> IO () writeFileProtected :: OsPath -> String -> IO ()
writeFileProtected file content = writeFileProtected' file writeFileProtected file content = writeFileProtected' file

2
Utility/FreeDesktop.hs
View file

@ -75,7 +75,7 @@ buildDesktopMenuFile d = unlines ("[Desktop Entry]" : map keyvalue d) ++ "\n"
writeDesktopMenuFile :: DesktopEntry -> OsPath -> IO () writeDesktopMenuFile :: DesktopEntry -> OsPath -> IO ()
writeDesktopMenuFile d file = do writeDesktopMenuFile d file = do
createDirectoryIfMissing True (takeDirectory file) createDirectoryIfMissing True (takeDirectory file)
writeFile (fromOsPath file) $ buildDesktopMenuFile d writeFileString file $ buildDesktopMenuFile d
{- Path to use for a desktop menu file, in either the systemDataDir or {- Path to use for a desktop menu file, in either the systemDataDir or
- the userDataDir -} - the userDataDir -}

4
Utility/InodeCache.hs
View file

@ -234,7 +234,7 @@ noTSDelta = TSDelta (pure 0)
writeSentinalFile :: SentinalFile -> IO () writeSentinalFile :: SentinalFile -> IO ()
writeSentinalFile s = do writeSentinalFile s = do
F.writeFile' (sentinalFile s) mempty F.writeFile' (sentinalFile s) mempty
maybe noop (writeFile (fromOsPath (sentinalCacheFile s)) . showInodeCache) maybe noop (writeFileString (sentinalCacheFile s) . showInodeCache)
=<< genInodeCache (sentinalFile s) noTSDelta =<< genInodeCache (sentinalFile s) noTSDelta
data SentinalStatus = SentinalStatus data SentinalStatus = SentinalStatus
@ -263,7 +263,7 @@ checkSentinalFile s = do
Just new -> return $ calc old new Just new -> return $ calc old new
where where
loadoldcache = catchDefaultIO Nothing $ loadoldcache = catchDefaultIO Nothing $
readInodeCache <$> readFile (fromOsPath (sentinalCacheFile s)) readInodeCache <$> readFileString (sentinalCacheFile s)
gennewcache = genInodeCache (sentinalFile s) noTSDelta gennewcache = genInodeCache (sentinalFile s) noTSDelta
calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) =
SentinalStatus (not unchanged) tsdelta SentinalStatus (not unchanged) tsdelta

5
Utility/LockFile/PidLock.hs
View file

@ -41,6 +41,7 @@ import Utility.Env.Set
import Utility.Tmp import Utility.Tmp
import Utility.RawFilePath import Utility.RawFilePath
import Utility.OsPath import Utility.OsPath
import qualified Utility.FileIO as F
import qualified Utility.LockFile.Posix as Posix import qualified Utility.LockFile.Posix as Posix
import System.IO import System.IO
@ -77,7 +78,7 @@ mkPidLock = PidLock
readPidLock :: PidLockFile -> IO (Maybe PidLock) readPidLock :: PidLockFile -> IO (Maybe PidLock)
readPidLock lockfile = (readish =<<) readPidLock lockfile = (readish =<<)
<$> catchMaybeIO (readFile (fromOsPath lockfile)) <$> catchMaybeIO (F.readFileString lockfile)
-- To avoid races when taking over a stale pid lock, a side lock is used. -- To avoid races when taking over a stale pid lock, a side lock is used.
-- This is a regular posix exclusive lock. -- This is a regular posix exclusive lock.
@ -214,7 +215,7 @@ linkToLock (Just _) src dest = do
(CloseOnExecFlag True) (CloseOnExecFlag True)
fdToHandle fd fdToHandle fd
let cleanup = hClose let cleanup = hClose
let go h = readFile (fromOsPath src) >>= hPutStr h let go h = F.readFileString src >>= hPutStr h
bracket setup cleanup go bracket setup cleanup go
getFileStatus dest' getFileStatus dest'
where where

2
Utility/Misc.hs
View file

@ -110,7 +110,7 @@ fileLines' = map stripCR . S8.lines
fileLines' = S8.lines fileLines' = S8.lines
#endif #endif
-- One windows, writeFile does NewlineMode translation, -- On windows, writeFile does NewlineMode translation,
-- adding CR before LF. When converting to ByteString, use this to emulate that. -- adding CR before LF. When converting to ByteString, use this to emulate that.
linesFile :: L.ByteString -> L.ByteString linesFile :: L.ByteString -> L.ByteString
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS

2
Utility/Shell.hs
View file

@ -37,7 +37,7 @@ findShellCommand f = do
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
defcmd defcmd
#else #else
l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFile (fromOsPath f) l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFileString f
case l of case l of
Just ('#':'!':rest) -> case words rest of Just ('#':'!':rest) -> case words rest of
[] -> defcmd [] -> defcmd

6
Utility/Tmp.hs
View file

@ -49,13 +49,13 @@ openTmpFileIn dir template = F.openTempFile dir template
let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template) let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template)
in annotateIOError e loc Nothing Nothing in annotateIOError e loc Nothing Nothing
{- Runs an action like writeFile, writing to a temp file first and {- Runs an action like writeFileString, writing to a temp file first and
- then moving it into place. The temp file is stored in the same - then moving it into place. The temp file is stored in the same
- directory as the final file to avoid cross-device renames. - directory as the final file to avoid cross-device renames.
- -
- While this uses a temp file, the file will end up with the same - While this uses a temp file, the file will end up with the same
- mode as it would when using writeFile, unless the writer action changes - mode as it would when using writeFileString, unless the writer action
- it. - changes it.
-} -}
viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m () viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m ()
viaTmp a file content = bracketIO setup cleanup use viaTmp a file content = bracketIO setup cleanup use

8
Utility/Tor.hs
View file

@ -71,7 +71,7 @@ connectHiddenService (OnionAddress address) port = do
addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort) addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort)
addHiddenService appname uid ident = do addHiddenService appname uid ident = do
prepHiddenServiceSocketDir appname uid ident prepHiddenServiceSocketDir appname uid ident
ls <- lines <$> (readFile . fromOsPath =<< findTorrc) ls <- lines <$> (readFileString =<< findTorrc)
let portssocks = mapMaybe (parseportsock . separate isSpace) ls let portssocks = mapMaybe (parseportsock . separate isSpace) ls
case filter (\(_, s) -> s == fromOsPath sockfile) portssocks of case filter (\(_, s) -> s == fromOsPath sockfile) portssocks of
((p, _s):_) -> waithiddenservice 1 p ((p, _s):_) -> waithiddenservice 1 p
@ -80,7 +80,7 @@ addHiddenService appname uid ident = do
let newport = fromMaybe (error "internal") $ headMaybe $ let newport = fromMaybe (error "internal") $ headMaybe $
filter (`notElem` map fst portssocks) highports filter (`notElem` map fst portssocks) highports
torrc <- findTorrc torrc <- findTorrc
writeFile (fromOsPath torrc) $ unlines $ writeFileString torrc $ unlines $
ls ++ ls ++
[ "" [ ""
, "HiddenServiceDir " ++ fromOsPath (hiddenServiceDir appname uid ident) , "HiddenServiceDir " ++ fromOsPath (hiddenServiceDir appname uid ident)
@ -112,7 +112,7 @@ addHiddenService appname uid ident = do
waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort) waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort)
waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running" waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running"
waithiddenservice n p = do waithiddenservice n p = do
v <- tryIO $ readFile $ fromOsPath $ v <- tryIO $ readFileString $
hiddenServiceHostnameFile appname uid ident hiddenServiceHostnameFile appname uid ident
case v of case v of
Right s | ".onion\n" `isSuffixOf` s -> Right s | ".onion\n" `isSuffixOf` s ->
@ -152,7 +152,7 @@ hiddenServiceSocketFile appname uid ident =
getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe OsPath) getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe OsPath)
getHiddenServiceSocketFile _appname uid ident = getHiddenServiceSocketFile _appname uid ident =
parse . map words . lines <$> catchDefaultIO "" parse . map words . lines <$> catchDefaultIO ""
(readFile . fromOsPath =<< findTorrc) (readFileString =<< findTorrc)
where where
parse [] = Nothing parse [] = Nothing
parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest) parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest)