diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/gogol.cabal b/gogol.cabal --- a/gogol.cabal +++ b/gogol.cabal @@ -1,85 +1,89 @@ -name: gogol -version: 0.5.0 -synopsis: Comprehensive Google Services SDK. -homepage: https://github.com/brendanhay/gogol -bug-reports: https://github.com/brendanhay/gogol/issues -license: OtherLicense -license-file: LICENSE -author: Brendan Hay -maintainer: Brendan Hay -copyright: Copyright (c) 2015-2016 Brendan Hay -category: Network, Google, Cloud -build-type: Simple -extra-source-files: README.md CHANGELOG.md -cabal-version: >= 1.10 +cabal-version: 2.2 +name: gogol +version: 1.0.0.0 +synopsis: Comprehensive Google Services SDK. +homepage: https://github.com/brendanhay/gogol +bug-reports: https://github.com/brendanhay/gogol/issues +license: MPL-2.0 +license-file: LICENSE +author: Brendan Hay +maintainer: + Brendan Hay , Toni Cebrián +copyright: Copyright (c) 2015-2025 Brendan Hay +category: Google +build-type: Simple +extra-source-files: + CHANGELOG.md + README.md + description: - This client library contains request and response logic to communicate - with Google Services compatible APIs using the types supplied by the - various @gogol-*@ service libraries. See the - category on Hackage for supported services. - . - To get started, import the desired @gogol-*@ library (such as - ) - and @Network.Google@ from this package. - . - /Warning:/ This is an experimental prototype/preview release which is still - under exploratory development and not intended for public use, caveat emptor! - . - GHC 7.10.2 and higher is officially supported. + This client library contains request and response logic to communicate + with Google Services compatible APIs using the types supplied by the + various @gogol-*@ service libraries. See the + category on Hackage for supported services. + . + To get started, import the desired @gogol-*@ library (such as + ) + and @Gogol@ from this package. + . + /Warning:/ This is an experimental prototype/preview release which is still + under exploratory development and not intended for public use, caveat emptor! + . + GHC 8.8.4 and higher is officially supported. source-repository head - type: git - location: git://github.com/brendanhay/gogol.git + type: git + location: git://github.com/brendanhay/gogol.git library - default-language: Haskell2010 - hs-source-dirs: src - - ghc-options: -Wall + default-language: GHC2021 + hs-source-dirs: src + ghc-options: + -Wall -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates -funbox-strict-fields + -fwarn-unused-packages - exposed-modules: - Network.Google - , Network.Google.Auth - , Network.Google.Auth.Scope - , Network.Google.Auth.ApplicationDefault - , Network.Google.Auth.InstalledApplication - , Network.Google.Auth.ServiceAccount - , Network.Google.Compute.Metadata - , Network.Google.Env + exposed-modules: + Gogol + Gogol.Auth + Gogol.Auth.ApplicationDefault + Gogol.Auth.InstalledApplication + Gogol.Auth.Scope + Gogol.Auth.ServiceAccount + Gogol.Auth.TokenFile + Gogol.Compute.Metadata + Gogol.Env + Gogol.Internal.Auth + Gogol.Internal.Body + Gogol.Internal.HTTP + Gogol.Internal.Logger + Gogol.Internal.Multipart - other-modules: - Network.Google.Internal.Auth - , Network.Google.Internal.Body - , Network.Google.Internal.HTTP - , Network.Google.Internal.Logger - , Network.Google.Internal.Multipart + reexported-modules: + Gogol.Prelude, Gogol.Types, Gogol.Data.Base64, Gogol.Data.JSON, Gogol.Data.Time - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring >= 0.9 - , case-insensitive >= 1.2 - , conduit >= 1.1 - , conduit-extra >= 1.1 - , cryptonite >= 0.6 - , directory >= 1.2 - , exceptions >= 0.6 - , filepath >= 1.2 - , gogol-core == 0.5.0.* - , http-client >= 0.5 && < 1 - , http-conduit >= 2.3 && < 3 - , http-media >= 0.6 - , http-types >= 0.8.6 - , lens >= 4.4 - , memory >= 0.8 - , mime-types >= 0.1 - , mtl >= 2.1.3.1 - , resourcet >= 1.1 - , text >= 1.1 - , time >= 1.2 - , transformers >= 0.2 - , unliftio-core >= 0.1 - , unordered-containers >= 0.2.5 - , x509 >= 1.5 - , x509-store >= 1.5 + build-depends: + , aeson >=0.8 && <2.3 + , base >=4.12 && <5 + , bytestring >=0.9 && <0.14 + , case-insensitive >=1.2 && <1.3 + , conduit-extra >=1.1 && <1.4 + , crypton >=0.34 && <1.1 + , crypton-x509 >=1.5 && <1.8 + , crypton-x509-store >=1.5 && <1.7 + , directory >=1.2 && <1.5 + , exceptions >=0.6 && <0.12 + , filepath >=1.2 && <1.7 + , gogol-core ^>=1 + , http-client >=0.5 && <1 + , http-conduit >=2.3 && <3 + , http-media >=0.6 && <0.9 + , http-types >=0.8.6 && <0.13 + , lens >=4.4 && <5.4 + , memory >=0.8 && <0.19 + , mime-types >=0.1 && <0.2 + , mtl >=2.2 && <2.4 + , resourcet >=1.1 && <1.4 + , text >=1.1 && <2.2 + , time >=1.2 && <2 diff --git a/src/Gogol.hs b/src/Gogol.hs new file mode 100644 --- /dev/null +++ b/src/Gogol.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +-- | +-- Module : Gogol +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- This module provides a common set of operations which can be performed against +-- the remote Google Service APIs. Typically you will import this module qualified +-- along with modules from the various @gogol-*@ libraries for services you wish +-- to communicate with. +module Gogol + ( -- * Usage + -- $usage + + -- * Environment + Env, + HasEnv (..), + newEnv, + newEnvWith, + + -- ** Credentials + -- $credentials + getApplicationDefault, + + -- ** Authorization + -- $authorization + type AllowRequest, + + -- * Sending Requests + send, + sendEither, + + -- ** Streaming Media + download, + downloadEither, + upload, + uploadEither, + GBody (..), + bodyContentType, + sourceBody, + getMIMEType, + + -- * Service Configuration + -- $configuration + + -- ** Overriding Defaults + configure, + override, + timeout, + + -- ** Lenses + serviceHost, + servicePort, + servicePath, + serviceSecure, + serviceTimeout, + + -- * Handling Errors + AsError (..), + AsAuthError (..), + + -- * Logging + -- $logging + Logger, + LogLevel (..), + + -- ** Constructing a Logger + newLogger, + + -- * Constructing a HTTP Manager + newManager, + tlsManagerSettings, + + -- * Running Asynchronous Actions + -- $async + + -- * Compute Metadata + -- $metadata + + -- * Re-exported Types + module Gogol.Types, + Base64 (..), + DateTime (..), + Date (..), + Time (..), + Duration (..), + AsText (..), + + -- * Re-exported Utilities + runResourceT, + ) +where + +import Control.Exception.Lens +import Control.Monad +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (MonadResource, runResourceT) +import Gogol.Auth +import Gogol.Env +import Gogol.Internal.Body +import Gogol.Internal.HTTP +import Gogol.Internal.Logger +import Gogol.Prelude +import Gogol.Types +import Network.HTTP.Conduit (newManager, tlsManagerSettings) + +-- | Send a request, returning the associated response if successful. +sendEither :: + ( MonadResource m, + AllowRequest a scopes + ) => + Env scopes -> + a -> + m (Either Error (Rs a)) +sendEither = + unsafeRequest + +-- | Send a request, returning the associated response if successful. +-- +-- Throws 'Gogol.Types.Error'. +send :: + ( MonadResource m, + AllowRequest a scopes + ) => + Env scopes -> + a -> + m (Rs a) +send env = + sendEither env + >=> hoistEither + +-- | Send a request returning the associated streaming media response if successful. +-- +-- Some request data types have two possible responses, the JSON metadata and +-- a streaming media response. Use 'send' to retrieve the metadata and 'download' +-- to retrieve the streaming media. +-- +-- Equivalent to: +-- +-- @ +-- 'sendEither' . 'MediaDownload' +-- @ +downloadEither :: + ( MonadResource m, + AllowRequest (MediaDownload a) scopes + ) => + Env scopes -> + a -> + m (Either Error (Rs (MediaDownload a))) +downloadEither env = + sendEither env + . MediaDownload + +-- | Send a request returning the associated streaming media response if successful. +-- +-- Some request data types have two possible responses, the JSON metadata and +-- a streaming media response. Use 'send' to retrieve the metadata and 'download' +-- to retrieve the streaming media. +-- +-- Equivalent to: +-- +-- @ +-- 'send' . 'MediaDownload' +-- @ +-- +-- Throws 'Gogol.Types.Error'. +download :: + ( MonadResource m, + AllowRequest (MediaDownload a) scopes + ) => + Env scopes -> + a -> + m (Rs (MediaDownload a)) +download env = + downloadEither env + >=> hoistEither + +-- | Send a request with an attached upload. +-- +-- Equivalent to: +-- +-- @ +-- 'sendEither' . 'MediaUpload' +-- @ +-- +-- For example: +-- +-- @ +-- uploadFile +-- :: HasScope StorageObjectsInsert scopes +-- => Env scopes +-- -> Text +-- -> Object +-- -> MediaType +-- -> FilePath +-- -> IO (Either Error Object) +-- uploadFile env bucket object media path = do +-- let meta = newStorageObjectsInsert bucket (object { bucket = Just bucket }) +-- +-- body <- GBody media <$> Network.HTTP.Client.streamFile path +-- +-- runResourceT (upload env meta body) +-- @ +uploadEither :: + ( MonadResource m, + AllowRequest (MediaUpload a) scopes + ) => + Env scopes -> + a -> + GBody -> + m (Either Error (Rs (MediaUpload a))) +uploadEither env x = + sendEither env + . MediaUpload x + +-- | Send a request with an attached upload. +-- +-- Equivalent to: +-- +-- @ +-- 'send' . 'MediaUpload' +-- @ +-- +-- Throws 'Gogol.Types.Error'. +upload :: + ( MonadResource m, + AllowRequest (MediaUpload a) scopes + ) => + Env scopes -> + a -> + GBody -> + m (Rs (MediaUpload a)) +upload env x = + uploadEither env x + >=> hoistEither + +hoistEither :: (MonadIO m) => Either Error a -> m a +hoistEither = either (liftIO . throwingM _Error) pure + +-- $usage +-- +-- The request and response types provided by the various @gogol-*@ libraries can +-- be used with either 'send', 'upload', or 'download', depending upon the +-- request's purpose. Namely, 'send' is the function you will most commonly use to +-- send requests, with 'upload' and 'download' as convenience when dealing with +-- streaming requests and responses respectively. +-- +-- To get started we will need to specify our Google Service credentials and +-- create an 'Env' environment containing configuration which will be used by +-- calling functions to perform any actions. Your Google 'Credentials' can be supplied +-- in a number of ways, by having Gogol retrieve +-- +-- for use on Google App Engine and Google Compute Engine, or by explicitly +-- supplying your credentials. See the <#credentials Credentials> section for +-- information about supported credential mechanisms. +-- +-- The following example demonstrates uploading a file to Google +-- using 'ObjectsInsert' from +-- : +-- +-- +-- > {-# LANGUAGE DataKinds #-} +-- > {-# LANGUAGE FlexibleContexts #-} +-- > {-# LANGUAGE OverloadedLabels #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE ScopedTypeVariables #-} +-- > +-- > import Control.Lens ((.~), (<&>), (?~)) +-- > import Control.Monad.Trans.Resource (liftResourceT) +-- > import Data.Conduit (runConduit, (.|)) +-- > import qualified Data.Conduit.Binary as Conduit +-- > import Data.Function ((&)) +-- > import Data.Generics.Labels () +-- > import Data.Proxy +-- > import Data.Text +-- > import qualified Data.Text as Text +-- > import Gogol +-- > import qualified Gogol.Storage as Storage +-- > import System.IO (stdout) +-- > +-- > import qualified Data.Text as Text +-- > +-- > example :: IO Storage.Object +-- > example = do +-- > lgr <- newLogger Debug stdout -- (1) +-- > env <- newEnv <&> (envLogger .~ lgr) . (envScopes .~ (Proxy :: Proxy '[Storage.Devstorage'ReadWrite])) -- (2) (3) +-- > body <- sourceBody "/path/to/image.jpg" -- (4) +-- > let key = "image.jpg" +-- > bucket = "my-storage-bucket" +-- > +-- > runResourceT $ -- (5) +-- > upload env (Storage.newStorageObjectsInsert bucket (Storage.newObject & #name ?~ key)) body +-- +-- Breaking down the above example, we have the following points of interest: +-- +-- 1. A new 'Logger' to replace the default noop logger is created, set to print +-- debug information and errors to 'stdout'. +-- +-- 2. The 'Env' is created using 'newEnv'. This creates a new HTTP 'Manager' and +-- retrieves the application default 'Credentials'. +-- +-- 3. The lenses 'envLogger' and 'envScopes' are used to set the newly created +-- 'Logger' and authorised OAuth2 scopes, respectively. Explicitly annotating the +-- 'Env' with the scopes ensures that any mismatch between the remote +-- operations performed in 'upload' and the credential scopes are raised as +-- errors at compile time. +-- See the <#authorization Authorization> section for more information. +-- +-- 4. The streaming 'body' for the object is retrieved from a 'FilePath', and the +-- MIME type is calculated from the file extension. +-- The MIME type is used as the object's @Content-Type@ in Cloud Storage, and +-- can be overriden using the 'bodyContentType' lens as follows: +-- +-- > import Network.HTTP.Media ((//)) +-- > +-- > body <- sourceBody f <&> bodyContentType .~ "application" // "json" +-- +-- 5. Finally, we run the 'Google' computation using @'runResourceT'@ +-- which serialises the 'StorageObjectsInsert' type to a HTTP request and sets the streaming 'Body'. +-- The resulting 'Storage.Object' metadata is then parsed from a successful HTTP response. +-- 1 +-- Additional examples can be found can be found in the +-- project's +-- source control. + +-- $authorization #authorization# +-- Each request within a particular 'send', 'upload' or 'download' context requires specific +-- OAuth2 scopes to be have been authorized for the given credentials. +-- +-- For example, the Google Storage 'StorageObjectsInsert' has the associated scopes of: +-- +-- > type Scopes ObjectsInsert = +-- > '["https://www.googleapis.com/auth/cloud-platform", +-- > "https://www.googleapis.com/auth/devstorage.full_control", +-- > "https://www.googleapis.com/auth/devstorage.read_write"] +-- +-- Multiple differing requests within a given function call context will then require +-- the credentials to have a minimal set of these associated request scopes. +-- This authorization information is represented as a type-level set, +-- the 's' type parameter of 'Env'. A mismatch of the sent request scopes and the 'Env' credential scopes results in a informative +-- compile error. +-- +-- You can use 'allow' or the 'envScopes' lens to specify the 'Env's set of scopes. +-- The various @gogol-*@ libraries export their individual scopes from @Gogol.*" +-- and you can use the '(!)' combinator to combine these into a larger set. +-- +-- For example: +-- +-- > import Control.Lens ((<&>), (.~)) +-- > import Gogol +-- > import Gogol.Monitoring +-- > import Gogol.Compute +-- > +-- > main :: IO () +-- > main = do +-- > env <- newEnv <&> envScopes .~ (Proxy :: Proxy '[Monitoring'Read, Monitoring'Write, Compute'ReadOnly]) +-- > ... +-- +-- >>> :type env +-- Env '["https://www.googleapis.com/auth/monitoring.read", "https://www.googleapis.com/auth/monitoring.write", "https://www.googleapis.com/auth/compute.readonly"] + +-- $configuration +-- Each service has its own configuration such as host, port, path prefix, and timeout +-- which can be customized independent of other services. +-- It can be desirable to customize this when mocking service endpoints or adjusting +-- HTTP response timeouts for a specific request. +-- +-- For example, to point all calls to Google Compute to @https://localhost@ instead +-- of the actual remote endpoint, we can use @Control.Monad.Reader.local@ in conjunction +-- with 'override': +-- +-- > import Control.Lens ((&), (.~)) +-- > import Control.Monad.Reader (local) +-- > import Gogol +-- > import Gogol.Compute +-- > +-- > local (override (computeService & serviceHost .~ "localhost")) $ do +-- > _ <- send $ instancesGet "project" "zone" "instance-id" +-- > ... + +-- $credentials #credentials# +-- By default 'newEnv' uses 'getApplicationDefault' to discover credentials +-- from the underlying, following Google's official library behaviour. +-- If you wish to manually specify 'Credentials' via 'newEnvWith', you can use one +-- of the following supported credential mechanisms: +-- +-- * "Gogol.Auth.InstalledApplication" - Applications installed on devices. +-- * "Gogol.Auth.ServiceAccount" - Applications deployed to custom environments. +-- * "Gogol.Auth.ApplicationDefault" - Applications deployed to App Engine (GAE) or Compute Engine (GCE). +-- +-- See "Gogol.Auth" for more information. + +-- $async +-- Requests can be sent asynchronously, but due to guarantees about resource closure +-- require the use of . + +-- $metadata +-- +-- Google Compute metadata can be retrieve when running on GCE instances. +-- See the documentation in "Gogol.Compute.Metadata" for the available +-- functions. + +-- $logging +-- The exposed logging interface is a primitive 'Logger' function which gets +-- threaded through service calls and serialisation routines. This allows the +-- consuming library to output useful information and diagnostics. +-- +-- The 'newLogger' function can be used to construct a simple logger which writes +-- output to a 'Handle', but in most production code you should probably consider +-- using a more robust logging library such as +-- or +-- . diff --git a/src/Gogol/Auth.hs b/src/Gogol/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Auth.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Gogol.Auth +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Explicitly specify your Google credentials, or retrieve them +-- from the underlying OS. +module Gogol.Auth + ( -- * Credentials + Credentials (..), + + -- ** Application Default Credentials + getApplicationDefault, + fromWellKnownPath, + fromFilePath, + saveAuthorizedUserToWellKnownPath, + saveAuthorizedUser, + + -- ** Service account user impersonation + serviceAccountUser, + + -- *** Kubernetes + serviceAccountTokenFile, + + -- ** Installed Application Credentials + installedApplication, + formURL, + + -- ** Authorizing Requests + authorize, + + -- ** Thread-safe Storage + Store, + initStore, + retrieveAuthFromStore, + retrieveTokenFromStore, + Auth (..), + authToAuthorizedUser, + exchange, + refresh, + + -- ** Default Constants + checkGCEVar, + cloudSDKConfigDir, + defaultCredentialsFile, + + -- ** Handling Errors + AsAuthError (..), + AuthError (..), + + -- * OAuth Types + OAuthClient (..), + OAuthToken (..), + OAuthCode (..), + OAuthScope (..), + + -- * Re-exported Types + AccessToken (..), + RefreshToken (..), + GSecret (..), + ServiceId (..), + ClientId (..), + + -- * Re-exported Modules + module Gogol.Auth.Scope, + ) +where + +import Control.Concurrent +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Time (getCurrentTime) +import GHC.TypeLits (Symbol) +import Gogol.Auth.ApplicationDefault +import Gogol.Auth.InstalledApplication +import Gogol.Auth.Scope +import Gogol.Auth.ServiceAccount +import Gogol.Auth.TokenFile +import Gogol.Compute.Metadata (checkGCEVar) +import Gogol.Internal.Auth +import Gogol.Internal.Logger (Logger) +import Gogol.Prelude +import Network.HTTP.Conduit (Manager) +import Network.HTTP.Conduit qualified as Client +import Network.HTTP.Types (hAuthorization) + +-- | 'authToAuthorizedUser' converts 'Auth' into an 'AuthorizedUser' +-- by returning 'Right' if there is a 'FromClient'-constructed +-- Credentials and a refreshed token; otherwise, returning +-- 'Left' with error message. +authToAuthorizedUser :: (KnownScopes s) => Auth s -> Either Text AuthorizedUser +authToAuthorizedUser a = + AuthorizedUser + <$> (_clientId <$> getClient) + <*> maybe (Left "no refresh token") Right (_tokenRefresh (_token a)) + <*> (_clientSecret <$> getClient) + where + getClient = case _credentials a of + FromClient c _ -> Right c + _ -> Left "not FromClient" + +-- | An 'OAuthToken' that can potentially be expired, with the original +-- credentials that can be used to perform a refresh. +data Auth (s :: [Symbol]) = Auth + { _credentials :: !(Credentials s), + _token :: !(OAuthToken s) + } + +-- | Check if the given token is still valid, ie. younger than the projected +-- expiry time. +-- +-- This deliberately makes no external calls due to the absolute construction of +-- the '_tokenExpiry' field, unlike the +-- +-- validation method. +validate :: (MonadIO m) => Auth s -> m Bool +validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime + +-- | Data store which ensures thread-safe access of credentials. +newtype Store (s :: [Symbol]) = Store (MVar (Auth s)) + +-- | Construct storage containing the credentials which have not yet been +-- exchanged or refreshed. +initStore :: + (MonadIO m, MonadCatch m, KnownScopes s) => + Credentials s -> + Logger -> + Manager -> + m (Store s) +initStore c l m = exchange c l m >>= fmap Store . liftIO . newMVar + +-- | Retrieve auth from storage +retrieveAuthFromStore :: + (MonadIO m, KnownScopes s) => + Store s -> + m (Auth s) +retrieveAuthFromStore (Store s) = + liftIO (readMVar s) + +-- | Concurrently read the current token, and if expired, then +-- safely perform a single serial refresh. +retrieveTokenFromStore :: + (MonadIO m, MonadCatch m, KnownScopes s) => + Store s -> + Logger -> + Manager -> + m (OAuthToken s) +retrieveTokenFromStore (Store s) l m = do + x <- liftIO (readMVar s) + mx <- validate x + if mx + then pure (_token x) + else liftIO . modifyMVar s $ \y -> do + my <- validate y + if my + then pure (y, _token y) + else do + z <- refresh y l m + pure (z, _token z) + +-- | Perform the initial credentials exchange to obtain a valid 'OAuthToken' +-- suitable for authorizing requests. +exchange :: + forall m s. + (MonadIO m, MonadCatch m, KnownScopes s) => + Credentials s -> + Logger -> + Manager -> + m (Auth s) +exchange c l = fmap (Auth c) . action l + where + action = case c of + FromMetadata s -> metadataToken s + FromAccount a -> serviceAccountToken a (Proxy :: Proxy s) + FromClient x n -> exchangeCode x n + FromUser u -> authorizedUserToken u Nothing + FromTokenFile f -> \_l _m -> readTokenFile f + +-- | Refresh an existing 'OAuthToken'. +refresh :: + forall m s. + (MonadIO m, MonadCatch m, KnownScopes s) => + Auth s -> + Logger -> + Manager -> + m (Auth s) +refresh (Auth c t) l = fmap (Auth c) . action l + where + action = case c of + FromMetadata s -> metadataToken s + FromAccount a -> serviceAccountToken a (Proxy :: Proxy s) + FromClient x _ -> refreshToken x t + FromUser u -> authorizedUserToken u (_tokenRefresh t) + FromTokenFile f -> \_l _m -> readTokenFile f + +-- | Apply the (by way of possible token refresh) a bearer token to the +-- authentication header of a request. +authorize :: + (MonadIO m, MonadCatch m, KnownScopes s) => + Client.Request -> + Store s -> + Logger -> + Manager -> + m Client.Request +authorize rq s l m = bearer <$> retrieveTokenFromStore s l m + where + bearer t = + rq + { Client.requestHeaders = + ( hAuthorization, + "Bearer " <> toHeader (_tokenAccess t) + ) + : Client.requestHeaders rq + } + +-- | Set the user to be impersonated for a service account with domain +-- wide delegation. See +-- https://developers.google.com/identity/protocols/OAuth2ServiceAccount +serviceAccountUser :: + forall s. + (KnownScopes s) => + Maybe Text -> + Credentials s -> + Credentials s +serviceAccountUser u (FromAccount s) = FromAccount $ s {_serviceAccountUser = u} +serviceAccountUser _ c = c diff --git a/src/Gogol/Auth/ApplicationDefault.hs b/src/Gogol/Auth/ApplicationDefault.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Auth/ApplicationDefault.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Gogol.Auth.ApplicationDefaultCredentials +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Application Default Credentials are suited for cases when access to a Google service +-- needs to have the same identity and authorization level for the application +-- independent of the user. This is Google\'s the recommended approach to authorize +-- calls to Google Cloud APIs, particularly when you're building an application +-- that is deployed to Google App Engine or Google Compute Engine virtual machines. +-- +-- /See:/ . +module Gogol.Auth.ApplicationDefault where + +import Control.Exception.Lens (catching, throwingM) +import Control.Monad (unless, when) +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Aeson +import Data.Aeson.Types (parseEither) +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as Text +import Gogol.Compute.Metadata (isGCE) +import Gogol.Internal.Auth +import Network.HTTP.Conduit (Manager) +import System.Directory (createDirectoryIfMissing, doesFileExist, getHomeDirectory) +import System.Environment (lookupEnv) +import System.FilePath (takeDirectory, ()) +import System.Info (os) + +-- | The environment variable name which is used to specify the directory +-- containing the @application_default_credentials.json@ generated by @gcloud init@. +cloudSDKConfigDir :: String +cloudSDKConfigDir = "CLOUDSDK_CONFIG" + +-- | Return the filepath to the Cloud SDK well known file location such as +-- @~\/.config\/gcloud\/application_default_credentials.json@. +cloudSDKConfigPath :: (MonadIO m) => m FilePath +cloudSDKConfigPath = do + m <- liftIO (lookupEnv cloudSDKConfigDir) + case m of + Just d -> pure $! d "application_default_credentials.json" + Nothing -> do + d <- getConfigDirectory + pure $! d "gcloud/application_default_credentials.json" + +-- | The environment variable pointing the file with local +-- Application Default Credentials. +defaultCredentialsFile :: String +defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS" + +-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the +-- default application credentials filepath. +defaultCredentialsPath :: (MonadIO m) => m (Maybe FilePath) +defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile) + +-- | Performs credentials discovery in the following order: +-- +-- 1. Read the default credentials from a file specified by +-- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists. +-- +-- 2. Read the platform equivalent of @~\/.config\/gcloud\/application_default_credentials.json@ if it exists. +-- The @~/.config@ component of the path can be overriden by the environment +-- variable @CLOUDSDK_CONFIG@ if it exists. +-- +-- 3. Retrieve the default service account application credentials if +-- running on GCE. The environment variable @NO_GCE_CHECK@ can be used to +-- skip this check if set to a truthy value such as @1@ or @true@. +-- +-- The specified 'Scope's are used to authorize any @service_account@ that is +-- found with the appropriate OAuth2 scopes, otherwise they are not used. See the +-- top-level module of each individual @gogol-*@ library for a list of available +-- scopes, such as @Gogol.Compute.computeScope@. +-- +-- /See:/ +getApplicationDefault :: + (MonadIO m, MonadCatch m) => + Manager -> + m (Credentials s) +getApplicationDefault m = + catching _MissingFileError fromWellKnownPath $ \f -> do + p <- isGCE m + unless p $ + throwingM _MissingFileError f + pure $! FromMetadata "default" + +-- | Attempt to load either a @service_account@ or @authorized_user@ formatted +-- file to obtain the credentials neccessary to perform a token refresh. +-- +-- The specified 'Scope's are used to authorize any @service_account@ that is +-- found with the appropriate scopes, otherwise they are not used. See the +-- top-level module of each individual @gogol-*@ library for a list of available +-- scopes, such as @Gogol.Compute.computeScope@. +-- +-- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'. +fromWellKnownPath :: (MonadIO m, MonadCatch m) => m (Credentials s) +fromWellKnownPath = do + f <- defaultCredentialsPath + case f of + Just x -> fromFilePath x + Nothing -> do + x <- cloudSDKConfigPath + fromFilePath x + +-- | Attempt to load either a @service_account@ or @authorized_user@ formatted +-- file to obtain the credentials neccessary to perform a token refresh from +-- the specified file. +-- +-- The specified 'Scope's are used to authorize any @service_account@ that is +-- found with the appropriate scopes, otherwise they are not used. See the +-- top-level module of each individual @gogol-*@ library for a list of available +-- scopes, such as @Gogol.Compute.computeScope@. +fromFilePath :: (MonadIO m, MonadCatch m) => FilePath -> m (Credentials s) +fromFilePath f = do + p <- liftIO (doesFileExist f) + unless p $ + throwM (MissingFileError f) + bs <- liftIO (LBS.readFile f) + either + (throwM . InvalidFileError f . Text.pack) + pure + (fromJSONCredentials bs) + +-- | Save 'AuthorizedUser' +-- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'. +saveAuthorizedUserToWellKnownPath :: + (MonadIO m, MonadCatch m) => + -- | Force to save if True + Bool -> + AuthorizedUser -> + m () +saveAuthorizedUserToWellKnownPath b a = do + d <- defaultCredentialsPath + f <- maybe cloudSDKConfigPath pure d + liftIO $ createDirectoryIfMissing True $ takeDirectory f + saveAuthorizedUser f b a + +-- | Save 'AuthorizedUser' +saveAuthorizedUser :: + (MonadIO m, MonadCatch m) => + FilePath -> + -- | Force to save if True + Bool -> + AuthorizedUser -> + m () +saveAuthorizedUser f b a = do + p <- liftIO (doesFileExist f) + when (p && not b) $ + throwM (FileExistError f) + liftIO (LBS.writeFile f $ encode a) + +-- | Attempt to parse either a @service_account@ or @authorized_user@ formatted +-- JSON value to obtain credentials. +fromJSONCredentials :: LBS.ByteString -> Either String (Credentials s) +fromJSONCredentials bs = do + v <- eitherDecode' bs + let x = FromAccount <$> parseEither parseJSON v + y = FromUser <$> parseEither parseJSON v + case (x, y) of + (Left xe, Left ye) -> + Left $ + "Failed parsing service_account: " + ++ xe + ++ ", Failed parsing authorized_user: " + ++ ye + (Right a, _) -> Right a + (_, Right u) -> Right u + +getConfigDirectory :: (MonadIO m) => m FilePath +getConfigDirectory = do + h <- liftIO getHomeDirectory + if os == "windows" + then pure h + else pure $! h ".config" diff --git a/src/Gogol/Auth/InstalledApplication.hs b/src/Gogol/Auth/InstalledApplication.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Auth/InstalledApplication.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Gogol.Auth.InstalledApplication +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Credentials for applications that are installed on devices such as +-- computers, cell phones, or a tablet. Installed apps are distributed to +-- individual machines, and it is assumed that these apps securely store secrets. +-- +-- These apps might access a Google service while the user is present at the +-- application, or when the application is running in the background. +-- +-- /See:/ . +module Gogol.Auth.InstalledApplication + ( installedApplication, + + -- * Forming the URL + AccessType (..), + redirectURI, + formURL, + formAccessTypeURL, + formURLWith, + formAccessTypeURLWith, + + -- * Internal Exchange and Refresh + exchangeCode, + refreshToken, + ) +where + +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import GHC.TypeLits (Symbol) +import Gogol.Auth.Scope + ( KnownScopes (..), + queryEncodeScopes, + ) +import Gogol.Internal.Auth +import Gogol.Internal.Logger (Logger) +import Gogol.Prelude +import Network.HTTP.Conduit (Manager) +import Network.HTTP.Conduit qualified as Client + +-- | Create new Installed Application credentials. +-- +-- Since it is intended that the user opens the URL generated by 'formURL' in a browser +-- and the resulting 'OAuthCode' is then received out-of-band, +-- you must ensure that the scopes passed to 'formURL' and the type of 'OAuthCode' +-- correctly match, otherwise an authorization error will occur. +-- +-- For example, doing this via 'getLine' and copy-paste: +-- +-- > {-# LANGUAGE ScopedTypeVariables #-} +-- +-- > import Data.Proxy (Proxy (..)) +-- > import Data.Text as T +-- > import Data.Text.IO as T +-- > import System.Exit (exitFailure) +-- > import System.Info (os) +-- > import System.Process (rawSystem) +-- +-- > redirectPrompt :: KnownScopes (s :: [Symbol]) => OAuthClient -> proxy s -> IO (OAuthCode s) +-- > redirectPrompt c p = do +-- > let url = formURL c p +-- > T.putStrLn $ "Opening URL " `T.append` url +-- > _ <- case os of +-- > "darwin" -> rawSystem "open" [unpack url] +-- > "linux" -> rawSystem "xdg-open" [unpack url] +-- > _ -> T.putStrLn "Unsupported OS" >> exitFailure +-- > T.putStrLn "Please input the authorisation code: " +-- > OAuthCode <$> T.getLine +-- +-- This ensures the scopes passed to 'formURL' and the type of 'OAuthCode' 's' +-- are correct. +installedApplication :: OAuthClient -> OAuthCode s -> Credentials s +installedApplication = FromClient + +-- /See:/ +data AccessType = Online | Offline deriving (Show, Eq) + +-- | The redirection URI used in 'formURL': @urn:ietf:wg:oauth:2.0:oob@. +redirectURI :: Text +redirectURI = "urn:ietf:wg:oauth:2.0:oob" + +-- | Given an 'OAuthClient' and a list of scopes to authorize, +-- construct a URL that can be used to obtain the 'OAuthCode'. +-- +-- /See:/ . +formURL :: (KnownScopes (s :: [Symbol])) => OAuthClient -> proxy s -> Text +formURL c = formURLWith c . scopeVals + +-- | 'formURL' for 'AccessType' +-- +-- /See:/ 'formUrl'. +formAccessTypeURL :: (KnownScopes (s :: [Symbol])) => OAuthClient -> AccessType -> proxy s -> Text +formAccessTypeURL c a = formAccessTypeURLWith c a . scopeVals + +-- | Form a URL using 'OAuthScope' values. +-- +-- /See:/ 'formURL'. +formURLWith :: OAuthClient -> [OAuthScope] -> Text +formURLWith c ss = + accountsURL + <> "?response_type=code" + <> "&client_id=" + <> toQueryParam (_clientId c) + <> "&redirect_uri=" + <> redirectURI + <> "&scope=" + <> Text.decodeUtf8 (queryEncodeScopes ss) + +-- | 'formURLWith' for 'AccessType' +-- +-- /See:/ 'formURLWith'. +formAccessTypeURLWith :: OAuthClient -> AccessType -> [OAuthScope] -> Text +formAccessTypeURLWith c a ss = + formURLWith c ss + <> "&access_type=" + <> (Text.toLower . Text.pack $ show a) + +-- | Exchange 'OAuthClient' details and the received 'OAuthCode' for a new +-- 'OAuthToken'. +-- +-- /See:/ . +exchangeCode :: + (MonadIO m, MonadCatch m) => + OAuthClient -> + (OAuthCode s) -> + Logger -> + Manager -> + m (OAuthToken s) +exchangeCode c n = + refreshRequest $ + tokenRequest + { Client.requestBody = + textBody $ + "grant_type=authorization_code" + <> "&client_id=" + <> toQueryParam (_clientId c) + <> "&client_secret=" + <> toQueryParam (_clientSecret c) + <> "&code=" + <> toQueryParam n + <> "&redirect_uri=" + <> redirectURI + } + +-- | Perform a refresh to obtain a valid 'OAuthToken' with a new expiry time. +-- +-- /See:/ . +refreshToken :: + (MonadIO m, MonadCatch m) => + OAuthClient -> + (OAuthToken s) -> + Logger -> + Manager -> + m (OAuthToken s) +refreshToken c t = + refreshRequest $ + tokenRequest + { Client.requestBody = + textBody $ + "grant_type=refresh_token" + <> "&client_id=" + <> toQueryParam (_clientId c) + <> "&client_secret=" + <> toQueryParam (_clientSecret c) + <> maybe mempty ("&refresh_token=" <>) (toQueryParam <$> _tokenRefresh t) + } diff --git a/src/Gogol/Auth/Scope.hs b/src/Gogol/Auth/Scope.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Auth/Scope.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Gogol.Auth.Scope +-- Copyright : (c) 2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Helpers for specifying and using type-level OAuth scopes. +module Gogol.Auth.Scope + ( -- * Scope constraints + type AllowRequest, + type SatisfyScope, + + -- ** Modifying type-level lists of scopes + allow, + forbid, + (!), + + -- * Manipulating scope values + KnownScopes (..), + concatScopes, + queryEncodeScopes, + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.Coerce (coerce) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Type.Bool (type If, type (||)) +import Data.Typeable (Proxy (..)) +import GHC.Exts (Constraint) +import GHC.TypeLits +import Gogol.Internal.Auth (Credentials) +import Gogol.Types (GoogleRequest (..), OAuthScope (..)) +import Network.HTTP.Types (urlEncode) + +-- | 'Constraint' kind for proving the @scopes@ context contains one of the +-- scopes necessary for authenticating the request, @a@. +-- +-- @ +-- uploadAndDownloadFile +-- :: ( AllowRequest StorageObjectsInsert scopes +-- , AllowRequest StorageObjectsGet scopes +-- ) +-- => Env scopes +-- -> Text +-- -> Object +-- -> MediaType +-- -> FilePath +-- -> FilePath +-- -> IO Object +-- uploadAndDownloadFile env bucket object media src dst = do +-- let put = newStorageObjectsInsert bucket (object { bucket = Just bucket }) +-- get = newStorageObjectsGet bucket object +-- +-- body <- GBody media <$> HTTP.streamFile src +-- +-- runResourceT $ do +-- _object <- upload env meta body +-- stream <- download env meta +-- +-- Conduit.connect stream (Conduit.Combinators.sinkFileCautious dst) +-- @ +-- +-- /See:/ 'SatisfyScope'. +type AllowRequest a scopes = (GoogleRequest a, KnownScopes scopes, SatisfyScope (Scopes a) scopes) + +-- | 'Constraint' proving at least _one_ scope from @required@ exists in +-- the provided context, @scopes@. +-- +-- That is, the set of possible scopes a request requires are on the left, and +-- the set of scopes credentials or an environment contain are on the right. +type family SatisfyScope (required :: [Symbol]) (scopes :: [Symbol]) :: Constraint where + SatisfyScope '[] _ = () -- Special case; no scopes are required. + SatisfyScope required scopes = + If (Intersect scopes required) (() :: Constraint) (TypeError (MissingScopesError required scopes)) + +type MissingScopesError (required :: [k]) (scopes :: [k]) = + 'Text "One scope from the following list is required:" + ':$$: 'Text " " ':<>: 'ShowType required + ':$$: 'Text "However, none of these scopes are present in the list of scopes you provided:" + ':$$: 'Text " " ':<>: 'ShowType scopes + +-- Short-circuiting intersection - does at least one element exist in both lists? +type family Intersect (as :: [k]) (bs :: [k]) :: Bool where + Intersect '[] _ = 'False + Intersect _ '[] = 'False + Intersect (a ': as) bs = Elem a bs || Intersect as bs + +-- Type-level 'Data.List.elem'. +type family Elem (x :: k) (xs :: [k]) :: Bool where + Elem _ '[] = 'False + Elem x (x ': xs) = 'True + Elem x (y ': xs) = Elem x xs + +-- This exists to allow users to choose between using 'newEnv' +-- with a 'Proxy' constructed by '!', or explicitly +-- specifying scopes via a type annotation. +-- +-- /See:/ '!', 'envScopes', and the scopes available for each service. +allow :: proxy s -> k s -> k s +allow _ = id + +-- | Annotate credentials with no scope authorization. +forbid :: k '[] -> k '[] +forbid = id + +-- | Append two sets of scopes. +-- +-- /See:/ 'allow'. +(!) :: proxy xs -> proxy ys -> Proxy (Nub (xs ++ ys)) +(!) _ _ = Proxy + +-- | Append two lists. +type family (++) xs ys where + (++) xs '[] = xs + (++) '[] ys = ys + (++) (x ': xs) ys = x ': (xs ++ ys) + +-- | Remove duplicates from a list. +type family Nub xs where + Nub '[] = '[] + Nub (x ': xs) = x ': Nub (Delete x xs) + +-- | Remove a specific element from a list. +type family Delete x xs where + Delete x '[] = '[] + Delete x (x ': ys) = Delete x ys + Delete x (y ': ys) = y ': Delete x ys + +class KnownScopes a where + -- | Obtain a list of supported 'OAuthScope' values from a proxy. + -- + -- This is used to pass scope _values_ to functions that require them, + -- such as 'Gogol.Auth.ServiceAccount.serviceAccountToken'. + scopeVals :: proxy a -> [OAuthScope] + +instance KnownScopes '[] where + scopeVals _ = [] + +instance (KnownSymbol x, KnownScopes xs) => KnownScopes (x ': xs) where + scopeVals _ = scope (Proxy :: Proxy x) : scopeVals (Proxy :: Proxy xs) + where + scope = OAuthScope . Text.pack . symbolVal + +instance (KnownScopes s) => KnownScopes (Credentials s) where + scopeVals _ = scopeVals (Proxy :: Proxy s) + +-- | Concatenate a list of scopes using spaces. +concatScopes :: [OAuthScope] -> Text +concatScopes = Text.intercalate " " . coerce + +-- | Encode a list of scopes suitable for embedding in a query string. +queryEncodeScopes :: [OAuthScope] -> ByteString +queryEncodeScopes = + BS8.intercalate "+" + . map (urlEncode True . Text.encodeUtf8) + . coerce diff --git a/src/Gogol/Auth/ServiceAccount.hs b/src/Gogol/Auth/ServiceAccount.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Auth/ServiceAccount.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} + +-- | +-- Module : Gogol.Auth.ServiceAccount +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Credentials for Server to Server communication, such as between a deployed web +-- application and a Google service. +-- +-- Typically, an application uses a service account when the application uses +-- Google services to work with its own data rather than a specific user's data. +-- +-- /See:/ . +module Gogol.Auth.ServiceAccount + ( ServiceAccount (..), + AuthorizedUser (..), + maxTokenLifetime, + metadataToken, + authorizedUserToken, + serviceAccountToken, + encodeBearerJWT, + ) +where + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Crypto.Hash.Algorithms (SHA256 (..)) +import Crypto.PubKey.RSA.PKCS15 (signSafer) +import Data.Aeson +import Data.ByteString.Char8 qualified as BS8 +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time.Clock.POSIX +import Gogol.Auth.Scope (KnownScopes (..), concatScopes) +import Gogol.Compute.Metadata +import Gogol.Internal.Auth +import Gogol.Internal.Logger +import Gogol.Prelude hiding (buildText) +import Network.HTTP.Conduit hiding (Request) +import Network.HTTP.Conduit qualified as Client + +-- | The maximum lifetime of a @service_account@ token which is 1 hour, in seconds. +maxTokenLifetime :: Seconds +maxTokenLifetime = 3600 + +-- | Obtain an 'OAuthToken' from the local instace metadata +-- using the specific 'ServiceId'. +-- +-- For example: @http:\/\/metadata.google.internal\/computeMetadata\/v1\/instance\/service-accounts\/default\/token@ +-- will be retrieved if the given 'ServiceId' is @\"default\"@. +metadataToken :: + (MonadIO m, MonadCatch m) => + ServiceId -> + Logger -> + Manager -> + m (OAuthToken s) +metadataToken s = + refreshRequest $ + metadataRequest + { Client.path = + "/computeMetadata/v1/instance/service-accounts/" + <> Text.encodeUtf8 (toQueryParam s) + <> "/token" + } + +-- | Use the 'AuthorizedUser' to obtain a new 'OAuthToken'. If the supplied +-- 'RefreshToken' is 'Nothing', the original 'RefreshToken' from the user will +-- be used. +authorizedUserToken :: + (MonadIO m, MonadCatch m) => + AuthorizedUser -> + Maybe RefreshToken -> + Logger -> + Manager -> + m (OAuthToken s) +authorizedUserToken u r = + refreshRequest $ + tokenRequest + { Client.requestBody = + textBody $ + "grant_type=refresh_token" + <> "&client_id=" + <> toQueryParam (_userId u) + <> "&client_secret=" + <> toQueryParam (_userSecret u) + <> "&refresh_token=" + <> toQueryParam (fromMaybe (_userRefresh u) r) + } + +-- | Obtain an 'OAuthToken' from @https://accounts.google.com/o/oauth2/v2/auth@ +-- by signing and sending a JSON Web Token (JWT) using the supplied 'ServiceAccount'. +serviceAccountToken :: + (MonadIO m, MonadCatch m, KnownScopes s) => + ServiceAccount -> + proxy s -> + Logger -> + Manager -> + m (OAuthToken s) +serviceAccountToken s p l m = do + b <- encodeBearerJWT s p + let rq = + tokenRequest + { Client.requestBody = + RequestBodyBS $ + "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer" + <> "&assertion=" + <> b + } + refreshRequest rq l m + +-- | Encode the supplied 'ServiceAccount's key id, email, and scopes using the +-- private key in the JSON Web Token (JWT) format. +encodeBearerJWT :: + (MonadIO m, MonadThrow m, KnownScopes s) => + ServiceAccount -> + proxy s -> + m ByteString +encodeBearerJWT s p = liftIO $ do + i <- input . truncate <$> getPOSIXTime + r <- signSafer (Just SHA256) (_servicePrivateKey s) i + either failure (pure . concat' i) r + where + concat' i x = i <> "." <> signature (base64 x) + + failure e = + throwM $ + TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing + + signature bs = + case BS8.unsnoc bs of + Nothing -> mempty + Just (bs', x) + | x == '=' -> bs' + | otherwise -> bs + + input n = header <> "." <> payload + where + header = + base64Encode + [ "alg" .= ("RS256" :: Text), + "typ" .= ("JWT" :: Text), + "kid" .= _serviceKeyId s + ] + + payload = + base64Encode $ + [ "aud" .= tokenURL, + "scope" .= concatScopes (scopeVals p), + "iat" .= n, + "exp" .= (n + seconds maxTokenLifetime), + "iss" .= _serviceEmail s + ] + <> maybe [] (\sub -> ["sub" .= sub]) (_serviceAccountUser s) diff --git a/src/Gogol/Auth/TokenFile.hs b/src/Gogol/Auth/TokenFile.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Auth/TokenFile.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Gogol.Auth.TokenFile +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Auth.TokenFile where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.ByteString qualified as ByteString +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Time qualified as Time +import Gogol.Internal.Auth +import Gogol.Types (AccessToken (..)) + +serviceAccountTokenFile :: FilePath +serviceAccountTokenFile = "/var/run/secrets/kubernetes.io/serviceaccount/token" + +readTokenFile :: (MonadIO m) => FilePath -> m (OAuthToken s) +readTokenFile path = + liftIO $ do + access <- Text.strip . Text.Encoding.decodeUtf8 <$> ByteString.readFile path + expiry <- Time.addUTCTime 60 <$> Time.getCurrentTime + + pure + OAuthToken + { _tokenAccess = AccessToken access, + _tokenRefresh = Nothing, + _tokenExpiry = expiry + } diff --git a/src/Gogol/Compute/Metadata.hs b/src/Gogol/Compute/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Compute/Metadata.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Gogol.Compute.Metadata +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Google Compute Engine defines a set of default metadata entries that provide +-- information about your instance or project. +-- +-- This module contains functions for retrieving various Compute metadata from an +-- instance\'s local metadata endpoint using 'MonadIO', prior to initialisation +-- of the environment used by the "Gogol" monad. +module Gogol.Compute.Metadata + ( -- * Google Compute Instance Check + checkGCEVar, + isGCE, + + -- * Retrieving Metadata + getProjectAttribute, + getSSHKeys, + getNumericProjectId, + getProjectId, + getInstanceAttribute, + getDescription, + getHostname, + getInstanceId, + getMachineType, + getTags, + getZone, + + -- * Raw Metadata Requests + metadataFlavorHeader, + metadataFlavorDesired, + metadataRequest, + getMetadata, + ) +where + +import Control.Exception (throwIO) +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Aeson (eitherDecode') +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Char (toLower) +import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as LText +import Data.Text.Lazy.Encoding qualified as LText +import Gogol.Prelude (Text) +import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager) +import Network.HTTP.Client qualified as Client +import Network.HTTP.Types (HeaderName) +import System.Environment (lookupEnv) + +-- | The @NO_GCE_CHECK@ environment variable. +checkGCEVar :: String +checkGCEVar = "NO_GCE_CHECK" + +-- | The @Metadata-Flavor@ header. +metadataFlavorHeader :: HeaderName +metadataFlavorHeader = "Metadata-Flavor" + +-- | The desired metadata flavor. +metadataFlavorDesired :: ByteString +metadataFlavorDesired = "Google" + +-- | Detect if the underlying host is running on GCE. +-- +-- The environment variable @NO_GCE_CHECK@ can be set to @1@, @true@, @yes@, or @on@ +-- to skip this check and always return @False@. +isGCE :: (MonadIO m) => Manager -> m Bool +isGCE m = liftIO $ do + p <- check <$> lookupEnv checkGCEVar + if p + then (success <$> Client.httpLbs rq m) `catch` failure + else pure False + where + check Nothing = True + check (Just x) = map toLower x `notElem` ["1", "true", "yes", "on"] + + success rs = + fromEnum (Client.responseStatus rs) == 200 + && ( lookup metadataFlavorHeader (Client.responseHeaders rs) + == Just metadataFlavorDesired + ) + + failure :: HttpException -> IO Bool + failure = const (pure False) + + rq = + metadataRequest + { Client.responseTimeout = Client.responseTimeoutMicro 1000000 + } + +-- | A directory of custom metadata values that have been set for this project. +getProjectAttribute :: (MonadIO m) => Text -> Manager -> m (Maybe LBS.ByteString) +getProjectAttribute k = + getMetadataMaybe ("project/attributes/" <> Text.encodeUtf8 k) + +-- | SSH keys that can connect to instances in the project. SSH keys for Compute +-- Engine use a specialized format where the keys are prepended with a username, +-- like so: @user1:ssh-rsa my-public-ssh-key user1@host.com@ +getSSHKeys :: (MonadIO m) => Manager -> m [Text] +getSSHKeys m = do + mx <- getMetadataMaybe "project/attributes/sshKeys" m + case mx of + Nothing -> pure [] + Just x -> + pure + . map LText.toStrict + . LText.split (== '\n') + $ LText.decodeUtf8 x + +-- | The numeric project ID of the instance, which is not the same as the project +-- name visible in the Google Developers Console. This value is different from +-- the project-id metadata entry value. The project-id value is required for all +-- requests to the Compute Engine service. +getNumericProjectId :: (MonadIO m) => Manager -> m Text +getNumericProjectId = getMetadataText "project/numeric-project-id" + +-- | The project ID. +getProjectId :: (MonadIO m) => Manager -> m Text +getProjectId = getMetadataText "project/project-id" + +-- | A directory of custom metadata values passed to the instance during startup +-- or shutdown. +getInstanceAttribute :: (MonadIO m) => Text -> Manager -> m (Maybe LBS.ByteString) +getInstanceAttribute k = + getMetadataMaybe ("instance/attributes/" <> Text.encodeUtf8 k) + +-- | The free-text description of an instance, assigned using the +-- @--description@ flag, or set in the API. +getDescription :: (MonadIO m) => Manager -> m Text +getDescription = getMetadataText "instance/description" + +-- | The host name of the instance. +getHostname :: (MonadIO m) => Manager -> m Text +getHostname = getMetadataText "instance/hostname" + +-- | The ID of the instance. This is a unique, numerical ID that is generated by +-- Google Compute Engine. This is useful for identifying instances if you do not +-- want to use instance names. +getInstanceId :: (MonadIO m) => Manager -> m Text +getInstanceId = getMetadataText "instance/id" + +-- | The fully-qualified machine type name of the instance's host machine. +getMachineType :: (MonadIO m) => Manager -> m Text +getMachineType = getMetadataText "instance/machine-type" + +-- | Any tags associated with the instance. +getTags :: (MonadIO m) => Manager -> m [Text] +getTags m = do + rs <- getMetadata "instance/tags" [] m + case eitherDecode' (Client.responseBody rs) of + Left _ -> pure [] + Right xs -> pure xs + +-- | The instance's zone. +getZone :: (MonadIO m) => Manager -> m Text +getZone = getMetadataText "instance/zone" + +-- -- | A directory of disks attached to this instance. +-- getDisk :: +-- "instance/disks/" + +-- -- | A directory of service accounts associated with the instance. +-- getServiceAccount +-- "instance/service-accounts/" + +-- -- | A directory of network interfaces for the instance. +-- getNetworkInterfaces +-- "instance/network-interfaces/" + +-- -- | A directory of any external IPs that are currently pointing to this virtual +-- -- machine instance, for the network interface at . Specifically, provides +-- -- a list of external IPs served by forwarding rules that direct packets to this +-- -- instance. +-- getForwardedIPs +-- "instance/network-interfaces//forwarded-ips/" + +-- -- | A directory with the scheduling options for the instance. +-- getScheduling +-- "instance/scheduling/" + +-- -- | The instance's transparent maintenance event behavior setting. This value is +-- -- set with the @--on_host_maintenance@ flag or via the API. +-- getOnHostMaintenance +-- "instance/scheduling/on-host-maintenance" + +-- -- | The instance's automatic restart setting. This value is set with the +-- -- @‑‑automatic_restart@ flag or via the API. +-- getAutomaticRestart +-- "instance/scheduling/automatic-restart" + +-- -- | The path that indicates that a transparent maintenance event is affecting this instance. +-- -- See Transparent maintenance notice for details. +-- getMaintenanceEvent +-- "instance/maintenance-event" + +-- Metadata wait for change +-- curl "http://metadata.google.internal/computeMetadata/v1/instance/tags?wait_for_change=true" + +getMetadataMaybe :: + (MonadIO m) => + ByteString -> + Manager -> + m (Maybe LBS.ByteString) +getMetadataMaybe path m = do + rs <- getMetadata path [404] m + if fromEnum (Client.responseStatus rs) == 404 + then pure Nothing + else pure $ Just (Client.responseBody rs) + +getMetadataText :: + (MonadIO m) => + ByteString -> + Manager -> + m Text +getMetadataText path m = + LText.toStrict . LText.decodeUtf8 . Client.responseBody + <$> getMetadata path [] m + +getMetadata :: + (MonadIO m) => + -- | The request path. + ByteString -> + -- | Acceptable status code responses. + [Int] -> + Manager -> + m (Client.Response LBS.ByteString) +getMetadata path statuses m = + liftIO . flip Client.httpLbs m $ + metadataRequest + { Client.path = "/computeMetadata/v1/" <> path, + Client.checkResponse = \rq rs -> + let c = fromEnum (Client.responseStatus rs) + in if 200 <= c && c < 300 && notElem c statuses + then return () + else do + bs <- Client.brReadSome (Client.responseBody rs) 4096 + throwIO . HttpExceptionRequest rq $ + StatusCodeException (() <$ rs) (LBS.toStrict bs) + } + +-- | A default @http-client@ 'Client.Request' with the host, port, and headers +-- set appropriately for @metadata.google.internal@ use. +metadataRequest :: Client.Request +metadataRequest = + Client.defaultRequest + { Client.host = "metadata.google.internal", + Client.port = 80, + Client.secure = False, + Client.method = "GET", + Client.requestHeaders = [(metadataFlavorHeader, metadataFlavorDesired)] + } diff --git a/src/Gogol/Env.hs b/src/Gogol/Env.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Env.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Gogol.Env +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Environment and Google specific configuration for the "Gogol" monad. +module Gogol.Env where + +import Control.Lens (Lens', lens, (<>~), (?~)) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Reader (MonadReader (local)) +import Data.Function (on) +import Data.Monoid (Dual (..), Endo (..)) +import Data.Proxy (Proxy (..)) +import GHC.TypeLits (Symbol) +import Gogol.Auth +import Gogol.Internal.Logger (Logger) +import Gogol.Types +import Network.HTTP.Conduit (Manager, newManager, tlsManagerSettings) + +-- | The environment containing the parameters required to make Google requests. +data Env (scopes :: [Symbol]) = Env + { _envOverride :: !(Dual (Endo ServiceConfig)), + _envLogger :: !Logger, + _envManager :: !Manager, + _envStore :: !(Store scopes) + } + +-- Note: The strictness annotations aobe are applied to ensure +-- total field initialisation. + +class HasEnv scopes a | a -> scopes where + environment :: Lens' a (Env scopes) + {-# MINIMAL environment #-} + + -- | The currently applied overrides to all 'Service' configuration. + envOverride :: Lens' a (Dual (Endo ServiceConfig)) + + -- | The function used to output log messages. + envLogger :: Lens' a Logger + + -- | The 'Manager' used to create and manage open HTTP connections. + envManager :: Lens' a Manager + + -- | The credential store used to sign requests for authentication with Google. + envStore :: Lens' a (Store scopes) + + -- | The authorised OAuth2 scopes. + -- + -- /See:/ 'allow', '!', and the related scopes available for each service. + envScopes :: Lens' a (Proxy scopes) + + envOverride = environment . lens _envOverride (\s a -> s {_envOverride = a}) + envLogger = environment . lens _envLogger (\s a -> s {_envLogger = a}) + envManager = environment . lens _envManager (\s a -> s {_envManager = a}) + envStore = environment . lens _envStore (\s a -> s {_envStore = a}) + envScopes = environment . lens (\_ -> Proxy :: Proxy scopes) (flip allow) + +instance HasEnv scopes (Env scopes) where + environment = id + +-- | Provide a function which will be added to the stack +-- of overrides, which are applied to all service configurations. +-- This provides a way to configure any request that is sent using the +-- modified 'Env'. +-- +-- /See:/ 'override'. +configure :: (HasEnv scopes a) => (ServiceConfig -> ServiceConfig) -> a -> a +configure f = envOverride <>~ Dual (Endo f) + +-- | Override a specific 'ServiceConfig'. All requests belonging to the +-- supplied service will use this configuration instead of the default. +-- +-- Typically you would override a modified version of the default 'ServiceConfig' +-- for the desired service: +-- +-- > override (gmailService & serviceHost .~ "localhost") env +-- +-- Or when using "Gogol" with "Control.Monad.Reader" or "Control.Lens.Zoom" +-- and the 'ServiceConfig' lenses: +-- +-- > local (override (computeService & serviceHost .~ "localhost")) $ do +-- > ... +-- +-- /See:/ 'configure'. +override :: (HasEnv scopes a) => ServiceConfig -> a -> a +override s = configure f + where + f x + | on (==) _svcId s x = s + | otherwise = x + +-- | Scope an action such that any HTTP response will use this timeout value. +-- +-- Default timeouts are chosen by considering: +-- +-- * This 'timeout', if set. +-- +-- * The related 'Service' timeout for the sent request if set. (Default 70s) +-- +-- * The 'envManager' timeout, if set. +-- +-- * The 'ClientRequest' timeout. (Default 30s) +timeout :: (MonadReader r m, HasEnv scopes r) => Seconds -> m a -> m a +timeout s = local (configure (serviceTimeout ?~ s)) + +-- | Creates a new environment with a newly initialized 'Manager', without logging. +-- and Credentials that are determined by calling 'getApplicationDefault'. +-- Use 'newEnvWith' to supply custom credentials such as an 'OAuthClient' +-- and 'OAuthCode'. +-- +-- The 'Allow'ed 'OAuthScope's are used to authorize any @service_account@ that is +-- found with the appropriate scopes. See the top-level module of each individual +-- @gogol-*@ library for a list of available scopes, such as +-- @Gogol.Compute.authComputeScope@. +-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'. +-- +-- /See:/ 'newEnvWith', 'getApplicationDefault'. +newEnv :: + forall scopes m. + ( MonadIO m, + MonadCatch m, + KnownScopes scopes + ) => + m (Env scopes) +newEnv = do + m <- liftIO (newManager tlsManagerSettings) + c <- getApplicationDefault m + newEnvWith c (\_ _ -> pure ()) m + +-- | Create a new environment. +-- +-- /See:/ 'newEnv'. +newEnvWith :: + forall scopes m. + ( MonadIO m, + MonadCatch m, + KnownScopes scopes + ) => + Credentials scopes -> + Logger -> + Manager -> + m (Env scopes) +newEnvWith c l m = + Env mempty l m <$> initStore c l m diff --git a/src/Gogol/Internal/Auth.hs b/src/Gogol/Internal/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Internal/Auth.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Gogol.Internal.Auth +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Internal types and helpers for constructing OAuth credentials. +module Gogol.Internal.Auth where + +import Control.Exception (Exception, SomeException, catch, throwIO) +import Control.Exception.Lens (exception) +import Control.Lens (Prism', prism) +import Control.Monad.IO.Class (MonadIO (..)) +import Crypto.PubKey.RSA.Types (PrivateKey) +import Data.Aeson +import Data.Aeson.Types (Pair) +import Data.ByteArray (ByteArray) +import Data.ByteArray.Encoding +import Data.ByteString.Builder () +import Data.ByteString.Lazy qualified as LBS +import Data.String (IsString) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time +import Data.X509 (PrivKey (..)) +import Data.X509.Memory (readKeyFileFromMemory) +import GHC.TypeLits (Symbol) +import Gogol.Internal.Logger +import Gogol.Prelude +import Network.HTTP.Conduit (HttpException, Manager) +import Network.HTTP.Conduit qualified as Client +import Network.HTTP.Types (Status, hContentType) + +-- | The supported credential mechanisms. +data Credentials (s :: [Symbol]) + = -- | Obtain and refresh access tokens from the underlying GCE host metadata + -- at @http:\/\/169.254.169.254@. + FromMetadata !ServiceId + | -- | Obtain and refresh access tokens using the specified client secret + -- and authorization code obtained from. + -- + -- See the + -- documentation for more information. + FromClient !OAuthClient !(OAuthCode s) + | -- | Use the specified @service_account@ and scopes to sign and request + -- an access token. The 'ServiceAccount' will also be used for subsequent + -- token refreshes. + -- + -- A 'ServiceAccount' is typically generated through the + -- Google Developer Console. + FromAccount !ServiceAccount + | -- | Use the specified @authorized_user@ to obtain and refresh access tokens. + -- + -- An 'AuthorizedUser' is typically created by the @gcloud init@ command + -- of the Google CloudSDK Tools. + FromUser !AuthorizedUser + | FromTokenFile !FilePath + +-- | Service Account credentials which are typically generated/download +-- from the Google Developer console of the following form: +-- +-- > { +-- > \"type\": \"service_account\", +-- > \"private_key_id\": \"303ad77e5efdf2ce952DFa\", +-- > \"private_key\": \"-----BEGIN PRIVATE KEY-----\n...\n\", +-- > \"client_email\": \"email@serviceaccount.com\", +-- > \"client_id\": \"035-2-310.useraccount.com\" +-- > } +-- +-- The private key is used to sign a JSON Web Token (JWT) of the +-- grant_type @urn:ietf:params:oauth:grant-type:jwt-bearer@, which is sent to +-- 'accountsURL' to obtain a valid 'OAuthToken'. This process requires explicitly +-- specifying which 'Scope's the resulting 'OAuthToken' is authorized to access. +-- +-- /See:/ . +data ServiceAccount = ServiceAccount + { _serviceId :: !ClientId, + _serviceEmail :: !Text, + _serviceKeyId :: !Text, + _servicePrivateKey :: !PrivateKey, + _serviceAccountUser :: !(Maybe Text) + } + deriving (Eq, Show) + +instance FromJSON ServiceAccount where + parseJSON = withObject "service_account" $ \o -> do + bs <- Text.encodeUtf8 <$> o .: "private_key" + k <- case listToMaybe (readKeyFileFromMemory bs) of + Just (PrivKeyRSA k) -> pure k + _ -> + fail "Unable to parse key contents from \"private_key\"" + ServiceAccount + <$> o .: "client_id" + <*> o .: "client_email" + <*> o .: "private_key_id" + <*> pure k + <*> pure Nothing + +-- | Authorized User credentials which are typically generated by the Cloud SDK +-- Tools such as @gcloud init@, of the following form: +-- +-- > { +-- > \"type\": \"authorized_user\", +-- > \"client_id\": \"32555940559.apps.googleusercontent.com\", +-- > \"client_secret\": \"Zms2qjJy2998hD4CTg2ejr2\", +-- > \"refresh_token\": \"1/B3gM1x35v.VtqffS1n5w-rSJ\" +-- > } +-- +-- The secret and refresh token are used to obtain a valid 'OAuthToken' from +-- 'accountsURL' using grant_type @refresh_token@. +data AuthorizedUser = AuthorizedUser + { _userId :: !ClientId, + _userRefresh :: !RefreshToken, + _userSecret :: !GSecret + } + deriving (Eq, Show) + +instance ToJSON AuthorizedUser where + toJSON (AuthorizedUser i r s) = + object + [ "client_id" .= i, + "refresh_token" .= r, + "client_secret" .= s + ] + +instance FromJSON AuthorizedUser where + parseJSON = withObject "authorized_user" $ \o -> + AuthorizedUser + <$> o .: "client_id" + <*> o .: "refresh_token" + <*> o .: "client_secret" + +-- | A client identifier and accompanying secret used to obtain/refresh a token. +data OAuthClient = OAuthClient + { _clientId :: !ClientId, + _clientSecret :: !GSecret + } + deriving (Eq, Show) + +-- | An OAuth bearer type token of the following form: +-- +-- > { +-- > \"token_type\": \"Bearer\", +-- > \"access_token\": \"eyJhbGci...\", +-- > \"refresh_token\": \"1/B3gq9K...\", +-- > \"expires_in\": 3600, +-- > ... +-- > } +-- +-- The '_tokenAccess' field will be inserted verbatim into the +-- @Authorization: Bearer ...@ header for all HTTP requests. +data OAuthToken (s :: [Symbol]) = OAuthToken + { _tokenAccess :: !AccessToken, + _tokenRefresh :: !(Maybe RefreshToken), + _tokenExpiry :: !UTCTime + } + deriving (Eq, Show) + +instance FromJSON (UTCTime -> OAuthToken s) where + parseJSON = withObject "bearer" $ \o -> do + t <- o .: "access_token" + r <- o .:? "refresh_token" + e <- o .: "expires_in" <&> fromInteger + pure (OAuthToken t r . addUTCTime e) + +-- | An OAuth client authorization code. +newtype OAuthCode (s :: [Symbol]) = OAuthCode Text + deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromJSON, ToJSON) + +instance ToHttpApiData (OAuthCode s) where + toQueryParam (OAuthCode c) = c + toHeader (OAuthCode c) = Text.encodeUtf8 c + +-- | An error thrown when attempting to read/write AuthN/AuthZ information. +data AuthError + = RetrievalError HttpException + | MissingFileError FilePath + | InvalidFileError FilePath Text + | TokenRefreshError Status Text (Maybe Text) + | FileExistError FilePath + deriving (Show, Typeable) + +instance Exception AuthError + +class AsAuthError a where + -- | A general authentication error. + _AuthError :: Prism' a AuthError + + {-# MINIMAL _AuthError #-} + + -- | An error occured while communicating over HTTP with either then + -- local metadata or remote accounts.google.com endpoints. + _RetrievalError :: Prism' a HttpException + + -- | The specified default credentials file could not be found. + _MissingFileError :: Prism' a FilePath + + -- | An error occured parsing the default credentials file. + _InvalidFileError :: Prism' a (FilePath, Text) + + -- | An error occured when attempting to refresh a token. + _TokenRefreshError :: Prism' a (Status, Text, Maybe Text) + + _RetrievalError = _AuthError . _RetrievalError + _MissingFileError = _AuthError . _MissingFileError + _InvalidFileError = _AuthError . _InvalidFileError + _TokenRefreshError = _AuthError . _TokenRefreshError + +instance AsAuthError SomeException where + _AuthError = exception + +instance AsAuthError AuthError where + _AuthError = id + + _RetrievalError = prism RetrievalError $ \case + RetrievalError e -> Right e + x -> Left x + + _MissingFileError = prism MissingFileError $ \case + MissingFileError f -> Right f + x -> Left x + + _InvalidFileError = + prism + (uncurry InvalidFileError) + ( \case + InvalidFileError f e -> Right (f, e) + x -> Left x + ) + + _TokenRefreshError = + prism + (\(s, e, d) -> TokenRefreshError s e d) + ( \case + TokenRefreshError s e d -> Right (s, e, d) + x -> Left x + ) + +data RefreshError = RefreshError + { _error :: !Text, + _description :: !(Maybe Text) + } + +instance FromJSON RefreshError where + parseJSON = withObject "refresh_error" $ \o -> + RefreshError + <$> o .: "error" + <*> o .:? "error_description" + +-- | @https://accounts.google.com/o/oauth2/v2/auth@. +accountsURL :: Text +accountsURL = "https://accounts.google.com/o/oauth2/v2/auth" + +accountsRequest :: Client.Request +accountsRequest = + Client.defaultRequest + { Client.host = "accounts.google.com", + Client.port = 443, + Client.secure = True, + Client.method = "POST", + Client.path = "/o/oauth2/v2/auth", + Client.requestHeaders = + [ (hContentType, "application/x-www-form-urlencoded") + ] + } + +-- | @https://www.googleapis.com/oauth2/v4/token@. +tokenURL :: Text +tokenURL = "https://www.googleapis.com/oauth2/v4/token" + +tokenRequest :: Client.Request +tokenRequest = + Client.defaultRequest + { Client.host = "www.googleapis.com", + Client.port = 443, + Client.secure = True, + Client.method = "POST", + Client.path = "/oauth2/v4/token", + Client.requestHeaders = + [ (hContentType, "application/x-www-form-urlencoded") + ] + } + +refreshRequest :: + (MonadIO m) => + Client.Request -> + Logger -> + Manager -> + m (OAuthToken s) +refreshRequest rq l m = do + logDebug l rq -- debug:ClientRequest + rs <- liftIO (Client.httpLbs rq m `catch` (throwIO . RetrievalError)) + + let bs = Client.responseBody rs + s = Client.responseStatus rs + + logDebug l rs -- debug:ClientResponse + logTrace l $ "[Response Body]\n" <> bs -- trace:ResponseBody + if fromEnum s == 200 + then success s bs + else failure s bs + where + success s bs = do + f <- parseErr s bs + ts <- liftIO getCurrentTime + pure (f ts) + + failure s bs = do + let e = "Failure refreshing token from " <> host <> path + logError l $ "[Refresh Error] " <> build e + case parseLBS bs of + Right x -> refreshErr s (_error x) (_description x) + Left _ -> refreshErr s e Nothing + + parseErr s bs = + case parseLBS bs of + Right !x -> pure x + Left e -> do + logError l $ + "[Parse Error] Failure parsing token refresh " <> build e + refreshErr s e Nothing + + refreshErr :: (MonadIO m) => Status -> Text -> Maybe Text -> m a + refreshErr s e = liftIO . throwIO . TokenRefreshError s e + + host = Text.decodeUtf8 (Client.host rq) + path = Text.decodeUtf8 (Client.path rq) + +parseLBS :: (FromJSON a) => LBS.ByteString -> Either Text a +parseLBS = either (Left . Text.pack) Right . eitherDecode' + +base64Encode :: [Pair] -> ByteString +base64Encode = base64 . LBS.toStrict . encode . object + +base64 :: (ByteArray a) => a -> ByteString +base64 = convertToBase Base64URLUnpadded + +textBody :: Text -> RequestBody +textBody = Client.RequestBodyBS . Text.encodeUtf8 diff --git a/src/Gogol/Internal/Body.hs b/src/Gogol/Internal/Body.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Internal/Body.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Gogol.Internal.Body +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Internal.Body where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Conduit.Binary (sourceFile) +import Data.Maybe (fromMaybe) +import Data.Text qualified as Text +import Gogol.Types (GBody (..)) +import Network.HTTP.Conduit (requestBodySource) +import Network.HTTP.Media (MediaType, parseAccept, (//)) +import Network.Mime qualified as MIME +import System.IO + +-- | Convenience function for obtaining the size of a file. +getFileSize :: (MonadIO m) => FilePath -> m Integer +getFileSize f = liftIO (withBinaryFile f ReadMode hFileSize) + +-- | Attempt to calculate the MIME type based on file extension. +-- +-- Defaults to @application/octet-stream@ if no file extension is recognised. +getMIMEType :: FilePath -> MediaType +getMIMEType = + fromMaybe ("application" // "octet-stream") + . parseAccept + . MIME.defaultMimeLookup + . Text.takeWhileEnd (/= '/') + . Text.pack + +-- | Construct a 'GBody' from a 'FilePath'. +-- +-- This uses 'getMIMEType' to calculate the MIME type from the file extension, +-- you can use 'bodyContentType' to set a MIME type explicitly. +sourceBody :: (MonadIO m) => FilePath -> m GBody +sourceBody f = do + n <- getFileSize f + pure $ + GBody + (getMIMEType f) + (requestBodySource (fromIntegral n) (sourceFile f)) diff --git a/src/Gogol/Internal/HTTP.hs b/src/Gogol/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Internal/HTTP.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Gogol.Internal.HTTP +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Internal.HTTP where + +import Control.Exception (Handler (..), catches, throwIO, toException) +import Control.Lens ((%~), (&)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Resource (MonadResource (..), transResourceT) +import Data.Monoid (Dual (..), Endo (..)) +import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as LText +import Data.Text.Lazy.Builder qualified as Build +import GHC.Exts (toList) +import Gogol.Auth (KnownScopes, authorize) +import Gogol.Env (Env (..)) +import Gogol.Internal.Logger (logDebug) +import Gogol.Internal.Multipart +import Gogol.Types +import Network.HTTP.Client.Conduit qualified as Client +import Network.HTTP.Conduit +import Network.HTTP.Media (RenderHeader (..)) +import Network.HTTP.Types + +-- FIXME: "mediaType" param also comes/calculated from the request body? +-- +-- Resumable endpoints - Not supported to begin with, need to figure +-- out how to return session id etc. +-- - Assume initially that every service supports multipart upload. +-- +-- "resumable" or "multipart" needs to go into the "uploadType" param + +unsafeRequest :: + ( MonadResource m, + GoogleRequest a, + KnownScopes scopes + ) => + Env scopes -> + a -> + m (Either Error (Rs a)) +unsafeRequest Env {..} x = + liftResourceT (transResourceT (`catches` handlers) go) + where + Request {..} = _cliRequest + + ServiceConfig {..} = _cliService + + GClient {..} = + requestClient x + & clientService %~ appEndo (getDual _envOverride) + + go = do + (ct, b) <- getContent _rqBody + rq <- authorize (request ct b) _envStore _envLogger _envManager + + logDebug _envLogger rq -- debug:ClientRequest + rs <- http rq _envManager + + logDebug _envLogger rs -- debug:ClientResponse + statusCheck rs + + r <- _cliResponse (responseBody rs) + + pure $! case r of + Right y -> Right y + Left (e, bs) -> + Left . SerializeError $ + SerializeError' + { _serializeId = _svcId, + _serializeHeaders = responseHeaders rs, + _serializeStatus = responseStatus rs, + _serializeMessage = e, + _serializeBody = Just bs + } + + request ct b = + Client.defaultRequest + { Client.host = _svcHost, + Client.port = _svcPort, + Client.secure = _svcSecure, + Client.responseTimeout = timeout, + Client.method = _cliMethod, + Client.path = path, + Client.queryString = renderQuery True (toList _rqQuery), + Client.requestHeaders = accept (ct (toList _rqHeaders)), + Client.requestBody = b + } + + accept + | Just t <- _cliAccept = ((hAccept, renderHeader t) :) + | otherwise = id + + path = + Text.encodeUtf8 + . LText.toStrict + $ Build.toLazyText (_svcPath <> _rqPath) + + statusCheck rs + | _cliCheck (responseStatus rs) = pure () + | otherwise = do + b <- sinkLBS (responseBody rs) + + liftIO . throwIO . toException . ServiceError $ + ServiceError' + { _serviceId = _svcId, + _serviceStatus = responseStatus rs, + _serviceHeaders = responseHeaders rs, + _serviceBody = Just b + } + + timeout = + maybe + Client.responseTimeoutNone + (Client.responseTimeoutMicro . microseconds) + _svcTimeout + + handlers = + [ Handler $ err, + Handler $ err . TransportError + ] + where + err e = return (Left e) + +getContent :: + (MonadIO m) => + [GBody] -> + m ([Header] -> [Header], RequestBody) +getContent [] = pure (id, mempty) +getContent [GBody t s] = pure (((hContentType, renderHeader t) :), s) +getContent bs = do + b <- genBoundary + pure + ( (multipartHeader b :), + renderParts b bs + ) diff --git a/src/Gogol/Internal/Logger.hs b/src/Gogol/Internal/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Internal/Logger.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Gogol.Internal.Logger +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Types and functions for constructing loggers and emitting log messages. +module Gogol.Internal.Logger + ( -- * Constructing a Logger + Logger, + newLogger, + + -- * Levels + LogLevel (..), + logError, + logInfo, + logDebug, + logTrace, + + -- * Building Messages + ToLog (..), + buildLines, + ) +where + +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString qualified as BS +import Data.ByteString.Builder (Builder) +import Data.ByteString.Builder qualified as Build +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.CaseInsensitive (CI) +import Data.CaseInsensitive qualified as CI +import Data.Int (Int16, Int8) +import Data.List (intersperse) +import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as LText +import Data.Text.Lazy.Encoding qualified as LText +import Data.Word (Word16) +import Gogol.Prelude hiding (Request) +import Network.HTTP.Conduit +import Network.HTTP.Types +import Numeric (showFFloat) +import System.IO + +-- | A function threaded through various request and serialisation routines +-- to log informational and debug messages. +type Logger = LogLevel -> Builder -> IO () + +data LogLevel + = -- | Info messages supplied by the user - this level is not emitted by the library. + Info + | -- | Error messages only. + Error + | -- | Useful debug information + info + error levels. + Debug + | -- | Includes potentially credentials metadata, and non-streaming response bodies. + Trace + deriving (Eq, Ord, Enum, Show) + +-- | This is a primitive logger which can be used to log builds to a 'Handle'. +-- +-- /Note:/ A more sophisticated logging library such as +-- or +-- +-- should be used in production code. +newLogger :: (MonadIO m) => LogLevel -> Handle -> m Logger +newLogger x hd = liftIO $ do + hSetBinaryMode hd True + hSetBuffering hd LineBuffering + return $ \y b -> + when (x >= y) $ + Build.hPutBuilder hd (b <> "\n") + +logError, + logInfo, + logDebug, + logTrace :: + (MonadIO m, ToLog a) => Logger -> a -> m () +logError f = liftIO . f Error . build +logInfo f = liftIO . f Info . build +logDebug f = liftIO . f Debug . build +logTrace f = liftIO . f Trace . build + +class ToLog a where + -- | Convert a value to a loggable builder. + build :: a -> Builder + +instance ToLog Builder where build = id + +instance ToLog LBS.ByteString where build = Build.lazyByteString + +instance ToLog ByteString where build = Build.byteString + +instance ToLog Int where build = Build.intDec + +instance ToLog Int8 where build = Build.int8Dec + +instance ToLog Int16 where build = Build.int16Dec + +instance ToLog Int32 where build = Build.int32Dec + +instance ToLog Int64 where build = Build.int64Dec + +instance ToLog Integer where build = Build.integerDec + +instance ToLog Word where build = Build.wordDec + +instance ToLog Word8 where build = Build.word8Dec + +instance ToLog Word16 where build = Build.word16Dec + +instance ToLog Word32 where build = Build.word32Dec + +instance ToLog Word64 where build = Build.word64Dec + +instance ToLog UTCTime where build = Build.stringUtf8 . show + +instance ToLog Float where build = build . ($ "") . showFFloat Nothing + +instance ToLog Double where build = build . ($ "") . showFFloat Nothing + +instance ToLog Text where build = build . Text.encodeUtf8 + +instance ToLog LText.Text where build = build . LText.encodeUtf8 + +instance ToLog Char where build = build . BS8.singleton + +instance ToLog [Char] where build = build . BS8.pack + +instance ToLog StdMethod where build = build . renderStdMethod + +-- | Intercalate a list of 'Builder's with newlines. +buildLines :: [Builder] -> Builder +buildLines = mconcat . intersperse "\n" + +instance (ToLog a) => ToLog (CI a) where + build = build . CI.foldedCase + +instance (ToLog a) => ToLog (Maybe a) where + build Nothing = "Nothing" + build (Just x) = "Just " <> build x + +instance ToLog Bool where + build True = "True" + build False = "False" + +instance ToLog Status where + build x = build (statusCode x) <> " " <> build (statusMessage x) + +instance ToLog [Header] where + build = + mconcat + . intersperse "; " + . map (\(k, v) -> build k <> ": " <> build v) + +instance ToLog HttpVersion where + build HttpVersion {..} = + "HTTP/" + <> build httpMajor + <> build '.' + <> build httpMinor + +instance ToLog RequestBody where + build = \case + RequestBodyBuilder n _ -> " build n <> ">" + RequestBodyStream n _ -> " build n <> ">" + RequestBodyLBS lbs + | n <= 4096 -> build lbs + | otherwise -> " build n <> ">" + where + n = LBS.length lbs + RequestBodyBS bs + | n <= 4096 -> build bs + | otherwise -> " build n <> ">" + where + n = BS.length bs + _ -> " " + +instance ToLog HttpException where + build x = "[HttpException] {\n" <> build (show x) <> "\n}" + +instance ToLog Request where + build x = + buildLines + [ "[Client Request] {", + " host = " <> build (host x) <> ":" <> build (port x), + " secure = " <> build (secure x), + " method = " <> build (method x), + " timeout = " <> build (show (responseTimeout x)), + " redirects = " <> build (redirectCount x), + " path = " <> build (path x), + " query = " <> build (queryString x), + " headers = " <> build (requestHeaders x), + " body = " <> build (requestBody x), + "}" + ] + +instance ToLog (Response a) where + build x = + buildLines + [ "[Client Response] {", + " status = " <> build (responseStatus x), + " headers = " <> build (responseHeaders x), + "}" + ] diff --git a/src/Gogol/Internal/Multipart.hs b/src/Gogol/Internal/Multipart.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Internal/Multipart.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Gogol.Internal.Multipart +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Internal.Multipart where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Builder.Extra (byteStringCopy) +import Gogol.Types (GBody (..)) +import Network.HTTP.Client +import Network.HTTP.Client.MultipartFormData (webkitBoundary) +import Network.HTTP.Media (RenderHeader (..)) +import Network.HTTP.Types (Header, hContentType) + +-- POST /upload/drive/v2/files?uploadType=multipart HTTP/1.1 +-- Host: www.googleapis.com +-- Authorization: Bearer your_auth_token +-- Content-Type: multipart/related; boundary="foo_bar_baz" +-- Content-Length: number_of_bytes_in_entire_request_body + +-- --foo_bar_baz +-- Content-Type: application/json; charset=UTF-8N +-- { +-- "title": "My File" +-- } +-- --foo_bar_baz +-- Content-Type: image/jpeg +-- JPEG data +-- --foo_bar_baz-- + +newtype Boundary = Boundary ByteString + +genBoundary :: (MonadIO m) => m Boundary +genBoundary = Boundary <$> liftIO webkitBoundary + +multipartHeader :: Boundary -> Header +multipartHeader (Boundary bs) = + ( hContentType, + "multipart/related; boundary=" <> bs + ) + +start :: Boundary -> RequestBody +start (Boundary bs) = copy "--" <> copy bs <> copy "\r\n" + +part :: Boundary -> RequestBody +part (Boundary bs) = copy "--" <> copy bs <> copy "--\r\n" + +copy :: ByteString -> RequestBody +copy bs = RequestBodyBuilder (fromIntegral (BS.length bs)) (byteStringCopy bs) + +renderParts :: Boundary -> [GBody] -> RequestBody +renderParts b = (<> part b) . foldMap go + where + go (GBody ct x) = + start b + <> copy "Content-Type: " + <> copy (renderHeader ct) + <> copy "\r\n\r\n" + <> x + <> copy "\r\n" diff --git a/src/Network/Google.hs b/src/Network/Google.hs deleted file mode 100644 --- a/src/Network/Google.hs +++ /dev/null @@ -1,445 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} - --- | --- Module : Network.Google --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- This module provides a 'Google' monad and common set of operations which --- can be performed against the remote Google Service APIs. Typically you will --- import this module along with modules from various @gogol-*@ libraries --- for the services you wish to communicate with. -module Network.Google - ( - -- * Usage - -- $usage - - -- * The Google Monad - Google (..) - , MonadGoogle (..) - , runGoogle - , runResourceT - - -- * Environment - , Env - , HasEnv (..) - - , newEnv - , newEnvWith - - -- ** Credentials - -- $credentials - - , getApplicationDefault - - -- ** Authorization - -- $authorization - - , (!) - , allow - - , AllowScopes - , type HasScope - - -- * Sending Requests - , send - - -- ** Streaming Media - , download - , upload - - , GBody (..) - , bodyContentType - - , sourceBody - , getMIMEType - - -- * Service Configuration - -- $configuration - - -- ** Overriding Defaults - , configure - , override - , timeout - - -- ** Lenses - , serviceHost - , servicePort - , servicePath - , serviceSecure - , serviceTimeout - - -- * Handling Errors - , AsError (..) - , AsAuthError (..) - - , trying - , catching - - -- * Logging - -- $logging - - , Logger - , LogLevel (..) - - -- ** Constructing a Logger - , newLogger - - -- * Constructing a HTTP Manager - , newManager - , tlsManagerSettings - - -- * Running Asynchronous Actions - -- $async - - -- * Compute Metadata - -- $metadata - - -- * Re-exported Types - , module Network.Google.Types - ) where - -import Control.Applicative -import Control.Exception.Lens -import Control.Monad -import Control.Monad.Catch -import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO)) -import Control.Monad.Reader -import Control.Monad.Trans.Except (ExceptT) -import Control.Monad.Trans.Identity (IdentityT) -import Control.Monad.Trans.List (ListT) -import Control.Monad.Trans.Maybe (MaybeT) -import Control.Monad.Trans.Resource - -import Network.Google.Auth -import Network.Google.Env -import Network.Google.Internal.Body -import Network.Google.Internal.HTTP -import Network.Google.Internal.Logger -import Network.Google.Prelude -import Network.Google.Types -import Network.HTTP.Conduit (newManager, tlsManagerSettings) - -import qualified Control.Monad.Writer.Lazy as LW -import qualified Control.Monad.Writer.Strict as W -import qualified Control.Monad.RWS.Lazy as LRW -import qualified Control.Monad.RWS.Strict as RW -import qualified Control.Monad.State.Lazy as LS -import qualified Control.Monad.State.Strict as S - --- | The 'Google' monad containing configuration environment and tracks --- resource allocation via 'ResourceT'. --- The functions in "Network.Google" are generalised -newtype Google s a = Google { unGoogle :: ReaderT (Env s) (ResourceT IO) a } - deriving - ( Functor - , Applicative - , Alternative - , Monad - , MonadPlus - , MonadIO - , MonadThrow - , MonadCatch - , MonadMask - , MonadReader (Env s) - , MonadResource - ) - --- | Run a 'Google' action using the specified environment and --- credentials annotated with sufficient authorization scopes. -runGoogle :: (MonadResource m, HasEnv s r) => r -> Google s a -> m a -runGoogle e m = liftResourceT $ runReaderT (unGoogle m) (e ^. environment) - --- | Monads in which 'Google' actions may be embedded. --- --- The functions in "Network.Google" have 'MonadGoogle' constraints to provide --- automatic lifting when embedding 'Google' as a layer inside your own --- application stack. -class ( Functor m - , Applicative m - , Monad m - , MonadIO m - , MonadCatch m - , AllowScopes s - ) => MonadGoogle s m | m -> s where - -- | Lift a computation to the 'Google' monad. - liftGoogle :: Google s a -> m a - -instance AllowScopes s => MonadGoogle s (Google s) where - liftGoogle = id - -instance MonadUnliftIO (Google s) where - withRunInIO inner = - Google $ withRunInIO $ \run -> - inner (run . unGoogle) - {-# INLINE withRunInIO #-} - -instance MonadGoogle s m => MonadGoogle s (IdentityT m) where - liftGoogle = lift . liftGoogle - -instance MonadGoogle s m => MonadGoogle s (ListT m) where - liftGoogle = lift . liftGoogle - -instance MonadGoogle s m => MonadGoogle s (MaybeT m) where - liftGoogle = lift . liftGoogle - -instance MonadGoogle s m => MonadGoogle s (ExceptT e m) where - liftGoogle = lift . liftGoogle - -instance MonadGoogle s m => MonadGoogle s (ReaderT r m) where - liftGoogle = lift . liftGoogle - -instance MonadGoogle s m => MonadGoogle s (S.StateT s' m) where - liftGoogle = lift . liftGoogle - -instance MonadGoogle s m => MonadGoogle s (LS.StateT s' m) where - liftGoogle = lift . liftGoogle - -instance (Monoid w, MonadGoogle s m) => MonadGoogle s (W.WriterT w m) where - liftGoogle = lift . liftGoogle - -instance (Monoid w, MonadGoogle s m) => MonadGoogle s (LW.WriterT w m) where - liftGoogle = lift . liftGoogle - -instance (Monoid w, MonadGoogle s m) => MonadGoogle s (RW.RWST r w s' m) where - liftGoogle = lift . liftGoogle - -instance (Monoid w, MonadGoogle s m) => MonadGoogle s (LRW.RWST r w s' m) where - liftGoogle = lift . liftGoogle - --- | Send a request, returning the associated response if successful. --- --- Throws 'Error'. -send :: (MonadGoogle s m, HasScope s a, GoogleRequest a) => a -> m (Rs a) -send x = liftGoogle $ do - e <- ask - r <- perform e x - hoistError r - --- | Send a request returning the associated streaming media response if successful. --- --- Some request data types have two possible responses, the JSON metadata and --- a streaming media response. Use 'send' to retrieve the metadata and 'download' --- to retrieve the streaming media. --- --- Equivalent to: --- --- @ --- 'send' . 'MediaDownload' --- @ --- --- Throws 'Error'. -download :: ( MonadGoogle s m - , HasScope s (MediaDownload a) - , GoogleRequest (MediaDownload a) - ) - => a - -> m (Rs (MediaDownload a)) -download = send . MediaDownload - --- | Send a request with an attached upload. --- --- Equivalent to: --- --- @ --- 'send' . 'MediaUpload' --- @ --- --- Throws 'Error'. -upload :: ( MonadGoogle s m - , HasScope s (MediaUpload a) - , GoogleRequest (MediaUpload a) - ) - => a - -> GBody - -> m (Rs (MediaUpload a)) -upload x = send . MediaUpload x - -hoistError :: MonadThrow m => Either Error a -> m a -hoistError = either (throwingM _Error) return - -{- $usage - -The request and response types provided by the various @gogol-*@ libraries can -be used with either 'send', 'upload', or 'download', depending upon the -request's purpose. Namely, 'send' is the function you will most commonly use to -send requests, with 'upload' and 'download' as convenience when dealing with -streaming requests and responses respectively. - -To get started we will need to specify our Google Service credentials and -create an 'Env' environment containing configuration which will be used by -'runGoogle' to perform any actions. Your Google 'Credentials' can be supplied -in a number of ways, by having Gogol retrieve - -for use on Google App Engine and Google Compute Engine, or by explicitly -supplying your credentials. See the <#credentials Credentials> section for -information about supported credential mechanisms. - -The following example demonstrates uploading a file to Google - using 'ObjectsInsert' from -: - -> import Control.Lens ((&), (.~), (<&>), (?~)) -> import Data.Text (Text) -> import Network.Google -> import Network.Google.Storage -> import System.IO (stdout) -> -> import qualified Data.Text as Text -> -> example :: IO Object -> example = do -> lgr <- newLogger Debug stdout -- (1) -> env <- newEnv <&> (envLogger .~ lgr) . (envScopes .~ storageReadWriteScope) -- (2) (3) -> body <- sourceBody "/path/to/image.jpg" -- (4) -> -> let key = "image.jpg" -> bkt = "my-storage-bucket" -> -> runResourceT . runGoogle env $ -- (5) -> upload (objectsInsert bkt object' & oiName ?~ key) body - -Breaking down the above example, we have the following points of interest: - -1. A new 'Logger' to replace the default noop logger is created, set to print - debug information and errors to 'stdout'. - -2. The 'Env' is created using 'newEnv'. This creates a new HTTP 'Manager' and - retrieves the application default 'Credentials'. - -3. The lenses 'envLogger' and 'envScopes' are used to set the newly created - 'Logger' and authorised OAuth2 scopes, respectively. Explicitly annotating the - 'Env' with the scopes ensures that any mismatch between the remote - operations performed in 'runGoogle' and the credential scopes are raised as - errors at compile time. - See the <#authorization Authorization> section for more information. - -4. The streaming 'body' for the object is retrieved from a 'FilePath', and the - MIME type is calculated from the file extension. - The MIME type is used as the object's @Content-Type@ in Cloud Storage, and - can be overriden using the 'bodyContentType' lens as follows: - - > import Network.HTTP.Media ((//)) - > - > body <- sourceBody f <&> bodyContentType .~ "application" // "json" - -5. Finally, we run the 'Google' computation using @'runResourceT' . 'runGoogle'@ - which serialises the 'ObjectsInsert' type to a HTTP request and sets the streaming 'Body'. - The resulting 'Object' metadata is then parsed from a successful HTTP response. -1 -Additional examples can be found can be found in the - project's -source control. - --} - -{- $authorization #authorization# -Each request within a particular 'runGoogle' context requires specific -OAuth2 scopes to be have been authorized for the given credentials. - -For example, the Google Storage 'ObjectsInsert' has the associated scopes of: - -> type Scopes ObjectsInsert = -> '["https://www.googleapis.com/auth/cloud-platform", -> "https://www.googleapis.com/auth/devstorage.full_control", -> "https://www.googleapis.com/auth/devstorage.read_write"] - -Multiple differing requests within a given 'runGoogle' context will then require -the credentials to have a minimal set of these associated request scopes. -This authorization information is represented as a type-level set, -the 's' type parameter of 'Google' and 'MonadGoogle'. A mismatch -of the sent request scopes and the 'Env' credential scopes results in a informative -compile error. - -You can use 'allow' or the 'envScopes' lens to specify the 'Env's set of scopes. -The various @gogol-*@ libraries export their individual scopes from @Network.Google.*" -and you can use the '(!)' combinator to combine these into a larger set. - -For example: - -> import Control.Lens ((<&>), (.~)) -> import Network.Google -> import Network.Google.Monitoring -> -> main :: IO () -> main = do -> env <- newEnv <&> envScopes .~ (monitoringReadScope ! monitoringWriteScope ! computeReadOnlyScope) -> ... - ->>> :type env -Env '["https://www.googleapis.com/auth/monitoring.read", "https://www.googleapis.com/auth/monitoring.write", "https://www.googleapis.com/auth/compute.readonly"] - --} - -{- $configuration -Each service has its own configuration such as host, port, path prefix, and timeout -which can be customized independent of other services. -It can be desirable to customize this when mocking service endpoints or adjusting -HTTP response timeouts for a specific request. - -For example, to point all calls to Google Compute to @https://localhost@ instead -of the actual remote endpoint, we can use @Control.Monad.Reader.local@ in conjunction -with 'override': - -> import Control.Lens ((&), (.~)) -> import Control.Monad.Reader (local) -> import Network.Google -> import Network.Google.Compute -> -> local (override (computeService & serviceHost .~ "localhost")) $ do -> _ <- send $ instancesGet "project" "zone" "instance-id" -> ... - --} - -{- $credentials #credentials# -By default 'newEnv' uses 'getApplicationDefault' to discover credentials -from the underlying, following Google's official library behaviour. -If you wish to manually specify 'Credentials' via 'newEnvWith', you can use one -of the following supported credential mechanisms: - -* "Network.Google.Auth.InstalledApplication" - Applications installed on devices. -* "Network.Google.Auth.ServiceAccount" - Applications deployed to custom environments. -* "Network.Google.Auth.ApplicationDefault" - Applications deployed to App Engine (GAE) or Compute Engine (GCE). - -See "Network.Google.Auth" for more information. --} - -{- $async -Requests can be sent asynchronously, but due to guarantees about resource closure -require the use of . --} - -{- $metadata - -Google Compute metadata can be retrieve when running on GCE instances. -See the documentation in "Network.Google.Compute.Metadata" for the available -functions. --} - -{- $logging -The exposed logging interface is a primitive 'Logger' function which gets -threaded through service calls and serialisation routines. This allows the -consuming library to output useful information and diagnostics. - -The 'newLogger' function can be used to construct a simple logger which writes -output to a 'Handle', but in most production code you should probably consider -using a more robust logging library such as - or -. --} diff --git a/src/Network/Google/Auth.hs b/src/Network/Google/Auth.hs deleted file mode 100644 --- a/src/Network/Google/Auth.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Network.Google.Auth --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Explicitly specify your Google credentials, or retrieve them --- from the underlying OS. -module Network.Google.Auth - ( - -- * Credentials - Credentials (..) - - -- ** Application Default Credentials - , getApplicationDefault - , fromWellKnownPath - , fromFilePath - , saveAuthorizedUserToWellKnownPath - , saveAuthorizedUser - - -- ** Service account user impersonation - , serviceAccountUser - - -- ** Installed Application Credentials - , installedApplication - , formURL - - -- ** Authorizing Requests - , authorize - - -- ** Thread-safe Storage - , Store - , initStore - , retrieveAuthFromStore - , retrieveTokenFromStore - - , Auth (..) - , authToAuthorizedUser - , exchange - , refresh - - -- ** Default Constants - , checkGCEVar - , cloudSDKConfigDir - , defaultCredentialsFile - - -- ** Handling Errors - , AsAuthError (..) - , AuthError (..) - - -- * OAuth Types - , OAuthClient (..) - , OAuthToken (..) - , OAuthCode (..) - , OAuthScope (..) - - -- * Re-exported Types - , AccessToken (..) - , RefreshToken (..) - , GSecret (..) - , ServiceId (..) - , ClientId (..) - - -- * Re-exported Modules - , module Network.Google.Auth.Scope - ) where - -import Control.Concurrent -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Time (getCurrentTime) -import GHC.TypeLits (Symbol) -import Network.Google.Auth.ApplicationDefault -import Network.Google.Auth.InstalledApplication -import Network.Google.Auth.Scope -import Network.Google.Auth.ServiceAccount -import Network.Google.Compute.Metadata (checkGCEVar) -import Network.Google.Internal.Auth -import Network.Google.Internal.Logger (Logger) -import Network.Google.Prelude -import Network.HTTP.Conduit (Manager) -import qualified Network.HTTP.Conduit as Client -import Network.HTTP.Types (hAuthorization) - --- | 'authToAuthorizedUser' converts 'Auth' into an 'AuthorizedUser' --- by returning 'Right' if there is a 'FromClient'-constructed --- Credentials and a refreshed token; otherwise, returning --- 'Left' with error message. -authToAuthorizedUser :: AllowScopes s => Auth s -> Either Text AuthorizedUser -authToAuthorizedUser a = AuthorizedUser - <$> (_clientId <$> getClient) - <*> maybe (Left "no refresh token") Right (_tokenRefresh (_token a)) - <*> (_clientSecret <$> getClient) - where getClient = case _credentials a of - FromClient c _ -> Right c - _ -> Left "not FromClient" - --- | An 'OAuthToken' that can potentially be expired, with the original --- credentials that can be used to perform a refresh. -data Auth (s :: [Symbol]) = Auth - { _credentials :: !(Credentials s) - , _token :: !(OAuthToken s) - } - --- | Check if the given token is still valid, ie. younger than the projected --- expiry time. --- --- This deliberately makes no external calls due to the absolute construction of --- the '_tokenExpiry' field, unlike the --- --- validation method. -validate :: MonadIO m => Auth s -> m Bool -validate a = (< _tokenExpiry (_token a)) <$> liftIO getCurrentTime - --- | Data store which ensures thread-safe access of credentials. -newtype Store (s :: [Symbol]) = Store (MVar (Auth s)) - --- | Construct storage containing the credentials which have not yet been --- exchanged or refreshed. -initStore :: (MonadIO m, MonadCatch m, AllowScopes s) - => Credentials s - -> Logger - -> Manager - -> m (Store s) -initStore c l m = exchange c l m >>= fmap Store . liftIO . newMVar - --- | Retrieve auth from storage -retrieveAuthFromStore - :: (MonadIO m, AllowScopes s) - => Store s - -> m (Auth s) -retrieveAuthFromStore (Store s) = - liftIO (readMVar s) - --- | Concurrently read the current token, and if expired, then --- safely perform a single serial refresh. -retrieveTokenFromStore - :: (MonadIO m, MonadCatch m, AllowScopes s) - => Store s - -> Logger - -> Manager - -> m (OAuthToken s) -retrieveTokenFromStore (Store s) l m = do - x <- liftIO (readMVar s) - mx <- validate x - if mx - then pure (_token x) - else liftIO . modifyMVar s $ \y -> do - my <- validate y - if my - then pure (y, _token y) - else do - z <- refresh y l m - pure (z, _token z) - --- | Perform the initial credentials exchange to obtain a valid 'OAuthToken' --- suitable for authorizing requests. -exchange :: forall m s. (MonadIO m, MonadCatch m, AllowScopes s) - => Credentials s - -> Logger - -> Manager - -> m (Auth s) -exchange c l = fmap (Auth c) . action l - where - action = case c of - FromMetadata s -> metadataToken s - FromAccount a -> serviceAccountToken a (Proxy :: Proxy s) - FromClient x n -> exchangeCode x n - FromUser u -> authorizedUserToken u Nothing - --- | Refresh an existing 'OAuthToken'. -refresh :: forall m s. (MonadIO m, MonadCatch m, AllowScopes s) - => Auth s - -> Logger - -> Manager - -> m (Auth s) -refresh (Auth c t) l = fmap (Auth c) . action l - where - action = case c of - FromMetadata s -> metadataToken s - FromAccount a -> serviceAccountToken a (Proxy :: Proxy s) - FromClient x _ -> refreshToken x t - FromUser u -> authorizedUserToken u (_tokenRefresh t) - --- | Apply the (by way of possible token refresh) a bearer token to the --- authentication header of a request. -authorize :: (MonadIO m, MonadCatch m, AllowScopes s) - => Client.Request - -> Store s - -> Logger - -> Manager - -> m Client.Request -authorize rq s l m = bearer <$> retrieveTokenFromStore s l m - where - bearer t = rq - { Client.requestHeaders = - ( hAuthorization - , "Bearer " <> toHeader (_tokenAccess t) - ) : Client.requestHeaders rq - } - --- | Set the user to be impersonated for a service account with domain --- wide delegation. See --- https://developers.google.com/identity/protocols/OAuth2ServiceAccount -serviceAccountUser :: forall s. (AllowScopes s) - => Maybe Text - -> Credentials s - -> Credentials s -serviceAccountUser u (FromAccount s) = FromAccount $ s { _serviceAccountUser = u } -serviceAccountUser _ c = c diff --git a/src/Network/Google/Auth/ApplicationDefault.hs b/src/Network/Google/Auth/ApplicationDefault.hs deleted file mode 100644 --- a/src/Network/Google/Auth/ApplicationDefault.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Network.Google.Auth.ApplicationDefaultCredentials --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Application Default Credentials are suited for cases when access to a Google service --- needs to have the same identity and authorization level for the application --- independent of the user. This is Google\'s the recommended approach to authorize --- calls to Google Cloud APIs, particularly when you're building an application --- that is deployed to Google App Engine or Google Compute Engine virtual machines. --- --- /See:/ . -module Network.Google.Auth.ApplicationDefault where - -import Control.Applicative -import Control.Exception.Lens (catching, throwingM) -import Control.Monad (unless, when) -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Aeson -import Data.Aeson.Types (parseEither) -import qualified Data.ByteString.Lazy as LBS -import Data.Maybe (maybe) -import qualified Data.Text as Text -import Network.Google.Compute.Metadata (isGCE) -import Network.Google.Internal.Auth - -import Network.HTTP.Conduit (Manager) -import System.Directory (doesFileExist, getHomeDirectory, createDirectoryIfMissing) -import System.Environment (lookupEnv) -import System.FilePath ((), takeDirectory) -import System.Info (os) - --- | The environment variable name which is used to specify the directory --- containing the @application_default_credentials.json@ generated by @gcloud init@. -cloudSDKConfigDir :: String -cloudSDKConfigDir = "CLOUDSDK_CONFIG" - --- | Return the filepath to the Cloud SDK well known file location such as --- @~\/.config\/gcloud\/application_default_credentials.json@. -cloudSDKConfigPath :: MonadIO m => m FilePath -cloudSDKConfigPath = do - m <- liftIO (lookupEnv cloudSDKConfigDir) - case m of - Just d -> pure $! d "application_default_credentials.json" - Nothing -> do - d <- getConfigDirectory - pure $! d "gcloud/application_default_credentials.json" - --- | The environment variable pointing the file with local --- Application Default Credentials. -defaultCredentialsFile :: String -defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS" - --- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the --- default application credentials filepath. -defaultCredentialsPath :: MonadIO m => m (Maybe FilePath) -defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile) - --- | Performs credentials discovery in the following order: --- --- 1. Read the default credentials from a file specified by --- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists. --- --- 2. Read the platform equivalent of @~\/.config\/gcloud\/application_default_credentials.json@ if it exists. --- The @~/.config@ component of the path can be overriden by the environment --- variable @CLOUDSDK_CONFIG@ if it exists. --- --- 3. Retrieve the default service account application credentials if --- running on GCE. The environment variable @NO_GCE_CHECK@ can be used to --- skip this check if set to a truthy value such as @1@ or @true@. --- --- The specified 'Scope's are used to authorize any @service_account@ that is --- found with the appropriate OAuth2 scopes, otherwise they are not used. See the --- top-level module of each individual @gogol-*@ library for a list of available --- scopes, such as @Network.Google.Compute.computeScope@. --- --- /See:/ -getApplicationDefault :: (MonadIO m, MonadCatch m) - => Manager - -> m (Credentials s) -getApplicationDefault m = - catching _MissingFileError fromWellKnownPath $ \f -> do - p <- isGCE m - unless p $ - throwingM _MissingFileError f - pure $! FromMetadata "default" - --- | Attempt to load either a @service_account@ or @authorized_user@ formatted --- file to obtain the credentials neccessary to perform a token refresh. --- --- The specified 'Scope's are used to authorize any @service_account@ that is --- found with the appropriate scopes, otherwise they are not used. See the --- top-level module of each individual @gogol-*@ library for a list of available --- scopes, such as @Network.Google.Compute.computeScope@. --- --- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'. -fromWellKnownPath :: (MonadIO m, MonadCatch m) => m (Credentials s) -fromWellKnownPath = do - f <- defaultCredentialsPath - case f of - Just x -> fromFilePath x - Nothing -> do - x <- cloudSDKConfigPath - fromFilePath x - --- | Attempt to load either a @service_account@ or @authorized_user@ formatted --- file to obtain the credentials neccessary to perform a token refresh from --- the specified file. --- --- The specified 'Scope's are used to authorize any @service_account@ that is --- found with the appropriate scopes, otherwise they are not used. See the --- top-level module of each individual @gogol-*@ library for a list of available --- scopes, such as @Network.Google.Compute.computeScope@. -fromFilePath :: (MonadIO m, MonadCatch m) => FilePath -> m (Credentials s) -fromFilePath f = do - p <- liftIO (doesFileExist f) - unless p $ - throwM (MissingFileError f) - bs <- liftIO (LBS.readFile f) - either (throwM . InvalidFileError f . Text.pack) pure - (fromJSONCredentials bs) - --- | Save 'AuthorizedUser' --- /See:/ 'cloudSDKConfigPath', 'defaultCredentialsPath'. -saveAuthorizedUserToWellKnownPath :: (MonadIO m, MonadCatch m) - => Bool -- ^ Force to save if True - -> AuthorizedUser - -> m () -saveAuthorizedUserToWellKnownPath b a = do - d <- defaultCredentialsPath - f <- maybe cloudSDKConfigPath pure d - liftIO $ createDirectoryIfMissing True $ takeDirectory f - saveAuthorizedUser f b a - --- | Save 'AuthorizedUser' -saveAuthorizedUser :: (MonadIO m, MonadCatch m) - => FilePath - -> Bool -- ^ Force to save if True - -> AuthorizedUser - -> m () -saveAuthorizedUser f b a = do - p <- liftIO (doesFileExist f) - when (p && not b) $ - throwM (FileExistError f) - liftIO (LBS.writeFile f $ encode a) - --- | Attempt to parse either a @service_account@ or @authorized_user@ formatted --- JSON value to obtain credentials. -fromJSONCredentials :: LBS.ByteString -> Either String (Credentials s) -fromJSONCredentials bs = do - v <- eitherDecode' bs - let x = FromAccount <$> parseEither parseJSON v - y = FromUser <$> parseEither parseJSON v - case (x, y) of - (Left xe, Left ye) -> Left $ - "Failed parsing service_account: " ++ xe ++ - ", Failed parsing authorized_user: " ++ ye - _ -> x <|> y - -getConfigDirectory :: MonadIO m => m FilePath -getConfigDirectory = do - h <- liftIO getHomeDirectory - if os == "windows" - then pure h - else pure $! h ".config" diff --git a/src/Network/Google/Auth/InstalledApplication.hs b/src/Network/Google/Auth/InstalledApplication.hs deleted file mode 100644 --- a/src/Network/Google/Auth/InstalledApplication.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DataKinds #-} - --- | --- Module : Network.Google.Auth.InstalledApplication --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Credentials for applications that are installed on devices such as --- computers, cell phones, or a tablet. Installed apps are distributed to --- individual machines, and it is assumed that these apps securely store secrets. --- --- These apps might access a Google service while the user is present at the --- application, or when the application is running in the background. --- --- /See:/ . -module Network.Google.Auth.InstalledApplication - ( installedApplication - - -- * Forming the URL - , AccessType (..) - , redirectURI - , formURL - , formAccessTypeURL - , formURLWith - , formAccessTypeURLWith - - -- * Internal Exchange and Refresh - , exchangeCode - , refreshToken - ) where - -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import GHC.TypeLits (Symbol) -import Network.Google.Auth.Scope (AllowScopes (..), - queryEncodeScopes) -import Network.Google.Internal.Auth -import Network.Google.Internal.Logger (Logger) -import Network.Google.Prelude -import Network.HTTP.Conduit (Manager) -import qualified Network.HTTP.Conduit as Client - --- | Create new Installed Application credentials. --- --- Since it is intended that the user opens the URL generated by 'formURL' in a browser --- and the resulting 'OAuthCode' is then received out-of-band, --- you must ensure that the scopes passed to 'formURL' and the type of 'OAuthCode' --- correctly match, otherwise an authorization error will occur. --- --- For example, doing this via 'getLine' and copy-paste: --- --- > {-# LANGUAGE ScopedTypeVariables #-} --- --- > import Data.Proxy (Proxy (..)) --- > import Data.Text as T --- > import Data.Text.IO as T --- > import System.Exit (exitFailure) --- > import System.Info (os) --- > import System.Process (rawSystem) --- --- > redirectPrompt :: AllowScopes (s :: [Symbol]) => OAuthClient -> proxy s -> IO (OAuthCode s) --- > redirectPrompt c p = do --- > let url = formURL c p --- > T.putStrLn $ "Opening URL " `T.append` url --- > _ <- case os of --- > "darwin" -> rawSystem "open" [unpack url] --- > "linux" -> rawSystem "xdg-open" [unpack url] --- > _ -> T.putStrLn "Unsupported OS" >> exitFailure --- > T.putStrLn "Please input the authorisation code: " --- > OAuthCode <$> T.getLine --- --- This ensures the scopes passed to 'formURL' and the type of 'OAuthCode' 's' --- are correct. -installedApplication :: OAuthClient -> OAuthCode s -> Credentials s -installedApplication = FromClient - --- /See:/ -data AccessType = Online | Offline deriving (Show, Eq) - --- | The redirection URI used in 'formURL': @urn:ietf:wg:oauth:2.0:oob@. -redirectURI :: Text -redirectURI = "urn:ietf:wg:oauth:2.0:oob" - --- | Given an 'OAuthClient' and a list of scopes to authorize, --- construct a URL that can be used to obtain the 'OAuthCode'. --- --- /See:/ . -formURL :: AllowScopes (s :: [Symbol]) => OAuthClient -> proxy s -> Text -formURL c = formURLWith c . allowScopes - --- | 'formURL' for 'AccessType' --- --- /See:/ 'formUrl'. -formAccessTypeURL :: AllowScopes (s :: [Symbol]) => OAuthClient -> AccessType -> proxy s -> Text -formAccessTypeURL c a = formAccessTypeURLWith c a . allowScopes - --- | Form a URL using 'OAuthScope' values. --- --- /See:/ 'formURL'. -formURLWith :: OAuthClient -> [OAuthScope] -> Text -formURLWith c ss = accountsURL - <> "?response_type=code" - <> "&client_id=" <> toQueryParam (_clientId c) - <> "&redirect_uri=" <> redirectURI - <> "&scope=" <> Text.decodeUtf8 (queryEncodeScopes ss) - --- | 'formURLWith' for 'AccessType' --- --- /See:/ 'formURLWith'. -formAccessTypeURLWith :: OAuthClient -> AccessType -> [OAuthScope] -> Text -formAccessTypeURLWith c a ss = formURLWith c ss - <> "&access_type=" <> (Text.toLower . Text.pack $ show a) - --- | Exchange 'OAuthClient' details and the received 'OAuthCode' for a new --- 'OAuthToken'. --- --- /See:/ . -exchangeCode :: (MonadIO m, MonadCatch m) - => OAuthClient - -> (OAuthCode s) - -> Logger - -> Manager - -> m (OAuthToken s) -exchangeCode c n = refreshRequest $ - tokenRequest - { Client.requestBody = textBody $ - "grant_type=authorization_code" - <> "&client_id=" <> toQueryParam (_clientId c) - <> "&client_secret=" <> toQueryParam (_clientSecret c) - <> "&code=" <> toQueryParam n - <> "&redirect_uri=" <> redirectURI - } - --- | Perform a refresh to obtain a valid 'OAuthToken' with a new expiry time. --- --- /See:/ . -refreshToken :: (MonadIO m, MonadCatch m) - => OAuthClient - -> (OAuthToken s) - -> Logger - -> Manager - -> m (OAuthToken s) -refreshToken c t = refreshRequest $ - tokenRequest - { Client.requestBody = textBody $ - "grant_type=refresh_token" - <> "&client_id=" <> toQueryParam (_clientId c) - <> "&client_secret=" <> toQueryParam (_clientSecret c) - <> maybe mempty ("&refresh_token=" <>) (toQueryParam <$> _tokenRefresh t) - } diff --git a/src/Network/Google/Auth/Scope.hs b/src/Network/Google/Auth/Scope.hs deleted file mode 100644 --- a/src/Network/Google/Auth/Scope.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Network.Google.Auth.Scope --- Copyright : (c) 2015 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Helpers for specifying and using 'Scope's with "Network.Google". -module Network.Google.Auth.Scope where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import Data.Coerce (coerce) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Type.Bool (type (||)) -import Data.Type.Equality (type (==)) -import Data.Typeable (Proxy (..)) -import GHC.Exts (Constraint) -import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -import Network.Google.Internal.Auth (Credentials) -import Network.Google.Prelude (GoogleRequest (..), - OAuthScope (..)) -import Network.HTTP.Types (urlEncode) - --- | Annotate credentials with the specified scopes. --- This exists to allow users to choose between using 'newEnv' --- with a 'Proxy' constructed by '!', or explicitly --- specifying scopes via a type annotation. --- --- /See:/ '!', 'envScopes', and the scopes available for each service. -allow :: proxy s -> k s -> k s -allow _ = id - --- | Annotate credentials with no scope authorization. -forbid :: k '[] -> k '[] -forbid = id - --- | Append two sets of scopes. --- --- /See:/ 'allow'. -(!) :: proxy xs -> proxy ys -> Proxy (Nub (xs ++ ys)) -(!) _ _ = Proxy - --- | Determine if _any_ of the scopes a request requires is --- listed in the scopes the credentials supports. --- --- For error message/presentation purposes, this wraps the result of --- the 'HasScope' membership check to show both lists of scopes before --- reduction. -type family HasScope (s :: [Symbol]) a :: Constraint where - HasScope s a = (s `HasScope'` Scopes a) ~ 'True - --- | Check if any of actual supplied scopes 's' exist in the required set 'a'. --- If the required set 'a' is empty, then succeed. -type family HasScope' s a where - HasScope' s '[] = 'True -- No scopes are required. - HasScope' (x ': xs) a = x ∈ a || HasScope' xs a - --- | Membership predicate. -type family (∈) a b where - (∈) x '[] = 'False - (∈) x (y ': xs) = x == y || x ∈ xs - --- | Append two lists. -type family (++) xs ys where - (++) xs '[] = xs - (++) '[] ys = ys - (++) (x ': xs) ys = x ': (xs ++ ys) - --- | Remove duplicates from a list. -type family Nub xs where - Nub '[] = '[] - Nub (x ': xs) = x ': Nub (Delete x xs) - --- | Remove a specific element from a list. -type family Delete x xs where - Delete x '[] = '[] - Delete x (x ': ys) = Delete x ys - Delete x (y ': ys) = y ': Delete x ys - -class AllowScopes a where - -- | Obtain a list of supported 'OAuthScope' values from a proxy. - allowScopes :: proxy a -> [OAuthScope] - -instance AllowScopes '[] where - allowScopes _ = [] - -instance (KnownSymbol x, AllowScopes xs) => AllowScopes (x ': xs) where - allowScopes _ = scope (Proxy :: Proxy x) : allowScopes (Proxy :: Proxy xs) - where - scope = OAuthScope . Text.pack . symbolVal - -instance AllowScopes s => AllowScopes (Credentials s) where - allowScopes _ = allowScopes (Proxy :: Proxy s) - --- | Concatenate a list of scopes using spaces. -concatScopes :: [OAuthScope] -> Text -concatScopes = Text.intercalate " " . coerce - --- | Encode a list of scopes suitable for embedding in a query string. -queryEncodeScopes :: [OAuthScope] -> ByteString -queryEncodeScopes = - BS8.intercalate "+" - . map (urlEncode True . Text.encodeUtf8) - . coerce diff --git a/src/Network/Google/Auth/ServiceAccount.hs b/src/Network/Google/Auth/ServiceAccount.hs deleted file mode 100644 --- a/src/Network/Google/Auth/ServiceAccount.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} - --- | --- Module : Network.Google.Auth.ServiceAccount --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Credentials for Server to Server communication, such as between a deployed web --- application and a Google service. --- --- Typically, an application uses a service account when the application uses --- Google services to work with its own data rather than a specific user's data. --- --- /See:/ . -module Network.Google.Auth.ServiceAccount where - -import Control.Monad.Catch -import Control.Monad.IO.Class -import Crypto.Hash.Algorithms (SHA256 (..)) -import Crypto.PubKey.RSA.PKCS15 (signSafer) -import Data.Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Time.Clock.POSIX -import Network.Google.Auth.Scope (AllowScopes (..), - concatScopes) -import Network.Google.Compute.Metadata -import Network.Google.Internal.Auth -import Network.Google.Internal.Logger -import Network.Google.Prelude hiding (buildText) -import Network.HTTP.Conduit hiding (Request) -import qualified Network.HTTP.Conduit as Client - --- | The maximum lifetime of a @service_account@ token which is 1 hour, in seconds. -maxTokenLifetime :: Seconds -maxTokenLifetime = 3600 - --- | Obtain an 'OAuthToken' from the local instace metadata --- using the specific 'ServiceId'. --- --- For example: @http:\/\/metadata.google.internal\/computeMetadata\/v1\/instance\/service-accounts\/default\/token@ --- will be retrieved if the given 'ServiceId' is @\"default\"@. -metadataToken :: (MonadIO m, MonadCatch m) - => ServiceId - -> Logger - -> Manager - -> m (OAuthToken s) -metadataToken s = refreshRequest $ - metadataRequest - { Client.path = "/computeMetadata/v1/instance/service-accounts/" - <> Text.encodeUtf8 (toQueryParam s) - <> "/token" - } - --- | Use the 'AuthorizedUser' to obtain a new 'OAuthToken'. If the supplied --- 'RefreshToken' is 'Nothing', the original 'RefreshToken' from the user will --- be used. -authorizedUserToken :: (MonadIO m, MonadCatch m) - => AuthorizedUser - -> Maybe RefreshToken - -> Logger - -> Manager - -> m (OAuthToken s) -authorizedUserToken u r = refreshRequest $ - tokenRequest - { Client.requestBody = textBody $ - "grant_type=refresh_token" - <> "&client_id=" <> toQueryParam (_userId u) - <> "&client_secret=" <> toQueryParam (_userSecret u) - <> "&refresh_token=" <> toQueryParam (fromMaybe (_userRefresh u) r) - } - --- | Obtain an 'OAuthToken' from @https://accounts.google.com/o/oauth2/v2/auth@ --- by signing and sending a JSON Web Token (JWT) using the supplied 'ServiceAccount'. -serviceAccountToken :: (MonadIO m, MonadCatch m, AllowScopes s) - => ServiceAccount - -> proxy s - -> Logger - -> Manager - -> m (OAuthToken s) -serviceAccountToken s p l m = do - b <- encodeBearerJWT s p - let rq = tokenRequest - { Client.requestBody = RequestBodyBS $ - "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer" - <> "&assertion=" - <> b - } - refreshRequest rq l m - --- | Encode the supplied 'ServiceAccount's key id, email, and scopes using the --- private key in the JSON Web Token (JWT) format. -encodeBearerJWT :: (MonadIO m, MonadThrow m, AllowScopes s) - => ServiceAccount - -> proxy s - -> m ByteString -encodeBearerJWT s p = liftIO $ do - i <- input . truncate <$> getPOSIXTime - r <- signSafer (Just SHA256) (_servicePrivateKey s) i - either failure (pure . concat' i) r - where - concat' i x = i <> "." <> signature (base64 x) - - failure e = throwM $ - TokenRefreshError (toEnum 400) (Text.pack (show e)) Nothing - - signature bs = - case BS8.unsnoc bs of - Nothing -> mempty - Just (bs', x) - | x == '=' -> bs' - | otherwise -> bs - - input n = header <> "." <> payload - where - header = base64Encode - [ "alg" .= ("RS256" :: Text) - , "typ" .= ("JWT" :: Text) - , "kid" .= _serviceKeyId s - ] - - payload = base64Encode $ - [ "aud" .= tokenURL - , "scope" .= concatScopes (allowScopes p) - , "iat" .= n - , "exp" .= (n + seconds maxTokenLifetime) - , "iss" .= _serviceEmail s - ] <> maybe [] (\sub -> ["sub" .= sub]) (_serviceAccountUser s) diff --git a/src/Network/Google/Compute/Metadata.hs b/src/Network/Google/Compute/Metadata.hs deleted file mode 100644 --- a/src/Network/Google/Compute/Metadata.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Network.Google.Compute.Metadata --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Google Compute Engine defines a set of default metadata entries that provide --- information about your instance or project. --- --- This module contains functions for retrieving various Compute metadata from an --- instance\'s local metadata endpoint using 'MonadIO', prior to initialisation --- of the environment used by the "Network.Google" monad. -module Network.Google.Compute.Metadata - ( - -- * Google Compute Instance Check - checkGCEVar - , isGCE - - -- * Retrieving Metadata - , getProjectAttribute - , getSSHKeys - , getNumericProjectId - , getProjectId - , getInstanceAttribute - , getDescription - , getHostname - , getInstanceId - , getMachineType - , getTags - , getZone - - -- * Raw Metadata Requests - , metadataFlavorHeader - , metadataFlavorDesired - , metadataRequest - , getMetadata - ) where - -import Control.Exception (throwIO) -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Aeson (eitherDecode') -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import Data.Char (toLower) -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Encoding as LText -import Network.Google.Prelude (Text, (<>)) -import Network.HTTP.Client (HttpException (..), - HttpExceptionContent (..), Manager) -import qualified Network.HTTP.Client as Client -import Network.HTTP.Types (HeaderName) -import System.Environment (lookupEnv) - --- | The @NO_GCE_CHECK@ environment variable. -checkGCEVar :: String -checkGCEVar = "NO_GCE_CHECK" - --- | The @Metadata-Flavor@ header. -metadataFlavorHeader :: HeaderName -metadataFlavorHeader = "Metadata-Flavor" - --- | The desired metadata flavor. -metadataFlavorDesired :: ByteString -metadataFlavorDesired = "Google" - --- | Detect if the underlying host is running on GCE. --- --- The environment variable @NO_GCE_CHECK@ can be set to @1@, @true@, @yes@, or @on@ --- to skip this check and always return @False@. -isGCE :: MonadIO m => Manager -> m Bool -isGCE m = liftIO $ do - p <- check <$> lookupEnv checkGCEVar - if p - then (success <$> Client.httpLbs rq m) `catch` failure - else pure False - where - check Nothing = True - check (Just x) = map toLower x `notElem` ["1", "true", "yes", "on"] - - success rs = - fromEnum (Client.responseStatus rs) == 200 - && (lookup metadataFlavorHeader (Client.responseHeaders rs) - == Just metadataFlavorDesired) - - failure :: HttpException -> IO Bool - failure = const (pure False) - - rq = metadataRequest - { Client.responseTimeout = Client.responseTimeoutMicro 1000000 - } - --- | A directory of custom metadata values that have been set for this project. -getProjectAttribute :: MonadIO m => Text -> Manager -> m (Maybe LBS.ByteString) -getProjectAttribute k = - getMetadataMaybe ("project/attributes/" <> Text.encodeUtf8 k) - --- | SSH keys that can connect to instances in the project. SSH keys for Compute --- Engine use a specialized format where the keys are prepended with a username, --- like so: @user1:ssh-rsa my-public-ssh-key user1@host.com@ -getSSHKeys :: MonadIO m => Manager -> m [Text] -getSSHKeys m = do - mx <- getMetadataMaybe "project/attributes/sshKeys" m - case mx of - Nothing -> pure [] - Just x -> pure - . map LText.toStrict - . LText.split (== '\n') - $ LText.decodeUtf8 x - --- | The numeric project ID of the instance, which is not the same as the project --- name visible in the Google Developers Console. This value is different from --- the project-id metadata entry value. The project-id value is required for all --- requests to the Compute Engine service. -getNumericProjectId :: MonadIO m => Manager -> m Text -getNumericProjectId = getMetadataText "project/numeric-project-id" - --- | The project ID. -getProjectId :: MonadIO m => Manager -> m Text -getProjectId = getMetadataText "project/project-id" - --- | A directory of custom metadata values passed to the instance during startup --- or shutdown. -getInstanceAttribute :: MonadIO m => Text -> Manager -> m (Maybe LBS.ByteString) -getInstanceAttribute k = - getMetadataMaybe ("instance/attributes/" <> Text.encodeUtf8 k) - --- | The free-text description of an instance, assigned using the --- @--description@ flag, or set in the API. -getDescription :: MonadIO m => Manager -> m Text -getDescription = getMetadataText "instance/description" - --- | The host name of the instance. -getHostname :: MonadIO m => Manager -> m Text -getHostname = getMetadataText "instance/hostname" - --- | The ID of the instance. This is a unique, numerical ID that is generated by --- Google Compute Engine. This is useful for identifying instances if you do not --- want to use instance names. -getInstanceId :: MonadIO m => Manager -> m Text -getInstanceId = getMetadataText "instance/id" - --- | The fully-qualified machine type name of the instance's host machine. -getMachineType :: MonadIO m => Manager -> m Text -getMachineType = getMetadataText "instance/machine-type" - --- | Any tags associated with the instance. -getTags :: MonadIO m => Manager -> m [Text] -getTags m = do - rs <- getMetadata "instance/tags" [] m - case eitherDecode' (Client.responseBody rs) of - Left _ -> pure [] - Right xs -> pure xs - --- | The instance's zone. -getZone :: MonadIO m => Manager -> m Text -getZone = getMetadataText "instance/zone" - --- -- | A directory of disks attached to this instance. --- getDisk :: --- "instance/disks/" - --- -- | A directory of service accounts associated with the instance. --- getServiceAccount --- "instance/service-accounts/" - --- -- | A directory of network interfaces for the instance. --- getNetworkInterfaces --- "instance/network-interfaces/" - --- -- | A directory of any external IPs that are currently pointing to this virtual --- -- machine instance, for the network interface at . Specifically, provides --- -- a list of external IPs served by forwarding rules that direct packets to this --- -- instance. --- getForwardedIPs --- "instance/network-interfaces//forwarded-ips/" - --- -- | A directory with the scheduling options for the instance. --- getScheduling --- "instance/scheduling/" - --- -- | The instance's transparent maintenance event behavior setting. This value is --- -- set with the @--on_host_maintenance@ flag or via the API. --- getOnHostMaintenance --- "instance/scheduling/on-host-maintenance" - --- -- | The instance's automatic restart setting. This value is set with the --- -- @‑‑automatic_restart@ flag or via the API. --- getAutomaticRestart --- "instance/scheduling/automatic-restart" - --- -- | The path that indicates that a transparent maintenance event is affecting this instance. --- -- See Transparent maintenance notice for details. --- getMaintenanceEvent --- "instance/maintenance-event" - --- Metadata wait for change --- curl "http://metadata.google.internal/computeMetadata/v1/instance/tags?wait_for_change=true" - -getMetadataMaybe :: MonadIO m - => ByteString - -> Manager - -> m (Maybe LBS.ByteString) -getMetadataMaybe path m = do - rs <- getMetadata path [404] m - if fromEnum (Client.responseStatus rs) == 404 - then pure Nothing - else pure $ Just (Client.responseBody rs) - -getMetadataText :: MonadIO m - => ByteString - -> Manager - -> m Text -getMetadataText path m = LText.toStrict . LText.decodeUtf8 . Client.responseBody - <$> getMetadata path [] m - -getMetadata :: MonadIO m - => ByteString -- ^ The request path. - -> [Int] -- ^ Acceptable status code responses. - -> Manager - -> m (Client.Response LBS.ByteString) -getMetadata path statuses m = - liftIO . flip Client.httpLbs m $ - metadataRequest - { Client.path = "/computeMetadata/v1/" <> path - , Client.checkResponse = \rq rs -> - let c = fromEnum (Client.responseStatus rs) - in if 200 <= c && c < 300 && notElem c statuses - then return () - else do - bs <- Client.brReadSome (Client.responseBody rs) 4096 - throwIO . HttpExceptionRequest rq $ - StatusCodeException (() <$ rs) (LBS.toStrict bs) - } - --- | A default @http-client@ 'Client.Request' with the host, port, and headers --- set appropriately for @metadata.google.internal@ use. -metadataRequest :: Client.Request -metadataRequest = Client.defaultRequest - { Client.host = "metadata.google.internal" - , Client.port = 80 - , Client.secure = False - , Client.method = "GET" - , Client.requestHeaders = [(metadataFlavorHeader, metadataFlavorDesired)] - } diff --git a/src/Network/Google/Env.hs b/src/Network/Google/Env.hs deleted file mode 100644 --- a/src/Network/Google/Env.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Network.Google.Env --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Environment and Google specific configuration for the "Network.Google" monad. -module Network.Google.Env where - -import Control.Lens (Lens', lens, (<>~), (?~)) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Reader (MonadReader (local)) -import Data.Function (on) -import Data.Monoid (Dual (..), Endo (..)) -import Data.Proxy (Proxy (..)) -import GHC.TypeLits (Symbol) -import Network.Google.Auth -import Network.Google.Internal.Logger (Logger) -import Network.Google.Types -import Network.HTTP.Conduit (Manager, newManager, tlsManagerSettings) - --- | The environment containing the parameters required to make Google requests. -data Env (s :: [Symbol]) = Env - { _envOverride :: !(Dual (Endo ServiceConfig)) - , _envLogger :: !Logger - , _envManager :: !Manager - , _envStore :: !(Store s) - } - --- Note: The strictness annotations aobe are applied to ensure --- total field initialisation. - -class HasEnv s a | a -> s where - environment :: Lens' a (Env s) - {-# MINIMAL environment #-} - - -- | The currently applied overrides to all 'Service' configuration. - envOverride :: Lens' a (Dual (Endo ServiceConfig)) - - -- | The function used to output log messages. - envLogger :: Lens' a Logger - - -- | The 'Manager' used to create and manage open HTTP connections. - envManager :: Lens' a Manager - - -- | The credential store used to sign requests for authentication with Google. - envStore :: Lens' a (Store s) - - -- | The authorised OAuth2 scopes. - -- - -- /See:/ 'allow', '!', and the related scopes available for each service. - envScopes :: Lens' a (Proxy s) - - envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a }) - envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a }) - envManager = environment . lens _envManager (\s a -> s { _envManager = a }) - envStore = environment . lens _envStore (\s a -> s { _envStore = a }) - envScopes = environment . lens (\_ -> Proxy :: Proxy s) (flip allow) - -instance HasEnv s (Env s) where - environment = id - --- | Provide a function which will be added to the stack --- of overrides, which are applied to all service configurations. --- This provides a way to configure any request that is sent using the --- modified 'Env'. --- --- /See:/ 'override'. -configure :: HasEnv s a => (ServiceConfig -> ServiceConfig) -> a -> a -configure f = envOverride <>~ Dual (Endo f) - --- | Override a specific 'ServiceConfig'. All requests belonging to the --- supplied service will use this configuration instead of the default. --- --- Typically you would override a modified version of the default 'ServiceConfig' --- for the desired service: --- --- > override (gmailService & serviceHost .~ "localhost") env --- --- Or when using "Network.Google" with "Control.Monad.Reader" or "Control.Lens.Zoom" --- and the 'ServiceConfig' lenses: --- --- > local (override (computeService & serviceHost .~ "localhost")) $ do --- > ... --- --- /See:/ 'configure'. -override :: HasEnv s a => ServiceConfig -> a -> a -override s = configure f - where - f x | on (==) _svcId s x = s - | otherwise = x - --- | Scope an action such that any HTTP response will use this timeout value. --- --- Default timeouts are chosen by considering: --- --- * This 'timeout', if set. --- --- * The related 'Service' timeout for the sent request if set. (Default 70s) --- --- * The 'envManager' timeout, if set. --- --- * The 'ClientRequest' timeout. (Default 30s) -timeout :: (MonadReader r m, HasEnv s r) => Seconds -> m a -> m a -timeout s = local (configure (serviceTimeout ?~ s)) - --- | Creates a new environment with a newly initialized 'Manager', without logging. --- and Credentials that are determined by calling 'getApplicationDefault'. --- Use 'newEnvWith' to supply custom credentials such as an 'OAuthClient' --- and 'OAuthCode'. --- --- The 'Allow'ed 'OAuthScope's are used to authorize any @service_account@ that is --- found with the appropriate scopes. See the top-level module of each individual --- @gogol-*@ library for a list of available scopes, such as --- @Network.Google.Compute.authComputeScope@. --- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'. --- --- /See:/ 'newEnvWith', 'getApplicationDefault'. -newEnv :: (MonadIO m, MonadCatch m, AllowScopes s) => m (Env s) -newEnv = do - m <- liftIO (newManager tlsManagerSettings) - c <- getApplicationDefault m - newEnvWith c (\_ _ -> pure ()) m - --- | Create a new environment. --- --- /See:/ 'newEnv'. -newEnvWith :: (MonadIO m, MonadCatch m, AllowScopes s) - => Credentials s - -> Logger - -> Manager - -> m (Env s) -newEnvWith c l m = Env mempty l m <$> initStore c l m diff --git a/src/Network/Google/Internal/Auth.hs b/src/Network/Google/Internal/Auth.hs deleted file mode 100644 --- a/src/Network/Google/Internal/Auth.hs +++ /dev/null @@ -1,345 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Network.Google.Internal.Auth --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Internal types and helpers for constructing OAuth credentials. -module Network.Google.Internal.Auth where - -import Control.Exception.Lens (exception) -import Control.Lens (Prism', prism, (<&>)) -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO (..)) -import Crypto.PubKey.RSA.Types (PrivateKey) -import Data.Aeson -import Data.Aeson.Types (Pair) -import Data.ByteArray (ByteArray) -import Data.ByteArray.Encoding -import Data.ByteString (ByteString) -import Data.ByteString.Builder () -import qualified Data.ByteString.Lazy as LBS -import Data.String (IsString) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Time -import Data.X509 (PrivKey (..)) -import Data.X509.Memory (readKeyFileFromMemory) -import GHC.TypeLits (Symbol) -import Network.Google.Internal.Logger -import Network.Google.Prelude -import Network.HTTP.Conduit (HttpException, Manager) -import qualified Network.HTTP.Conduit as Client -import Network.HTTP.Types (Status, hContentType) - --- | The supported credential mechanisms. -data Credentials (s :: [Symbol]) - = FromMetadata !ServiceId - -- ^ Obtain and refresh access tokens from the underlying GCE host metadata - -- at @http:\/\/169.254.169.254@. - - | FromClient !OAuthClient !(OAuthCode s) - -- ^ Obtain and refresh access tokens using the specified client secret - -- and authorization code obtained from. - -- - -- See the - -- documentation for more information. - - | FromAccount !ServiceAccount - -- ^ Use the specified @service_account@ and scopes to sign and request - -- an access token. The 'ServiceAccount' will also be used for subsequent - -- token refreshes. - -- - -- A 'ServiceAccount' is typically generated through the - -- Google Developer Console. - - | FromUser !AuthorizedUser - -- ^ Use the specified @authorized_user@ to obtain and refresh access tokens. - -- - -- An 'AuthorizedUser' is typically created by the @gcloud init@ command - -- of the Google CloudSDK Tools. - -{-| Service Account credentials which are typically generated/download -from the Google Developer console of the following form: - -> { -> \"type\": \"service_account\", -> \"private_key_id\": \"303ad77e5efdf2ce952DFa\", -> \"private_key\": \"-----BEGIN PRIVATE KEY-----\n...\n\", -> \"client_email\": \"email@serviceaccount.com\", -> \"client_id\": \"035-2-310.useraccount.com\" -> } - -The private key is used to sign a JSON Web Token (JWT) of the -grant_type @urn:ietf:params:oauth:grant-type:jwt-bearer@, which is sent to -'accountsURL' to obtain a valid 'OAuthToken'. This process requires explicitly -specifying which 'Scope's the resulting 'OAuthToken' is authorized to access. - -/See:/ . --} -data ServiceAccount = ServiceAccount - { _serviceId :: !ClientId - , _serviceEmail :: !Text - , _serviceKeyId :: !Text - , _servicePrivateKey :: !PrivateKey - , _serviceAccountUser :: !(Maybe Text) - } deriving (Eq, Show) - -instance FromJSON ServiceAccount where - parseJSON = withObject "service_account" $ \o -> do - bs <- Text.encodeUtf8 <$> o .: "private_key" - k <- case listToMaybe (readKeyFileFromMemory bs) of - Just (PrivKeyRSA k) -> pure k - _ -> - fail "Unable to parse key contents from \"private_key\"" - ServiceAccount - <$> o .: "client_id" - <*> o .: "client_email" - <*> o .: "private_key_id" - <*> pure k - <*> pure Nothing - -{-| Authorized User credentials which are typically generated by the Cloud SDK -Tools such as @gcloud init@, of the following form: - -> { -> \"type\": \"authorized_user\", -> \"client_id\": \"32555940559.apps.googleusercontent.com\", -> \"client_secret\": \"Zms2qjJy2998hD4CTg2ejr2\", -> \"refresh_token\": \"1/B3gM1x35v.VtqffS1n5w-rSJ\" -> } - -The secret and refresh token are used to obtain a valid 'OAuthToken' from -'accountsURL' using grant_type @refresh_token@. --} -data AuthorizedUser = AuthorizedUser - { _userId :: !ClientId - , _userRefresh :: !RefreshToken - , _userSecret :: !GSecret - } deriving (Eq, Show) - -instance ToJSON AuthorizedUser where - toJSON (AuthorizedUser i r s) = - object [ "client_id" .= i - , "refresh_token" .= r - , "client_secret" .= s - ] - -instance FromJSON AuthorizedUser where - parseJSON = withObject "authorized_user" $ \o -> AuthorizedUser - <$> o .: "client_id" - <*> o .: "refresh_token" - <*> o .: "client_secret" - --- | A client identifier and accompanying secret used to obtain/refresh a token. -data OAuthClient = OAuthClient - { _clientId :: !ClientId - , _clientSecret :: !GSecret - } deriving (Eq, Show) - -{-| An OAuth bearer type token of the following form: - -> { -> \"token_type\": \"Bearer\", -> \"access_token\": \"eyJhbGci...\", -> \"refresh_token\": \"1/B3gq9K...\", -> \"expires_in\": 3600, -> ... -> } - -The '_tokenAccess' field will be inserted verbatim into the -@Authorization: Bearer ...@ header for all HTTP requests. --} -data OAuthToken (s :: [Symbol]) = OAuthToken - { _tokenAccess :: !AccessToken - , _tokenRefresh :: !(Maybe RefreshToken) - , _tokenExpiry :: !UTCTime - } deriving (Eq, Show) - -instance FromJSON (UTCTime -> OAuthToken s) where - parseJSON = withObject "bearer" $ \o -> do - t <- o .: "access_token" - r <- o .:? "refresh_token" - e <- o .: "expires_in" <&> fromInteger - pure (OAuthToken t r . addUTCTime e) - --- | An OAuth client authorization code. -newtype OAuthCode (s :: [Symbol]) = OAuthCode Text - deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, FromJSON, ToJSON) - -instance ToHttpApiData (OAuthCode s) where - toQueryParam (OAuthCode c) = c - toHeader (OAuthCode c) = Text.encodeUtf8 c - --- | An error thrown when attempting to read/write AuthN/AuthZ information. -data AuthError - = RetrievalError HttpException - | MissingFileError FilePath - | InvalidFileError FilePath Text - | TokenRefreshError Status Text (Maybe Text) - | FileExistError FilePath - deriving (Show, Typeable) - -instance Exception AuthError - -class AsAuthError a where - -- | A general authentication error. - _AuthError :: Prism' a AuthError - {-# MINIMAL _AuthError #-} - - -- | An error occured while communicating over HTTP with either then - -- local metadata or remote accounts.google.com endpoints. - _RetrievalError :: Prism' a HttpException - - -- | The specified default credentials file could not be found. - _MissingFileError :: Prism' a FilePath - - -- | An error occured parsing the default credentials file. - _InvalidFileError :: Prism' a (FilePath, Text) - - -- | An error occured when attempting to refresh a token. - _TokenRefreshError :: Prism' a (Status, Text, Maybe Text) - - _RetrievalError = _AuthError . _RetrievalError - _MissingFileError = _AuthError . _MissingFileError - _InvalidFileError = _AuthError . _InvalidFileError - _TokenRefreshError = _AuthError . _TokenRefreshError - -instance AsAuthError SomeException where - _AuthError = exception - -instance AsAuthError AuthError where - _AuthError = id - - _RetrievalError = prism RetrievalError $ \case - RetrievalError e -> Right e - x -> Left x - - _MissingFileError = prism MissingFileError $ \case - MissingFileError f -> Right f - x -> Left x - - _InvalidFileError = prism - (uncurry InvalidFileError) - (\case - InvalidFileError f e -> Right (f, e) - x -> Left x) - - _TokenRefreshError = prism - (\(s, e, d) -> TokenRefreshError s e d) - (\case - TokenRefreshError s e d -> Right (s, e, d) - x -> Left x) - -data RefreshError = RefreshError - { _error :: !Text - , _description :: !(Maybe Text) - } - -instance FromJSON RefreshError where - parseJSON = withObject "refresh_error" $ \o -> RefreshError - <$> o .: "error" - <*> o .:? "error_description" - --- | @https://accounts.google.com/o/oauth2/v2/auth@. -accountsURL :: Text -accountsURL = "https://accounts.google.com/o/oauth2/v2/auth" - -accountsRequest :: Client.Request -accountsRequest = Client.defaultRequest - { Client.host = "accounts.google.com" - , Client.port = 443 - , Client.secure = True - , Client.method = "POST" - , Client.path = "/o/oauth2/v2/auth" - , Client.requestHeaders = - [ (hContentType, "application/x-www-form-urlencoded") - ] - } - --- | @https://www.googleapis.com/oauth2/v4/token@. -tokenURL :: Text -tokenURL = "https://www.googleapis.com/oauth2/v4/token" - -tokenRequest :: Client.Request -tokenRequest = Client.defaultRequest - { Client.host = "www.googleapis.com" - , Client.port = 443 - , Client.secure = True - , Client.method = "POST" - , Client.path = "/oauth2/v4/token" - , Client.requestHeaders = - [ (hContentType, "application/x-www-form-urlencoded") - ] - } - -refreshRequest :: (MonadIO m, MonadCatch m) - => Client.Request - -> Logger - -> Manager - -> m (OAuthToken s) -refreshRequest rq l m = do - logDebug l rq -- debug:ClientRequest - - rs <- liftIO (Client.httpLbs rq m) `catch` (throwM . RetrievalError) - - let bs = Client.responseBody rs - s = Client.responseStatus rs - - logDebug l rs -- debug:ClientResponse - logTrace l $ "[Response Body]\n" <> bs -- trace:ResponseBody - - if fromEnum s == 200 - then success s bs - else failure s bs - where - success s bs = do - f <- parseErr s bs - ts <- liftIO getCurrentTime - pure (f ts) - - failure s bs = do - let e = "Failure refreshing token from " <> host <> path - logError l $ "[Refresh Error] " <> build e - case parseLBS bs of - Right x -> refreshErr s (_error x) (_description x) - Left _ -> refreshErr s e Nothing - - parseErr s bs = - case parseLBS bs of - Right !x -> pure x - Left e -> do - logError l $ - "[Parse Error] Failure parsing token refresh " <> build e - refreshErr s e Nothing - - refreshErr :: MonadThrow m => Status -> Text -> Maybe Text -> m a - refreshErr s e = throwM . TokenRefreshError s e - - host = Text.decodeUtf8 (Client.host rq) - path = Text.decodeUtf8 (Client.path rq) - -parseLBS :: FromJSON a => LBS.ByteString -> Either Text a -parseLBS = either (Left . Text.pack) Right . eitherDecode' - -base64Encode :: [Pair] -> ByteString -base64Encode = base64 . LBS.toStrict . encode . object - -base64 :: ByteArray a => a -> ByteString -base64 = convertToBase Base64URLUnpadded - -textBody :: Text -> RequestBody -textBody = Client.RequestBodyBS . Text.encodeUtf8 diff --git a/src/Network/Google/Internal/Body.hs b/src/Network/Google/Internal/Body.hs deleted file mode 100644 --- a/src/Network/Google/Internal/Body.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Network.Google.Internal.Body --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.Google.Internal.Body where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Conduit.Binary (sourceFile) -import Data.Maybe (fromMaybe) -import qualified Data.Text as Text -import Network.Google.Types (GBody (..)) -import Network.HTTP.Conduit (requestBodySource) -import Network.HTTP.Media (MediaType, parseAccept, (//)) -import qualified Network.Mime as MIME -import System.IO - --- | Convenience function for obtaining the size of a file. -getFileSize :: MonadIO m => FilePath -> m Integer -getFileSize f = liftIO (withBinaryFile f ReadMode hFileSize) - --- | Attempt to calculate the MIME type based on file extension. --- --- Defaults to @application/octet-stream@ if no file extension is recognised. -getMIMEType :: FilePath -> MediaType -getMIMEType = - fromMaybe ("application" // "octet-stream") - . parseAccept - . MIME.defaultMimeLookup - . Text.takeWhileEnd (/= '/') - . Text.pack - --- | Construct a 'GBody' from a 'FilePath'. --- --- This uses 'getMIMEType' to calculate the MIME type from the file extension, --- you can use 'bodyContentType' to set a MIME type explicitly. -sourceBody :: MonadIO m => FilePath -> m GBody -sourceBody f = do - n <- getFileSize f - pure $ GBody - (getMIMEType f) - (requestBodySource (fromIntegral n) (sourceFile f)) diff --git a/src/Network/Google/Internal/HTTP.hs b/src/Network/Google/Internal/HTTP.hs deleted file mode 100644 --- a/src/Network/Google/Internal/HTTP.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Network.Google.Internal.HTTP --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.Google.Internal.HTTP where - -import Control.Lens ((%~), (&)) -import Control.Monad.Catch -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Resource (MonadResource (..)) - -import Data.Monoid (Dual (..), Endo (..), (<>)) - -import GHC.Exts (toList) - -import Network.Google.Auth (AllowScopes, authorize) -import Network.Google.Env (Env (..)) -import Network.Google.Internal.Logger (logDebug) -import Network.Google.Internal.Multipart -import Network.Google.Types -import Network.HTTP.Conduit -import Network.HTTP.Media (RenderHeader (..)) -import Network.HTTP.Types - -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Builder as Build -import qualified Network.HTTP.Client.Conduit as Client - --- FIXME: "mediaType" param also comes/calculated from the request body? --- --- Resumable endpoints - Not supported to begin with, need to figure --- out how to return session id etc. --- - Assume initially that every service supports multipart upload. --- --- "resumable" or "multipart" needs to go into the "uploadType" param - -perform :: (MonadCatch m, MonadResource m, AllowScopes s, GoogleRequest a) - => Env s - -> a - -> m (Either Error (Rs a)) -perform Env{..} x = catches go handlers - where - Request {..} = _cliRequest - ServiceConfig {..} = _cliService - GClient {..} = requestClient x - & clientService %~ appEndo (getDual _envOverride) - - go = liftResourceT $ do - (ct, b) <- getContent _rqBody - rq <- authorize (request ct b) _envStore _envLogger _envManager - - logDebug _envLogger rq -- debug:ClientRequest - - rs <- http rq _envManager - - logDebug _envLogger rs -- debug:ClientResponse - - statusCheck rs - - r <- _cliResponse (responseBody rs) - - pure $! case r of - Right y -> Right y - Left (e, bs) -> Left . SerializeError $ SerializeError' - { _serializeId = _svcId - , _serializeHeaders = responseHeaders rs - , _serializeStatus = responseStatus rs - , _serializeMessage = e - , _serializeBody = Just bs - } - - request ct b = Client.defaultRequest - { Client.host = _svcHost - , Client.port = _svcPort - , Client.secure = _svcSecure - , Client.responseTimeout = timeout - , Client.method = _cliMethod - , Client.path = path - , Client.queryString = renderQuery True (toList _rqQuery) - , Client.requestHeaders = accept (ct (toList _rqHeaders)) - , Client.requestBody = b - } - - accept - | Just t <- _cliAccept = ((hAccept, renderHeader t) :) - | otherwise = id - - path = Text.encodeUtf8 - . LText.toStrict - $ Build.toLazyText (_svcPath <> _rqPath) - - statusCheck rs - | _cliCheck (responseStatus rs) = pure () - | otherwise = do - b <- sinkLBS (responseBody rs) - throwM . toException . ServiceError $ ServiceError' - { _serviceId = _svcId - , _serviceStatus = responseStatus rs - , _serviceHeaders = responseHeaders rs - , _serviceBody = Just b - } - - timeout = - maybe Client.responseTimeoutNone - (Client.responseTimeoutMicro . microseconds) - _svcTimeout - - handlers = - [ Handler $ err - , Handler $ err . TransportError - ] - where - err e = return (Left e) - -getContent :: MonadIO m - => [GBody] - -> m ([Header] -> [Header], RequestBody) -getContent [] = pure (id, mempty) -getContent [GBody t s] = pure (((hContentType, renderHeader t) :), s) -getContent bs = do - b <- genBoundary - pure ( (multipartHeader b :) - , renderParts b bs - ) diff --git a/src/Network/Google/Internal/Logger.hs b/src/Network/Google/Internal/Logger.hs deleted file mode 100644 --- a/src/Network/Google/Internal/Logger.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | --- Module : Network.Google.Internal.Logger --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- --- Types and functions for constructing loggers and emitting log messages. -module Network.Google.Internal.Logger - ( - -- * Constructing a Logger - Logger - , newLogger - - -- * Levels - , LogLevel (..) - , logError - , logInfo - , logDebug - , logTrace - - -- * Building Messages - , ToLog (..) - , buildLines - ) where - -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Builder as Build -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.Int (Int16, Int8) -import Data.List (intersperse) -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Encoding as LText -import Data.Word (Word16) -import Network.Google.Prelude hiding (Request) -import Network.HTTP.Conduit -import Network.HTTP.Types -import Numeric (showFFloat) -import System.IO - --- | A function threaded through various request and serialisation routines --- to log informational and debug messages. -type Logger = LogLevel -> Builder -> IO () - -data LogLevel - = Info -- ^ Info messages supplied by the user - this level is not emitted by the library. - | Error -- ^ Error messages only. - | Debug -- ^ Useful debug information + info + error levels. - | Trace -- ^ Includes potentially credentials metadata, and non-streaming response bodies. - deriving (Eq, Ord, Enum, Show, Data, Typeable) - --- | This is a primitive logger which can be used to log builds to a 'Handle'. --- --- /Note:/ A more sophisticated logging library such as --- or --- --- should be used in production code. -newLogger :: MonadIO m => LogLevel -> Handle -> m Logger -newLogger x hd = liftIO $ do - hSetBinaryMode hd True - hSetBuffering hd LineBuffering - return $ \y b -> - when (x >= y) $ - Build.hPutBuilder hd (b <> "\n") - -logError, logInfo, logDebug, logTrace - :: (MonadIO m, ToLog a) => Logger -> a -> m () -logError f = liftIO . f Error . build -logInfo f = liftIO . f Info . build -logDebug f = liftIO . f Debug . build -logTrace f = liftIO . f Trace . build - -class ToLog a where - -- | Convert a value to a loggable builder. - build :: a -> Builder - -instance ToLog Builder where build = id -instance ToLog LBS.ByteString where build = Build.lazyByteString -instance ToLog ByteString where build = Build.byteString -instance ToLog Int where build = Build.intDec -instance ToLog Int8 where build = Build.int8Dec -instance ToLog Int16 where build = Build.int16Dec -instance ToLog Int32 where build = Build.int32Dec -instance ToLog Int64 where build = Build.int64Dec -instance ToLog Integer where build = Build.integerDec -instance ToLog Word where build = Build.wordDec -instance ToLog Word8 where build = Build.word8Dec -instance ToLog Word16 where build = Build.word16Dec -instance ToLog Word32 where build = Build.word32Dec -instance ToLog Word64 where build = Build.word64Dec -instance ToLog UTCTime where build = Build.stringUtf8 . show -instance ToLog Float where build = build . ($ "") . showFFloat Nothing -instance ToLog Double where build = build . ($ "") . showFFloat Nothing -instance ToLog Text where build = build . Text.encodeUtf8 -instance ToLog LText.Text where build = build . LText.encodeUtf8 -instance ToLog Char where build = build . BS8.singleton -instance ToLog [Char] where build = build . BS8.pack -instance ToLog StdMethod where build = build . renderStdMethod - --- | Intercalate a list of 'Builder's with newlines. -buildLines :: [Builder] -> Builder -buildLines = mconcat . intersperse "\n" - -instance ToLog a => ToLog (CI a) where - build = build . CI.foldedCase - -instance ToLog a => ToLog (Maybe a) where - build Nothing = "Nothing" - build (Just x) = "Just " <> build x - -instance ToLog Bool where - build True = "True" - build False = "False" - -instance ToLog Status where - build x = build (statusCode x) <> " " <> build (statusMessage x) - -instance ToLog [Header] where - build = mconcat - . intersperse "; " - . map (\(k, v) -> build k <> ": " <> build v) - -instance ToLog HttpVersion where - build HttpVersion{..} = - "HTTP/" - <> build httpMajor - <> build '.' - <> build httpMinor - -instance ToLog RequestBody where - build = \case - RequestBodyBuilder n _ -> " build n <> ">" - RequestBodyStream n _ -> " build n <> ">" - - RequestBodyLBS lbs - | n <= 4096 -> build lbs - | otherwise -> " build n <> ">" - where - n = LBS.length lbs - - RequestBodyBS bs - | n <= 4096 -> build bs - | otherwise -> " build n <> ">" - where - n = BS.length bs - - _ -> " " - -instance ToLog HttpException where - build x = "[HttpException] {\n" <> build (show x) <> "\n}" - -instance ToLog Request where - build x = buildLines - [ "[Client Request] {" - , " host = " <> build (host x) <> ":" <> build (port x) - , " secure = " <> build (secure x) - , " method = " <> build (method x) - , " timeout = " <> build (show (responseTimeout x)) - , " redirects = " <> build (redirectCount x) - , " path = " <> build (path x) - , " query = " <> build (queryString x) - , " headers = " <> build (requestHeaders x) - , " body = " <> build (requestBody x) - , "}" - ] - -instance ToLog (Response a) where - build x = buildLines - [ "[Client Response] {" - , " status = " <> build (responseStatus x) - , " headers = " <> build (responseHeaders x) - , "}" - ] diff --git a/src/Network/Google/Internal/Multipart.hs b/src/Network/Google/Internal/Multipart.hs deleted file mode 100644 --- a/src/Network/Google/Internal/Multipart.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- Module : Network.Google.Internal.Multipart --- Copyright : (c) 2015-2016 Brendan Hay --- License : Mozilla Public License, v. 2.0. --- Maintainer : Brendan Hay --- Stability : provisional --- Portability : non-portable (GHC extensions) --- -module Network.Google.Internal.Multipart where - -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder.Extra (byteStringCopy) -import Data.Monoid ((<>)) -import Network.Google.Types (GBody (..)) -import Network.HTTP.Client -import Network.HTTP.Client.MultipartFormData (webkitBoundary) -import Network.HTTP.Media (RenderHeader (..)) -import Network.HTTP.Types (Header, hContentType) - --- POST /upload/drive/v2/files?uploadType=multipart HTTP/1.1 --- Host: www.googleapis.com --- Authorization: Bearer your_auth_token --- Content-Type: multipart/related; boundary="foo_bar_baz" --- Content-Length: number_of_bytes_in_entire_request_body - --- --foo_bar_baz --- Content-Type: application/json; charset=UTF-8N --- { --- "title": "My File" --- } --- --foo_bar_baz --- Content-Type: image/jpeg --- JPEG data --- --foo_bar_baz-- - -newtype Boundary = Boundary ByteString - -genBoundary :: MonadIO m => m Boundary -genBoundary = Boundary <$> liftIO webkitBoundary - -multipartHeader :: Boundary -> Header -multipartHeader (Boundary bs) = - ( hContentType - , "multipart/related; boundary=" <> bs - ) - -start :: Boundary -> RequestBody -start (Boundary bs) = copy "--" <> copy bs <> copy "\r\n" - -part :: Boundary -> RequestBody -part (Boundary bs) = copy "--" <> copy bs <> copy "--\r\n" - -copy :: ByteString -> RequestBody -copy bs = RequestBodyBuilder (fromIntegral (BS.length bs)) (byteStringCopy bs) - -renderParts :: Boundary -> [GBody] -> RequestBody -renderParts b = (<> part b) . foldMap go - where - go (GBody ct x) = - start b - <> copy "Content-Type: " - <> copy (renderHeader ct) - <> copy "\r\n\r\n" - <> x - <> copy "\r\n"