{- git repository handling - - This is written to be completely independant of git-annex and should be - suitable for other uses. - - Copyright 2010, 2011 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Git ( Repo(..), Ref(..), Branch, Sha, Tag, repoIsUrl, repoIsSsh, repoIsHttp, repoIsLocalBare, repoDescribe, repoLocation, workTree, gitDir, configTrue, attributes, assertLocal, ) where import qualified Data.Map as M import Data.Char import Network.URI (uriPath, uriScheme, unEscapeString) import Common import Git.Types {- User-visible description of a git repo. -} repoDescribe :: Repo -> String repoDescribe Repo { remoteName = Just name } = name repoDescribe Repo { location = Url url } = show url repoDescribe Repo { location = Dir dir } = dir 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 = Dir dir } = dir repoLocation Repo { location = Unknown } = undefined {- 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 _ = False repoIsSsh :: Repo -> Bool repoIsSsh Repo { location = Url url } | scheme == "ssh:" = True -- git treats these the same as ssh | scheme == "git+ssh:" = True | scheme == "ssh+git:" = True | otherwise = False where scheme = uriScheme url repoIsSsh _ = False repoIsHttp :: Repo -> Bool repoIsHttp Repo { location = Url url } | uriScheme url == "http:" = True | uriScheme url == "https:" = True | otherwise = False repoIsHttp _ = False configAvail ::Repo -> Bool configAvail Repo { config = c } = c /= M.empty repoIsLocalBare :: Repo -> Bool repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r repoIsLocalBare _ = False assertLocal :: Repo -> a -> a assertLocal repo action = if not $ repoIsUrl repo then action else error $ "acting on non-local git repo " ++ repoDescribe repo ++ " not supported" configBare :: Repo -> Bool configBare repo = maybe unknown (fromMaybe False . configTrue) $ M.lookup "core.bare" $ config repo where unknown = error $ "it is not known if git repo " ++ repoDescribe repo ++ " is a bare repository; config not read" {- Path to a repository's gitattributes file. -} attributes :: Repo -> String attributes repo | configBare repo = workTree repo ++ "/info/.gitattributes" | otherwise = workTree repo ++ "/.gitattributes" {- Path to a repository's .git directory. -} gitDir :: Repo -> String gitDir repo | configBare repo = workTree repo | otherwise = workTree repo ".git" {- Path to a repository's --work-tree, that is, its top. - - Note that for URL repositories, this is the path on the remote host. -} workTree :: Repo -> FilePath workTree Repo { location = Url u } = unEscapeString $ uriPath u workTree Repo { location = Dir d } = d workTree Repo { location = Unknown } = undefined {- Checks if a string from git config is a true value. -} configTrue :: String -> Maybe Bool configTrue s | s' == "true" = Just True | s' == "false" = Just False | otherwise = Nothing where s' = map toLower s