Skip to content
Snippets Groups Projects
Git.hs 3.71 KiB
Newer Older
{- 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 <joey@kitenet.net>
Joey Hess's avatar
Joey Hess committed
 -
 - Licensed under the GNU GPL version 3 or higher.
Joey Hess's avatar
Joey Hess committed

Joey Hess's avatar
Joey Hess committed
module Git (
	Repo(..),
	Ref(..),
	Branch,
	Sha,
	Tag,
	repoIsUrl,
Joey Hess's avatar
Joey Hess committed
	repoIsSsh,
Joey Hess's avatar
Joey Hess committed
	repoIsHttp,
	repoIsLocalBare,
	repoDescribe,
	workTree,
Joey Hess's avatar
Joey Hess committed
	gitDir,
Joey Hess's avatar
Joey Hess committed
	configTrue,
	attributes,
Joey Hess's avatar
Joey Hess committed
	assertLocal,
Joey Hess's avatar
Joey Hess committed
) where
Joey Hess's avatar
Joey Hess committed

import qualified Data.Map as M
Joey Hess's avatar
Joey Hess committed
import Data.Char
import Network.URI (uriPath, uriScheme, unEscapeString)
Joey Hess's avatar
Joey Hess committed
import System.Posix.Files
Joey Hess's avatar
Joey Hess committed

Joey Hess's avatar
Joey Hess committed
import Common
import Git.Types
Joey Hess's avatar
Joey Hess committed
import Utility.FileMode
Joey Hess's avatar
Joey Hess committed

{- User-visible description of a git repo. -}
Joey Hess's avatar
Joey Hess committed
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"
Joey Hess's avatar
Joey Hess committed

{- 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. -}
Joey Hess's avatar
Joey Hess committed
repoIsUrl :: Repo -> Bool
repoIsUrl Repo { location = Url _ } = True
repoIsUrl _ = False

Joey Hess's avatar
Joey Hess committed
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
	where
		scheme = uriScheme url
Joey Hess's avatar
Joey Hess committed
repoIsHttp :: Repo -> Bool
repoIsHttp Repo { location = Url url } 
	| uriScheme url == "http:" = True
	| uriScheme url == "https:" = True
	| otherwise = False
repoIsHttp _ = False

configAvail ::Repo -> Bool
Joey Hess's avatar
Joey Hess committed
configAvail Repo { config = c } = c /= M.empty
repoIsLocalBare :: Repo -> Bool
repoIsLocalBare r@(Repo { location = Dir _ }) = configAvail r && configBare r
repoIsLocalBare _ = False

Joey Hess's avatar
Joey Hess committed
assertLocal :: Repo -> a -> a
assertLocal repo action = 
Joey Hess's avatar
Joey Hess committed
	if not $ repoIsUrl repo
Joey Hess's avatar
Joey Hess committed
		then action
		else error $ "acting on non-local git repo " ++  repoDescribe repo ++ 
Joey Hess's avatar
Joey Hess committed
				" not supported"
configBare :: Repo -> Bool
configBare repo = maybe unknown (fromMaybe False . configTrue) $
	M.lookup "core.bare" $ config repo
Joey Hess's avatar
Joey Hess committed
	where
		unknown = error $ "it is not known if git repo " ++
Joey Hess's avatar
Joey Hess committed
			repoDescribe repo ++
			" is a bare repository; config not read"
Joey Hess's avatar
Joey Hess committed

{- Path to a repository's gitattributes file. -}
	| configBare repo = workTree repo ++ "/info/.gitattributes"
Joey Hess's avatar
Joey Hess committed
	| otherwise = workTree repo ++ "/.gitattributes"
Joey Hess's avatar
Joey Hess committed

Joey Hess's avatar
Joey Hess committed
{- Path to a repository's .git directory. -}
Joey Hess's avatar
Joey Hess committed
gitDir repo
Joey Hess's avatar
Joey Hess committed
	| configBare repo = workTree repo
	| otherwise = workTree repo </> ".git"
Joey Hess's avatar
Joey Hess committed

{- Path to a given hook script in a repository, only if the hook exists
 - and is executable. -}
hookPath :: String -> Repo -> IO (Maybe FilePath)
hookPath script repo = do
	let hook = gitDir repo </> "hooks" </> script
Joey Hess's avatar
Joey Hess committed
	e <- doesFileExist hook
	if e
		then do
			m <- fileMode <$> getFileStatus hook
			return $ if isExecutable m then Just hook else Nothing
		else return Nothing
{- 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
Joey Hess's avatar
Joey Hess committed

{- 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