diff options
Diffstat (limited to 'Git.hs')
| -rw-r--r-- | Git.hs | 42 |
1 files changed, 24 insertions, 18 deletions
@@ -1,19 +1,21 @@ {- git repository handling - - - This is written to be completely independant of git-annex and should be + - This is written to be completely independent of git-annex and should be - suitable for other uses. - - - Copyright 2010-2012 Joey Hess <id@joeyh.name> + - Copyright 2010-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Git ( Repo(..), Ref(..), fromRef, + fromRef', Branch, Sha, Tag, @@ -36,10 +38,12 @@ module Git ( relPath, ) where +import qualified Data.ByteString as B import Network.URI (uriPath, uriScheme, unEscapeString) #ifndef mingw32_HOST_OS import System.Posix.Files #endif +import qualified System.FilePath.ByteString as P import Common import Git.Types @@ -51,6 +55,7 @@ import Utility.FileMode repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url +repoDescribe Repo { location = UnparseableUrl url } = url repoDescribe Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoDescribe Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoDescribe Repo { location = LocalUnknown dir } = fromRawFilePath dir @@ -59,10 +64,11 @@ repoDescribe Repo { location = Unknown } = "UNKNOWN" {- Location of the repo, either as a path or url. -} repoLocation :: Repo -> String repoLocation Repo { location = Url url } = show url +repoLocation Repo { location = UnparseableUrl url } = url repoLocation Repo { location = Local { worktree = Just dir } } = fromRawFilePath dir repoLocation Repo { location = Local { gitdir = dir } } = fromRawFilePath dir repoLocation Repo { location = LocalUnknown dir } = fromRawFilePath dir -repoLocation Repo { location = Unknown } = error "unknown repoLocation" +repoLocation Repo { location = Unknown } = giveup "unknown repoLocation" {- Path to a repository. For non-bare, this is the worktree, for bare, - it's the gitdir, and for URL repositories, is the path on the remote @@ -72,7 +78,8 @@ repoPath Repo { location = Url u } = toRawFilePath $ unEscapeString $ uriPath u repoPath Repo { location = Local { worktree = Just d } } = d repoPath Repo { location = Local { gitdir = d } } = d repoPath Repo { location = LocalUnknown dir } = dir -repoPath Repo { location = Unknown } = error "unknown repoPath" +repoPath Repo { location = Unknown } = giveup "unknown repoPath" +repoPath Repo { location = UnparseableUrl _u } = giveup "unknown repoPath" repoWorkTree :: Repo -> Maybe RawFilePath repoWorkTree Repo { location = Local { worktree = Just d } } = Just d @@ -81,12 +88,13 @@ repoWorkTree _ = Nothing {- Path to a local repository's .git directory. -} localGitDir :: Repo -> RawFilePath localGitDir Repo { location = Local { gitdir = d } } = d -localGitDir _ = error "unknown localGitDir" +localGitDir _ = giveup "unknown localGitDir" {- Some code needs to vary between URL and normal repos, - or bare and non-bare, these functions help with that. -} repoIsUrl :: Repo -> Bool repoIsUrl Repo { location = Url _ } = True +repoIsUrl Repo { location = UnparseableUrl _ } = True repoIsUrl _ = False repoIsSsh :: Repo -> Bool @@ -121,7 +129,7 @@ repoIsLocalUnknown _ = False assertLocal :: Repo -> a -> a assertLocal repo action - | repoIsUrl repo = error $ unwords + | repoIsUrl repo = giveup $ unwords [ "acting on non-local git repo" , repoDescribe repo , "not supported" @@ -129,14 +137,13 @@ assertLocal repo action | otherwise = action {- Path to a repository's gitattributes file. -} -attributes :: Repo -> FilePath +attributes :: Repo -> RawFilePath attributes repo | repoIsLocalBare repo = attributesLocal repo - | otherwise = fromRawFilePath (repoPath repo) </> ".gitattributes" + | otherwise = repoPath repo P.</> ".gitattributes" -attributesLocal :: Repo -> FilePath -attributesLocal repo = fromRawFilePath (localGitDir repo) - </> "info" </> "attributes" +attributesLocal :: Repo -> RawFilePath +attributesLocal repo = localGitDir repo P.</> "info" P.</> "attributes" {- Path to a given hook script in a repository, only if the hook exists - and is executable. -} @@ -149,7 +156,7 @@ hookPath script repo = do #if mingw32_HOST_OS isexecutable f = doesFileExist f #else - isexecutable f = isExecutable . fileMode <$> getFileStatus f + isexecutable f = isExecutable . fileMode <$> getSymbolicLinkStatus f #endif {- Makes the path to a local Repo be relative to the cwd. -} @@ -158,13 +165,13 @@ relPath = adjustPath torel where torel p = do p' <- relPathCwdToFile p - return $ if null p' then "." else p' + return $ if B.null p' then "." else p' {- Adusts the path to a local Repo using the provided function. -} -adjustPath :: (FilePath -> IO FilePath) -> Repo -> IO Repo +adjustPath :: (RawFilePath -> IO RawFilePath) -> Repo -> IO Repo adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do - d' <- f' d - w' <- maybe (pure Nothing) (Just <$$> f') w + d' <- f d + w' <- maybe (pure Nothing) (Just <$$> f) w return $ r { location = l { gitdir = d' @@ -172,8 +179,7 @@ adjustPath f r@(Repo { location = l@(Local { gitdir = d, worktree = w }) }) = do } } where - f' v = toRawFilePath <$> f (fromRawFilePath v) adjustPath f r@(Repo { location = LocalUnknown d }) = do - d' <- toRawFilePath <$> f (fromRawFilePath d) + d' <- f d return $ r { location = LocalUnknown d' } adjustPath _ r = pure r |