{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

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"


-- | Fetch the access token for the default service account from the local
-- metadata server. This only works when the code is running in the Google
-- cloud and the instance has a services account attached to it.

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"



-- | Store the token in the cache. If the cache already contains a token,
-- the better one of the two is actually stored (where *better* is defined
-- as the one which expires later). So it is safe to call this function
-- even if you are unsure if the token you have is better than the one
-- which is already in the cache.
--
-- Returns the better token.

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



-- | Return the value of the access token. The function guarantees that the
-- token is valid for at least 60 seconds. Though you should not be afraid
-- to call the function frequently, it caches the token inside the 'Handle' so
-- there is very little overhead.

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



-- | Construct a 'Header' that contains the authorization details. Such a header
-- needs to be supplied to all requsts which require authorization.
--
-- Not all requests require it. In particular, requests to the metadata server
-- don't.
authorizationHeader :: Cloud Header
authorizationHeader = do
    token <- accessToken
    return ("Authorization", "Bearer " <> encodeUtf8 token)