From 02f1bd2bf47d3ff49a222e9428ec27708ef55f64 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 Dec 2011 15:30:14 -0400 Subject: split more stuff out of Git.hs --- Git.hs | 148 +++++------------------------------------------------------------ 1 file changed, 10 insertions(+), 138 deletions(-) (limited to 'Git.hs') diff --git a/Git.hs b/Git.hs index b4cbd91aa..a3f2ad74c 100644 --- a/Git.hs +++ b/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 - - -} -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 -- cgit v1.2.3