more OsPath conversion
Sponsored-by: Nicholas Golder-Manning
This commit is contained in:
Joey Hess
parent
0376bc5ee0
commit
27305042f3
24 changed files with 180 additions and 153 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue