@@ -11,11 +11,12 @@ import Control.Monad.Except
1111import Data.Bool (bool)
1212import qualified Text.Megaparsec.Char.Lexer as ML
1313import Data.Bifunctor
14−import qualified Data.List as L
1514import Data.Char
1615import Data.Either
1716import Data.Semigroup ((<>))
17+import Data.Map (Map)
1818import qualified Data.Map as M
19+import Data.Maybe (maybeToList)
1920import Data.Text (Text)
2021import qualified Data.Text as T
2122import Data.Void (Void)
@@ -94,39 +95,37 @@ readProc = readProcessAndLogStderr Error
9495tshow :: Show a => a -> Text
9596tshow = T.pack . show
9697
97−-- like gitLsRemote, but also returns the ref branch if present
98−-- NOTE: getting a branch for a symref like HEAD relies on a minimum of git 1.8.5
99−gitLsRemoteHEAD :: String -> IO (Either String (CommitId, Maybe GitRef))
100−gitLsRemoteHEAD repository = runExceptT $ do
101− let symref = GitRef_Head
102− xs <- ExceptT $ gitLsRemote repository symref
103− let (commits, refs) = bimap M.fromList M.fromList $ partitionEithers $ flip fmap xs $ \case
104− (r, Left commitId) -> Left (r, commitId)
105− (r, Right ref) -> Right (r, ref)
106− case M.lookup symref commits of
107− Nothing -> fail $ "gitLsRemoteHead: Did not find " <> T.unpack (showGitRef symref) <> " in the refs of " <> repository
108− Just commitId -> return (commitId, M.lookup symref refs)
109−
110−gitLsRemoteRef :: String -> GitRef -> IO (Either String (CommitId, Maybe GitRef))
111−gitLsRemoteRef repository ref = runExceptT $ do
112− xs <- ExceptT $ gitLsRemote repository ref
98+gitLookupDefaultBranch :: GitLsRemoteMaps -> Either Text Text
99+gitLookupDefaultBranch (refs, _) = do
100+ ref <- case M.lookup GitRef_Head refs of
101+ Just ref -> pure ref
102+ Nothing -> throwError
103+ "gitLookupDefaultBranch: No symref entry for HEAD. \
104+ \ Is your git version at least 1.8.5? \
105+ \ Otherwise `git ls-remote --symref` will not work."
113106 case ref of
114− GitRef_Head -> do
115− let (commits, refs) = bimap M.fromList M.fromList $ partitionEithers $ flip fmap xs $ \case
116− (r, Left commitId) -> Left (r, commitId)
117− (r, Right symref) -> Right (r, symref)
118− case M.lookup ref commits of
119− Nothing -> fail $ "gitLsRemoteHead: Did not find " <> T.unpack (showGitRef ref) <> " in the refs of " <> repository
120− Just commitId -> return (commitId, M.lookup ref refs)
121− _ -> case L.lookup ref xs of
122− Just (Left a) -> return (a, Nothing)
123− _ -> fail $ "gitLsRemoteHead: Did not find " <> T.unpack (showGitRef ref) <> " in the refs of " <> repository
124−
125−gitLsRemote :: String -> GitRef -> IO (Either String [(GitRef, LsRemoteResult)])
126−gitLsRemote repository ref = do
127− res <- P.readProcess "git" ["ls-remote", "--symref", repository, T.unpack $ showGitRef ref] mempty
107+ GitRef_Branch b -> pure b
108+ _ -> throwError $
109+ "gitLookupDefaultBranch: Default ref " <> showGitRef ref <> " is not a branch!"
110+
111+gitLookupCommitForRef :: GitLsRemoteMaps -> GitRef -> Either Text CommitId
112+gitLookupCommitForRef (_, commits) ref = case M.lookup ref commits of
113+ Just a -> pure a
114+ Nothing -> throwError $ "gitLookupCommitForRef: Did not find " <> showGitRef ref
115+
116+gitLsRemote
117+ :: String
118+ -> Maybe GitRef
119+ -> IO (Either Text GitLsRemoteMaps)
120+gitLsRemote repository mRef = do
121+ res <- P.readProcess "git"
122+ (["ls-remote", "--symref", repository]
123+ ++ (maybeToList $ T.unpack . showGitRef <$> mRef))
124+ mempty
128125 let t = T.pack res
129− return $ first (MP.parseErrorPretty' t) $ MP.runParser (many parseLsRemote) "" t
126+ return $ first (T.pack . MP.parseErrorPretty' t)
127+ $ bimap M.fromList M.fromList . partitionEithers
128+ <$> MP.runParser (many parseLsRemote) "" t
130129
131130lexeme :: Parsec Void Text a -> Parsec Void Text a
132131lexeme = ML.lexeme space
@@ -134,10 +133,10 @@ lexeme = ML.lexeme space
134133-- $ git ls-remote --symref git@github.com:obsidiansystems/obelisk.git HEAD
135134-- ref: refs/heads/master HEAD
136135-- d0a8d25dc93f0acd096bc4ff2f550da9e2d0c8f5 refs/heads/master
137−parseLsRemote :: Parsec Void Text (GitRef, LsRemoteResult)
138−parseLsRemote = try parseRef <|> parseCommit
136+parseLsRemote :: Parsec Void Text (Either (GitRef, GitRef) (GitRef, CommitId))
137+parseLsRemote = try $ fmap Left parseRef <|> fmap Right parseCommit
139138 where
140− parseRef, parseCommit :: Parsec Void Text (GitRef, LsRemoteResult)
139+ parseRef :: Parsec Void Text (GitRef, GitRef)
141140 parseRef = do
142141 _ <- lexeme "ref:"
143142 ref <- lexeme $ MP.takeWhileP (Just "ref")
@@ -145,14 +144,15 @@ parseLsRemote = try parseRef <|> parseCommit
145144 symbolicRef <- lexeme $ MP.takeWhileP (Just "symbolic ref")
146145 $ not . isSpace
147146 _ <- MP.eol
148− return (toGitRef symbolicRef, Right $ toGitRef ref)
147+ return (toGitRef symbolicRef, toGitRef ref)
148+ parseCommit :: Parsec Void Text (GitRef, CommitId)
149149 parseCommit = do
150150 commitId <- lexeme $ MP.takeWhileP (Just "commit id")
151151 $ not . isSpace
152152 ref <- lexeme $ MP.takeWhileP (Just "ref")
153153 $ not . isSpace
154154 _ <- MP.eol
155− return (toGitRef ref, Left commitId)
155+ return (toGitRef ref, commitId)
156156
157157data GitRef
158158 = GitRef_Head
@@ -169,11 +169,13 @@ showGitRef = \case
169169 GitRef_Other x -> x
170170
171171toGitRef :: Text -> GitRef
172−toGitRef r =
173− if | "HEAD" == r -> GitRef_Head
174− | Just s <- "refs/heads/" `T.stripPrefix` r -> GitRef_Branch s
175− | Just s <- "refs/tags/" `T.stripPrefix` r -> GitRef_Tag s
176− | otherwise -> GitRef_Other r
172+toGitRef = \case
173+ "HEAD" -> GitRef_Head
174+ r -> if
175+ | Just s <- "refs/heads/" `T.stripPrefix` r -> GitRef_Branch s
176+ | Just s <- "refs/tags/" `T.stripPrefix` r -> GitRef_Tag s
177+ | otherwise -> GitRef_Other r
177178
178179type CommitId = Text
179−type LsRemoteResult = Either CommitId GitRef
180+
181+type GitLsRemoteMaps = (Map GitRef GitRef, Map GitRef CommitId)