{-# 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
mkGitlabProvider
:: T.Text
-> T.Text
-> T.Text
-> T.Text
-> [S.ByteString]
-> Maybe ProviderInfo
-> 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."
}
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)
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 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)
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