split more stuff out of Git.hs
This commit is contained in:
Joey Hess
parent
2b24e16a63
commit
02f1bd2bf4
20 changed files with 197 additions and 179 deletions
148
Git.hs
148
Git.hs
|
|
@ -9,7 +9,7 @@
|
|||
-}
|
||||
|
||||
module Git (
|
||||
Repo,
|
||||
Repo(..),
|
||||
Ref(..),
|
||||
Branch,
|
||||
Sha,
|
||||
|
|
@ -22,13 +22,6 @@ module Git (
|
|||
repoLocation,
|
||||
workTree,
|
||||
gitDir,
|
||||
urlPath,
|
||||
urlHost,
|
||||
urlPort,
|
||||
urlHostUser,
|
||||
urlAuthority,
|
||||
urlScheme,
|
||||
configMap,
|
||||
configTrue,
|
||||
gitCommandLine,
|
||||
run,
|
||||
|
|
@ -39,23 +32,14 @@ module Git (
|
|||
pipeNullSplit,
|
||||
pipeNullSplitB,
|
||||
attributes,
|
||||
remotes,
|
||||
remotesAdd,
|
||||
repoRemoteName,
|
||||
repoRemoteNameSet,
|
||||
repoRemoteNameFromKey,
|
||||
reap,
|
||||
useIndex,
|
||||
getSha,
|
||||
shaSize,
|
||||
assertLocal,
|
||||
) where
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Network.URI
|
||||
import Data.Char
|
||||
import System.Posix.Env (setEnv, unsetEnv, getEnv)
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
import Network.URI (uriPath, uriScheme)
|
||||
|
||||
import Common
|
||||
import Git.Types
|
||||
|
|
@ -73,29 +57,6 @@ repoLocation Repo { location = Url url } = show url
|
|||
repoLocation Repo { location = Dir dir } = dir
|
||||
repoLocation Repo { location = Unknown } = undefined
|
||||
|
||||
{- Constructs and returns an updated version of a repo with
|
||||
- different remotes list. -}
|
||||
remotesAdd :: Repo -> [Repo] -> Repo
|
||||
remotesAdd repo rs = repo { remotes = rs }
|
||||
|
||||
{- Returns the name of the remote that corresponds to the repo, if
|
||||
- it is a remote. -}
|
||||
repoRemoteName :: Repo -> Maybe String
|
||||
repoRemoteName Repo { remoteName = Just name } = Just name
|
||||
repoRemoteName _ = Nothing
|
||||
|
||||
{- Sets the name of a remote. -}
|
||||
repoRemoteNameSet :: String -> Repo -> Repo
|
||||
repoRemoteNameSet n r = r { remoteName = Just n }
|
||||
|
||||
{- Sets the name of a remote based on the git config key, such as
|
||||
"remote.foo.url". -}
|
||||
repoRemoteNameFromKey :: String -> Repo -> Repo
|
||||
repoRemoteNameFromKey k = repoRemoteNameSet basename
|
||||
where
|
||||
basename = join "." $ reverse $ drop 1 $
|
||||
reverse $ drop 1 $ split "." k
|
||||
|
||||
{- Some code needs to vary between URL and normal repos,
|
||||
- or bare and non-bare, these functions help with that. -}
|
||||
repoIsUrl :: Repo -> Bool
|
||||
|
|
@ -104,11 +65,13 @@ repoIsUrl _ = False
|
|||
|
||||
repoIsSsh :: Repo -> Bool
|
||||
repoIsSsh Repo { location = Url url }
|
||||
| uriScheme url == "ssh:" = True
|
||||
| scheme == "ssh:" = True
|
||||
-- git treats these the same as ssh
|
||||
| uriScheme url == "git+ssh:" = True
|
||||
| uriScheme url == "ssh+git:" = True
|
||||
| scheme == "git+ssh:" = True
|
||||
| scheme == "ssh+git:" = True
|
||||
| otherwise = False
|
||||
where
|
||||
scheme = uriScheme url
|
||||
repoIsSsh _ = False
|
||||
|
||||
repoIsHttp :: Repo -> Bool
|
||||
|
|
@ -129,15 +92,8 @@ assertLocal :: Repo -> a -> a
|
|||
assertLocal repo action =
|
||||
if not $ repoIsUrl repo
|
||||
then action
|
||||
else error $ "acting on URL git repo " ++ repoDescribe repo ++
|
||||
else error $ "acting on non-local git repo " ++ repoDescribe repo ++
|
||||
" not supported"
|
||||
assertUrl :: Repo -> a -> a
|
||||
assertUrl repo action =
|
||||
if repoIsUrl repo
|
||||
then action
|
||||
else error $ "acting on local git repo " ++ repoDescribe repo ++
|
||||
" not supported"
|
||||
|
||||
configBare :: Repo -> Bool
|
||||
configBare repo = maybe unknown configTrue $ M.lookup "core.bare" $ config repo
|
||||
where
|
||||
|
|
@ -161,61 +117,10 @@ gitDir repo
|
|||
-
|
||||
- Note that for URL repositories, this is the path on the remote host. -}
|
||||
workTree :: Repo -> FilePath
|
||||
workTree r@(Repo { location = Url _ }) = urlPath r
|
||||
workTree (Repo { location = Dir d }) = d
|
||||
workTree Repo { location = Url u } = uriPath u
|
||||
workTree Repo { location = Dir d } = d
|
||||
workTree Repo { location = Unknown } = undefined
|
||||
|
||||
{- Path of an URL repo. -}
|
||||
urlPath :: Repo -> String
|
||||
urlPath Repo { location = Url u } = uriPath u
|
||||
urlPath repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Scheme of an URL repo. -}
|
||||
urlScheme :: Repo -> String
|
||||
urlScheme Repo { location = Url u } = uriScheme u
|
||||
urlScheme repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Work around a bug in the real uriRegName
|
||||
- <http://trac.haskell.org/network/ticket/40> -}
|
||||
uriRegName' :: URIAuth -> String
|
||||
uriRegName' a = fixup $ uriRegName a
|
||||
where
|
||||
fixup x@('[':rest)
|
||||
| rest !! len == ']' = take len rest
|
||||
| otherwise = x
|
||||
where
|
||||
len = length rest - 1
|
||||
fixup x = x
|
||||
|
||||
{- Hostname of an URL repo. -}
|
||||
urlHost :: Repo -> String
|
||||
urlHost = urlAuthPart uriRegName'
|
||||
|
||||
{- Port of an URL repo, if it has a nonstandard one. -}
|
||||
urlPort :: Repo -> Maybe Integer
|
||||
urlPort r =
|
||||
case urlAuthPart uriPort r of
|
||||
":" -> Nothing
|
||||
(':':p) -> readMaybe p
|
||||
_ -> Nothing
|
||||
|
||||
{- Hostname of an URL repo, including any username (ie, "user@host") -}
|
||||
urlHostUser :: Repo -> String
|
||||
urlHostUser r = urlAuthPart uriUserInfo r ++ urlAuthPart uriRegName' r
|
||||
|
||||
{- The full authority portion an URL repo. (ie, "user@host:port") -}
|
||||
urlAuthority :: Repo -> String
|
||||
urlAuthority = urlAuthPart assemble
|
||||
where
|
||||
assemble a = uriUserInfo a ++ uriRegName' a ++ uriPort a
|
||||
|
||||
{- Applies a function to extract part of the uriAuthority of an URL repo. -}
|
||||
urlAuthPart :: (URIAuth -> a) -> Repo -> a
|
||||
urlAuthPart a Repo { location = Url u } = a auth
|
||||
where
|
||||
auth = fromMaybe (error $ "bad url " ++ show u) (uriAuthority u)
|
||||
urlAuthPart _ repo = assertUrl repo $ error "internal"
|
||||
|
||||
{- Constructs a git command line operating on the specified repo. -}
|
||||
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
|
||||
gitCommandLine params repo@(Repo { location = Dir _ } ) =
|
||||
|
|
@ -284,39 +189,6 @@ reap = do
|
|||
r <- catchDefaultIO (getAnyProcessStatus False True) Nothing
|
||||
maybe (return ()) (const reap) r
|
||||
|
||||
{- Forces git to use the specified index file.
|
||||
- Returns an action that will reset back to the default
|
||||
- index file. -}
|
||||
useIndex :: FilePath -> IO (IO ())
|
||||
useIndex index = do
|
||||
res <- getEnv var
|
||||
setEnv var index True
|
||||
return $ reset res
|
||||
where
|
||||
var = "GIT_INDEX_FILE"
|
||||
reset (Just v) = setEnv var v True
|
||||
reset _ = unsetEnv var
|
||||
|
||||
{- Runs an action that causes a git subcommand to emit a sha, and strips
|
||||
any trailing newline, returning the sha. -}
|
||||
getSha :: String -> IO String -> IO Sha
|
||||
getSha subcommand a = do
|
||||
t <- a
|
||||
let t' = if last t == '\n'
|
||||
then init t
|
||||
else t
|
||||
when (length t' /= shaSize) $
|
||||
error $ "failed to read sha from git " ++ subcommand ++ " (" ++ t' ++ ")"
|
||||
return $ Ref t'
|
||||
|
||||
{- Size of a git sha. -}
|
||||
shaSize :: Int
|
||||
shaSize = 40
|
||||
|
||||
{- Checks if a string from git config is a true value. -}
|
||||
configTrue :: String -> Bool
|
||||
configTrue s = map toLower s == "true"
|
||||
|
||||
{- Access to raw config Map -}
|
||||
configMap :: Repo -> M.Map String String
|
||||
configMap = config
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue