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