138 lines
3.7 KiB
Haskell
138 lines
3.7 KiB
Haskell
{- 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>
|
|
-
|
|
- 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,
|
|
hookPath,
|
|
assertLocal,
|
|
) where
|
|
|
|
import qualified Data.Map as M
|
|
import Data.Char
|
|
import Network.URI (uriPath, uriScheme, unEscapeString)
|
|
import System.Posix.Files
|
|
|
|
import Common
|
|
import Git.Types
|
|
import Utility.FileMode
|
|
|
|
{- 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
|
|
| repoIsUrl repo = error $ unwords
|
|
[ "acting on non-local git repo"
|
|
, repoDescribe repo
|
|
, "not supported"
|
|
]
|
|
| otherwise = action
|
|
|
|
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 -> FilePath
|
|
attributes repo
|
|
| configBare repo = workTree repo ++ "/info/.gitattributes"
|
|
| otherwise = workTree repo ++ "/.gitattributes"
|
|
|
|
{- Path to a repository's .git directory. -}
|
|
gitDir :: Repo -> FilePath
|
|
gitDir repo
|
|
| configBare repo = workTree repo
|
|
| otherwise = workTree repo </> ".git"
|
|
|
|
{- 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
|
|
ifM (catchBoolIO $ isexecutable hook)
|
|
( return $ Just hook , return Nothing )
|
|
where
|
|
isexecutable f = isExecutable . fileMode <$> getFileStatus f
|
|
|
|
{- 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
|