module Google.Cloud.Internal.Token where
import Control.Concurrent.STM
import Control.Monad.Reader
import Control.Monad.Except
import Data.Text (Text)
import Data.Text.Encoding
import Data.Monoid
import Data.Time
import Data.Aeson
import Data.Scientific
import qualified Data.HashMap.Strict as HMS
import Network.HTTP.Types.Header
import Google.Cloud.Internal.Types
import Google.Cloud.Internal.HTTP
import Google.Cloud.Internal.Metadata
tokenUrl :: String
tokenUrl = metadataServer <>
"/computeMetadata/v1/instance/service-accounts/default/token"
defaultMetadataToken :: Cloud Token
defaultMetadataToken = do
res <- getJSON tokenUrl [("Metadata-Flavor","Google")]
case res of
(Object o) -> case (HMS.lookup "access_token" o, HMS.lookup "expires_in" o) of
(Just (String value), Just (Number expiresIn)) -> do
case toBoundedInteger expiresIn :: Maybe Int of
Nothing -> throwError $ UnknownError "fetchToken: Bad expiration time"
Just i -> do
now <- cloudIO $ getCurrentTime
return $ Token (addUTCTime (fromIntegral i) now) value
_ -> throwError $ UnknownError "fetchToken: Could not decode response"
_ -> throwError $ UnknownError "fetchToken: Bad resposnse"
cacheToken :: Token -> Cloud Token
cacheToken token = do
tokenTVar <- asks hToken
cloudIO $ atomically $ do
currentToken <- readTVar tokenTVar
let newToken = case currentToken of
Nothing -> token
Just x -> if tokenExpiresAt x > tokenExpiresAt token then x else token
writeTVar tokenTVar (Just newToken)
return newToken
refreshToken :: Cloud Token
refreshToken = do
fetchToken <- asks hFetchToken
token <- fetchToken
cacheToken token
accessToken :: Cloud Text
accessToken = do
tokenTVar <- asks hToken
mbToken <- cloudIO $ atomically $ readTVar tokenTVar
tokenValue <$> case mbToken of
Nothing -> refreshToken
Just t -> do
now <- cloudIO $ getCurrentTime
if now > addUTCTime (60) (tokenExpiresAt t)
then refreshToken
else return t
authorizationHeader :: Cloud Header
authorizationHeader = do
token <- accessToken
return ("Authorization", "Bearer " <> encodeUtf8 token)