{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Google.Auth
(
Credentials (..)
, getApplicationDefault
, fromWellKnownPath
, fromFilePath
, saveAuthorizedUserToWellKnownPath
, saveAuthorizedUser
, serviceAccountUser
, installedApplication
, formURL
, authorize
, Store
, initStore
, retrieveAuthFromStore
, Auth (..)
, authToAuthorizedUser
, exchange
, refresh
, checkGCEVar
, cloudSDKConfigDir
, defaultCredentialsFile
, AsAuthError (..)
, AuthError (..)
, OAuthClient (..)
, OAuthToken (..)
, OAuthCode (..)
, OAuthScope (..)
, AccessToken (..)
, RefreshToken (..)
, Secret (..)
, ServiceId (..)
, ClientId (..)
, module Network.Google.Auth.Scope
) where
import Control.Concurrent
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Time (getCurrentTime)
import GHC.TypeLits (Symbol)
import Network.Google.Auth.ApplicationDefault
import Network.Google.Auth.InstalledApplication
import Network.Google.Auth.Scope
import Network.Google.Auth.ServiceAccount
import Network.Google.Compute.Metadata (checkGCEVar)
import Network.Google.Internal.Auth
import Network.Google.Internal.Logger (Logger)
import Network.Google.Prelude
import Network.HTTP.Conduit (Manager)
import qualified Network.HTTP.Conduit as Client
import Network.HTTP.Types (hAuthorization)
authToAuthorizedUser :: AllowScopes s => Auth s -> Either Text AuthorizedUser
authToAuthorizedUser a = AuthorizedUser
<$> (_clientId <$> getClient)
<*> maybe (Left "no refresh token") Right (_tokenRefresh (_token a))
<*> (_clientSecret <$> getClient)
where getClient = case _credentials a of
FromClient c _ -> Right c
_ -> Left "not FromClient"
data Auth (s :: [Symbol]) = Auth
{ _credentials :: !(Credentials s)
, _token :: !(OAuthToken s)
}
validate :: MonadIO m => Auth s -> m Bool
validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime
newtype Store (s :: [Symbol]) = Store (MVar (Auth s))
initStore :: (MonadIO m, MonadCatch m, AllowScopes s)
=> Credentials s
-> Logger
-> Manager
-> m (Store s)
initStore c l m = exchange c l m >>= fmap Store . liftIO . newMVar
retrieveAuthFromStore :: (MonadIO m, MonadCatch m, AllowScopes s)
=> Store s
-> m (Auth s)
retrieveAuthFromStore (Store s) = liftIO (readMVar s)
getToken :: (MonadIO m, MonadCatch m, AllowScopes s)
=> Store s
-> Logger
-> Manager
-> m (OAuthToken s)
getToken (Store s) l m = do
x <- liftIO (readMVar s)
mx <- validate x
if mx
then pure (_token x)
else liftIO . modifyMVar s $ \y -> do
my <- validate y
if my
then pure (y, _token y)
else do
z <- refresh y l m
pure (z, _token z)
exchange :: forall m s. (MonadIO m, MonadCatch m, AllowScopes s)
=> Credentials s
-> Logger
-> Manager
-> m (Auth s)
exchange c l = fmap (Auth c) . action l
where
action = case c of
FromMetadata s -> metadataToken s
FromAccount a -> serviceAccountToken a (Proxy :: Proxy s)
FromClient x n -> exchangeCode x n
FromUser u -> authorizedUserToken u Nothing
refresh :: forall m s. (MonadIO m, MonadCatch m, AllowScopes s)
=> Auth s
-> Logger
-> Manager
-> m (Auth s)
refresh (Auth c t) l = fmap (Auth c) . action l
where
action = case c of
FromMetadata s -> metadataToken s
FromAccount a -> serviceAccountToken a (Proxy :: Proxy s)
FromClient x _ -> refreshToken x t
FromUser u -> authorizedUserToken u (_tokenRefresh t)
authorize :: (MonadIO m, MonadCatch m, AllowScopes s)
=> Client.Request
-> Store s
-> Logger
-> Manager
-> m Client.Request
authorize rq s l m = bearer <$> getToken s l m
where
bearer t = rq
{ Client.requestHeaders =
( hAuthorization
, "Bearer " <> toHeader (_tokenAccess t)
) : Client.requestHeaders rq
}
serviceAccountUser :: forall s. (AllowScopes s)
=> Maybe Text
-> Credentials s
-> Credentials s
serviceAccountUser u (FromAccount s) = FromAccount $ s { _serviceAccountUser = u }
serviceAccountUser _ c = c