gogol-0.0.1: src/Network/Google/Auth.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- |
-- Module : Network.Google.Auth
-- Copyright : (c) 2015 Brendan Hay
-- License : Mozilla Public License, v. 2.0.
-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability : provisional
-- Portability : non-portable (GHC extensions)
--
-- Explicitly specify your Google credentials, or retrieve them
-- from the underlying OS.
module Network.Google.Auth
(
-- * Authentication
-- ** Retrieving Authentication
getAuth
, Credentials (..)
, Auth
-- ** Authorising Requests
, authorise
-- ** Default Constants
-- *** Google Compute Engine
, checkGCEVar
-- *** Cloud SDK
, cloudSDKConfigDir
, cloudSDKConfigPath
-- *** Application Default Credentials
, defaultCredentialsFile
, defaultCredentialsPath
-- ** Credentials
, fromMetadata
, fromFile
, fromFilePath
-- ** Handling Errors
, AsAuthError (..)
, AuthError (..)
-- ** Re-exported Types
, OAuthScope (..)
, OAuthToken (..)
, ServiceId (..)
, ClientId (..)
) where
import Control.Applicative
import Control.Concurrent
import Control.Exception.Lens
import Control.Lens hiding ((.=))
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Crypto.Hash.Algorithms (SHA256 (..))
import Crypto.PubKey.RSA.PKCS15 (signSafer)
import Crypto.PubKey.RSA.Types (PrivateKey)
import Data.Aeson
import Data.Aeson.Types
import Data.ByteArray
import Data.ByteArray.Encoding
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import Data.Default.Class (def)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time
import Data.Time.Clock.POSIX
import Data.Typeable
import Data.X509
import Data.X509.Memory
import Network.Google.Compute.Metadata
import Network.Google.Internal.Logger
import Network.Google.Prelude
import Network.HTTP.Conduit hiding (Request)
import qualified Network.HTTP.Conduit as Client
import Network.HTTP.Types
import System.Directory (doesFileExist,
getHomeDirectory)
import System.Environment (lookupEnv)
import System.FilePath ((</>))
import System.Info (os)
-- | 1 hour in seconds.
maxTokenLifetimeSeconds :: Int
maxTokenLifetimeSeconds = 3600
-- | The environment variable name which is used to specify the directory
-- containing the @application_default_credentials.json@ generated by @gcloud init@.
--
-- /Default:/ @~\/.config\/gcloud\/application_default_credentials.json@.
cloudSDKConfigDir :: String
cloudSDKConfigDir = "CLOUDSDK_CONFIG"
-- | The environment variable pointing the file with local
-- Application Default Credentials.
defaultCredentialsFile :: String
defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS"
-- | An error thrown when attempting to read AuthN/AuthZ information.
data AuthError
= RetrievalError HttpException
| MissingFileError FilePath
| InvalidFileError FilePath Text
| TokenRefreshError Status Text (Maybe Text)
deriving (Show, Typeable)
instance Exception AuthError
class AsAuthError a where
-- | A general authentication error.
_AuthError :: Prism' a AuthError
{-# MINIMAL _AuthError #-}
-- | An error occured while communicating over HTTP with either then
-- local metadata or remote accounts.google.com endpoints.
_RetrievalError :: Prism' a HttpException
-- | The specified default credentials file could not be found.
_MissingFileError :: Prism' a FilePath
-- | An error occured parsing the default credentials file.
_InvalidFileError :: Prism' a (FilePath, Text)
-- | An error occured when attempting to refresh a token.
_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)
-- | Determines how AuthN/AuthZ information is retrieved.
data Credentials
= FromToken !OAuthToken
-- ^ Supply an explicit access token. See 'fromToken'.
| FromFile !FilePath
-- ^ Load the Application Default Credentials from a specific file path.
-- The file can be formatted as either a @service_account@ or an @authorized_user@.
| FromAccount !ServiceId
-- ^ Retrieve the Application Default Credentials using the speicfic
-- 'ServiceId' from the local metadata endpoint.
| Discover
-- ^ Attempt credentials discovery via the following steps:
--
-- * Read the default credentials from a file specified by
-- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists.
--
-- * Read the platform equivalent of @~\/.config\/gcloud\/application_default_credentials.json@ if it exists.
-- The @~/.config@ component of the path can be overriden by the environment
-- variable @CLOUDSDK_CONFIG@ if it exists.
--
-- * Retrieve the default service account application credentials if
-- running on GCE.
deriving (Eq, Show)
-- | Retrieve authentication information via the specified 'Credentials' mechanism.
--
-- Throws 'AuthError' when environment variables or service account information
-- cannot be read, and credentials files are invalid or cannot be found.
getAuth :: (MonadIO m, MonadCatch m)
=> Credentials
-> Logger
-> Manager
-> m Auth
getAuth c l m = case c of
FromToken t -> pure (AuthToken t)
FromFile f -> fromFilePath f l m
FromAccount s -> fromMetadata s l m
Discover ->
catching _MissingFileError (fromFile l m) $ \f -> do
p <- isGCE m
unless p $
throwingM _MissingFileError f
fromMetadata "default" l m
-- | Refresh a token from the local GCE metadata endpoint for the specified
-- 'ServiceId'.
fromMetadata :: (MonadIO m, MonadCatch m)
=> ServiceId
-> Logger
-> Manager
-> m Auth
fromMetadata s l = refresh s l >=> fmap AuthMeta . liftIO . newMVar
-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
-- file to obtain the credentials neccessary to perform a token refresh.
fromFile :: (MonadIO m, MonadCatch m) => Logger -> Manager -> m Auth
fromFile l m = do
f <- defaultCredentialsPath
case f of
Just x -> fromFilePath x l m
Nothing -> do
x <- cloudSDKConfigPath
fromFilePath x l m
data Parse = SA !ServiceAccount | AU !AuthorisedUser
instance FromJSON Parse where
parseJSON o = SA <$> parseJSON o <|> AU <$> parseJSON o
-- | Attempt to load either a @service_account@ or @authorized_user@ formatted
-- file to obtain the credentials neccessary to perform a token refresh from
-- the specified file.
fromFilePath :: (MonadIO m, MonadCatch m)
=> FilePath
-> Logger
-> Manager
-> m Auth
fromFilePath f l m = do
p <- liftIO (doesFileExist f)
unless p $
throwM (MissingFileError f)
e <- liftIO (LBS.readFile f) >>=
either (throwM . InvalidFileError f) pure . parseLBS
case e of
SA a -> refresh a l m >>= fmap AuthSign . liftIO . newMVar
AU u -> refresh u l m >>= fmap AuthUser . liftIO . newMVar
-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the
-- default application credentials filepath.
defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)
defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile)
-- | Return the filepath to the Cloud SDK well known file location such as
-- @~\/.config\/gcloud\/application_default_credentials.json@.
cloudSDKConfigPath :: MonadIO m => m FilePath
cloudSDKConfigPath = do
m <- liftIO (lookupEnv cloudSDKConfigDir)
case m of
Just d -> pure $! d </> "application_default_credentials.json"
Nothing -> do
d <- getConfigDirectory
pure $! d </> "gcloud/application_default_credentials.json"
getConfigDirectory :: MonadIO m => m FilePath
getConfigDirectory = do
h <- liftIO getHomeDirectory
if os == "windows"
then pure h
else pure $! h </> ".config"
data RefreshError = RefreshError
{ _error :: !Text
, _description :: !(Maybe Text)
}
instance FromJSON RefreshError where
parseJSON = withObject "refresh_error" $ \o -> RefreshError
<$> o .: "error"
<*> o .:? "error_description"
data Expires a = Expires
{ _expiry :: !UTCTime
, _token :: !OAuthToken
, _details :: !a
}
isValid :: MonadIO m => Expires a -> m Bool
isValid r = (< _expiry r) <$> liftIO getCurrentTime
data Auth
= AuthToken !OAuthToken
| AuthSign !(MVar (Expires ServiceAccount))
| AuthMeta !(MVar (Expires ServiceId))
| AuthUser !(MVar (Expires AuthorisedUser))
authorise :: (MonadIO m, MonadCatch m)
=> Logger
-> Manager
-> Client.Request
-> Auth
-> m Client.Request
authorise l m rq = \case
AuthToken t -> pure $! authoriseBearer rq t
AuthSign r -> authoriseToken l m r rq
AuthMeta r -> authoriseToken l m r rq
AuthUser r -> authoriseToken l m r rq
authoriseBearer :: Client.Request -> OAuthToken -> Client.Request
authoriseBearer rq t = rq
{ Client.requestHeaders = (hAuthorization, "Bearer " <> tokenToBS t)
: Client.requestHeaders rq
}
authoriseToken :: (MonadIO m, MonadCatch m, Refresh a)
=> Logger
-> Manager
-> MVar (Expires a)
-> Client.Request
-> m Client.Request
authoriseToken l m r rq = authoriseBearer rq <$> refreshToken l m r
refreshToken :: (MonadIO m, MonadCatch m, Refresh a)
=> Logger
-> Manager
-> MVar (Expires a)
-> m OAuthToken
refreshToken l m r = do
x <- liftIO (readMVar r)
xv <- isValid x
if xv
then pure (_token x)
else liftIO . modifyMVar r $ \y -> do
yv <- isValid y
if yv
then pure (y, _token y)
else do
z <- refresh (_details y) l m
pure (z, _token z)
-- {
-- "access_token": "sadsdasd",
-- "expires_in": 3600,
-- "id_token": "eyJhbGciOiJSd",
-- "refresh_token": "1/B3gq9K",
-- "token_type": "Bearer"
-- }
data Bearer = Bearer
{ _bearerAccess :: !OAuthToken
, _bearerRefresh :: !(Maybe Text)
, _bearerExpiry :: !UTCTime
}
instance FromJSON (UTCTime -> Bearer) where
parseJSON = withObject "bearer" $ \o -> do
t <- o .: "access_token"
r <- o .:? "refresh_token"
e <- o .: "expires_in" <&> fromInteger
pure (Bearer t r . addUTCTime e)
-- {
-- "private_key_id": "303ad77e5efdf2ce952DFa",
-- "private_key": "-----BEGIN PRIVATE KEY-----\nMIIE...\n",
-- "client_email": "01395191@gserviceaccount.com",
-- "client_id": "035-2-310eusercontent.com",
-- "type": "service_account"
-- }
data ServiceAccount = ServiceAccount
{ _serviceId :: !ClientId
, _serviceEmail :: !Text
, _serviceKeyId :: !Text
, _serviceKey :: !PrivateKey
}
instance FromJSON ServiceAccount where
parseJSON = withObject "service_account" $ \o -> do
bs <- Text.encodeUtf8 <$> o .: "private_key_id"
ServiceAccount
<$> o .: "client_id"
<*> o .: "client_email"
<*> o .: "private_key"
<*> parseKey bs
where
parseKey bs =
case listToMaybe (readKeyFileFromMemory bs) of
Just (PrivKeyRSA k) -> pure k
_ ->
fail "Unable to parse key contents from 'private_key_id'"
-- {
-- "client_id": "32555940559.apps.googleusercontent.com",
-- "client_secret": "ZmssLNjJy2998hD4CTg2ejr2",
-- "refresh_token": "1/B3gqKM1xzVtqffS1n5w-rSJ",
-- "type": "authorized_user"
-- }
data AuthorisedUser = AuthorisedUser
{ _userId :: !ClientId
, _userSecret :: !Text
, _userRefresh :: !Text
}
instance FromJSON AuthorisedUser where
parseJSON = withObject "authorized_user" $ \o -> AuthorisedUser
<$> o .: "client_id"
<*> o .: "client_secret"
<*> o .: "refresh_token"
class Refresh a where
refresh :: (MonadIO m, MonadCatch m)
=> a
-> Logger
-> Manager
-> m (Expires a)
instance Refresh ServiceAccount where
refresh s l m = do
b <- jwtEncode s
let rq = accountsRequest
{ Client.requestBody = RequestBodyBS $
"grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"
<> "&assertion="
<> b
}
refreshRequest s rq l m
jwtEncode :: (MonadIO m, MonadThrow m) => ServiceAccount -> m ByteString
jwtEncode s = liftIO $ do
i <- input . truncate <$> getPOSIXTime
r <- signSafer (Just SHA256) (_serviceKey s) i
either failure (\x -> pure (i <> "." <> signature (base64 x))) r
where
failure e = throwM $
TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing
signature bs =
case BS8.unsnoc bs of
Nothing -> mempty
Just (bs', x)
| x == '=' -> bs'
| otherwise -> bs
input n = header <> "." <> payload
where
header = base64Encode
[ "alg" .= ("RS256" :: Text)
, "typ" .= ("JWT" :: Text)
, "kid" .= _serviceKeyId s
]
payload = base64Encode
[ "aud" .= Text.decodeUtf8 (Client.host accountsRequest)
, "scope" .= ([] :: [Text])
, "iat" .= n
, "exp" .= (n + maxTokenLifetimeSeconds)
, "iss" .= _serviceEmail s
]
instance Refresh AuthorisedUser where
refresh u@AuthorisedUser{..} = refreshRequest u $
accountsRequest
{ Client.requestBody = RequestBodyBS . Text.encodeUtf8 $
"grant_type=refresh_token"
<> "&client_id=" <> clientIdToText _userId
<> "&client_secret=" <> _userSecret
<> "&refresh_token=" <> _userRefresh
}
instance Refresh ServiceId where
refresh sid = refreshRequest sid $
metadataRequest
{ Client.path = "instance/service-accounts/"
<> Text.encodeUtf8 (serviceIdToText sid)
<> "/token"
}
accountsRequest :: Client.Request
accountsRequest = def
{ Client.host = "accounts.google.com"
, Client.port = 443
, Client.secure = True
, Client.checkStatus = \_ _ _ -> Nothing
, Client.method = "POST"
, Client.path = "/o/oauth2/token"
, Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]
}
refreshRequest :: (MonadIO m, MonadCatch m)
=> a
-> Client.Request
-> Logger
-> Manager
-> m (Expires a)
refreshRequest r rq l m = do
logDebug l rq -- debug:ClientRequest
rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)
logDebug l rs -- debug:ClientResponse
let bs = responseBody rs
s = responseStatus rs
if fromEnum s == 200
then success s bs
else failure s
where
success s bs = do
f <- parseErr s bs
ts <- liftIO getCurrentTime
let Bearer {..} = f ts
pure $! Expires _bearerExpiry _bearerAccess r
failure s = do
let e = "Failure refreshing token from " <> host <> path
logError l $ "[Refresh Error] " <> build e
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 :: ToJSON a =>
base64 :: ByteArray a => a -> ByteString
base64 = convertToBase Base64URLUnpadded