diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,4 +8,10 @@ ## Unreleased +## 1.1.0.0 - 2025-09-11 + +- Synchronized version bump for v1.1.0.0 release. +- For authentication using Compute metadata server +- Add lower/upper bounds: jwt (>=0.11 && <0.12), time (>=1.9 && <1.15) + ## 0.1.0.0 - YYYY-MM-DD diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/google-cloud-common.cabal b/google-cloud-common.cabal --- a/google-cloud-common.cabal +++ b/google-cloud-common.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: google-cloud-common -version: 0.1.0.0 +version: 1.1.0.0 synopsis: GCP Client for Haskell description: A common module for all GCP Client packages. category: Web @@ -39,11 +39,9 @@ , bytestring >=0.9.1.4 , containers >=0.6 && <1 , http-conduit >=2.2 && <2.4 - , jwt - , mtl - , process + , jwt ==0.11.* , text >=1.2 && <3 - , time + , time >=1.9 && <1.15 default-language: Haskell2010 test-suite google-cloud-common-test @@ -62,9 +60,7 @@ , google-cloud-common , hspec >=1.3 , http-conduit >=2.2 && <2.4 - , jwt - , mtl - , process + , jwt ==0.11.* , text >=1.2 && <3 - , time + , time >=1.9 && <1.15 default-language: Haskell2010 diff --git a/src/Google/Cloud/Common/Core.hs b/src/Google/Cloud/Common/Core.hs --- a/src/Google/Cloud/Common/Core.hs +++ b/src/Google/Cloud/Common/Core.hs @@ -1,24 +1,47 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{- | +Module : Google.Cloud.Common.Core +License : MIT +Maintainer : maintainers@google-cloud-haskell +Stability : experimental + +Shared functionality and types used across Google Cloud client packages. + +This module provides: + +- Access token generation using either application credentials or metadata server +- A thin HTTP request layer with JSON helpers +- Shared request option types and utilities +- Convenience helpers for path building +-} module Google.Cloud.Common.Core - ( genAccessToken + ( -- * Authentication + genAccessToken + + -- * Request API , RequestOptions (..) , RequestMethod (..) - , AccessTokenResp (..) - , GoogleApplicationCred (..) , doRequest , doRequestJSON - , toPath - , googleLoggingUrl + , doRequestRaw + + -- * Types + , AccessTokenResp (..) + , GoogleApplicationCred (..) + + -- * Utilities + , toPath ) where import Control.Exception (try) -import Control.Monad.Error.Class (MonadError (throwError)) import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.IORef +import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text.Encoding as TE @@ -28,42 +51,60 @@ import GHC.IO (unsafePerformIO) import Network.HTTP.Simple import System.Environment (lookupEnv) -import System.Process import qualified Web.JWT as JWT -import qualified Data.Map.Strict as Map +{- | Google application credential JSON as produced by a service account key. + +This structure corresponds to the JSON file pointed to by +the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable. +Field names match the JSON keys, with minor adaptations for Haskell naming. +-} data GoogleApplicationCred = GooGleApplicationCred { type_ :: Text + -- ^ Type of the credential (usually @service_account@) , projectId :: Text + -- ^ Project ID associated with the credential , privateKeyId :: Text + -- ^ Private key ID , privateKey :: Text + -- ^ PEM-encoded RSA private key , clientEmail :: Text + -- ^ Service account email address , clientId :: Text + -- ^ Client ID , authUri :: Text + -- ^ OAuth2 authorization URI , tokenUri :: Text + -- ^ OAuth2 token exchange URI , auth_provider_x509_cert_url :: Text + -- ^ Auth provider certificate URL , client_x509_cert_url :: Text + -- ^ Client certificate URL , universe_domain :: Text + -- ^ Universe domain } deriving (Eq, Show) +-- | Response returned by OAuth2 token endpoints. data AccessTokenResp = AccessTokenResp { accessToken :: String + -- ^ Bearer access token , expiresIn :: Integer + -- ^ Lifetime in seconds , tokenType :: String + -- ^ Token type (usually @Bearer@) } deriving (Eq, Show) instance FromJSON AccessTokenResp where - parseJSON (Object v) = + parseJSON = withObject "AccessTokenResp" $ \v -> AccessTokenResp <$> v .: "access_token" <*> v .: "expires_in" <*> v .: "token_type" - parseJSON _ = error "asd" instance FromJSON GoogleApplicationCred where - parseJSON (Object v) = + parseJSON = withObject "GoogleApplicationCred" $ \v -> GooGleApplicationCred <$> v .: "type" <*> v .: "project_id" @@ -76,14 +117,17 @@ <*> v .: "auth_provider_x509_cert_url" <*> v .: "client_x509_cert_url" <*> v .: "universe_domain" - parseJSON _ = error "asd" -{- | Authentication - - There are two ways of authentication, - 1. Application will look for `GOOGLE_APPLICATION_CREDENTIALS` environment variable - and read the JSON file path. - 2. If the env variable is not stored, it will use `print-access-token`. - Make sure gcloud is installed and logged in for this to work. +{- | Generate a Google Cloud access token. + +Resolution order: + +1. If @GOOGLE_APPLICATION_CREDENTIALS@ is set, read the JSON file and + exchange a JWT for an OAuth2 access token. +2. Otherwise, fetch a token from the Compute metadata server (suitable for + GCE/GKE environments with a default service account). + +Returns 'Right' token on success, or 'Left' with an error message. -} genAccessToken :: IO (Either String BS.ByteString) genAccessToken = do @@ -94,26 +138,30 @@ case eRes of Left err -> pure $ Left err Right jsonVal -> getValidToken jsonVal - Nothing -> genTokenViaPrintAccessToken + Nothing -> getTokenFromMetadataServer --- Global IORef to store the token in memory +-- | In-memory cache of the latest token and its expiry epoch seconds. {-# NOINLINE tokenCache #-} tokenCache :: IORef (Maybe (BS.ByteString, Integer)) tokenCache = unsafePerformIO (newIORef Nothing) --- Create JWT Token +-- | Create a signed JWT for the given credential with Cloud Platform scope. createJWT :: GoogleApplicationCred -> IO (Maybe Text) createJWT GooGleApplicationCred {..} = do now <- round <$> getPOSIXTime :: IO Integer - let expiration = now + 3600 -- 1-hour expiry + let expiration = now + 3600 -- 1 hour expiry let claims = mempty { JWT.iss = JWT.stringOrURI clientEmail , JWT.aud = Left <$> JWT.stringOrURI tokenUri , JWT.exp = JWT.numericDate (fromIntegral expiration) , JWT.iat = JWT.numericDate (fromIntegral now) - , JWT.unregisteredClaims = - JWT.ClaimsMap (Map.singleton "scope" "https://www.googleapis.com/auth/cloud-platform") + , JWT.unregisteredClaims = + JWT.ClaimsMap + ( Map.singleton + "scope" + "https://www.googleapis.com/auth/cloud-platform" + ) } mbPrivateKeyBS = JWT.readRsaSecret (TE.encodeUtf8 privateKey) @@ -134,11 +182,11 @@ jwtHeader claims --- Exchange JWT for OAuth2 Access Token +-- | Exchange a JWT for an OAuth2 access token. Returns token bytes and expiry. fetchAccessToken :: Text -> IO (Maybe (BS.ByteString, Integer)) fetchAccessToken jwt = do now <- round <$> getPOSIXTime - let reqBody = + let reqBody = "grant_type=urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Ajwt-bearer&assertion=" <> jwt initialRequest <- parseRequest "https://oauth2.googleapis.com/token" let request = @@ -149,21 +197,20 @@ (setRequestBodyLBS (BSL.fromStrict $ TE.encodeUtf8 reqBody) initialRequest) ) response <- httpLbs request - print response - let rBody = eitherDecodeStrict (BS.toStrict $ getResponseBody response) + let rBody = eitherDecodeStrict (BSL.toStrict $ getResponseBody response) case rBody of - Right AccessTokenResp {..} -> return (Just (BS.pack accessToken, now + 3600)) -- Expiry set to 1 hour - Left err -> do - print err - return Nothing + Right AccessTokenResp {..} -> return (Just (BS.pack accessToken, now + 3600)) + Left err -> do + print err + return Nothing --- Get a valid token (reuses existing one if valid) +-- | Get a valid token, reusing a cached one if it has not expired yet. getValidToken :: GoogleApplicationCred -> IO (Either String BS.ByteString) getValidToken json_ = do now <- round <$> getPOSIXTime cached <- readIORef tokenCache case cached of - Just (token, expiry) | now < expiry -> return (Right token) -- Return cached token + Just (token, expiry) | now < expiry -> return (Right token) _ -> do maybeJwt <- createJWT json_ case maybeJwt of @@ -171,11 +218,12 @@ maybeToken <- fetchAccessToken jwt case maybeToken of Just (token, expiry) -> do - writeIORef tokenCache (Just (token, expiry)) -- Cache new token + writeIORef tokenCache (Just (token, expiry)) return (Right token) - Nothing -> return $ Left "Something went wrong with token 1" - Nothing -> return $ Left "Something went wrong with token 2" + Nothing -> return $ Left "Failed to exchange JWT for access token" + Nothing -> return $ Left "Failed to create JWT from credentials" +-- | Read and decode a JSON credentials file into 'GoogleApplicationCred'. readJSONFile :: FilePath -> IO (Either String GoogleApplicationCred) readJSONFile jsonFilePath = do eRes <- try $ readFile jsonFilePath @@ -183,39 +231,72 @@ Left err -> pure . Left $ show (err :: IOError) Right content -> pure $ eitherDecodeStrict (BS.pack content) -genTokenViaPrintAccessToken :: IO (Either String BS.ByteString) -genTokenViaPrintAccessToken = do - eRes <- try $ readProcess "gcloud" (words "auth print-access-token") [] - case eRes of - Right s -> pure . Right $ BS.pack (init s) - Left err -> pure . Left $ show (err :: IOError) +-- | Fetch an access token from the metadata server (GCE/GKE default SA). +getTokenFromMetadataServer :: IO (Either String BS.ByteString) +getTokenFromMetadataServer = do + initialRequest <- + parseRequest + "http://metadata.google.internal/computeMetadata/v1/instance/service-accounts/default/token" + let request = + setRequestHeaders + [("Metadata-Flavor", "Google")] + ( setRequestMethod + "GET" + initialRequest + ) + eResp <- try $ httpLbs request + case eResp of + Left (_ :: HttpException) -> + pure $ + Left + "No application credentials found and metadata server is unavailable. Set GOOGLE_APPLICATION_CREDENTIALS to a service account JSON or run on GCE/GKE with a default service account." + Right response -> do + let rBody = eitherDecodeStrict (BSL.toStrict $ getResponseBody response) + case rBody of + Right AccessTokenResp {..} -> return . Right $ BS.pack accessToken + Left _ -> + pure $ Left "Unexpected response from metadata server while fetching access token." -data RequestMethod = GET | POST | PATCH | DELETE +-- | Custom HTTP methods used in requests. +data RequestMethod = GET | POST | PATCH | DELETE | PUT deriving (Eq, Show) +{- | Options for performing an HTTP request. + +You can construct this record and pass it to 'doRequest' or 'doRequestJSON'. +Unused optional fields can be 'Nothing'. +-} data RequestOptions = RequestOptions { reqMethod :: RequestMethod + -- ^ HTTP method to use , reqUrl :: String + -- ^ Base URL (e.g. https://example.googleapis.com) , mbReqHeaders :: Maybe RequestHeaders + -- ^ Optional request headers , mbQueryParams :: Maybe Query + -- ^ Optional query string parameters , mbReqBody :: Maybe BSL.ByteString + -- ^ Optional lazy bytestring request body , mbReqPath :: Maybe String + -- ^ Optional path to append to 'reqUrl' } deriving (Eq, Show) -doRequest :: RequestOptions -> IO (Either String BSL.ByteString) -doRequest RequestOptions {..} = do +{- | Perform an HTTP request and return the raw 'Response' body on success. +Returns a textual error on failure. +-} +doRequestRaw :: RequestOptions -> IO (Either String (Response BSL.ByteString)) +doRequestRaw RequestOptions {..} = do token <- genAccessToken case token of - Left err -> throwError (userError err) + Left err -> pure (Left err) Right tokenBS -> do initialRequest <- parseRequest (reqUrl <> fromMaybe "" mbReqPath) let request = foldl (flip ($)) initialRequest - [ - maybe Prelude.id setRequestHeaders mbReqHeaders + [ maybe Prelude.id setRequestHeaders mbReqHeaders , maybe Prelude.id setRequestQueryString mbQueryParams , maybe Prelude.id setRequestBodyLBS mbReqBody , addRequestHeader "Authorization" ("Bearer " <> tokenBS) @@ -224,13 +305,26 @@ eResp <- try $ httpLbs request case eResp of Left err -> pure $ Left (show (err :: HttpException)) - Right resp -> do - let respStatus = getResponseStatusCode resp - respBody = getResponseBody resp - if respStatus <= 299 && respStatus >= 200 - then return $ Right respBody - else return $ Left (T.unpack $ decodeUtf8 respBody) + Right resp -> pure $ Right resp +{- | Perform an HTTP request and return the response body. +Fails with an "HTTP : " error if the status is non-2xx. +-} +doRequest :: RequestOptions -> IO (Either String BSL.ByteString) +doRequest reqOpts = do + eResp <- doRequestRaw reqOpts + case eResp of + Left err -> pure $ Left err + Right resp -> do + let respStatus = getResponseStatusCode resp + respBody = getResponseBody resp + if respStatus <= 299 && respStatus >= 200 + then return $ Right respBody + else return $ Left ("HTTP " <> show respStatus <> ": " <> T.unpack (decodeUtf8 respBody)) + +{- | Perform an HTTP request and decode the response body as JSON. +An empty body is treated as @{}@ for convenience. +-} doRequestJSON :: (FromJSON b) => RequestOptions -> IO (Either String b) doRequestJSON reqOpts = do eResp <- doRequest reqOpts @@ -242,8 +336,12 @@ Left err -> pure $ Left err Right res -> pure $ Right res +{- | Build a URL path from path segments. + +Example: + +>>> toPath ["hello", "world"] +"/hello/world" +-} toPath :: [String] -> String toPath = foldl (\acc x -> acc <> "/" <> x) "" - -googleLoggingUrl :: String -googleLoggingUrl = "https://logging.googleapis.com/v2" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Hspec -import Google.Cloud.Common.Core import Data.Aeson (decode) import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Maybe (isJust) +import Google.Cloud.Common.Core +import Test.Hspec main :: IO () main = hspec spec @@ -12,6 +12,16 @@ spec :: Spec spec = do describe "Google.Cloud.Common.Core" $ do + context "RequestMethod Show/Eq" $ do + it "shows constructors as HTTP verbs" $ do + show GET `shouldBe` "GET" + show POST `shouldBe` "POST" + show PATCH `shouldBe` "PATCH" + show DELETE `shouldBe` "DELETE" + show PUT `shouldBe` "PUT" + it "equality works for same constructor" $ do + (GET == GET) `shouldBe` True + (POST == GET) `shouldBe` False context "AccessTokenResp JSON parsing" $ do it "successfully parses valid JSON" $ do let json = "{\"access_token\":\"ya29.a0AfH6SM...\",\"expires_in\":3599,\"token_type\":\"Bearer\"}" @@ -25,7 +35,8 @@ context "GoogleApplicationCred JSON parsing" $ do it "successfully parses valid JSON" $ do - let json = "{\"type\":\"service_account\",\"project_id\":\"my-project\",\"private_key_id\":\"1234\",\"private_key\":\"-----BEGIN PRIVATE KEY-----\\n...\\n-----END PRIVATE KEY-----\\n\",\"client_email\":\"my-email@my-project.iam.gserviceaccount.com\",\"client_id\":\"123456789\",\"auth_uri\":\"https://accounts.google.com/o/oauth2/auth\",\"token_uri\":\"https://oauth2.googleapis.com/token\",\"auth_provider_x509_cert_url\":\"https://www.googleapis.com/oauth2/v1/certs\",\"client_x509_cert_url\":\"https://www.googleapis.com/robot/v1/metadata/x509/my-email%40my-project.iam.gserviceaccount.com\",\"universe_domain\":\"googleapis.com\"}" + let json = + "{\"type\":\"service_account\",\"project_id\":\"my-project\",\"private_key_id\":\"1234\",\"private_key\":\"-----BEGIN PRIVATE KEY-----\\n...\\n-----END PRIVATE KEY-----\\n\",\"client_email\":\"my-email@my-project.iam.gserviceaccount.com\",\"client_id\":\"123456789\",\"auth_uri\":\"https://accounts.google.com/o/oauth2/auth\",\"token_uri\":\"https://oauth2.googleapis.com/token\",\"auth_provider_x509_cert_url\":\"https://www.googleapis.com/oauth2/v1/certs\",\"client_x509_cert_url\":\"https://www.googleapis.com/robot/v1/metadata/x509/my-email%40my-project.iam.gserviceaccount.com\",\"universe_domain\":\"googleapis.com\"}" let parsed = decode (BSL.pack json) :: Maybe GoogleApplicationCred parsed `shouldSatisfy` isJust