google-cloud-common 0.1.0.0 → 1.1.0.0

raw patch · 5 files changed

+183/−71 lines, 5 filesdep −mtldep −processdep ~jwtdep ~timesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies removed: mtl, process

Dependency ranges changed: jwt, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Setup.hs +1/−0
• google-cloud-common.cabal +6/−10
• src/Google/Cloud/Common/Core.hs +156/−58
• test/Spec.hs +14/−3

@@ -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

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -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

@@ -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 <status>: <body>" 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"

@@ -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