packages feed

google-cloud-common (empty) → 0.1.0.0

raw patch · 7 files changed

+396/−0 lines, 7 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, google-cloud-common, hspec, http-conduit, jwt, mtl, process, text, time

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `google-cloud-common`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2025 Tushar Adhatrao++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,1 @@+# google-cloud-common
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ google-cloud-common.cabal view
@@ -0,0 +1,70 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           google-cloud-common+version:        0.1.0.0+synopsis:       GCP Client for Haskell+description:    A common module for all GCP Client packages.+category:       Web+homepage:       https://github.com/tusharad/google-cloud-haskell#readme+bug-reports:    https://github.com/tusharad/google-cloud-haskell/issues+author:         tushar+maintainer:     tusharadhatrao@gmail.com+copyright:      2025 tushar+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/tusharad/google-cloud-haskell++library+  exposed-modules:+      Google.Cloud.Common.Core+  other-modules:+      Paths_google_cloud_common+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson <3+    , base >=4.7 && <5+    , bytestring >=0.9.1.4+    , containers >=0.6 && <1+    , http-conduit >=2.2 && <2.4+    , jwt+    , mtl+    , process+    , text >=1.2 && <3+    , time+  default-language: Haskell2010++test-suite google-cloud-common-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_google_cloud_common+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson <3+    , base >=4.7 && <5+    , bytestring >=0.9.1.4+    , containers >=0.6 && <1+    , google-cloud-common+    , hspec >=1.3+    , http-conduit >=2.2 && <2.4+    , jwt+    , mtl+    , process+    , text >=1.2 && <3+    , time+  default-language: Haskell2010
+ src/Google/Cloud/Common/Core.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Google.Cloud.Common.Core+  ( genAccessToken+  , RequestOptions (..)+  , RequestMethod (..)+  , AccessTokenResp (..)+  , GoogleApplicationCred (..)+  , doRequest+  , doRequestJSON+  , toPath +  , googleLoggingUrl +  ) 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 Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.Time.Clock.POSIX+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++data GoogleApplicationCred = GooGleApplicationCred+  { type_ :: Text+  , projectId :: Text+  , privateKeyId :: Text+  , privateKey :: Text+  , clientEmail :: Text+  , clientId :: Text+  , authUri :: Text+  , tokenUri :: Text+  , auth_provider_x509_cert_url :: Text+  , client_x509_cert_url :: Text+  , universe_domain :: Text+  }+  deriving (Eq, Show)++data AccessTokenResp = AccessTokenResp+  { accessToken :: String+  , expiresIn :: Integer+  , tokenType :: String+  }+  deriving (Eq, Show)++instance FromJSON AccessTokenResp where+  parseJSON (Object v) =+    AccessTokenResp+      <$> v .: "access_token"+      <*> v .: "expires_in"+      <*> v .: "token_type"+  parseJSON _ = error "asd"++instance FromJSON GoogleApplicationCred where+  parseJSON (Object v) =+    GooGleApplicationCred+      <$> v .: "type"+      <*> v .: "project_id"+      <*> v .: "private_key_id"+      <*> v .: "private_key"+      <*> v .: "client_email"+      <*> v .: "client_id"+      <*> v .: "auth_uri"+      <*> v .: "token_uri"+      <*> 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.+-}+genAccessToken :: IO (Either String BS.ByteString)+genAccessToken = do+  mbEnv <- lookupEnv "GOOGLE_APPLICATION_CREDENTIALS"+  case mbEnv of+    Just jsonFilePath -> do+      eRes <- readJSONFile jsonFilePath+      case eRes of+        Left err -> pure $ Left err+        Right jsonVal -> getValidToken jsonVal+    Nothing -> genTokenViaPrintAccessToken++-- Global IORef to store the token in memory+{-# NOINLINE tokenCache #-}+tokenCache :: IORef (Maybe (BS.ByteString, Integer))+tokenCache = unsafePerformIO (newIORef Nothing)++-- Create JWT Token+createJWT :: GoogleApplicationCred -> IO (Maybe Text)+createJWT GooGleApplicationCred {..} = do+  now <- round <$> getPOSIXTime :: IO Integer+  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")+          }++      mbPrivateKeyBS = JWT.readRsaSecret (TE.encodeUtf8 privateKey)+      jwtHeader =+        JWT.JOSEHeader+          { JWT.alg = Just JWT.RS256+          , JWT.typ = Just "jwt"+          , JWT.kid = Just privateKeyId+          , JWT.cty = Nothing+          }+  case mbPrivateKeyBS of+    Nothing -> pure Nothing+    Just pKey ->+      return $+        Just $+          JWT.encodeSigned+            (JWT.EncodeRSAPrivateKey pKey)+            jwtHeader+            claims++-- Exchange JWT for OAuth2 Access Token+fetchAccessToken :: Text -> IO (Maybe (BS.ByteString, Integer))+fetchAccessToken jwt = do+  now <- round <$> getPOSIXTime+  let reqBody = +        "grant_type=urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Ajwt-bearer&assertion=" <> jwt+  initialRequest <- parseRequest "https://oauth2.googleapis.com/token"+  let request =+        setRequestHeaders+          [("Content-Type", "application/x-www-form-urlencoded")]+          ( setRequestMethod+              "POST"+              (setRequestBodyLBS (BSL.fromStrict $ TE.encodeUtf8 reqBody) initialRequest)+          )+  response <- httpLbs request+  print response+  let rBody = eitherDecodeStrict (BS.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++-- Get a valid token (reuses existing one if valid)+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+    _ -> do+      maybeJwt <- createJWT json_+      case maybeJwt of+        Just jwt -> do+          maybeToken <- fetchAccessToken jwt+          case maybeToken of+            Just (token, expiry) -> do+              writeIORef tokenCache (Just (token, expiry)) -- Cache new token+              return (Right token)+            Nothing -> return $ Left "Something went wrong with token 1"+        Nothing -> return $ Left "Something went wrong with token 2"++readJSONFile :: FilePath -> IO (Either String GoogleApplicationCred)+readJSONFile jsonFilePath = do+  eRes <- try $ readFile jsonFilePath+  case eRes of+    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)++data RequestMethod = GET | POST | PATCH | DELETE+  deriving (Eq, Show)++data RequestOptions = RequestOptions+  { reqMethod :: RequestMethod+  , reqUrl :: String+  , mbReqHeaders :: Maybe RequestHeaders+  , mbQueryParams :: Maybe Query+  , mbReqBody :: Maybe BSL.ByteString+  , mbReqPath :: Maybe String+  }+  deriving (Eq, Show)++doRequest :: RequestOptions -> IO (Either String BSL.ByteString)+doRequest RequestOptions {..} = do+  token <- genAccessToken+  case token of+    Left err -> throwError (userError err)+    Right tokenBS -> do+      initialRequest <- parseRequest (reqUrl <> fromMaybe "" mbReqPath)+      let request =+            foldl+              (flip ($))+              initialRequest+              [ +               maybe Prelude.id setRequestHeaders mbReqHeaders+              , maybe Prelude.id setRequestQueryString mbQueryParams+              , maybe Prelude.id setRequestBodyLBS mbReqBody+              , addRequestHeader "Authorization" ("Bearer " <> tokenBS)+              , setRequestMethod (BS.pack $ show reqMethod)+              ]+      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)++doRequestJSON :: (FromJSON b) => RequestOptions -> IO (Either String b)+doRequestJSON reqOpts = do+  eResp <- doRequest reqOpts+  case eResp of+    Left err -> return $ Left err+    Right respBody -> do+      let respBody' = if BSL.null respBody then "{}" else respBody+      case eitherDecode respBody' of+        Left err -> pure $ Left err+        Right res -> pure $ Right res++toPath :: [String] -> String+toPath = foldl (\acc x -> acc <> "/" <> x) ""++googleLoggingUrl :: String+googleLoggingUrl = "https://logging.googleapis.com/v2"
+ test/Spec.hs view
@@ -0,0 +1,42 @@+{-# 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)++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "Google.Cloud.Common.Core" $ do+    context "AccessTokenResp JSON parsing" $ do+      it "successfully parses valid JSON" $ do+        let json = "{\"access_token\":\"ya29.a0AfH6SM...\",\"expires_in\":3599,\"token_type\":\"Bearer\"}"+        let parsed = decode (BSL.pack json) :: Maybe AccessTokenResp+        parsed `shouldSatisfy` isJust++      it "fails to parse invalid JSON" $ do+        let json = "{\"invalid_json\":\"...\"}"+        let parsed = decode (BSL.pack json) :: Maybe AccessTokenResp+        parsed `shouldBe` Nothing++    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 parsed = decode (BSL.pack json) :: Maybe GoogleApplicationCred+        parsed `shouldSatisfy` isJust++      it "fails to parse invalid JSON" $ do+        let json = "{\"invalid_json\":\"...\"}"+        let parsed = decode (BSL.pack json) :: Maybe GoogleApplicationCred+        parsed `shouldBe` Nothing++    context "toPath" $ do+      it "concatenates parts with slashes" $ do+        toPath ["part1", "part2", "part3"] `shouldBe` "/part1/part2/part3"++      it "returns empty string for empty list" $ do+        toPath [] `shouldBe` ""