{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Network.Wai.Middleware.Auth.OAuth2.Gitlab
    ( Gitlab(..)
    , mkGitlabProvider
    , gitlabParser
    ) where
import           Control.Exception.Safe               (catchAny)
import           Data.Maybe                           (fromMaybe)
import           Data.Aeson
import qualified Data.ByteString                      as S
import           Data.Proxy                           (Proxy (..))
import qualified Data.Text                            as T
import           Data.Text.Encoding                   (encodeUtf8)
import           Network.HTTP.Simple                  (getResponseBody,
                                                       httpJSON, parseRequest,
                                                       setRequestHeaders)
import           Network.HTTP.Types
import qualified Network.OAuth.OAuth2                 as OA2
import           Network.Wai.Auth.Internal            (decodeToken)
import           Network.Wai.Auth.Tools               (getValidEmail)
import           Network.Wai.Middleware.Auth.OAuth2
import           Network.Wai.Middleware.Auth.Provider

-- | Create a gitlab authentication provider
--
-- @since 0.2.4.0
mkGitlabProvider
  :: T.Text -- ^ Hostname of GitLab instance (e.g. @gitlab.com@)
  -> T.Text -- ^ Name of the application as it is registered on gitlab
  -> T.Text -- ^ @client_id@ from gitlab
  -> T.Text -- ^ @client_secret@ from gitlab
  -> [S.ByteString] -- ^ White list of posix regular expressions for emails
  -- attached to gitlab account.
  -> Maybe ProviderInfo -- ^ Replacement for default info
  -> Gitlab
mkGitlabProvider :: Text
-> Text
-> Text
-> Text
-> [ByteString]
-> Maybe ProviderInfo
-> Gitlab
mkGitlabProvider Text
gitlabHost Text
appName Text
clientId Text
clientSecret [ByteString]
emailWhiteList Maybe ProviderInfo
mProviderInfo =
  Text -> Text -> [ByteString] -> OAuth2 -> Gitlab
Gitlab
    Text
appName
    (Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gitlabHost Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/api/v4/user")
    [ByteString]
emailWhiteList
    OAuth2 :: Text
-> Text -> Text -> Text -> Maybe [Text] -> ProviderInfo -> OAuth2
OAuth2
    { oa2ClientId :: Text
oa2ClientId = Text
clientId
    , oa2ClientSecret :: Text
oa2ClientSecret = Text
clientSecret
    , oa2AuthorizeEndpoint :: Text
oa2AuthorizeEndpoint = (Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gitlabHost Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/oauth/authorize")
    , oa2AccessTokenEndpoint :: Text
oa2AccessTokenEndpoint = (Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
gitlabHost Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/oauth/token")
    , oa2Scope :: Maybe [Text]
oa2Scope = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text
"read_user"]
    , oa2ProviderInfo :: ProviderInfo
oa2ProviderInfo = ProviderInfo -> Maybe ProviderInfo -> ProviderInfo
forall a. a -> Maybe a -> a
fromMaybe ProviderInfo
defProviderInfo Maybe ProviderInfo
mProviderInfo
    }
  where
    defProviderInfo :: ProviderInfo
defProviderInfo =
      ProviderInfo :: Text -> Text -> Text -> ProviderInfo
ProviderInfo
      { providerTitle :: Text
providerTitle = Text
"GitLab"
      , providerLogoUrl :: Text
providerLogoUrl =
          Text
"https://about.gitlab.com/images/press/logo/png/gitlab-icon-rgb.png"
      , providerDescr :: Text
providerDescr = Text
"Use your GitLab account to access this page."
      }

-- | Aeson parser for `Gitlab` provider.
--
-- @since 0.2.4.0
gitlabParser :: ProviderParser
gitlabParser :: ProviderParser
gitlabParser = Proxy Gitlab -> ProviderParser
forall ap.
(FromJSON ap, AuthProvider ap) =>
Proxy ap -> ProviderParser
mkProviderParser (Proxy Gitlab
forall k (t :: k). Proxy t
Proxy :: Proxy Gitlab)


-- | Gitlab authentication provider
data Gitlab = Gitlab
  { Gitlab -> Text
gitlabAppName          :: T.Text
  , Gitlab -> Text
gitlabAPIUserEndpoint  :: T.Text
  , Gitlab -> [ByteString]
gitlabEmailWhitelist   :: [S.ByteString]
  , Gitlab -> OAuth2
gitlabOAuth2           :: OAuth2
  }

instance FromJSON Gitlab where
  parseJSON :: Value -> Parser Gitlab
parseJSON =
    String -> (Object -> Parser Gitlab) -> Value -> Parser Gitlab
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Gitlab Provider Object" ((Object -> Parser Gitlab) -> Value -> Parser Gitlab)
-> (Object -> Parser Gitlab) -> Value -> Parser Gitlab
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      Maybe Text
gitlabHost <- Object
obj Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"gitlab_host"
      Text
appName <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"app_name"
      Text
clientId <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"client_id"
      Text
clientSecret <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"client_secret"
      [Text]
emailWhiteList <- Object
obj Object -> Text -> Parser (Maybe [Text])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"email_white_list" Parser (Maybe [Text]) -> [Text] -> Parser [Text]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
      Maybe ProviderInfo
mProviderInfo <- Object
obj Object -> Text -> Parser (Maybe ProviderInfo)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"provider_info"
      Gitlab -> Parser Gitlab
forall (m :: * -> *) a. Monad m => a -> m a
return (Gitlab -> Parser Gitlab) -> Gitlab -> Parser Gitlab
forall a b. (a -> b) -> a -> b
$
        Text
-> Text
-> Text
-> Text
-> [ByteString]
-> Maybe ProviderInfo
-> Gitlab
mkGitlabProvider
          (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"gitlab.com" Maybe Text
gitlabHost)
          Text
appName
          Text
clientId
          Text
clientSecret
          ((Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
encodeUtf8 [Text]
emailWhiteList)
          Maybe ProviderInfo
mProviderInfo

-- | Newtype wrapper for a gitlab user
newtype GitlabEmail = GitlabEmail { GitlabEmail -> ByteString
gitlabEmail :: S.ByteString } deriving Int -> GitlabEmail -> ShowS
[GitlabEmail] -> ShowS
GitlabEmail -> String
(Int -> GitlabEmail -> ShowS)
-> (GitlabEmail -> String)
-> ([GitlabEmail] -> ShowS)
-> Show GitlabEmail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitlabEmail] -> ShowS
$cshowList :: [GitlabEmail] -> ShowS
show :: GitlabEmail -> String
$cshow :: GitlabEmail -> String
showsPrec :: Int -> GitlabEmail -> ShowS
$cshowsPrec :: Int -> GitlabEmail -> ShowS
Show

instance FromJSON GitlabEmail where
  parseJSON :: Value -> Parser GitlabEmail
parseJSON = String
-> (Object -> Parser GitlabEmail) -> Value -> Parser GitlabEmail
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Gitlab Email" ((Object -> Parser GitlabEmail) -> Value -> Parser GitlabEmail)
-> (Object -> Parser GitlabEmail) -> Value -> Parser GitlabEmail
forall a b. (a -> b) -> a -> b
$ \ Object
obj -> do
    Text
email <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"email"
    GitlabEmail -> Parser GitlabEmail
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> GitlabEmail
GitlabEmail (ByteString -> GitlabEmail) -> ByteString -> GitlabEmail
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
email)


-- | Makes an API call to gitlab and retrieves user's verified email.
-- Note: we only retrieve the PRIMARY email, because there is no way
-- to tell whether secondary emails are verified or not.
retrieveUser :: T.Text -> T.Text -> S.ByteString -> IO GitlabEmail
retrieveUser :: Text -> Text -> ByteString -> IO GitlabEmail
retrieveUser Text
appName Text
userApiEndpoint ByteString
accessToken = do
  Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
T.unpack Text
userApiEndpoint)
  Response GitlabEmail
resp <- Request -> IO (Response GitlabEmail)
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response a)
httpJSON (Request -> IO (Response GitlabEmail))
-> Request -> IO (Response GitlabEmail)
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> Request -> Request
setRequestHeaders RequestHeaders
headers Request
req
  GitlabEmail -> IO GitlabEmail
forall (m :: * -> *) a. Monad m => a -> m a
return (GitlabEmail -> IO GitlabEmail) -> GitlabEmail -> IO GitlabEmail
forall a b. (a -> b) -> a -> b
$ Response GitlabEmail -> GitlabEmail
forall a. Response a -> a
getResponseBody Response GitlabEmail
resp
  where
    headers :: RequestHeaders
headers =
      [ (HeaderName
"Authorization", ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
accessToken)
      , (HeaderName
"User-Agent", Text -> ByteString
encodeUtf8 Text
appName)
      ]


instance AuthProvider Gitlab where
  getProviderName :: Gitlab -> Text
getProviderName Gitlab
_ = Text
"gitlab"
  getProviderInfo :: Gitlab -> ProviderInfo
getProviderInfo = OAuth2 -> ProviderInfo
forall ap. AuthProvider ap => ap -> ProviderInfo
getProviderInfo (OAuth2 -> ProviderInfo)
-> (Gitlab -> OAuth2) -> Gitlab -> ProviderInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gitlab -> OAuth2
gitlabOAuth2
  handleLogin :: Gitlab
-> Request
-> [Text]
-> Render ProviderUrl
-> (ByteString -> IO Response)
-> (Status -> ByteString -> IO Response)
-> IO Response
handleLogin Gitlab {[ByteString]
Text
OAuth2
gitlabOAuth2 :: OAuth2
gitlabEmailWhitelist :: [ByteString]
gitlabAPIUserEndpoint :: Text
gitlabAppName :: Text
gitlabOAuth2 :: Gitlab -> OAuth2
gitlabEmailWhitelist :: Gitlab -> [ByteString]
gitlabAPIUserEndpoint :: Gitlab -> Text
gitlabAppName :: Gitlab -> Text
..} Request
req [Text]
suffix Render ProviderUrl
renderUrl ByteString -> IO Response
onSuccess Status -> ByteString -> IO Response
onFailure = do
    let onOAuth2Success :: ByteString -> IO Response
onOAuth2Success ByteString
oauth2Tokens = do
          IO Response -> (SomeException -> IO Response) -> IO Response
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAny
            (do ByteString
accessToken <-
                  case ByteString -> Either String OAuth2Token
decodeToken ByteString
oauth2Tokens of
                    Left String
err -> String -> IO ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
                    Right OAuth2Token
tokens -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AccessToken -> Text
OA2.atoken (AccessToken -> Text) -> AccessToken -> Text
forall a b. (a -> b) -> a -> b
$ OAuth2Token -> AccessToken
OA2.accessToken OAuth2Token
tokens
                ByteString
email <-
                  GitlabEmail -> ByteString
gitlabEmail (GitlabEmail -> ByteString) -> IO GitlabEmail -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  Text -> Text -> ByteString -> IO GitlabEmail
retrieveUser
                    Text
gitlabAppName
                    Text
gitlabAPIUserEndpoint
                    ByteString
accessToken
                let mValidEmail :: Maybe ByteString
mValidEmail = [ByteString] -> [ByteString] -> Maybe ByteString
getValidEmail [ByteString]
gitlabEmailWhitelist [ByteString
email]
                case Maybe ByteString
mValidEmail of
                  Just ByteString
validEmail -> ByteString -> IO Response
onSuccess ByteString
validEmail
                  Maybe ByteString
Nothing ->
                    Status -> ByteString -> IO Response
onFailure Status
status403 (ByteString -> IO Response) -> ByteString -> IO Response
forall a b. (a -> b) -> a -> b
$
                    ByteString
"Your primary email address does not have permission to access this resource. " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
                    ByteString
"Please contact the administrator.")
            (\SomeException
_err -> Status -> ByteString -> IO Response
onFailure Status
status501 ByteString
"Issue communicating with gitlab")
    OAuth2
-> Request
-> [Text]
-> Render ProviderUrl
-> (ByteString -> IO Response)
-> (Status -> ByteString -> IO Response)
-> IO Response
forall ap.
AuthProvider ap =>
ap
-> Request
-> [Text]
-> Render ProviderUrl
-> (ByteString -> IO Response)
-> (Status -> ByteString -> IO Response)
-> IO Response
handleLogin OAuth2
gitlabOAuth2 Request
req [Text]
suffix Render ProviderUrl
renderUrl ByteString -> IO Response
onOAuth2Success Status -> ByteString -> IO Response
onFailure