From 27305042f37e03ae8cf32678edaab1796b048acf Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 29 Jan 2025 11:53:20 -0400 Subject: [PATCH] more OsPath conversion Sponsored-by: Nicholas Golder-Manning --- Annex/Hook.hs | 38 ++++++++++---------- Annex/Perms.hs | 76 ++++++++++++++++++++------------------- Annex/Url.hs | 4 +-- Annex/VariantFile.hs | 21 ++++++----- Annex/View/ViewedFile.hs | 33 +++++++++-------- Assistant/Ssh.hs | 45 ++++++++++++----------- Backend/GitRemoteAnnex.hs | 2 +- Backend/Hash.hs | 8 ++--- Backend/Utilities.hs | 2 +- Backend/WORM.hs | 4 +-- Config.hs | 4 +-- Config/Smudge.hs | 11 +++--- Git/Hook.hs | 2 +- Git/Repair.hs | 8 ++--- Types/Backend.hs | 3 +- Types/KeySource.hs | 6 ++-- Utility/FileIO.hs | 9 +++++ Utility/FileMode.hs | 33 ++++++++--------- Utility/Gpg.hs | 2 +- Utility/LockFile/Posix.hs | 5 ++- Utility/Metered.hs | 9 ++--- Utility/SshConfig.hs | 4 +-- Utility/Tor.hs | 2 +- Utility/Url.hs | 2 +- 24 files changed, 180 insertions(+), 153 deletions(-) diff --git a/Annex/Hook.hs b/Annex/Hook.hs index 3241d3b556..086665abce 100644 --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -21,10 +21,11 @@ import Utility.Shell import qualified Data.Map as M preCommitHook :: Git.Hook -preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .") [] +preCommitHook = Git.Hook (literalOsPath "pre-commit") + (mkHookScript "git annex pre-commit .") [] postReceiveHook :: Git.Hook -postReceiveHook = Git.Hook "post-receive" +postReceiveHook = Git.Hook (literalOsPath "post-receive") -- Only run git-annex post-receive when git-annex supports it, -- to avoid failing if the repository with this hook is used -- with an older version of git-annex. @@ -34,10 +35,10 @@ postReceiveHook = Git.Hook "post-receive" ] postCheckoutHook :: Git.Hook -postCheckoutHook = Git.Hook "post-checkout" smudgeHook [] +postCheckoutHook = Git.Hook (literalOsPath "post-checkout") smudgeHook [] postMergeHook :: Git.Hook -postMergeHook = Git.Hook "post-merge" smudgeHook [] +postMergeHook = Git.Hook (literalOsPath "post-merge") smudgeHook [] -- Older versions of git-annex didn't support this command, but neither did -- they support v7 repositories. @@ -45,28 +46,28 @@ smudgeHook :: String smudgeHook = mkHookScript "git annex smudge --update" preCommitAnnexHook :: Git.Hook -preCommitAnnexHook = Git.Hook "pre-commit-annex" "" [] +preCommitAnnexHook = Git.Hook (literalOsPath "pre-commit-annex") "" [] postUpdateAnnexHook :: Git.Hook -postUpdateAnnexHook = Git.Hook "post-update-annex" "" [] +postUpdateAnnexHook = Git.Hook (literalOsPath "post-update-annex") "" [] preInitAnnexHook :: Git.Hook -preInitAnnexHook = Git.Hook "pre-init-annex" "" [] +preInitAnnexHook = Git.Hook (literalOsPath "pre-init-annex") "" [] freezeContentAnnexHook :: Git.Hook -freezeContentAnnexHook = Git.Hook "freezecontent-annex" "" [] +freezeContentAnnexHook = Git.Hook (literalOsPath "freezecontent-annex") "" [] thawContentAnnexHook :: Git.Hook -thawContentAnnexHook = Git.Hook "thawcontent-annex" "" [] +thawContentAnnexHook = Git.Hook (literalOsPath "thawcontent-annex") "" [] secureEraseAnnexHook :: Git.Hook -secureEraseAnnexHook = Git.Hook "secure-erase-annex" "" [] +secureEraseAnnexHook = Git.Hook (literalOsPath "secure-erase-annex") "" [] commitMessageAnnexHook :: Git.Hook -commitMessageAnnexHook = Git.Hook "commitmessage-annex" "" [] +commitMessageAnnexHook = Git.Hook (literalOsPath "commitmessage-annex") "" [] httpHeadersAnnexHook :: Git.Hook -httpHeadersAnnexHook = Git.Hook "http-headers-annex" "" [] +httpHeadersAnnexHook = Git.Hook (literalOsPath "http-headers-annex") "" [] mkHookScript :: String -> String mkHookScript s = unlines @@ -87,8 +88,8 @@ hookWarning :: Git.Hook -> String -> Annex () hookWarning h msg = do r <- gitRepo warning $ UnquotedString $ - fromRawFilePath (Git.hookName h) ++ - " hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg + fromOsPath (Git.hookName h) ++ + " hook (" ++ fromOsPath (Git.hookFile h r) ++ ") " ++ msg {- To avoid checking if the hook exists every time, the existing hooks - are cached. -} @@ -121,7 +122,7 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook) ( return Nothing , do h <- fromRepo (Git.hookFile hook) - commandfailed (fromRawFilePath h) + commandfailed (fromOsPath h) ) runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case Nothing -> return Nothing @@ -132,18 +133,19 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook) ) commandfailed c = return $ Just c -runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> RawFilePath -> Annex Bool +runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex Bool runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook) ( runhook , runcommandcfg ) where - runhook = inRepo $ Git.runHook boolSystem hook [ File (fromRawFilePath p) ] + runhook = inRepo $ Git.runHook boolSystem hook [ File p' ] runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case Nothing -> return True Just basecmd -> liftIO $ boolSystem "sh" [Param "-c", Param $ gencmd basecmd] - gencmd = massReplace [ (pathtoken, shellEscape (fromRawFilePath p)) ] + gencmd = massReplace [ (pathtoken, shellEscape p') ] + p' = fromOsPath p outputOfAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String) outputOfAnnexHook hook commandcfg = ifM (doesAnnexHookExist hook) diff --git a/Annex/Perms.hs b/Annex/Perms.hs index 03bce4fe83..9674873248 100644 --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -49,20 +49,20 @@ import System.PosixCompat.Files (fileMode, intersectFileModes, nullFileMode, gro withShared :: (SharedRepository -> Annex a) -> Annex a withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig -setAnnexFilePerm :: RawFilePath -> Annex () +setAnnexFilePerm :: OsPath -> Annex () setAnnexFilePerm = setAnnexPerm False -setAnnexDirPerm :: RawFilePath -> Annex () +setAnnexDirPerm :: OsPath -> Annex () setAnnexDirPerm = setAnnexPerm True {- Sets appropriate file mode for a file or directory in the annex, - other than the content files and content directory. Normally, - don't change the mode, but with core.sharedRepository set, - allow the group to write, etc. -} -setAnnexPerm :: Bool -> RawFilePath -> Annex () +setAnnexPerm :: Bool -> OsPath -> Annex () setAnnexPerm isdir file = setAnnexPerm' Nothing isdir >>= \go -> liftIO (go file) -setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (RawFilePath -> IO ()) +setAnnexPerm' :: Maybe ([FileMode] -> FileMode -> FileMode) -> Bool -> Annex (OsPath -> IO ()) setAnnexPerm' modef isdir = ifM crippledFileSystem ( return (const noop) , withShared $ \s -> return $ \file -> go s file @@ -79,11 +79,12 @@ setAnnexPerm' modef isdir = ifM crippledFileSystem Nothing -> noop Just f -> void $ tryIO $ modifyFileMode file $ f [] - go (UmaskShared n) file = void $ tryIO $ R.setFileMode file $ - if isdir then umaskSharedDirectory n else n + go (UmaskShared n) file = void $ tryIO $ + R.setFileMode (fromOsPath file) $ + if isdir then umaskSharedDirectory n else n modef' = fromMaybe addModes modef -resetAnnexFilePerm :: RawFilePath -> Annex () +resetAnnexFilePerm :: OsPath -> Annex () resetAnnexFilePerm = resetAnnexPerm False {- Like setAnnexPerm, but ignores the current mode of the file entirely, @@ -94,7 +95,7 @@ resetAnnexFilePerm = resetAnnexPerm False - which is going to be moved to a non-temporary location and needs - usual modes. -} -resetAnnexPerm :: Bool -> RawFilePath -> Annex () +resetAnnexPerm :: Bool -> OsPath -> Annex () resetAnnexPerm isdir file = unlessM crippledFileSystem $ do defmode <- liftIO defaultFileMode let modef moremodes _oldmode = addModes moremodes defmode @@ -115,7 +116,7 @@ annexFileMode = do {- Creates a directory inside the gitAnnexDir (or possibly the dbdir), - creating any parent directories up to and including the gitAnnexDir. - Makes directories with appropriate permissions. -} -createAnnexDirectory :: RawFilePath -> Annex () +createAnnexDirectory :: OsPath -> Annex () createAnnexDirectory dir = do top <- parentDir <$> fromRepo gitAnnexDir tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case @@ -124,7 +125,7 @@ createAnnexDirectory dir = do createDirectoryUnder' tops dir createdir where createdir p = do - liftIO $ R.createDirectory p + liftIO $ createDirectory p setAnnexDirPerm p {- Create a directory in the git work tree, creating any parent @@ -132,7 +133,7 @@ createAnnexDirectory dir = do - - Uses default permissions. -} -createWorkTreeDirectory :: RawFilePath -> Annex () +createWorkTreeDirectory :: OsPath -> Annex () createWorkTreeDirectory dir = do fromRepo repoWorkTree >>= liftIO . \case Just wt -> createDirectoryUnder [wt] dir @@ -159,16 +160,16 @@ createWorkTreeDirectory dir = do - it should not normally have. checkContentWritePerm can detect when - that happens with write permissions. -} -freezeContent :: RawFilePath -> Annex () +freezeContent :: OsPath -> Annex () freezeContent file = withShared $ \sr -> freezeContent' sr file -freezeContent' :: SharedRepository -> RawFilePath -> Annex () +freezeContent' :: SharedRepository -> OsPath -> Annex () freezeContent' sr file = freezeContent'' sr file =<< getVersion -freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex () +freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex () freezeContent'' sr file rv = do - fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file) + fastDebug "Annex.Perms" ("freezing content " ++ fromOsPath file) unlessM crippledFileSystem $ go sr freezeHook file where @@ -211,7 +212,7 @@ freezeContent'' sr file rv = do - support removing write permissions, so when there is such a hook - write permissions are ignored. -} -checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool) +checkContentWritePerm :: OsPath -> Annex (Maybe Bool) checkContentWritePerm file = ifM crippledFileSystem ( return (Just True) , do @@ -221,7 +222,7 @@ checkContentWritePerm file = ifM crippledFileSystem liftIO $ checkContentWritePerm' sr file rv hasfreezehook ) -checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool) +checkContentWritePerm' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool) checkContentWritePerm' sr file rv hasfreezehook | hasfreezehook = return (Just True) | otherwise = case sr of @@ -240,7 +241,7 @@ checkContentWritePerm' sr file rv hasfreezehook | otherwise -> want sharedret (\havemode -> havemode == removeModes writeModes n) where - want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file) + want mk f = catchMaybeIO (fileMode <$> R.getFileStatus (fromOsPath file)) >>= return . \case Just havemode -> mk (f havemode) Nothing -> mk True @@ -253,18 +254,19 @@ checkContentWritePerm' sr file rv hasfreezehook {- Allows writing to an annexed file that freezeContent was called on - before. -} -thawContent :: RawFilePath -> Annex () +thawContent :: OsPath -> Annex () thawContent file = withShared $ \sr -> thawContent' sr file -thawContent' :: SharedRepository -> RawFilePath -> Annex () +thawContent' :: SharedRepository -> OsPath -> Annex () thawContent' sr file = do - fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file) + fastDebug "Annex.Perms" ("thawing content " ++ fromOsPath file) thawPerms (go sr) (thawHook file) where go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file go AllShared = liftIO $ void $ tryIO $ groupWriteRead file go UnShared = liftIO $ allowWrite file - go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode file n + go (UmaskShared n) = liftIO $ void $ tryIO $ + R.setFileMode (fromOsPath file) n {- Runs an action that thaws a file's permissions. This will probably - fail on a crippled filesystem. But, if file modes are supported on a @@ -281,9 +283,9 @@ thawPerms a hook = ifM crippledFileSystem - is set, this is not done, since the group must be allowed to delete the - file without being able to thaw the directory. -} -freezeContentDir :: RawFilePath -> Annex () +freezeContentDir :: OsPath -> Annex () freezeContentDir file = do - fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir) + fastDebug "Annex.Perms" ("freezing content directory " ++ fromOsPath dir) unlessM crippledFileSystem $ withShared go freezeHook dir where @@ -291,29 +293,29 @@ freezeContentDir file = do go UnShared = liftIO $ preventWrite dir go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir go AllShared = liftIO $ void $ tryIO $ groupWriteRead dir - go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode dir $ + go (UmaskShared n) = liftIO $ void $ tryIO $ R.setFileMode (fromOsPath dir) $ umaskSharedDirectory $ - -- If n includes group or other write mode, leave them set - -- to allow them to delete the file without being able to - -- thaw the directory. + -- If n includes group or other write mode, leave + -- them set to allow them to delete the file without + -- being able to thaw the directory. removeModes [ownerWriteMode] n -thawContentDir :: RawFilePath -> Annex () +thawContentDir :: OsPath -> Annex () thawContentDir file = do - fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir) + fastDebug "Annex.Perms" ("thawing content directory " ++ fromOsPath dir) thawPerms (withShared (liftIO . go)) (thawHook dir) where dir = parentDir file go UnShared = allowWrite dir go GroupShared = allowWrite dir go AllShared = allowWrite dir - go (UmaskShared n) = R.setFileMode dir n + go (UmaskShared n) = R.setFileMode (fromOsPath dir) n {- Makes the directory tree to store an annexed file's content, - with appropriate permissions on each level. -} -createContentDir :: RawFilePath -> Annex () +createContentDir :: OsPath -> Annex () createContentDir dest = do - unlessM (liftIO $ R.doesPathExist dir) $ + unlessM (liftIO $ doesDirectoryExist dir) $ createAnnexDirectory dir -- might have already existed with restricted perms thawHook dir @@ -324,7 +326,7 @@ createContentDir dest = do {- Creates the content directory for a file if it doesn't already exist, - or thaws it if it does, then runs an action to modify a file in the - directory, and finally, freezes the content directory. -} -modifyContentDir :: RawFilePath -> Annex a -> Annex a +modifyContentDir :: OsPath -> Annex a -> Annex a modifyContentDir f a = do createContentDir f -- also thaws it v <- tryNonAsync a @@ -333,7 +335,7 @@ modifyContentDir f a = do {- Like modifyContentDir, but avoids creating the content directory if it - does not already exist. In that case, the action will probably fail. -} -modifyContentDirWhenExists :: RawFilePath -> Annex a -> Annex a +modifyContentDirWhenExists :: OsPath -> Annex a -> Annex a modifyContentDirWhenExists f a = do thawContentDir f v <- tryNonAsync a @@ -352,11 +354,11 @@ hasThawHook = <||> (doesAnnexHookExist thawContentAnnexHook) -freezeHook :: RawFilePath -> Annex () +freezeHook :: OsPath -> Annex () freezeHook = void . runAnnexPathHook "%path" freezeContentAnnexHook annexFreezeContentCommand -thawHook :: RawFilePath -> Annex () +thawHook :: OsPath -> Annex () thawHook = void . runAnnexPathHook "%path" thawContentAnnexHook annexThawContentCommand diff --git a/Annex/Url.hs b/Annex/Url.hs index e796b314b9..795b4b7b97 100644 --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -174,13 +174,13 @@ checkBoth url expected_size uo = Right r -> return r Left err -> warning (UnquotedString err) >> return False -download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex Bool +download :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex Bool download meterupdate iv url file uo = liftIO (U.download meterupdate iv url file uo) >>= \case Right () -> return True Left err -> warning (UnquotedString err) >> return False -download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> FilePath -> U.UrlOptions -> Annex (Either String ()) +download' :: MeterUpdate -> Maybe IncrementalVerifier -> U.URLString -> OsPath -> U.UrlOptions -> Annex (Either String ()) download' meterupdate iv url file uo = liftIO (U.download meterupdate iv url file uo) diff --git a/Annex/VariantFile.hs b/Annex/VariantFile.hs index 781732368d..fac1a6ca7a 100644 --- a/Annex/VariantFile.hs +++ b/Annex/VariantFile.hs @@ -5,21 +5,24 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.VariantFile where import Annex.Common import Utility.Hash +import qualified Utility.OsString as OS import qualified Data.ByteString as S -variantMarker :: String -variantMarker = ".variant-" +variantMarker :: OsPath +variantMarker = literalOsPath ".variant-" -mkVariant :: FilePath -> String -> FilePath +mkVariant :: OsPath -> OsPath -> OsPath mkVariant file variant = takeDirectory file dropExtension (takeFileName file) - ++ variantMarker ++ variant - ++ takeExtension file + <> variantMarker <> variant + <> takeExtension file {- The filename to use when resolving a conflicted merge of a file, - that points to a key. @@ -34,12 +37,12 @@ mkVariant file variant = takeDirectory file - conflicted merge resolution code. That case is detected, and the full - key is used in the filename. -} -variantFile :: FilePath -> Key -> FilePath +variantFile :: OsPath -> Key -> OsPath variantFile file key - | doubleconflict = mkVariant file (fromRawFilePath (keyFile key)) - | otherwise = mkVariant file (shortHash $ serializeKey' key) + | doubleconflict = mkVariant file (keyFile key) + | otherwise = mkVariant file (toOsPath (shortHash $ serializeKey' key)) where - doubleconflict = variantMarker `isInfixOf` file + doubleconflict = variantMarker `OS.isInfixOf` file shortHash :: S.ByteString -> String shortHash = take 4 . show . md5s diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs index 84dcbc897a..897e40929e 100644 --- a/Annex/View/ViewedFile.hs +++ b/Annex/View/ViewedFile.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Annex.View.ViewedFile ( @@ -20,13 +21,14 @@ module Annex.View.ViewedFile ( import Annex.Common import Utility.QuickCheck import Backend.Utilities (maxExtensions) +import qualified Utility.OsString as OS import qualified Data.ByteString as S type FileName = String type ViewedFile = FileName -type MkViewedFile = FilePath -> ViewedFile +type MkViewedFile = OsPath -> ViewedFile {- Converts a filepath used in a reference branch to the - filename that will be used in the view. @@ -44,23 +46,26 @@ viewedFileFromReference g = viewedFileFromReference' viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile viewedFileFromReference' maxextlen maxextensions f = concat $ - [ escape (fromRawFilePath base') - , if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%" + [ escape (fromOsPath base') + , if null dirs + then "" + else "_%" ++ intercalate "%" (map (escape . fromOsPath) dirs) ++ "%" , escape $ fromRawFilePath $ S.concat extensions' ] where (path, basefile) = splitFileName f - dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path) + dirs = filter (/= literalOsPath ".") $ + map dropTrailingPathSeparator (splitPath path) (base, extensions) = case maxextlen of - Nothing -> splitShortExtensions (toRawFilePath basefile') - Just n -> splitShortExtensions' (n+1) (toRawFilePath basefile') + Nothing -> splitShortExtensions basefile' + Just n -> splitShortExtensions' (n+1) basefile' {- Limit number of extensions. -} maxextensions' = fromMaybe maxExtensions maxextensions (base', extensions') | length extensions <= maxextensions' = (base, extensions) | otherwise = let (es,more) = splitAt maxextensions' (reverse extensions) - in (base <> mconcat (reverse more), reverse es) + in (base <> toOsPath (mconcat (reverse more)), reverse es) {- On Windows, if the filename looked like "dir/c:foo" then - basefile would look like it contains a drive letter, which will - not work. There cannot really be a filename like that, probably, @@ -85,12 +90,12 @@ escchar = '!' {- For use when operating already within a view, so whatever filepath - is present in the work tree is already a ViewedFile. -} viewedFileReuse :: MkViewedFile -viewedFileReuse = takeFileName +viewedFileReuse = fromOsPath . takeFileName {- Extracts from a ViewedFile the directory where the file is located on - in the reference branch. -} dirFromViewedFile :: ViewedFile -> FilePath -dirFromViewedFile = joinPath . drop 1 . sep [] "" +dirFromViewedFile = fromOsPath . joinPath . map toOsPath . drop 1 . sep [] "" where sep l _ [] = reverse l sep l curr (c:cs) @@ -103,10 +108,10 @@ dirFromViewedFile = joinPath . drop 1 . sep [] "" prop_viewedFile_roundtrips :: TestableFilePath -> Bool prop_viewedFile_roundtrips tf -- Relative filenames wanted, not directories. - | any (isPathSeparator) (end f ++ beginning f) = True - | isAbsolute f || isDrive f = True - | otherwise = dir == dirFromViewedFile - (viewedFileFromReference' Nothing Nothing f) + | OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True + | isAbsolute (toOsPath f) || isDrive (toOsPath f) = True + | otherwise = fromOsPath dir == dirFromViewedFile + (viewedFileFromReference' Nothing Nothing (toOsPath f)) where f = fromTestableFilePath tf - dir = joinPath $ beginning $ splitDirectories f + dir = joinPath $ beginning $ splitDirectories (toOsPath f) diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 3a9235c76d..69f2462557 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Assistant.Ssh where import Annex.Common @@ -94,7 +96,7 @@ genSshUrl sshdata = case sshRepoUrl sshdata of {- Reverses genSshUrl -} parseSshUrl :: String -> Maybe SshData parseSshUrl u - | "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u) + | "ssh://" `isPrefixOf` u = fromssh (drop (length ("ssh://" :: String)) u) | otherwise = fromrsync u where mkdata (userhost, dir) = Just $ SshData @@ -159,7 +161,7 @@ removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO () removeAuthorizedKeys gitannexshellonly dir pubkey = do let keyline = authorizedKeysLine gitannexshellonly dir pubkey sshdir <- sshDir - let keyfile = toOsPath $ toRawFilePath $ sshdir "authorized_keys" + let keyfile = sshdir literalOsPath "authorized_keys" tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case Just ls -> viaTmp writeSshConfig keyfile $ unlines $ filter (/= keyline) ls @@ -213,16 +215,16 @@ authorizedKeysLine gitannexshellonly dir pubkey {- Generates a ssh key pair. -} genSshKeyPair :: IO SshKeyPair -genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do +genSshKeyPair = withTmpDir (literalOsPath "git-annex-keygen") $ \dir -> do ok <- boolSystem "ssh-keygen" [ Param "-P", Param "" -- no password - , Param "-f", File $ dir "key" + , Param "-f", File $ fromOsPath (dir literalOsPath "key") ] unless ok $ giveup "ssh-keygen failed" SshKeyPair - <$> readFile (dir "key.pub") - <*> readFile (dir "key") + <$> readFile (fromOsPath (dir literalOsPath "key.pub")) + <*> readFile (fromOsPath (dir literalOsPath "key")) {- 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 @@ -245,25 +247,28 @@ genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir installSshKeyPair :: SshKeyPair -> SshData -> IO SshData installSshKeyPair sshkeypair sshdata = do sshdir <- sshDir - createDirectoryIfMissing True $ fromRawFilePath $ - parentDir $ toRawFilePath $ sshdir sshPrivKeyFile sshdata + createDirectoryIfMissing True $ + parentDir $ sshdir sshPrivKeyFile sshdata unlessM (doesFileExist $ sshdir sshPrivKeyFile sshdata) $ - writeFileProtected (toRawFilePath (sshdir sshPrivKeyFile sshdata)) (sshPrivKey sshkeypair) + writeFileProtected (sshdir sshPrivKeyFile sshdata) + (sshPrivKey sshkeypair) unlessM (doesFileExist $ sshdir sshPubKeyFile sshdata) $ - writeFile (sshdir sshPubKeyFile sshdata) (sshPubKey sshkeypair) + writeFile (fromOsPath (sshdir sshPubKeyFile sshdata)) + (sshPubKey sshkeypair) setSshConfig sshdata - [ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata) + [ ("IdentityFile", "~/.ssh/" ++ fromOsPath (sshPrivKeyFile sshdata)) , ("IdentitiesOnly", "yes") , ("StrictHostKeyChecking", "yes") ] -sshPrivKeyFile :: SshData -> FilePath -sshPrivKeyFile sshdata = "git-annex" "key." ++ mangleSshHostName sshdata +sshPrivKeyFile :: SshData -> OsPath +sshPrivKeyFile sshdata = literalOsPath "git-annex" + literalOsPath "key." <> toOsPath (mangleSshHostName sshdata) -sshPubKeyFile :: SshData -> FilePath -sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub" +sshPubKeyFile :: SshData -> OsPath +sshPubKeyFile sshdata = sshPrivKeyFile sshdata <> literalOsPath ".pub" {- Generates an installs a new ssh key pair if one is not already - installed. Returns the modified SshData that will use the key pair, @@ -271,8 +276,8 @@ sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub" setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair) setupSshKeyPair sshdata = do sshdir <- sshDir - mprivkey <- catchMaybeIO $ readFile (sshdir sshPrivKeyFile sshdata) - mpubkey <- catchMaybeIO $ readFile (sshdir sshPubKeyFile sshdata) + mprivkey <- catchMaybeIO $ readFile (fromOsPath (sshdir sshPrivKeyFile sshdata)) + mpubkey <- catchMaybeIO $ readFile (fromOsPath (sshdir sshPubKeyFile sshdata)) keypair <- case (mprivkey, mpubkey) of (Just privkey, Just pubkey) -> return $ SshKeyPair { sshPubKey = pubkey @@ -324,7 +329,7 @@ setSshConfig :: SshData -> [(String, String)] -> IO SshData setSshConfig sshdata config = do sshdir <- sshDir createDirectoryIfMissing True sshdir - let configfile = sshdir "config" + let configfile = fromOsPath (sshdir literalOsPath "config") unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do appendFile configfile $ unlines $ [ "" @@ -332,7 +337,7 @@ setSshConfig sshdata config = do , "Host " ++ mangledhost ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) (settings ++ config) - setSshConfigMode (toRawFilePath configfile) + setSshConfigMode (toOsPath configfile) return $ sshdata { sshHostName = T.pack mangledhost @@ -403,7 +408,7 @@ unMangleSshHostName h = case splitc '-' h of knownHost :: Text -> IO Bool knownHost hostname = do sshdir <- sshDir - ifM (doesFileExist $ sshdir "known_hosts") + ifM (doesFileExist $ sshdir literalOsPath "known_hosts") ( not . null <$> checkhost , return False ) diff --git a/Backend/GitRemoteAnnex.hs b/Backend/GitRemoteAnnex.hs index 2eaba4a4d6..02b60244a5 100644 --- a/Backend/GitRemoteAnnex.hs +++ b/Backend/GitRemoteAnnex.hs @@ -75,7 +75,7 @@ sameCheckSum key s = s == expected expected = reverse $ takeWhile (/= '-') $ reverse $ decodeBS $ S.fromShort $ fromKey keyName key -genGitBundleKey :: UUID -> RawFilePath -> MeterUpdate -> Annex Key +genGitBundleKey :: UUID -> OsPath -> MeterUpdate -> Annex Key genGitBundleKey remoteuuid file meterupdate = do filesize <- liftIO $ getFileSize file s <- Hash.hashFile hash file meterupdate diff --git a/Backend/Hash.hs b/Backend/Hash.hs index 80cd8e64d8..652bd796d7 100644 --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -127,7 +127,7 @@ keyValueE hash source meterupdate = keyValue hash source meterupdate >>= addE source (const $ hashKeyVariety hash (HasExt True)) -checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> RawFilePath -> Annex Bool +checkKeyChecksum :: (Key -> String -> Bool) -> Hash -> Key -> OsPath -> Annex Bool checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do showAction (UnquotedString descChecksum) issame key @@ -187,7 +187,7 @@ trivialMigrate' oldkey newbackend afile maxextlen maxexts AssociatedFile Nothing -> Nothing AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d { keyName = S.toShort $ keyHash oldkey - <> selectExtension maxextlen maxexts file + <> selectExtension maxextlen maxexts (fromOsPath file) , keyVariety = newvariety } {- Upgrade to fix bad previous migration that created a @@ -205,9 +205,9 @@ trivialMigrate' oldkey newbackend afile maxextlen maxexts oldvariety = fromKey keyVariety oldkey newvariety = backendVariety newbackend -hashFile :: Hash -> RawFilePath -> MeterUpdate -> Annex String +hashFile :: Hash -> OsPath -> MeterUpdate -> Annex String hashFile hash file meterupdate = - liftIO $ withMeteredFile (fromRawFilePath file) meterupdate $ \b -> do + liftIO $ withMeteredFile file meterupdate $ \b -> do let h = (fst $ hasher hash) b -- Force full evaluation of hash so whole file is read -- before returning. diff --git a/Backend/Utilities.hs b/Backend/Utilities.hs index 244ded29e5..69da541452 100644 --- a/Backend/Utilities.hs +++ b/Backend/Utilities.hs @@ -49,7 +49,7 @@ addE source sethasext k = do let ext = selectExtension (annexMaxExtensionLength c) (annexMaxExtensions c) - (keyFilename source) + (fromOsPath (keyFilename source)) return $ alterKey k $ \d -> d { keyName = keyName d <> S.toShort ext , keyVariety = sethasext (keyVariety d) diff --git a/Backend/WORM.hs b/Backend/WORM.hs index 2e2df45004..1eb95d28b0 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -42,9 +42,9 @@ backend = Backend keyValue :: KeySource -> MeterUpdate -> Annex Key keyValue source _ = do let f = contentLocation source - stat <- liftIO $ R.getFileStatus f + stat <- liftIO $ R.getFileStatus (fromOsPath f) sz <- liftIO $ getFileSize' f stat - relf <- fromRawFilePath . getTopFilePath + relf <- fromOsPath . getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) return $ mkKey $ \k -> k { keyName = genKeyName relf diff --git a/Config.hs b/Config.hs index 15dce780d0..892c49d4a5 100644 --- a/Config.hs +++ b/Config.hs @@ -94,7 +94,7 @@ setCrippledFileSystem :: Bool -> Annex () setCrippledFileSystem b = setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) -pidLockFile :: Annex (Maybe RawFilePath) +pidLockFile :: Annex (Maybe OsPath) #ifndef mingw32_HOST_OS pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) ( Just <$> Annex.fromRepo gitAnnexPidLockFile @@ -111,4 +111,4 @@ splitRemoteAnnexTrackingBranchSubdir tb = (branch, subdir) branch = Git.Ref b subdir = if S.null p then Nothing - else Just (asTopFilePath p) + else Just (asTopFilePath (toOsPath p)) diff --git a/Config/Smudge.hs b/Config/Smudge.hs index aa89990c0a..c17eaa1bca 100644 --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -20,7 +20,6 @@ import Annex.Version import qualified Utility.FileIO as F import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P configureSmudgeFilter :: Annex () configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do @@ -47,11 +46,11 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do gfs <- readattr gf gittop <- Git.localGitDir <$> gitRepo liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do - createDirectoryUnder [gittop] (P.takeDirectory lf) - F.writeFile' (toOsPath lf) $ + createDirectoryUnder [gittop] (takeDirectory lf) + F.writeFile' lf $ linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr)) where - readattr = liftIO . catchDefaultIO mempty . F.readFile' . toOsPath + readattr = liftIO . catchDefaultIO mempty . F.readFile' configureSmudgeFilterProcess :: Annex () configureSmudgeFilterProcess = @@ -70,8 +69,8 @@ deconfigureSmudgeFilter :: Annex () deconfigureSmudgeFilter = do lf <- Annex.fromRepo Git.attributesLocal ls <- liftIO $ catchDefaultIO [] $ - map decodeBS . fileLines' <$> F.readFile' (toOsPath lf) - liftIO $ writeFile (fromRawFilePath lf) $ unlines $ + map decodeBS . fileLines' <$> F.readFile' lf + liftIO $ writeFile (fromOsPath lf) $ unlines $ filter (\l -> l `notElem` stdattr && not (null l)) ls unsetConfig (ConfigKey "filter.annex.smudge") unsetConfig (ConfigKey "filter.annex.clean") diff --git a/Git/Hook.hs b/Git/Hook.hs index ce0782dd23..ef04bbca6f 100644 --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -64,7 +64,7 @@ hookWrite h r = ifM (doesFileExist f) -- they typically use unix newlines, which does work there -- and makes the repository more portable. viaTmp F.writeFile' f (encodeBS (hookScript h)) - void $ tryIO $ modifyFileMode (fromOsPath f) (addModes executeModes) + void $ tryIO $ modifyFileMode f (addModes executeModes) return True {- Removes a hook. Returns False if the hook contained something else, and diff --git a/Git/Repair.hs b/Git/Repair.hs index 2ea0b10bee..30fc3fb720 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -61,7 +61,7 @@ cleanCorruptObjects fsckresults r = do removeLoose s = removeWhenExistsWith R.removeLink $ fromOsPath $ looseObjectFile r s removeBad s = do - void $ tryIO $ allowRead $ fromOsPath $ looseObjectFile r s + void $ tryIO $ allowRead $ looseObjectFile r s whenM (isMissing s r) $ removeLoose s @@ -85,7 +85,7 @@ explodePacks r = go =<< listPackFiles r putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do -- Just in case permissions are messed up. - allowRead (fromOsPath packfile) + allowRead packfile -- May fail, if pack file is corrupt. void $ tryIO $ pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> @@ -477,7 +477,7 @@ preRepair g = do writeFile (fromOsPath headfile) "ref: refs/heads/master" explodePackedRefsFile g unless (repoIsLocalBare g) $ - void $ tryIO $ allowWrite $ fromOsPath $ indexFile g + void $ tryIO $ allowWrite $ indexFile g where headfile = localGitDir g literalOsPath "HEAD" validhead s = "ref: refs/" `isPrefixOf` s @@ -652,5 +652,5 @@ successfulRepair = fst safeReadFile :: OsPath -> IO B.ByteString safeReadFile f = do - allowRead (fromOsPath f) + allowRead f F.readFile' f diff --git a/Types/Backend.hs b/Types/Backend.hs index e4035916ee..b57953d319 100644 --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -12,6 +12,7 @@ module Types.Backend where import Types.Key import Types.KeySource import Utility.Metered +import Utility.OsPath import Utility.FileSystemEncoding import Utility.Hash (IncrementalVerifier) @@ -20,7 +21,7 @@ data BackendA a = Backend , genKey :: Maybe (KeySource -> MeterUpdate -> a Key) -- Verifies the content of a key, stored in a file, using a hash. -- This does not need to be cryptographically secure. - , verifyKeyContent :: Maybe (Key -> RawFilePath -> a Bool) + , verifyKeyContent :: Maybe (Key -> OsPath -> a Bool) -- Incrementally verifies the content of a key, using the same -- hash as verifyKeyContent, but with the content provided -- incrementally a piece at a time, until finalized. diff --git a/Types/KeySource.hs b/Types/KeySource.hs index e139340548..a96889f797 100644 --- a/Types/KeySource.hs +++ b/Types/KeySource.hs @@ -8,7 +8,7 @@ module Types.KeySource where import Utility.InodeCache -import System.FilePath.ByteString (RawFilePath) +import Utility.OsPath {- When content is in the process of being ingested into the annex, - and a Key generated from it, this data type is used. @@ -23,8 +23,8 @@ import System.FilePath.ByteString (RawFilePath) - files that may be made while they're in the process of being ingested. -} data KeySource = KeySource - { keyFilename :: RawFilePath - , contentLocation :: RawFilePath + { keyFilename :: OsPath + , contentLocation :: OsPath , inodeCache :: Maybe InodeCache } deriving (Show) diff --git a/Utility/FileIO.hs b/Utility/FileIO.hs index f8feb66886..ac7fe7f340 100644 --- a/Utility/FileIO.hs +++ b/Utility/FileIO.hs @@ -16,6 +16,7 @@ module Utility.FileIO ( withFile, openFile, + withBinaryFile, openBinaryFile, readFile, readFile', @@ -52,6 +53,11 @@ openFile f m = do f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) O.openFile f' m +withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile f m a = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.withBinaryFile f' m a + openBinaryFile :: OsPath -> IOMode -> IO Handle openBinaryFile f m = do f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) @@ -110,6 +116,9 @@ withFile = System.IO.withFile . fromRawFilePath openFile :: OsPath -> IOMode -> IO Handle openFile = System.IO.openFile . fromRawFilePath +withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile = System.IO.withBinaryFile . fromRawFilePath + openBinaryFile :: OsPath -> IOMode -> IO Handle openBinaryFile = System.IO.openBinaryFile . fromRawFilePath diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 95e5d570ef..a4d5cc5a20 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -25,26 +25,27 @@ import Foreign (complement) import Control.Monad.Catch import Utility.Exception -import Utility.FileSystemEncoding import qualified Utility.RawFilePath as R import qualified Utility.FileIO as F import Utility.OsPath {- Applies a conversion function to a file's mode. -} -modifyFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO () +modifyFileMode :: OsPath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert -modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode +modifyFileMode' :: OsPath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' f convert = do - s <- R.getFileStatus f + s <- R.getFileStatus f' let old = fileMode s let new = convert old when (new /= old) $ - R.setFileMode f new + R.setFileMode f' new return old + where + f' = fromOsPath f {- Runs an action after changing a file's mode, then restores the old mode. -} -withModifiedFileMode :: RawFilePath -> (FileMode -> FileMode) -> IO a -> IO a +withModifiedFileMode :: OsPath -> (FileMode -> FileMode) -> IO a -> IO a withModifiedFileMode file convert a = bracket setup cleanup go where setup = modifyFileMode' file convert @@ -77,15 +78,15 @@ otherGroupModes = ] {- Removes the write bits from a file. -} -preventWrite :: RawFilePath -> IO () +preventWrite :: OsPath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes {- Turns a file's owner write bit back on. -} -allowWrite :: RawFilePath -> IO () +allowWrite :: OsPath -> IO () allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] {- Turns a file's owner read bit back on. -} -allowRead :: RawFilePath -> IO () +allowRead :: OsPath -> IO () allowRead f = modifyFileMode f $ addModes [ownerReadMode] {- Allows owner and group to read and write to a file. -} @@ -95,7 +96,7 @@ groupSharedModes = , ownerReadMode, groupReadMode ] -groupWriteRead :: RawFilePath -> IO () +groupWriteRead :: OsPath -> IO () groupWriteRead f = modifyFileMode f $ addModes groupSharedModes checkMode :: FileMode -> FileMode -> Bool @@ -105,13 +106,13 @@ checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor isExecutable :: FileMode -> Bool isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 -data ModeSetter = ModeSetter FileMode (RawFilePath -> IO ()) +data ModeSetter = ModeSetter FileMode (OsPath -> IO ()) {- Runs an action which should create the file, passing it the desired - initial file mode. Then runs the ModeSetter's action on the file, which - can adjust the initial mode if umask prevented the file from being - created with the right mode. -} -applyModeSetter :: Maybe ModeSetter -> RawFilePath -> (Maybe FileMode -> IO a) -> IO a +applyModeSetter :: Maybe ModeSetter -> OsPath -> (Maybe FileMode -> IO a) -> IO a applyModeSetter (Just (ModeSetter mode modeaction)) file a = do r <- a (Just mode) void $ tryIO $ modeaction file @@ -159,7 +160,7 @@ isSticky = checkMode stickyMode stickyMode :: FileMode stickyMode = 512 -setSticky :: RawFilePath -> IO () +setSticky :: OsPath -> IO () setSticky f = modifyFileMode f $ addModes [stickyMode] #endif @@ -172,15 +173,15 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - On a filesystem that does not support file permissions, this is the same - as writeFile. -} -writeFileProtected :: RawFilePath -> String -> IO () +writeFileProtected :: OsPath -> String -> IO () writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) -writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' :: OsPath -> (Handle -> IO ()) -> IO () writeFileProtected' file writer = bracket setup cleanup writer where setup = do - h <- protectedOutput $ F.openFile (toOsPath file) WriteMode + h <- protectedOutput $ F.openFile file WriteMode void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes return h cleanup = hClose diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs index 29d51ce056..781b9a4a58 100644 --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -418,7 +418,7 @@ testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd)) origenviron <- getEnvironment let environ = addEntry var (fromOsPath subdir) origenviron -- gpg is picky about permissions on its home dir - liftIO $ void $ tryIO $ modifyFileMode (fromOsPath subdir) $ + liftIO $ void $ tryIO $ modifyFileMode subdir $ removeModes $ otherGroupModes -- For some reason, recent gpg needs a trustdb to be set up. _ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs index 5c7dd33f08..f74e3691a7 100644 --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -75,12 +75,11 @@ tryLock lockreq mode lockfile = uninterruptibleMask_ $ do -- Close on exec flag is set so child processes do not inherit the lock. openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd openLockFile lockreq filemode lockfile = do - l <- applyModeSetter filemode lockfile' $ \filemode' -> - openFdWithMode lockfile' openfor filemode' defaultFileFlags + l <- applyModeSetter filemode lockfile $ \filemode' -> + openFdWithMode (fromOsPath lockfile) openfor filemode' defaultFileFlags setFdOption l CloseOnExec True return l where - lockfile' = fromOsPath lockfile openfor = case lockreq of ReadLock -> ReadOnly _ -> ReadWrite diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 9785cf692e..f66e3833f1 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -55,6 +55,7 @@ import Utility.HumanTime import Utility.SimpleProtocol as Proto import Utility.ThreadScheduler import Utility.SafeOutput +import qualified Utility.FileIO as F import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -121,8 +122,8 @@ zeroBytesProcessed = BytesProcessed 0 {- Sends the content of a file to an action, updating the meter as it's - consumed. -} -withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a -withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> +withMeteredFile :: OsPath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a +withMeteredFile f meterupdate a = F.withBinaryFile f ReadMode $ \h -> hGetContentsMetered h meterupdate >>= a {- Calls the action repeatedly with chunks from the lazy ByteString. @@ -140,8 +141,8 @@ meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks meterupdate sofar' go sofar' cs -meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () -meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> +meteredWriteFile :: MeterUpdate -> OsPath -> L.ByteString -> IO () +meteredWriteFile meterupdate f b = F.withBinaryFile f WriteMode $ \h -> meteredWrite meterupdate (S.hPut h) b {- Applies an offset to a MeterUpdate. This can be useful when diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs index e341b73894..fcd725d077 100644 --- a/Utility/SshConfig.hs +++ b/Utility/SshConfig.hs @@ -150,7 +150,7 @@ changeUserSshConfig modifier = do writeSshConfig :: OsPath -> String -> IO () writeSshConfig f s = do F.writeFile' f (linesFile' (encodeBS s)) - setSshConfigMode (fromOsPath f) + setSshConfigMode 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 @@ -159,7 +159,7 @@ writeSshConfig f s = do - If the chmod fails, ignore the failure, as it might be a filesystem like - Android's that does not support file modes. -} -setSshConfigMode :: RawFilePath -> IO () +setSshConfigMode :: OsPath -> IO () setSshConfigMode f = void $ tryIO $ modifyFileMode f $ removeModes [groupWriteMode, otherWriteMode] diff --git a/Utility/Tor.hs b/Utility/Tor.hs index eeabbbae79..cd564d14ae 100644 --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -171,7 +171,7 @@ prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO () prepHiddenServiceSocketDir appname uid ident = do createDirectoryIfMissing True d setOwnerAndGroup (fromOsPath d) uid (-1) - modifyFileMode (fromOsPath d) $ + modifyFileMode d $ addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] where d = takeDirectory $ hiddenServiceSocketFile appname uid ident diff --git a/Utility/Url.hs b/Utility/Url.hs index 9100d80711..d98ade2738 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -433,7 +433,7 @@ download' nocurlerror meterupdate iv url file uo = downloadfile u = do noverification - let src = unEscapeString (uriPath u) + let src = toOsPath $ unEscapeString (uriPath u) withMeteredFile src meterupdate $ F.writeFile file return $ Right ()