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

more OsPath conversion

Browse source 
Sponsored-by: Nicholas Golder-Manning
This commit is contained in:
Joey Hess 2025-01-29 11:53:20 -04:00
parent 0376bc5ee0
commit 27305042f3
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
24 changed files with 180 additions and 153 deletions
Download patch file Download diff file Expand all files Collapse all files

38
Annex/Hook.hs
View file

@ -21,10 +21,11 @@ import Utility.Shell
import qualified Data.Map as M import qualified Data.Map as M
preCommitHook :: Git.Hook 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
postReceiveHook = Git.Hook "post-receive" postReceiveHook = Git.Hook (literalOsPath "post-receive")
-- Only run git-annex post-receive when git-annex supports it, -- Only run git-annex post-receive when git-annex supports it,
-- to avoid failing if the repository with this hook is used -- to avoid failing if the repository with this hook is used
-- with an older version of git-annex. -- with an older version of git-annex.
@ -34,10 +35,10 @@ postReceiveHook = Git.Hook "post-receive"
] ]
postCheckoutHook :: Git.Hook postCheckoutHook :: Git.Hook
postCheckoutHook = Git.Hook "post-checkout" smudgeHook [] postCheckoutHook = Git.Hook (literalOsPath "post-checkout") smudgeHook []
postMergeHook :: Git.Hook 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 -- Older versions of git-annex didn't support this command, but neither did
-- they support v7 repositories. -- they support v7 repositories.
@ -45,28 +46,28 @@ smudgeHook :: String
smudgeHook = mkHookScript "git annex smudge --update" smudgeHook = mkHookScript "git annex smudge --update"
preCommitAnnexHook :: Git.Hook preCommitAnnexHook :: Git.Hook
preCommitAnnexHook = Git.Hook "pre-commit-annex" "" [] preCommitAnnexHook = Git.Hook (literalOsPath "pre-commit-annex") "" []
postUpdateAnnexHook :: Git.Hook postUpdateAnnexHook :: Git.Hook
postUpdateAnnexHook = Git.Hook "post-update-annex" "" [] postUpdateAnnexHook = Git.Hook (literalOsPath "post-update-annex") "" []
preInitAnnexHook :: Git.Hook preInitAnnexHook :: Git.Hook
preInitAnnexHook = Git.Hook "pre-init-annex" "" [] preInitAnnexHook = Git.Hook (literalOsPath "pre-init-annex") "" []
freezeContentAnnexHook :: Git.Hook freezeContentAnnexHook :: Git.Hook
freezeContentAnnexHook = Git.Hook "freezecontent-annex" "" [] freezeContentAnnexHook = Git.Hook (literalOsPath "freezecontent-annex") "" []
thawContentAnnexHook :: Git.Hook thawContentAnnexHook :: Git.Hook
thawContentAnnexHook = Git.Hook "thawcontent-annex" "" [] thawContentAnnexHook = Git.Hook (literalOsPath "thawcontent-annex") "" []
secureEraseAnnexHook :: Git.Hook secureEraseAnnexHook :: Git.Hook
secureEraseAnnexHook = Git.Hook "secure-erase-annex" "" [] secureEraseAnnexHook = Git.Hook (literalOsPath "secure-erase-annex") "" []
commitMessageAnnexHook :: Git.Hook commitMessageAnnexHook :: Git.Hook
commitMessageAnnexHook = Git.Hook "commitmessage-annex" "" [] commitMessageAnnexHook = Git.Hook (literalOsPath "commitmessage-annex") "" []
httpHeadersAnnexHook :: Git.Hook httpHeadersAnnexHook :: Git.Hook
httpHeadersAnnexHook = Git.Hook "http-headers-annex" "" [] httpHeadersAnnexHook = Git.Hook (literalOsPath "http-headers-annex") "" []
mkHookScript :: String -> String mkHookScript :: String -> String
mkHookScript s = unlines mkHookScript s = unlines
@ -87,8 +88,8 @@ hookWarning :: Git.Hook -> String -> Annex ()
hookWarning h msg = do hookWarning h msg = do
r <- gitRepo r <- gitRepo
warning $ UnquotedString $ warning $ UnquotedString $
fromRawFilePath (Git.hookName h) ++ fromOsPath (Git.hookName h) ++
" hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg " hook (" ++ fromOsPath (Git.hookFile h r) ++ ") " ++ msg
{- To avoid checking if the hook exists every time, the existing hooks {- To avoid checking if the hook exists every time, the existing hooks
- are cached. -} - are cached. -}
@ -121,7 +122,7 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook)
( return Nothing ( return Nothing
, do , do
h <- fromRepo (Git.hookFile hook) h <- fromRepo (Git.hookFile hook)
commandfailed (fromRawFilePath h) commandfailed (fromOsPath h)
) )
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return Nothing Nothing -> return Nothing
@ -132,18 +133,19 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook)
) )
commandfailed c = return $ Just c 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) runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook)
( runhook ( runhook
, runcommandcfg , runcommandcfg
) )
where where
runhook = inRepo $ Git.runHook boolSystem hook [ File (fromRawFilePath p) ] runhook = inRepo $ Git.runHook boolSystem hook [ File p' ]
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
Nothing -> return True Nothing -> return True
Just basecmd -> liftIO $ Just basecmd -> liftIO $
boolSystem "sh" [Param "-c", Param $ gencmd basecmd] 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 :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String)
outputOfAnnexHook hook commandcfg = ifM (doesAnnexHookExist hook) outputOfAnnexHook hook commandcfg = ifM (doesAnnexHookExist hook)

76
Annex/Perms.hs
View file

@ -49,20 +49,20 @@ import System.PosixCompat.Files (fileMode, intersectFileModes, nullFileMode, gro
withShared :: (SharedRepository -> Annex a) -> Annex a withShared :: (SharedRepository -> Annex a) -> Annex a
withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig withShared a = a =<< coreSharedRepository <$> Annex.getGitConfig
setAnnexFilePerm :: RawFilePath -> Annex () setAnnexFilePerm :: OsPath -> Annex ()
setAnnexFilePerm = setAnnexPerm False setAnnexFilePerm = setAnnexPerm False
setAnnexDirPerm :: RawFilePath -> Annex () setAnnexDirPerm :: OsPath -> Annex ()
setAnnexDirPerm = setAnnexPerm True setAnnexDirPerm = setAnnexPerm True
{- Sets appropriate file mode for a file or directory in the annex, {- Sets appropriate file mode for a file or directory in the annex,
- other than the content files and content directory. Normally, - other than the content files and content directory. Normally,
- don't change the mode, but with core.sharedRepository set, - don't change the mode, but with core.sharedRepository set,
- allow the group to write, etc. -} - 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 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 setAnnexPerm' modef isdir = ifM crippledFileSystem
( return (const noop) ( return (const noop)
, withShared $ \s -> return $ \file -> go s file , withShared $ \s -> return $ \file -> go s file
@ -79,11 +79,12 @@ setAnnexPerm' modef isdir = ifM crippledFileSystem
Nothing -> noop Nothing -> noop
Just f -> void $ tryIO $ Just f -> void $ tryIO $
modifyFileMode file $ f [] modifyFileMode file $ f []
go (UmaskShared n) file = void $ tryIO $ R.setFileMode file $ go (UmaskShared n) file = void $ tryIO $
if isdir then umaskSharedDirectory n else n R.setFileMode (fromOsPath file) $
if isdir then umaskSharedDirectory n else n
modef' = fromMaybe addModes modef modef' = fromMaybe addModes modef
resetAnnexFilePerm :: RawFilePath -> Annex () resetAnnexFilePerm :: OsPath -> Annex ()
resetAnnexFilePerm = resetAnnexPerm False resetAnnexFilePerm = resetAnnexPerm False
{- Like setAnnexPerm, but ignores the current mode of the file entirely, {- 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 - which is going to be moved to a non-temporary location and needs
- usual modes. - usual modes.
-} -}
resetAnnexPerm :: Bool -> RawFilePath -> Annex () resetAnnexPerm :: Bool -> OsPath -> Annex ()
resetAnnexPerm isdir file = unlessM crippledFileSystem $ do resetAnnexPerm isdir file = unlessM crippledFileSystem $ do
defmode <- liftIO defaultFileMode defmode <- liftIO defaultFileMode
let modef moremodes _oldmode = addModes moremodes defmode let modef moremodes _oldmode = addModes moremodes defmode
@ -115,7 +116,7 @@ annexFileMode = do
{- Creates a directory inside the gitAnnexDir (or possibly the dbdir), {- Creates a directory inside the gitAnnexDir (or possibly the dbdir),
- creating any parent directories up to and including the gitAnnexDir. - creating any parent directories up to and including the gitAnnexDir.
- Makes directories with appropriate permissions. -} - Makes directories with appropriate permissions. -}
createAnnexDirectory :: RawFilePath -> Annex () createAnnexDirectory :: OsPath -> Annex ()
createAnnexDirectory dir = do createAnnexDirectory dir = do
top <- parentDir <$> fromRepo gitAnnexDir top <- parentDir <$> fromRepo gitAnnexDir
tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case tops <- annexDbDir <$> Annex.getGitConfig >>= return . \case
@ -124,7 +125,7 @@ createAnnexDirectory dir = do
createDirectoryUnder' tops dir createdir createDirectoryUnder' tops dir createdir
where where
createdir p = do createdir p = do
liftIO $ R.createDirectory p liftIO $ createDirectory p
setAnnexDirPerm p setAnnexDirPerm p
{- Create a directory in the git work tree, creating any parent {- Create a directory in the git work tree, creating any parent
@ -132,7 +133,7 @@ createAnnexDirectory dir = do
- -
- Uses default permissions. - Uses default permissions.
-} -}
createWorkTreeDirectory :: RawFilePath -> Annex () createWorkTreeDirectory :: OsPath -> Annex ()
createWorkTreeDirectory dir = do createWorkTreeDirectory dir = do
fromRepo repoWorkTree >>= liftIO . \case fromRepo repoWorkTree >>= liftIO . \case
Just wt -> createDirectoryUnder [wt] dir Just wt -> createDirectoryUnder [wt] dir
@ -159,16 +160,16 @@ createWorkTreeDirectory dir = do
- it should not normally have. checkContentWritePerm can detect when - it should not normally have. checkContentWritePerm can detect when
- that happens with write permissions. - that happens with write permissions.
-} -}
freezeContent :: RawFilePath -> Annex () freezeContent :: OsPath -> Annex ()
freezeContent file = freezeContent file =
withShared $ \sr -> freezeContent' sr file withShared $ \sr -> freezeContent' sr file
freezeContent' :: SharedRepository -> RawFilePath -> Annex () freezeContent' :: SharedRepository -> OsPath -> Annex ()
freezeContent' sr file = freezeContent'' sr file =<< getVersion freezeContent' sr file = freezeContent'' sr file =<< getVersion
freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex () freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex ()
freezeContent'' sr file rv = do freezeContent'' sr file rv = do
fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file) fastDebug "Annex.Perms" ("freezing content " ++ fromOsPath file)
unlessM crippledFileSystem $ go sr unlessM crippledFileSystem $ go sr
freezeHook file freezeHook file
where where
@ -211,7 +212,7 @@ freezeContent'' sr file rv = do
- support removing write permissions, so when there is such a hook - support removing write permissions, so when there is such a hook
- write permissions are ignored. - write permissions are ignored.
-} -}
checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool) checkContentWritePerm :: OsPath -> Annex (Maybe Bool)
checkContentWritePerm file = ifM crippledFileSystem checkContentWritePerm file = ifM crippledFileSystem
( return (Just True) ( return (Just True)
, do , do
@ -221,7 +222,7 @@ checkContentWritePerm file = ifM crippledFileSystem
liftIO $ checkContentWritePerm' sr file rv hasfreezehook 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 checkContentWritePerm' sr file rv hasfreezehook
| hasfreezehook = return (Just True) | hasfreezehook = return (Just True)
| otherwise = case sr of | otherwise = case sr of
@ -240,7 +241,7 @@ checkContentWritePerm' sr file rv hasfreezehook
| otherwise -> want sharedret | otherwise -> want sharedret
(\havemode -> havemode == removeModes writeModes n) (\havemode -> havemode == removeModes writeModes n)
where where
want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file) want mk f = catchMaybeIO (fileMode <$> R.getFileStatus (fromOsPath file))
>>= return . \case >>= return . \case
Just havemode -> mk (f havemode) Just havemode -> mk (f havemode)
Nothing -> mk True Nothing -> mk True
@ -253,18 +254,19 @@ checkContentWritePerm' sr file rv hasfreezehook
{- Allows writing to an annexed file that freezeContent was called on {- Allows writing to an annexed file that freezeContent was called on
- before. -} - before. -}
thawContent :: RawFilePath -> Annex () thawContent :: OsPath -> Annex ()
thawContent file = withShared $ \sr -> thawContent' sr file thawContent file = withShared $ \sr -> thawContent' sr file
thawContent' :: SharedRepository -> RawFilePath -> Annex () thawContent' :: SharedRepository -> OsPath -> Annex ()
thawContent' sr file = do thawContent' sr file = do
fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file) fastDebug "Annex.Perms" ("thawing content " ++ fromOsPath file)
thawPerms (go sr) (thawHook file) thawPerms (go sr) (thawHook file)
where where
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file
go AllShared = liftIO $ void $ tryIO $ groupWriteRead file go AllShared = liftIO $ void $ tryIO $ groupWriteRead file
go UnShared = liftIO $ allowWrite 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 {- 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 - 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 - is set, this is not done, since the group must be allowed to delete the
- file without being able to thaw the directory. - file without being able to thaw the directory.
-} -}
freezeContentDir :: RawFilePath -> Annex () freezeContentDir :: OsPath -> Annex ()
freezeContentDir file = do freezeContentDir file = do
fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir) fastDebug "Annex.Perms" ("freezing content directory " ++ fromOsPath dir)
unlessM crippledFileSystem $ withShared go unlessM crippledFileSystem $ withShared go
freezeHook dir freezeHook dir
where where
@ -291,29 +293,29 @@ freezeContentDir file = do
go UnShared = liftIO $ preventWrite dir go UnShared = liftIO $ preventWrite dir
go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir go GroupShared = liftIO $ void $ tryIO $ groupWriteRead dir
go AllShared = 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 $ umaskSharedDirectory $
-- If n includes group or other write mode, leave them set -- If n includes group or other write mode, leave
-- to allow them to delete the file without being able to -- them set to allow them to delete the file without
-- thaw the directory. -- being able to thaw the directory.
removeModes [ownerWriteMode] n removeModes [ownerWriteMode] n
thawContentDir :: RawFilePath -> Annex () thawContentDir :: OsPath -> Annex ()
thawContentDir file = do 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) thawPerms (withShared (liftIO . go)) (thawHook dir)
where where
dir = parentDir file dir = parentDir file
go UnShared = allowWrite dir go UnShared = allowWrite dir
go GroupShared = allowWrite dir go GroupShared = allowWrite dir
go AllShared = 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, {- Makes the directory tree to store an annexed file's content,
- with appropriate permissions on each level. -} - with appropriate permissions on each level. -}
createContentDir :: RawFilePath -> Annex () createContentDir :: OsPath -> Annex ()
createContentDir dest = do createContentDir dest = do
unlessM (liftIO $ R.doesPathExist dir) $ unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir createAnnexDirectory dir
-- might have already existed with restricted perms -- might have already existed with restricted perms
thawHook dir thawHook dir
@ -324,7 +326,7 @@ createContentDir dest = do
{- Creates the content directory for a file if it doesn't already exist, {- 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 - or thaws it if it does, then runs an action to modify a file in the
- directory, and finally, freezes the content directory. -} - directory, and finally, freezes the content directory. -}
modifyContentDir :: RawFilePath -> Annex a -> Annex a modifyContentDir :: OsPath -> Annex a -> Annex a
modifyContentDir f a = do modifyContentDir f a = do
createContentDir f -- also thaws it createContentDir f -- also thaws it
v <- tryNonAsync a v <- tryNonAsync a
@ -333,7 +335,7 @@ modifyContentDir f a = do
{- Like modifyContentDir, but avoids creating the content directory if it {- Like modifyContentDir, but avoids creating the content directory if it
- does not already exist. In that case, the action will probably fail. -} - 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 modifyContentDirWhenExists f a = do
thawContentDir f thawContentDir f
v <- tryNonAsync a v <- tryNonAsync a
@ -352,11 +354,11 @@ hasThawHook =
<||> <||>
(doesAnnexHookExist thawContentAnnexHook) (doesAnnexHookExist thawContentAnnexHook)
freezeHook :: RawFilePath -> Annex () freezeHook :: OsPath -> Annex ()
freezeHook = void . runAnnexPathHook "%path" freezeHook = void . runAnnexPathHook "%path"
freezeContentAnnexHook annexFreezeContentCommand freezeContentAnnexHook annexFreezeContentCommand
thawHook :: RawFilePath -> Annex () thawHook :: OsPath -> Annex ()
thawHook = void . runAnnexPathHook "%path" thawHook = void . runAnnexPathHook "%path"
thawContentAnnexHook annexThawContentCommand thawContentAnnexHook annexThawContentCommand

4
Annex/Url.hs
View file

@ -174,13 +174,13 @@ checkBoth url expected_size uo =
Right r -> return r Right r -> return r
Left err -> warning (UnquotedString err) >> return False 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 = download meterupdate iv url file uo =
liftIO (U.download meterupdate iv url file uo) >>= \case liftIO (U.download meterupdate iv url file uo) >>= \case
Right () -> return True Right () -> return True
Left err -> warning (UnquotedString err) >> return False 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 = download' meterupdate iv url file uo =
liftIO (U.download meterupdate iv url file uo) liftIO (U.download meterupdate iv url file uo)

21
Annex/VariantFile.hs
View file

@ -5,21 +5,24 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Annex.VariantFile where module Annex.VariantFile where
import Annex.Common import Annex.Common
import Utility.Hash import Utility.Hash
import qualified Utility.OsString as OS
import qualified Data.ByteString as S import qualified Data.ByteString as S
variantMarker :: String variantMarker :: OsPath
variantMarker = ".variant-" variantMarker = literalOsPath ".variant-"
mkVariant :: FilePath -> String -> FilePath mkVariant :: OsPath -> OsPath -> OsPath
mkVariant file variant = takeDirectory file mkVariant file variant = takeDirectory file
</> dropExtension (takeFileName file) </> dropExtension (takeFileName file)
++ variantMarker ++ variant <> variantMarker <> variant
++ takeExtension file <> takeExtension file
{- The filename to use when resolving a conflicted merge of a file, {- The filename to use when resolving a conflicted merge of a file,
- that points to a key. - 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 - conflicted merge resolution code. That case is detected, and the full
- key is used in the filename. - key is used in the filename.
-} -}
variantFile :: FilePath -> Key -> FilePath variantFile :: OsPath -> Key -> OsPath
variantFile file key variantFile file key
| doubleconflict = mkVariant file (fromRawFilePath (keyFile key)) | doubleconflict = mkVariant file (keyFile key)
| otherwise = mkVariant file (shortHash $ serializeKey' key) | otherwise = mkVariant file (toOsPath (shortHash $ serializeKey' key))
where where
doubleconflict = variantMarker `isInfixOf` file doubleconflict = variantMarker `OS.isInfixOf` file
shortHash :: S.ByteString -> String shortHash :: S.ByteString -> String
shortHash = take 4 . show . md5s shortHash = take 4 . show . md5s

33
Annex/View/ViewedFile.hs
View file

@ -5,6 +5,7 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Annex.View.ViewedFile ( module Annex.View.ViewedFile (
@ -20,13 +21,14 @@ module Annex.View.ViewedFile (
import Annex.Common import Annex.Common
import Utility.QuickCheck import Utility.QuickCheck
import Backend.Utilities (maxExtensions) import Backend.Utilities (maxExtensions)
import qualified Utility.OsString as OS
import qualified Data.ByteString as S import qualified Data.ByteString as S
type FileName = String type FileName = String
type ViewedFile = FileName type ViewedFile = FileName
type MkViewedFile = FilePath -> ViewedFile type MkViewedFile = OsPath -> ViewedFile
{- Converts a filepath used in a reference branch to the {- Converts a filepath used in a reference branch to the
- filename that will be used in the view. - filename that will be used in the view.
@ -44,23 +46,26 @@ viewedFileFromReference g = viewedFileFromReference'
viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile viewedFileFromReference' :: Maybe Int -> Maybe Int -> MkViewedFile
viewedFileFromReference' maxextlen maxextensions f = concat $ viewedFileFromReference' maxextlen maxextensions f = concat $
[ escape (fromRawFilePath base') [ escape (fromOsPath base')
, if null dirs then "" else "_%" ++ intercalate "%" (map escape dirs) ++ "%" , if null dirs
then ""
else "_%" ++ intercalate "%" (map (escape . fromOsPath) dirs) ++ "%"
, escape $ fromRawFilePath $ S.concat extensions' , escape $ fromRawFilePath $ S.concat extensions'
] ]
where where
(path, basefile) = splitFileName f (path, basefile) = splitFileName f
dirs = filter (/= ".") $ map dropTrailingPathSeparator (splitPath path) dirs = filter (/= literalOsPath ".") $
map dropTrailingPathSeparator (splitPath path)
(base, extensions) = case maxextlen of (base, extensions) = case maxextlen of
Nothing -> splitShortExtensions (toRawFilePath basefile') Nothing -> splitShortExtensions basefile'
Just n -> splitShortExtensions' (n+1) (toRawFilePath basefile') Just n -> splitShortExtensions' (n+1) basefile'
{- Limit number of extensions. -} {- Limit number of extensions. -}
maxextensions' = fromMaybe maxExtensions maxextensions maxextensions' = fromMaybe maxExtensions maxextensions
(base', extensions') (base', extensions')
| length extensions <= maxextensions' = (base, extensions) | length extensions <= maxextensions' = (base, extensions)
| otherwise = | otherwise =
let (es,more) = splitAt maxextensions' (reverse extensions) 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 {- On Windows, if the filename looked like "dir/c:foo" then
- basefile would look like it contains a drive letter, which will - basefile would look like it contains a drive letter, which will
- not work. There cannot really be a filename like that, probably, - 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 {- For use when operating already within a view, so whatever filepath
- is present in the work tree is already a ViewedFile. -} - is present in the work tree is already a ViewedFile. -}
viewedFileReuse :: MkViewedFile viewedFileReuse :: MkViewedFile
viewedFileReuse = takeFileName viewedFileReuse = fromOsPath . takeFileName
{- Extracts from a ViewedFile the directory where the file is located on {- Extracts from a ViewedFile the directory where the file is located on
- in the reference branch. -} - in the reference branch. -}
dirFromViewedFile :: ViewedFile -> FilePath dirFromViewedFile :: ViewedFile -> FilePath
dirFromViewedFile = joinPath . drop 1 . sep [] "" dirFromViewedFile = fromOsPath . joinPath . map toOsPath . drop 1 . sep [] ""
where where
sep l _ [] = reverse l sep l _ [] = reverse l
sep l curr (c:cs) sep l curr (c:cs)
@ -103,10 +108,10 @@ dirFromViewedFile = joinPath . drop 1 . sep [] ""
prop_viewedFile_roundtrips :: TestableFilePath -> Bool prop_viewedFile_roundtrips :: TestableFilePath -> Bool
prop_viewedFile_roundtrips tf prop_viewedFile_roundtrips tf
-- Relative filenames wanted, not directories. -- Relative filenames wanted, not directories.
| any (isPathSeparator) (end f ++ beginning f) = True | OS.any isPathSeparator (toOsPath (end f ++ beginning f)) = True
| isAbsolute f || isDrive f = True | isAbsolute (toOsPath f) || isDrive (toOsPath f) = True
| otherwise = dir == dirFromViewedFile | otherwise = fromOsPath dir == dirFromViewedFile
(viewedFileFromReference' Nothing Nothing f) (viewedFileFromReference' Nothing Nothing (toOsPath f))
where where
f = fromTestableFilePath tf f = fromTestableFilePath tf
dir = joinPath $ beginning $ splitDirectories f dir = joinPath $ beginning $ splitDirectories (toOsPath f)

45
Assistant/Ssh.hs
View file

@ -5,6 +5,8 @@
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
{-# LANGUAGE OverloadedStrings #-}
module Assistant.Ssh where module Assistant.Ssh where
import Annex.Common import Annex.Common
@ -94,7 +96,7 @@ genSshUrl sshdata = case sshRepoUrl sshdata of
{- Reverses genSshUrl -} {- Reverses genSshUrl -}
parseSshUrl :: String -> Maybe SshData parseSshUrl :: String -> Maybe SshData
parseSshUrl u parseSshUrl u
| "ssh://" `isPrefixOf` u = fromssh (drop (length "ssh://") u) | "ssh://" `isPrefixOf` u = fromssh (drop (length ("ssh://" :: String)) u)
| otherwise = fromrsync u | otherwise = fromrsync u
where where
mkdata (userhost, dir) = Just $ SshData mkdata (userhost, dir) = Just $ SshData
@ -159,7 +161,7 @@ removeAuthorizedKeys :: Bool -> FilePath -> SshPubKey -> IO ()
removeAuthorizedKeys gitannexshellonly dir pubkey = do removeAuthorizedKeys gitannexshellonly dir pubkey = do
let keyline = authorizedKeysLine gitannexshellonly dir pubkey let keyline = authorizedKeysLine gitannexshellonly dir pubkey
sshdir <- sshDir sshdir <- sshDir
let keyfile = toOsPath $ toRawFilePath $ sshdir </> "authorized_keys" let keyfile = sshdir </> literalOsPath "authorized_keys"
tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case tryWhenExists (map decodeBS . fileLines' <$> F.readFile' keyfile) >>= \case
Just ls -> viaTmp writeSshConfig keyfile $ Just ls -> viaTmp writeSshConfig keyfile $
unlines $ filter (/= keyline) ls unlines $ filter (/= keyline) ls
@ -213,16 +215,16 @@ authorizedKeysLine gitannexshellonly dir pubkey
{- Generates a ssh key pair. -} {- Generates a ssh key pair. -}
genSshKeyPair :: IO SshKeyPair genSshKeyPair :: IO SshKeyPair
genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir -> do genSshKeyPair = withTmpDir (literalOsPath "git-annex-keygen") $ \dir -> do
ok <- boolSystem "ssh-keygen" ok <- boolSystem "ssh-keygen"
[ Param "-P", Param "" -- no password [ Param "-P", Param "" -- no password
, Param "-f", File $ dir </> "key" , Param "-f", File $ fromOsPath (dir </> literalOsPath "key")
] ]
unless ok $ unless ok $
giveup "ssh-keygen failed" giveup "ssh-keygen failed"
SshKeyPair SshKeyPair
<$> readFile (dir </> "key.pub") <$> readFile (fromOsPath (dir </> literalOsPath "key.pub"))
<*> readFile (dir </> "key") <*> readFile (fromOsPath (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
@ -245,25 +247,28 @@ genSshKeyPair = withTmpDir (toOsPath (toRawFilePath "git-annex-keygen")) $ \dir
installSshKeyPair :: SshKeyPair -> SshData -> IO SshData installSshKeyPair :: SshKeyPair -> SshData -> IO SshData
installSshKeyPair sshkeypair sshdata = do installSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir sshdir <- sshDir
createDirectoryIfMissing True $ fromRawFilePath $ createDirectoryIfMissing True $
parentDir $ toRawFilePath $ sshdir </> sshPrivKeyFile sshdata parentDir $ sshdir </> sshPrivKeyFile sshdata
unlessM (doesFileExist $ 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) $ unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $
writeFile (sshdir </> sshPubKeyFile sshdata) (sshPubKey sshkeypair) writeFile (fromOsPath (sshdir </> sshPubKeyFile sshdata))
(sshPubKey sshkeypair)
setSshConfig sshdata setSshConfig sshdata
[ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata) [ ("IdentityFile", "~/.ssh/" ++ fromOsPath (sshPrivKeyFile sshdata))
, ("IdentitiesOnly", "yes") , ("IdentitiesOnly", "yes")
, ("StrictHostKeyChecking", "yes") , ("StrictHostKeyChecking", "yes")
] ]
sshPrivKeyFile :: SshData -> FilePath sshPrivKeyFile :: SshData -> OsPath
sshPrivKeyFile sshdata = "git-annex" </> "key." ++ mangleSshHostName sshdata sshPrivKeyFile sshdata = literalOsPath "git-annex"
</> literalOsPath "key." <> toOsPath (mangleSshHostName sshdata)
sshPubKeyFile :: SshData -> FilePath sshPubKeyFile :: SshData -> OsPath
sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub" sshPubKeyFile sshdata = sshPrivKeyFile sshdata <> literalOsPath ".pub"
{- Generates an installs a new ssh key pair if one is not already {- Generates an installs a new ssh key pair if one is not already
- installed. Returns the modified SshData that will use the key pair, - 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 -> IO (SshData, SshKeyPair)
setupSshKeyPair sshdata = do setupSshKeyPair sshdata = do
sshdir <- sshDir sshdir <- sshDir
mprivkey <- catchMaybeIO $ readFile (sshdir </> sshPrivKeyFile sshdata) mprivkey <- catchMaybeIO $ readFile (fromOsPath (sshdir </> sshPrivKeyFile sshdata))
mpubkey <- catchMaybeIO $ readFile (sshdir </> sshPubKeyFile sshdata) mpubkey <- catchMaybeIO $ readFile (fromOsPath (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
@ -324,7 +329,7 @@ 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 = sshdir </> "config" let configfile = fromOsPath (sshdir </> literalOsPath "config")
unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do
appendFile configfile $ unlines $ appendFile configfile $ unlines $
[ "" [ ""
@ -332,7 +337,7 @@ setSshConfig sshdata config = do
, "Host " ++ mangledhost , "Host " ++ mangledhost
] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v)
(settings ++ config) (settings ++ config)
setSshConfigMode (toRawFilePath configfile) setSshConfigMode (toOsPath configfile)
return $ sshdata return $ sshdata
{ sshHostName = T.pack mangledhost { sshHostName = T.pack mangledhost
@ -403,7 +408,7 @@ unMangleSshHostName h = case splitc '-' h of
knownHost :: Text -> IO Bool knownHost :: Text -> IO Bool
knownHost hostname = do knownHost hostname = do
sshdir <- sshDir sshdir <- sshDir
ifM (doesFileExist $ sshdir </> "known_hosts") ifM (doesFileExist $ sshdir </> literalOsPath "known_hosts")
( not . null <$> checkhost ( not . null <$> checkhost
, return False , return False
) )

2
Backend/GitRemoteAnnex.hs
View file

@ -75,7 +75,7 @@ sameCheckSum key s = s == expected
expected = reverse $ takeWhile (/= '-') $ reverse $ expected = reverse $ takeWhile (/= '-') $ reverse $
decodeBS $ S.fromShort $ fromKey keyName key decodeBS $ S.fromShort $ fromKey keyName key
genGitBundleKey :: UUID -> RawFilePath -> MeterUpdate -> Annex Key genGitBundleKey :: UUID -> OsPath -> MeterUpdate -> Annex Key
genGitBundleKey remoteuuid file meterupdate = do genGitBundleKey remoteuuid file meterupdate = do
filesize <- liftIO $ getFileSize file filesize <- liftIO $ getFileSize file
s <- Hash.hashFile hash file meterupdate s <- Hash.hashFile hash file meterupdate

8
Backend/Hash.hs
View file

@ -127,7 +127,7 @@ keyValueE hash source meterupdate =
keyValue hash source meterupdate keyValue hash source meterupdate
>>= addE source (const $ hashKeyVariety hash (HasExt True)) >>= 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 checkKeyChecksum issame hash key file = catchIOErrorType HardwareFault hwfault $ do
showAction (UnquotedString descChecksum) showAction (UnquotedString descChecksum)
issame key issame key
@ -187,7 +187,7 @@ trivialMigrate' oldkey newbackend afile maxextlen maxexts
AssociatedFile Nothing -> Nothing AssociatedFile Nothing -> Nothing
AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d AssociatedFile (Just file) -> Just $ alterKey oldkey $ \d -> d
{ keyName = S.toShort $ keyHash oldkey { keyName = S.toShort $ keyHash oldkey
<> selectExtension maxextlen maxexts file <> selectExtension maxextlen maxexts (fromOsPath file)
, keyVariety = newvariety , keyVariety = newvariety
} }
{- Upgrade to fix bad previous migration that created a {- Upgrade to fix bad previous migration that created a
@ -205,9 +205,9 @@ trivialMigrate' oldkey newbackend afile maxextlen maxexts
oldvariety = fromKey keyVariety oldkey oldvariety = fromKey keyVariety oldkey
newvariety = backendVariety newbackend newvariety = backendVariety newbackend
hashFile :: Hash -> RawFilePath -> MeterUpdate -> Annex String hashFile :: Hash -> OsPath -> MeterUpdate -> Annex String
hashFile hash file meterupdate = hashFile hash file meterupdate =
liftIO $ withMeteredFile (fromRawFilePath file) meterupdate $ \b -> do liftIO $ withMeteredFile file meterupdate $ \b -> do
let h = (fst $ hasher hash) b let h = (fst $ hasher hash) b
-- Force full evaluation of hash so whole file is read -- Force full evaluation of hash so whole file is read
-- before returning. -- before returning.

2
Backend/Utilities.hs
View file

@ -49,7 +49,7 @@ addE source sethasext k = do
let ext = selectExtension let ext = selectExtension
(annexMaxExtensionLength c) (annexMaxExtensionLength c)
(annexMaxExtensions c) (annexMaxExtensions c)
(keyFilename source) (fromOsPath (keyFilename source))
return $ alterKey k $ \d -> d return $ alterKey k $ \d -> d
{ keyName = keyName d <> S.toShort ext { keyName = keyName d <> S.toShort ext
, keyVariety = sethasext (keyVariety d) , keyVariety = sethasext (keyVariety d)

4
Backend/WORM.hs
View file

@ -42,9 +42,9 @@ backend = Backend
keyValue :: KeySource -> MeterUpdate -> Annex Key keyValue :: KeySource -> MeterUpdate -> Annex Key
keyValue source _ = do keyValue source _ = do
let f = contentLocation source let f = contentLocation source
stat <- liftIO $ R.getFileStatus f stat <- liftIO $ R.getFileStatus (fromOsPath f)
sz <- liftIO $ getFileSize' f stat sz <- liftIO $ getFileSize' f stat
relf <- fromRawFilePath . getTopFilePath relf <- fromOsPath . getTopFilePath
<$> inRepo (toTopFilePath $ keyFilename source) <$> inRepo (toTopFilePath $ keyFilename source)
return $ mkKey $ \k -> k return $ mkKey $ \k -> k
{ keyName = genKeyName relf { keyName = genKeyName relf

4
Config.hs
View file

@ -94,7 +94,7 @@ setCrippledFileSystem :: Bool -> Annex ()
setCrippledFileSystem b = setCrippledFileSystem b =
setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
pidLockFile :: Annex (Maybe RawFilePath) pidLockFile :: Annex (Maybe OsPath)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig)
( Just <$> Annex.fromRepo gitAnnexPidLockFile ( Just <$> Annex.fromRepo gitAnnexPidLockFile
@ -111,4 +111,4 @@ splitRemoteAnnexTrackingBranchSubdir tb = (branch, subdir)
branch = Git.Ref b branch = Git.Ref b
subdir = if S.null p subdir = if S.null p
then Nothing then Nothing
else Just (asTopFilePath p) else Just (asTopFilePath (toOsPath p))

11
Config/Smudge.hs
View file

@ -20,7 +20,6 @@ import Annex.Version
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
configureSmudgeFilter :: Annex () configureSmudgeFilter :: Annex ()
configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
@ -47,11 +46,11 @@ configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do
gfs <- readattr gf gfs <- readattr gf
gittop <- Git.localGitDir <$> gitRepo gittop <- Git.localGitDir <$> gitRepo
liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do liftIO $ unless ("filter=annex" `S.isInfixOf` (lfs <> gfs)) $ do
createDirectoryUnder [gittop] (P.takeDirectory lf) createDirectoryUnder [gittop] (takeDirectory lf)
F.writeFile' (toOsPath lf) $ F.writeFile' lf $
linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr)) linesFile' (lfs <> encodeBS ("\n" ++ unlines stdattr))
where where
readattr = liftIO . catchDefaultIO mempty . F.readFile' . toOsPath readattr = liftIO . catchDefaultIO mempty . F.readFile'
configureSmudgeFilterProcess :: Annex () configureSmudgeFilterProcess :: Annex ()
configureSmudgeFilterProcess = configureSmudgeFilterProcess =
@ -70,8 +69,8 @@ deconfigureSmudgeFilter :: Annex ()
deconfigureSmudgeFilter = do deconfigureSmudgeFilter = do
lf <- Annex.fromRepo Git.attributesLocal lf <- Annex.fromRepo Git.attributesLocal
ls <- liftIO $ catchDefaultIO [] $ ls <- liftIO $ catchDefaultIO [] $
map decodeBS . fileLines' <$> F.readFile' (toOsPath lf) map decodeBS . fileLines' <$> F.readFile' lf
liftIO $ writeFile (fromRawFilePath lf) $ unlines $ liftIO $ writeFile (fromOsPath 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")

2
Git/Hook.hs
View file

@ -64,7 +64,7 @@ hookWrite h r = ifM (doesFileExist f)
-- they typically use unix newlines, which does work there -- they typically use unix newlines, which does work there
-- and makes the repository more portable. -- and makes the repository more portable.
viaTmp F.writeFile' f (encodeBS (hookScript h)) viaTmp F.writeFile' f (encodeBS (hookScript h))
void $ tryIO $ modifyFileMode (fromOsPath f) (addModes executeModes) void $ tryIO $ modifyFileMode f (addModes executeModes)
return True return True
{- Removes a hook. Returns False if the hook contained something else, and {- Removes a hook. Returns False if the hook contained something else, and

8
Git/Repair.hs
View file

@ -61,7 +61,7 @@ cleanCorruptObjects fsckresults r = do
removeLoose s = removeWhenExistsWith R.removeLink $ removeLoose s = removeWhenExistsWith R.removeLink $
fromOsPath $ looseObjectFile r s fromOsPath $ looseObjectFile r s
removeBad s = do removeBad s = do
void $ tryIO $ allowRead $ fromOsPath $ looseObjectFile r s void $ tryIO $ allowRead $ looseObjectFile r s
whenM (isMissing s r) $ whenM (isMissing s r) $
removeLoose s removeLoose s
@ -85,7 +85,7 @@ explodePacks r = go =<< listPackFiles r
putStrLn "Unpacking all pack files." putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do forM_ packs $ \packfile -> do
-- Just in case permissions are messed up. -- Just in case permissions are messed up.
allowRead (fromOsPath packfile) allowRead packfile
-- May fail, if pack file is corrupt. -- May fail, if pack file is corrupt.
void $ tryIO $ void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
@ -477,7 +477,7 @@ preRepair g = do
writeFile (fromOsPath headfile) "ref: refs/heads/master" writeFile (fromOsPath headfile) "ref: refs/heads/master"
explodePackedRefsFile g explodePackedRefsFile g
unless (repoIsLocalBare g) $ unless (repoIsLocalBare g) $
void $ tryIO $ allowWrite $ fromOsPath $ indexFile g void $ tryIO $ allowWrite $ indexFile g
where where
headfile = localGitDir g </> literalOsPath "HEAD" headfile = localGitDir g </> literalOsPath "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s validhead s = "ref: refs/" `isPrefixOf` s
@ -652,5 +652,5 @@ successfulRepair = fst
safeReadFile :: OsPath -> IO B.ByteString safeReadFile :: OsPath -> IO B.ByteString
safeReadFile f = do safeReadFile f = do
allowRead (fromOsPath f) allowRead f
F.readFile' f F.readFile' f

3
Types/Backend.hs
View file

@ -12,6 +12,7 @@ module Types.Backend where
import Types.Key import Types.Key
import Types.KeySource import Types.KeySource
import Utility.Metered import Utility.Metered
import Utility.OsPath
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
import Utility.Hash (IncrementalVerifier) import Utility.Hash (IncrementalVerifier)
@ -20,7 +21,7 @@ data BackendA a = Backend
, genKey :: Maybe (KeySource -> MeterUpdate -> a Key) , genKey :: Maybe (KeySource -> MeterUpdate -> a Key)
-- Verifies the content of a key, stored in a file, using a hash. -- Verifies the content of a key, stored in a file, using a hash.
-- This does not need to be cryptographically secure. -- 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 -- Incrementally verifies the content of a key, using the same
-- hash as verifyKeyContent, but with the content provided -- hash as verifyKeyContent, but with the content provided
-- incrementally a piece at a time, until finalized. -- incrementally a piece at a time, until finalized.

6
Types/KeySource.hs
View file

@ -8,7 +8,7 @@
module Types.KeySource where module Types.KeySource where
import Utility.InodeCache import Utility.InodeCache
import System.FilePath.ByteString (RawFilePath) import Utility.OsPath
{- When content is in the process of being ingested into the annex, {- When content is in the process of being ingested into the annex,
- and a Key generated from it, this data type is used. - 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. - files that may be made while they're in the process of being ingested.
-} -}
data KeySource = KeySource data KeySource = KeySource
{ keyFilename :: RawFilePath { keyFilename :: OsPath
, contentLocation :: RawFilePath , contentLocation :: OsPath
, inodeCache :: Maybe InodeCache , inodeCache :: Maybe InodeCache
} }
deriving (Show) deriving (Show)

9
Utility/FileIO.hs
View file

@ -16,6 +16,7 @@ module Utility.FileIO
( (
withFile, withFile,
openFile, openFile,
withBinaryFile,
openBinaryFile, openBinaryFile,
readFile, readFile,
readFile', readFile',
@ -52,6 +53,11 @@ openFile f m = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
O.openFile f' m 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 :: OsPath -> IOMode -> IO Handle
openBinaryFile f m = do openBinaryFile f m = do
f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f)
@ -110,6 +116,9 @@ withFile = System.IO.withFile . fromRawFilePath
openFile :: OsPath -> IOMode -> IO Handle openFile :: OsPath -> IOMode -> IO Handle
openFile = System.IO.openFile . fromRawFilePath openFile = System.IO.openFile . fromRawFilePath
withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile = System.IO.withBinaryFile . fromRawFilePath
openBinaryFile :: OsPath -> IOMode -> IO Handle openBinaryFile :: OsPath -> IOMode -> IO Handle
openBinaryFile = System.IO.openBinaryFile . fromRawFilePath openBinaryFile = System.IO.openBinaryFile . fromRawFilePath

33
Utility/FileMode.hs
View file

@ -25,26 +25,27 @@ import Foreign (complement)
import Control.Monad.Catch import Control.Monad.Catch
import Utility.Exception import Utility.Exception
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R import qualified Utility.RawFilePath as R
import qualified Utility.FileIO as F import qualified Utility.FileIO as F
import Utility.OsPath import Utility.OsPath
{- Applies a conversion function to a file's mode. -} {- 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 f convert = void $ modifyFileMode' f convert
modifyFileMode' :: RawFilePath -> (FileMode -> FileMode) -> IO FileMode modifyFileMode' :: OsPath -> (FileMode -> FileMode) -> IO FileMode
modifyFileMode' f convert = do modifyFileMode' f convert = do
s <- R.getFileStatus f s <- R.getFileStatus f'
let old = fileMode s let old = fileMode s
let new = convert old let new = convert old
when (new /= old) $ when (new /= old) $
R.setFileMode f new R.setFileMode f' new
return old return old
where
f' = fromOsPath f
{- Runs an action after changing a file's mode, then restores the old mode. -} {- 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 withModifiedFileMode file convert a = bracket setup cleanup go
where where
setup = modifyFileMode' file convert setup = modifyFileMode' file convert
@ -77,15 +78,15 @@ otherGroupModes =
] ]
{- Removes the write bits from a file. -} {- Removes the write bits from a file. -}
preventWrite :: RawFilePath -> IO () preventWrite :: OsPath -> IO ()
preventWrite f = modifyFileMode f $ removeModes writeModes preventWrite f = modifyFileMode f $ removeModes writeModes
{- Turns a file's owner write bit back on. -} {- Turns a file's owner write bit back on. -}
allowWrite :: RawFilePath -> IO () allowWrite :: OsPath -> IO ()
allowWrite f = modifyFileMode f $ addModes [ownerWriteMode] allowWrite f = modifyFileMode f $ addModes [ownerWriteMode]
{- Turns a file's owner read bit back on. -} {- Turns a file's owner read bit back on. -}
allowRead :: RawFilePath -> IO () allowRead :: OsPath -> IO ()
allowRead f = modifyFileMode f $ addModes [ownerReadMode] allowRead f = modifyFileMode f $ addModes [ownerReadMode]
{- Allows owner and group to read and write to a file. -} {- Allows owner and group to read and write to a file. -}
@ -95,7 +96,7 @@ groupSharedModes =
, ownerReadMode, groupReadMode , ownerReadMode, groupReadMode
] ]
groupWriteRead :: RawFilePath -> IO () groupWriteRead :: OsPath -> IO ()
groupWriteRead f = modifyFileMode f $ addModes groupSharedModes groupWriteRead f = modifyFileMode f $ addModes groupSharedModes
checkMode :: FileMode -> FileMode -> Bool checkMode :: FileMode -> FileMode -> Bool
@ -105,13 +106,13 @@ checkMode checkfor mode = checkfor `intersectFileModes` mode == checkfor
isExecutable :: FileMode -> Bool isExecutable :: FileMode -> Bool
isExecutable mode = combineModes executeModes `intersectFileModes` mode /= 0 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 {- 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 - 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 - can adjust the initial mode if umask prevented the file from being
- created with the right mode. -} - 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 applyModeSetter (Just (ModeSetter mode modeaction)) file a = do
r <- a (Just mode) r <- a (Just mode)
void $ tryIO $ modeaction file void $ tryIO $ modeaction file
@ -159,7 +160,7 @@ isSticky = checkMode stickyMode
stickyMode :: FileMode stickyMode :: FileMode
stickyMode = 512 stickyMode = 512
setSticky :: RawFilePath -> IO () setSticky :: OsPath -> IO ()
setSticky f = modifyFileMode f $ addModes [stickyMode] setSticky f = modifyFileMode f $ addModes [stickyMode]
#endif #endif
@ -172,15 +173,15 @@ setSticky f = modifyFileMode f $ addModes [stickyMode]
- 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 writeFile.
-} -}
writeFileProtected :: RawFilePath -> String -> IO () writeFileProtected :: OsPath -> String -> IO ()
writeFileProtected file content = writeFileProtected' file writeFileProtected file content = writeFileProtected' file
(\h -> hPutStr h content) (\h -> hPutStr h content)
writeFileProtected' :: RawFilePath -> (Handle -> IO ()) -> IO () writeFileProtected' :: OsPath -> (Handle -> IO ()) -> IO ()
writeFileProtected' file writer = bracket setup cleanup writer writeFileProtected' file writer = bracket setup cleanup writer
where where
setup = do setup = do
h <- protectedOutput $ F.openFile (toOsPath file) WriteMode h <- protectedOutput $ F.openFile file WriteMode
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
return h return h
cleanup = hClose cleanup = hClose

2
Utility/Gpg.hs
View file

@ -418,7 +418,7 @@ testHarness tmpdir cmd a = ifM (inSearchPath (unGpgCmd cmd))
origenviron <- getEnvironment origenviron <- getEnvironment
let environ = addEntry var (fromOsPath subdir) origenviron let environ = addEntry var (fromOsPath subdir) origenviron
-- gpg is picky about permissions on its home dir -- gpg is picky about permissions on its home dir
liftIO $ void $ tryIO $ modifyFileMode (fromOsPath subdir) $ liftIO $ void $ tryIO $ modifyFileMode subdir $
removeModes $ otherGroupModes removeModes $ otherGroupModes
-- For some reason, recent gpg needs a trustdb to be set up. -- 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 _ <- pipeStrict' cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] (Just environ) mempty

5
Utility/LockFile/Posix.hs
View file

@ -75,12 +75,11 @@ tryLock lockreq mode lockfile = uninterruptibleMask_ $ do
-- Close on exec flag is set so child processes do not inherit the lock. -- Close on exec flag is set so child processes do not inherit the lock.
openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd
openLockFile lockreq filemode lockfile = do openLockFile lockreq filemode lockfile = do
l <- applyModeSetter filemode lockfile' $ \filemode' -> l <- applyModeSetter filemode lockfile $ \filemode' ->
openFdWithMode lockfile' openfor filemode' defaultFileFlags openFdWithMode (fromOsPath lockfile) openfor filemode' defaultFileFlags
setFdOption l CloseOnExec True setFdOption l CloseOnExec True
return l return l
where where
lockfile' = fromOsPath lockfile
openfor = case lockreq of openfor = case lockreq of
ReadLock -> ReadOnly ReadLock -> ReadOnly
_ -> ReadWrite _ -> ReadWrite

9
Utility/Metered.hs
View file

@ -55,6 +55,7 @@ import Utility.HumanTime
import Utility.SimpleProtocol as Proto import Utility.SimpleProtocol as Proto
import Utility.ThreadScheduler import Utility.ThreadScheduler
import Utility.SafeOutput import Utility.SafeOutput
import qualified Utility.FileIO as F
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as S 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 {- Sends the content of a file to an action, updating the meter as it's
- consumed. -} - consumed. -}
withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a withMeteredFile :: OsPath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h -> withMeteredFile f meterupdate a = F.withBinaryFile f ReadMode $ \h ->
hGetContentsMetered h meterupdate >>= a hGetContentsMetered h meterupdate >>= a
{- Calls the action repeatedly with chunks from the lazy ByteString. {- Calls the action repeatedly with chunks from the lazy ByteString.
@ -140,8 +141,8 @@ meteredWrite' meterupdate a = go zeroBytesProcessed . L.toChunks
meterupdate sofar' meterupdate sofar'
go sofar' cs go sofar' cs
meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO () meteredWriteFile :: MeterUpdate -> OsPath -> L.ByteString -> IO ()
meteredWriteFile meterupdate f b = withBinaryFile f WriteMode $ \h -> meteredWriteFile meterupdate f b = F.withBinaryFile f WriteMode $ \h ->
meteredWrite meterupdate (S.hPut h) b meteredWrite meterupdate (S.hPut h) b
{- Applies an offset to a MeterUpdate. This can be useful when {- Applies an offset to a MeterUpdate. This can be useful when

4
Utility/SshConfig.hs
View file

@ -150,7 +150,7 @@ changeUserSshConfig modifier = do
writeSshConfig :: OsPath -> String -> IO () writeSshConfig :: OsPath -> String -> IO ()
writeSshConfig f s = do writeSshConfig f s = do
F.writeFile' f (linesFile' (encodeBS s)) F.writeFile' f (linesFile' (encodeBS s))
setSshConfigMode (fromOsPath f) setSshConfigMode f
{- Ensure that the ssh config file lacks any group or other write bits, {- Ensure that the ssh config file lacks any group or other write bits,
- since ssh is paranoid about not working if other users can write - since ssh is paranoid about not working if other users can write
@ -159,7 +159,7 @@ writeSshConfig f s = do
- If the chmod fails, ignore the failure, as it might be a filesystem like - If the chmod fails, ignore the failure, as it might be a filesystem like
- Android's that does not support file modes. - Android's that does not support file modes.
-} -}
setSshConfigMode :: RawFilePath -> IO () setSshConfigMode :: OsPath -> IO ()
setSshConfigMode f = void $ tryIO $ modifyFileMode f $ setSshConfigMode f = void $ tryIO $ modifyFileMode f $
removeModes [groupWriteMode, otherWriteMode] removeModes [groupWriteMode, otherWriteMode]

2
Utility/Tor.hs
View file

@ -171,7 +171,7 @@ prepHiddenServiceSocketDir :: AppName -> UserID -> UniqueIdent -> IO ()
prepHiddenServiceSocketDir appname uid ident = do prepHiddenServiceSocketDir appname uid ident = do
createDirectoryIfMissing True d createDirectoryIfMissing True d
setOwnerAndGroup (fromOsPath d) uid (-1) setOwnerAndGroup (fromOsPath d) uid (-1)
modifyFileMode (fromOsPath d) $ modifyFileMode d $
addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode] addModes [ownerReadMode, ownerExecuteMode, ownerWriteMode]
where where
d = takeDirectory $ hiddenServiceSocketFile appname uid ident d = takeDirectory $ hiddenServiceSocketFile appname uid ident

2
Utility/Url.hs
View file

@ -433,7 +433,7 @@ download' nocurlerror meterupdate iv url file uo =
downloadfile u = do downloadfile u = do
noverification noverification
let src = unEscapeString (uriPath u) let src = toOsPath $ unEscapeString (uriPath u)
withMeteredFile src meterupdate $ withMeteredFile src meterupdate $
F.writeFile file F.writeFile file
return $ Right () return $ Right ()