module Google.Cloud.Internal.Token where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.Reader
import Data.Text (Text)
import Data.Text.Encoding
import Data.Monoid
import Data.Time
import Network.HTTP.Types.Header
import Google.Cloud.Internal.Types
import Google.Cloud.Compute.Metadata
import Prelude
defaultMetadataToken :: Cloud Token
defaultMetadataToken = serviceAccountToken "default"
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)