{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Google.Internal.Auth where
import Control.Exception.Lens (exception)
import Control.Lens (Prism', prism, (<&>))
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO (..))
import Crypto.PubKey.RSA.Types (PrivateKey)
import Data.Aeson
import Data.Aeson.Types (Pair)
import Data.ByteArray (ByteArray)
import Data.ByteArray.Encoding
import Data.ByteString (ByteString)
import Data.ByteString.Builder ()
import qualified Data.ByteString.Lazy as LBS
import Data.String (IsString)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time
import Data.X509 (PrivKey (..))
import Data.X509.Memory (readKeyFileFromMemory)
import GHC.TypeLits (Symbol)
import Network.Google.Internal.Logger
import Network.Google.Prelude
import Network.HTTP.Conduit (HttpException, Manager)
import qualified Network.HTTP.Conduit as Client
import Network.HTTP.Types (Status, hContentType)
data Credentials (s :: [Symbol])
= FromMetadata !ServiceId
| FromClient !OAuthClient !(OAuthCode s)
| FromAccount !ServiceAccount
| FromUser !AuthorizedUser
data ServiceAccount = ServiceAccount
{ _serviceId :: !ClientId
, _serviceEmail :: !Text
, _serviceKeyId :: !Text
, _servicePrivateKey :: !PrivateKey
, _serviceAccountUser :: !(Maybe Text)
} deriving (Eq, Show)
instance FromJSON ServiceAccount where
parseJSON = withObject "service_account" $ \o -> do
bs <- Text.encodeUtf8 <$> o .: "private_key"
k <- case listToMaybe (readKeyFileFromMemory bs) of
Just (PrivKeyRSA k) -> pure k
_ ->
fail "Unable to parse key contents from \"private_key\""
ServiceAccount
<$> o .: "client_id"
<*> o .: "client_email"
<*> o .: "private_key_id"
<*> pure k
<*> pure Nothing
data AuthorizedUser = AuthorizedUser
{ _userId :: !ClientId
, _userRefresh :: !RefreshToken
, _userSecret :: !Secret
} deriving (Eq, Show)
instance ToJSON AuthorizedUser where
toJSON (AuthorizedUser i r s) =
object [ "client_id" .= i
, "refresh_token" .= r
, "client_secret" .= s
]
instance FromJSON AuthorizedUser where
parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser
<$> o .: "client_id"
<*> o .: "refresh_token"
<*> o .: "client_secret"
data OAuthClient = OAuthClient
{ _clientId :: !ClientId
, _clientSecret :: !Secret
} deriving (Eq, Show)
data OAuthToken (s :: [Symbol]) = OAuthToken
{ _tokenAccess :: !AccessToken
, _tokenRefresh :: !(Maybe RefreshToken)
, _tokenExpiry :: !UTCTime
} deriving (Eq, Show)
instance FromJSON (UTCTime -> OAuthToken s) where
parseJSON = withObject "bearer" $ \o -> do
t <- o .: "access_token"
r <- o .:? "refresh_token"
e <- o .: "expires_in" <&> fromInteger
pure (OAuthToken t r . addUTCTime e)
newtype OAuthCode (s :: [Symbol]) = OAuthCode Text
deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromJSON, ToJSON)
instance ToHttpApiData (OAuthCode s) where
toQueryParam (OAuthCode c) = c
toHeader (OAuthCode c) = Text.encodeUtf8 c
data AuthError
= RetrievalError HttpException
| MissingFileError FilePath
| InvalidFileError FilePath Text
| TokenRefreshError Status Text (Maybe Text)
| FileExistError FilePath
deriving (Show, Typeable)
instance Exception AuthError
class AsAuthError a where
_AuthError :: Prism' a AuthError
{-# MINIMAL _AuthError #-}
_RetrievalError :: Prism' a HttpException
_MissingFileError :: Prism' a FilePath
_InvalidFileError :: Prism' a (FilePath, Text)
_TokenRefreshError :: Prism' a (Status, Text, Maybe Text)
_RetrievalError = _AuthError . _RetrievalError
_MissingFileError = _AuthError . _MissingFileError
_InvalidFileError = _AuthError . _InvalidFileError
_TokenRefreshError = _AuthError . _TokenRefreshError
instance AsAuthError SomeException where
_AuthError = exception
instance AsAuthError AuthError where
_AuthError = id
_RetrievalError = prism RetrievalError $ \case
RetrievalError e -> Right e
x -> Left x
_MissingFileError = prism MissingFileError $ \case
MissingFileError f -> Right f
x -> Left x
_InvalidFileError = prism
(uncurry InvalidFileError)
(\case
InvalidFileError f e -> Right (f, e)
x -> Left x)
_TokenRefreshError = prism
(\(s, e, d) -> TokenRefreshError s e d)
(\case
TokenRefreshError s e d -> Right (s, e, d)
x -> Left x)
data RefreshError = RefreshError
{ _error :: !Text
, _description :: !(Maybe Text)
}
instance FromJSON RefreshError where
parseJSON = withObject "refresh_error" $ \o -> RefreshError
<$> o .: "error"
<*> o .:? "error_description"
accountsURL :: Text
accountsURL = "https://accounts.google.com/o/oauth2/v2/auth"
accountsRequest :: Client.Request
accountsRequest = Client.defaultRequest
{ Client.host = "accounts.google.com"
, Client.port = 443
, Client.secure = True
, Client.method = "POST"
, Client.path = "/o/oauth2/v2/auth"
, Client.requestHeaders =
[ (hContentType, "application/x-www-form-urlencoded")
]
}
tokenURL :: Text
tokenURL = "https://www.googleapis.com/oauth2/v4/token"
tokenRequest :: Client.Request
tokenRequest = Client.defaultRequest
{ Client.host = "www.googleapis.com"
, Client.port = 443
, Client.secure = True
, Client.method = "POST"
, Client.path = "/oauth2/v4/token"
, Client.requestHeaders =
[ (hContentType, "application/x-www-form-urlencoded")
]
}
refreshRequest :: (MonadIO m, MonadCatch m)
=> Client.Request
-> Logger
-> Manager
-> m (OAuthToken s)
refreshRequest rq l m = do
logDebug l rq
rs <- liftIO (Client.httpLbs rq m) `catch` (throwM . RetrievalError)
let bs = Client.responseBody rs
s = Client.responseStatus rs
logDebug l rs
logTrace l $ "[Response Body]\n" <> bs
if fromEnum s == 200
then success s bs
else failure s bs
where
success s bs = do
f <- parseErr s bs
ts <- liftIO getCurrentTime
pure (f ts)
failure s bs = do
let e = "Failure refreshing token from " <> host <> path
logError l $ "[Refresh Error] " <> build e
case parseLBS bs of
Right x -> refreshErr s (_error x) (_description x)
Left _ -> refreshErr s e Nothing
parseErr s bs =
case parseLBS bs of
Right !x -> pure x
Left e -> do
logError l $
"[Parse Error] Failure parsing token refresh " <> build e
refreshErr s e Nothing
refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a
refreshErr s e = throwM . TokenRefreshError s e
host = Text.decodeUtf8 (Client.host rq)
path = Text.decodeUtf8 (Client.path rq)
parseLBS :: FromJSON a => LBS.ByteString -> Either Text a
parseLBS = either (Left . Text.pack) Right . eitherDecode'
base64Encode :: [Pair] -> ByteString
base64Encode = base64 . LBS.toStrict . encode . object
base64 :: ByteArray a => a -> ByteString
base64 = convertToBase Base64URLUnpadded
textBody :: Text -> RequestBody
textBody = Client.RequestBodyBS . Text.encodeUtf8