From 26e0bbbeb61ee6313b2ed67a6e90d10f9c4990da Mon Sep 17 00:00:00 2001
From: Eduardo Trujillo <ed@chromabits.com>
Date: Sat, 26 Dec 2020 22:43:20 -0800
Subject: [PATCH] feat(GitLab): Add support for looking up GitLab users
---
package.yaml | 5 +-
shift.cabal | 11 +++-
src/GitLab/UserSearch.hs | 124 +++++++++++++++++++++++++++++++++++++++
src/Shift/CLI.hs | 37 +++++++++++-
src/Shift/Git.hs | 31 ++++++++++
src/Shift/Types.hs | 65 +++++++++++++++++++-
6 files changed, 267 insertions(+), 6 deletions(-)
create mode 100644 src/GitLab/UserSearch.hs
diff --git a/package.yaml b/package.yaml
index 547285c..93c6627 100644
--- a/package.yaml
+++ b/package.yaml
@@ -42,6 +42,8 @@ dependencies:
- semigroups
- cmark-gfm
- scotty
+ - gitlab-haskell
+ - http-types
library:
source-dirs:
@@ -58,10 +60,11 @@ library:
- Shift.Types
- Shift.Utilities
- GitHub.UserSearch
+ - GitLab.UserSearch
other-modules: []
executables:
- dab:
+ shift:
source-dirs: app
main: Main.hs
dependencies:
diff --git a/shift.cabal b/shift.cabal
index 80a0383..c53d040 100644
--- a/shift.cabal
+++ b/shift.cabal
@@ -35,6 +35,7 @@ library
Shift.Types
Shift.Utilities
GitHub.UserSearch
+ GitLab.UserSearch
hs-source-dirs:
src
ghc-options: -Wall
@@ -47,9 +48,11 @@ library
, data-default
, exceptions
, github
+ , gitlab-haskell
, hgit
, http-client
, http-client-tls
+ , http-types
, io-memoize
, lens
, megaparsec
@@ -66,7 +69,7 @@ library
, versions
default-language: Haskell2010
-executable dab
+executable shift
main-is: Main.hs
other-modules:
Paths_shift
@@ -82,9 +85,11 @@ executable dab
, data-default
, exceptions
, github
+ , gitlab-haskell
, hgit
, http-client
, http-client-tls
+ , http-types
, io-memoize
, lens
, megaparsec
@@ -118,9 +123,11 @@ test-suite doctest
, doctest
, exceptions
, github
+ , gitlab-haskell
, hgit
, http-client
, http-client-tls
+ , http-types
, io-memoize
, lens
, megaparsec
@@ -156,12 +163,14 @@ test-suite spec
, data-default
, exceptions
, github
+ , gitlab-haskell
, hgit
, hspec
, hspec-discover
, hspec-megaparsec
, http-client
, http-client-tls
+ , http-types
, io-memoize
, lens
, megaparsec
diff --git a/src/GitLab/UserSearch.hs b/src/GitLab/UserSearch.hs
new file mode 100644
index 0000000..fd53da9
--- /dev/null
+++ b/src/GitLab/UserSearch.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module GitLab.UserSearch where
+
+import qualified Control.Exception as Exception
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Reader (asks)
+import Data.Aeson (FromJSON, eitherDecode)
+import qualified Data.ByteString.Lazy as BSL
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import GitLab.Types
+ ( GitLab,
+ GitLabServerConfig (retries, timeout, token, url),
+ GitLabState (httpManager, serverCfg),
+ User,
+ )
+import Network.HTTP.Client
+ ( HttpException,
+ Manager,
+ Request (requestHeaders, responseTimeout),
+ Response (responseBody, responseHeaders, responseStatus),
+ httpLbs,
+ parseRequest_,
+ responseTimeoutMicro,
+ )
+import Network.HTTP.Types (urlEncode)
+import Network.HTTP.Types.Status (Status (Status))
+import Text.Read (readMaybe)
+
+newtype GitLabUserSearchException = GitLabUserSearchException String
+ deriving (Eq, Show)
+
+instance Exception.Exception GitLabUserSearchException
+
+-- | Searches for a user given a Username or Email. Returns @Just User@ if the
+-- user is found, otherwise @Nothing@.
+searchUsers ::
+ -- | User to search for (Username, Email, etc)
+ Text ->
+ GitLab [User]
+searchUsers query = do
+ let path = "/search"
+ attrs = "&scope=users&search=" <> query
+ res <- gitlabReqJsonMany path attrs
+ case res of
+ Left _ -> return []
+ Right users -> return users
+
+gitlabReqJsonMany :: (FromJSON a) => Text -> Text -> GitLab (Either Status [a])
+gitlabReqJsonMany urlPath attrs =
+ go 1 []
+ where
+ go i accum = do
+ cfg <- asks serverCfg
+ manager <- asks httpManager
+ let url' =
+ url cfg
+ <> "/api/v4"
+ <> urlPath
+ <> "?per_page=100"
+ <> "&page="
+ <> T.pack (show i)
+ <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 attrs))
+ let request' = parseRequest_ (T.unpack url')
+ request =
+ request'
+ { requestHeaders =
+ [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))],
+ responseTimeout = responseTimeoutMicro (timeout cfg)
+ }
+ -- here
+ resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing
+ if successStatus (responseStatus resp)
+ then do
+ moreResults <- liftIO $ parseBSMany (responseBody resp)
+ let numPages = totalPages resp
+ accum' = accum ++ moreResults
+ if numPages == i
+ then return (Right accum')
+ else go (i + 1) accum'
+ else return (Left (responseStatus resp))
+
+tryGitLab ::
+ -- | the current retry count
+ Int ->
+ -- | the GitLab request
+ Request ->
+ -- | maximum number of retries permitted
+ Int ->
+ -- | HTTP manager
+ Manager ->
+ -- | the exception to report if maximum retries met
+ Maybe HttpException ->
+ IO (Response BSL.ByteString)
+tryGitLab i request maxRetries manager lastException
+ | i == maxRetries = error (show lastException)
+ | otherwise =
+ httpLbs request manager
+ `Exception.catch` \ex -> tryGitLab (i + 1) request maxRetries manager (Just ex)
+
+totalPages :: Response a -> Int
+totalPages resp =
+ let hdrs = responseHeaders resp
+ in findPages hdrs
+ where
+ findPages [] = 1 -- error "cannot find X-Total-Pages in header"
+ findPages (("X-Total-Pages", bs) : _) =
+ case readMaybe (T.unpack (T.decodeUtf8 bs)) of
+ Just s -> s
+ Nothing -> error "cannot find X-Total-Pages in header"
+ findPages (_ : xs) = findPages xs
+
+successStatus :: Status -> Bool
+successStatus (Status n _msg) =
+ n >= 200 && n <= 226
+
+parseBSMany :: FromJSON a => BSL.ByteString -> IO [a]
+parseBSMany bs =
+ case eitherDecode bs of
+ Left s -> Exception.throwIO $ GitLabUserSearchException s
+ Right xs -> return xs
diff --git a/src/Shift/CLI.hs b/src/Shift/CLI.hs
index 50724c5..eee8e7d 100644
--- a/src/Shift/CLI.hs
+++ b/src/Shift/CLI.hs
@@ -32,7 +32,11 @@ data ShiftOptions = ShiftOptions
_soToRef :: Maybe String,
_soGitHubOwner :: Maybe String,
_soGitHubRepository :: Maybe String,
- _soGitHubToken :: Maybe String
+ _soGitHubToken :: Maybe String,
+ _soGitLabOwner :: Maybe String,
+ _soGitLabRepository :: Maybe String,
+ _soGitLabServer :: Maybe String,
+ _soGitLabToken :: Maybe String
}
deriving (Show, Eq)
@@ -41,7 +45,7 @@ data ShiftCommand
| ServeCommand {_scPort :: Maybe Int}
deriving (Show, Eq)
-data HostingType = GitHubType | GitType deriving (Show, Eq, Enum)
+data HostingType = GitHubType | GitLabType | GitType deriving (Show, Eq, Enum)
shiftOptions :: Parser ShiftOptions
shiftOptions =
@@ -93,6 +97,34 @@ shiftOptions =
<> help "GitHub access token"
)
)
+ <*> optional
+ ( strOption
+ ( long "gitlab-owner"
+ <> metavar "USERNAME"
+ <> help "Username who owns the repository"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "gitlab-repository"
+ <> metavar "REPOSITORY"
+ <> help "Name of the repository"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "gitlab-server"
+ <> metavar "TOKEN"
+ <> help "GitLab Server URL"
+ )
+ )
+ <*> optional
+ ( strOption
+ ( long "gitlab-token"
+ <> metavar "TOKEN"
+ <> help "GitLab access token"
+ )
+ )
shiftCommand :: Parser ShiftCommand
shiftCommand =
@@ -124,6 +156,7 @@ shiftCommand =
hostingType :: ReadM HostingType
hostingType = eitherReader $ \case
"github" -> Right GitHubType
+ "gitlab" -> Right GitLabType
"git" -> Right GitType
x -> Left $ "`" ++ x ++ "` is not a supported hosting type"
diff --git a/src/Shift/Git.hs b/src/Shift/Git.hs
index 84dbcdd..c0c9afa 100644
--- a/src/Shift/Git.hs
+++ b/src/Shift/Git.hs
@@ -37,6 +37,7 @@ import Data.Tuple (swap)
import Data.Versions (versioning)
import Data.Void (Void)
import GitHub.Auth (Auth (OAuth))
+import GitLab (GitLabServerConfig (token, url), defaultGitLabServer)
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Shift.CLI
@@ -60,6 +61,13 @@ renderToNode opts = withRepo ".git" $ \repo -> do
GitHubType -> do
state <- initGitHubState
+ fst
+ <$> runReaderT
+ (runStateT (mapM (renderDiff repo) pairedTags) state)
+ opts
+ GitLabType -> do
+ state <- initGitLabState
+
fst
<$> runReaderT
(runStateT (mapM (renderDiff repo) pairedTags) state)
@@ -89,6 +97,29 @@ renderToNode opts = withRepo ".git" $ \repo -> do
_gcsOwner = cs repositoryOwner,
_gcsRepository = cs repositoryName
}
+ initGitLabState = do
+ manager <- newManager tlsManagerSettings
+
+ server <- (opts ^. soGitLabServer) `orError` SEMissingGitLabServer
+ token' <- (opts ^. soGitLabToken) `orError` SEMissingGitLabToken
+ repositoryOwner <- (opts ^. soGitLabOwner) `orError` SEMissingGitLabOwner
+ repositoryName <-
+ (opts ^. soGitLabRepository)
+ `orError` SEMissingGitLabRepository
+
+ pure
+ GitLabClientState
+ { _glcsCache = def,
+ _glcsServerCfg =
+ ( defaultGitLabServer
+ { url = cs server,
+ token = cs token'
+ }
+ ),
+ _glcsHttpManager = manager,
+ _glcsOwner = cs repositoryOwner,
+ _glcsRepository = cs repositoryName
+ }
pairedTagsFromOpts :: HashAlgorithm hash => ShiftOptions -> Git hash -> IO [(TagRef, TagRef)]
pairedTagsFromOpts opts repo = case opts of
diff --git a/src/Shift/Types.hs b/src/Shift/Types.hs
index 34340c4..69f745d 100644
--- a/src/Shift/Types.hs
+++ b/src/Shift/Types.hs
@@ -31,6 +31,7 @@ import Data.Git
)
import Data.HashMap.Strict (HashMap, insert, lookup)
import Data.HashSet (HashSet)
+import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Vector as V
@@ -46,6 +47,8 @@ import GitHub.Data.Search
)
import GitHub.Endpoints.Repos.Commits (commitR)
import GitHub.UserSearch (searchUsersR, urHtmlUrl, urLogin)
+import GitLab (GitLabServerConfig (url), User (user_username, user_web_url), runGitLab)
+import GitLab.UserSearch as GLUS (searchUsers)
import Network.HTTP.Client (Manager)
import Shift.CLI (ShiftOptions)
import Shift.Utilities (orThrow)
@@ -70,6 +73,10 @@ data ShiftException
| SEMissingGitHubToken
| SEMissingGitHubOwner
| SEMissingGitHubRepository
+ | SEMissingGitLabToken
+ | SEMissingGitLabOwner
+ | SEMissingGitLabServer
+ | SEMissingGitLabRepository
deriving (Show)
instance Exception ShiftException
@@ -212,7 +219,7 @@ instance ClientState GitHubClientState where
case lookup email cache of
Just hit -> pure hit
Nothing -> do
- result <- (lookupUserOnGitHub email)
+ result <- lookupUserOnGitHub email
result2 <- case result of
Nothing -> lookupUserOnGitHubCommit ref
@@ -243,7 +250,7 @@ lookupUserOnGitHub ::
lookupUserOnGitHub email = do
results <- executeRequest_ $ searchUsersR email
- case (searchResultTotalCount results == 1) of
+ case searchResultTotalCount results == 1 of
True -> liftIO $ do
let user = V.head $ searchResultResults results
@@ -262,6 +269,60 @@ executeRequest_ x = do
orThrow result
+data GitLabClientState = GitLabClientState
+ { _glcsCache :: RepositoryCache,
+ _glcsServerCfg :: GitLabServerConfig,
+ _glcsHttpManager :: Manager,
+ _glcsOwner :: Text,
+ _glcsRepository :: Text
+ }
+
+makeLenses ''GitLabClientState
+
+instance ClientState GitLabClientState where
+ getRefURL ref = do
+ serverCfg <- gets (view glcsServerCfg)
+ owner <- gets (view glcsOwner)
+ repositoryName <- gets (view glcsRepository)
+
+ pure . Just . mconcat $
+ [ url serverCfg,
+ "/",
+ owner,
+ "/",
+ repositoryName,
+ "/-/commit/",
+ cs . show $ ref
+ ]
+
+ getAuthorInfo person _ = do
+ serverCfg <- gets (view glcsServerCfg)
+
+ let email = cs $ personEmail person
+
+ cache <- gets (view $ glcsCache . rcAuthorInfos)
+
+ case lookup email cache of
+ Just hit -> pure hit
+ Nothing -> do
+ users <- liftIO $ runGitLab serverCfg $ GLUS.searchUsers email
+
+ case users of
+ (user : _) -> do
+ let result =
+ Just
+ ( user_username user,
+ fromMaybe (url serverCfg <> "/" <> user_username user) (user_web_url user)
+ )
+
+ assign (glcsCache . rcAuthorInfos) (insert email result cache)
+
+ pure result
+ _ -> do
+ assign (glcsCache . rcAuthorInfos) (insert email Nothing cache)
+
+ pure Nothing
+
makeLenses ''ConventionalCommit
makeLenses ''ChangeReport
makeLenses ''BreakingChange
--
GitLab