0b27e6baa0
Turns out that git will accept a .git/config containing an url with eg, spaces in its name. Handle this by escaping the url if it's not valid. This also fixes support for urls containing escaped characters like %20 for space. Before, the path from the url was not unescaped properly.
116 lines
3.1 KiB
Haskell
116 lines
3.1 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,
|
|
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 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 -> Bool
|
|
configTrue s = map toLower s == "true"
|