gogol 0.5.0 → 1.0.0.0

raw patch · 29 files changed

+2703/−2497 lines, 29 filesdep +cryptondep +crypton-x509dep +crypton-x509-storedep −conduitdep −cryptonitedep −transformersdep ~aesondep ~basedep ~bytestringsetup-changed

Dependencies added: crypton, crypton-x509, crypton-x509-store

Dependencies removed: conduit, cryptonite, transformers, unliftio-core, unordered-containers, x509, x509-store

Dependency ranges changed: aeson, base, bytestring, case-insensitive, conduit-extra, directory, exceptions, filepath, gogol-core, http-media, http-types, lens, memory, mime-types, mtl, resourcet, text, time

Files

• Setup.hs +0/−2
• gogol.cabal +80/−76
• src/Gogol.hs +427/−0
• src/Gogol/Auth.hs +234/−0
• src/Gogol/Auth/ApplicationDefault.hs +180/−0
• src/Gogol/Auth/InstalledApplication.hs +178/−0
• src/Gogol/Auth/Scope.hs +171/−0
• src/Gogol/Auth/ServiceAccount.hs +158/−0
• src/Gogol/Auth/TokenFile.hs +34/−0
• src/Gogol/Compute/Metadata.hs +259/−0
• src/Gogol/Env.hs +156/−0
• src/Gogol/Internal/Auth.hs +352/−0
• src/Gogol/Internal/Body.hs +47/−0
• src/Gogol/Internal/HTTP.hs +146/−0
• src/Gogol/Internal/Logger.hs +214/−0
• src/Gogol/Internal/Multipart.hs +67/−0
• src/Network/Google.hs +0/−445
• src/Network/Google/Auth.hs +0/−217
• src/Network/Google/Auth/ApplicationDefault.hs +0/−172
• src/Network/Google/Auth/InstalledApplication.hs +0/−157
• src/Network/Google/Auth/Scope.hs +0/−116
• src/Network/Google/Auth/ServiceAccount.hs +0/−134
• src/Network/Google/Compute/Metadata.hs +0/−250
• src/Network/Google/Env.hs +0/−143
• src/Network/Google/Internal/Auth.hs +0/−345
• src/Network/Google/Internal/Body.hs +0/−47
• src/Network/Google/Internal/HTTP.hs +0/−136
• src/Network/Google/Internal/Logger.hs +0/−188
• src/Network/Google/Internal/Multipart.hs +0/−69

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

@@ -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 <brendan.g.hay@gmail.com>-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 <brendan.g.hay+gogol@gmail.com>, Toni Cebrián <toni@tonicebrian.com> +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 <http://hackage.haskell.org/packages/#cat:Google Google>-    category on Hackage for supported services.-    .-    To get started, import the desired @gogol-*@ library (such as-    <http://hackage.haskell.org/package/gogol-gmail/docs/Network-Google-Gmail.html Network.Google.Gmail>)-    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 <http://hackage.haskell.org/packages/#cat:Google Google>+  category on Hackage for supported services.+  .+  To get started, import the desired @gogol-*@ library (such as+  <http://hackage.haskell.org/package/gogol-gmail/docs/Gogol-Gmail.html Gogol.Gmail>)+  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

@@ -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 <brendan.g.hay@gmail.com>+-- 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 <https://tools.ietf.org/html/rfc2387 multipart/related media> 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 <https://tools.ietf.org/html/rfc2387 multipart/related media> 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+-- <https://developers.google.com/identity/protocols/application-default-credentials Application Default Credentials>+-- 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+-- <https://cloud.google.com/storage/ Cloud Storage> using 'ObjectsInsert' from+-- <http://hackage.haskell.org/package/gogol-storage gogol-storage>:+--+--+-- > {-# 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+-- <https://github.com/brendanhay/gogol/tree/develop/examples Gogol> 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 <http://hackage.haskell.org/package/lifted-async lifted-async>.++-- $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+-- <http://hackage.haskell.org/package/tinylog tinylog> or+-- <http://hackage.haskell.org/package/fast-logger fast-logger>.

@@ -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 <brendan.g.hay@gmail.com>+-- 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+-- <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken documented>+-- 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

@@ -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 <brendan.g.hay@gmail.com>+-- 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:/ <https://developers.google.com/identity/protocols/application-default-credentials Application Default Documentation>.+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:/ <https://developers.google.com/identity/protocols/application-default-credentials Application Default Credentials>+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"

@@ -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 <brendan.g.hay@gmail.com>+-- 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:/ <https://developers.google.com/identity/protocols/OAuth2InstalledApp Installed Application Documentation>.+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:/ <https://developers.google.com/identity/protocols/OAuth2WebServer#offline>+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:/ <https://developers.google.com/accounts/docs/OAuth2InstalledApp#formingtheurl Forming the URL>.+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:/ <https://developers.google.com/accounts/docs/OAuth2InstalledApp#handlingtheresponse Exchanging the code>.+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:/ <https://developers.google.com/accounts/docs/OAuth2InstalledApp#offline Refreshing tokens>.+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)+      }

@@ -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 <brendan.g.hay@gmail.com>+-- 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

@@ -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 <brendan.g.hay@gmail.com>+-- 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:/ <https://developers.google.com/identity/protocols/OAuth2ServiceAccount Service Account Documentation>.+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)

@@ -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 <brendan.g.hay@gmail.com>+-- 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+        }

@@ -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 <brendan.g.hay@gmail.com>+-- 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 <index>. Specifically, provides+-- -- a list of external IPs served by forwarding rules that direct packets to this+-- -- instance.+-- getForwardedIPs+-- "instance/network-interfaces/<index>/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)]+    }

@@ -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 <brendan.g.hay@gmail.com>+-- 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

@@ -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 <brendan.g.hay@gmail.com>+-- 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 <https://developers.google.com/accounts/docs/OAuth2InstalledApp OAuth2 Installed Application>+    -- 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:/ <https://developers.google.com/identity/protocols/OAuth2ServiceAccount#delegatingauthority Delegating authority to your service account>.+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

@@ -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 <brendan.g.hay@gmail.com>+-- 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))

@@ -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 <brendan.g.hay@gmail.com>+-- 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+    )

@@ -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 <brendan.g.hay@gmail.com>+-- 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+-- <http://hackage.haskell.org/package/tinylog tinylog> or+-- <http://hackage.haskell.org/package/FastLogger fast-logger>+-- 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 _ -> " <msger:" <> build n <> ">"+    RequestBodyStream n _ -> " <stream:" <> build n <> ">"+    RequestBodyLBS lbs+      | n <= 4096 -> build lbs+      | otherwise -> " <lazy:" <> build n <> ">"+      where+        n = LBS.length lbs+    RequestBodyBS bs+      | n <= 4096 -> build bs+      | otherwise -> " <strict:" <> build n <> ">"+      where+        n = BS.length bs+    _ -> " <chunked>"++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),+        "}"+      ]

@@ -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 <brendan.g.hay@gmail.com>+-- 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"

@@ -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 <brendan.g.hay@gmail.com>--- 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 <https://tools.ietf.org/html/rfc2387 multipart/related media> 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-<https://developers.google.com/identity/protocols/application-default-credentials Application Default Credentials>-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-<https://cloud.google.com/storage/ Cloud Storage> using 'ObjectsInsert' from-<http://hackage.haskell.org/package/gogol-storage gogol-storage>:--> 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-<https://github.com/brendanhay/gogol/tree/develop/examples Gogol> 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 <http://hackage.haskell.org/package/lifted-async lifted-async>.--}--{- $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-<http://hackage.haskell.org/package/tinylog tinylog> or-<http://hackage.haskell.org/package/fast-logger fast-logger>.--}

@@ -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 <brendan.g.hay@gmail.com>--- 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--- <https://developers.google.com/accounts/docs/OAuth2Login#validatingtoken documented>--- 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

@@ -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 <brendan.g.hay@gmail.com>--- 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:/ <https://developers.google.com/identity/protocols/application-default-credentials Application Default Documentation>.-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:/ <https://developers.google.com/identity/protocols/application-default-credentials Application Default Credentials>-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"

@@ -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 <brendan.g.hay@gmail.com>--- 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:/ <https://developers.google.com/identity/protocols/OAuth2InstalledApp Installed Application Documentation>.-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:/ <https://developers.google.com/identity/protocols/OAuth2WebServer#offline>-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:/ <https://developers.google.com/accounts/docs/OAuth2InstalledApp#formingtheurl Forming the URL>.-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:/ <https://developers.google.com/accounts/docs/OAuth2InstalledApp#handlingtheresponse Exchanging the code>.-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:/ <https://developers.google.com/accounts/docs/OAuth2InstalledApp#offline Refreshing tokens>.-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)-        }

@@ -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 <brendan.g.hay@gmail.com>--- 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

@@ -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 <brendan.g.hay@gmail.com>--- 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:/ <https://developers.google.com/identity/protocols/OAuth2ServiceAccount Service Account Documentation>.-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)

@@ -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 <brendan.g.hay@gmail.com>--- 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 <index>. Specifically, provides--- -- a list of external IPs served by forwarding rules that direct packets to this--- -- instance.--- getForwardedIPs--- "instance/network-interfaces/<index>/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)]-    }

@@ -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 <brendan.g.hay@gmail.com>--- 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

@@ -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 <brendan.g.hay@gmail.com>--- 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 <https://developers.google.com/accounts/docs/OAuth2InstalledApp OAuth2 Installed Application>-      -- 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:/ <https://developers.google.com/identity/protocols/OAuth2ServiceAccount#delegatingauthority Delegating authority to your service account>.--}-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

@@ -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 <brendan.g.hay@gmail.com>--- 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))

@@ -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 <brendan.g.hay@gmail.com>--- 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-         )

@@ -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 <brendan.g.hay@gmail.com>--- 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--- <http://hackage.haskell.org/package/tinylog tinylog> or--- <http://hackage.haskell.org/package/FastLogger fast-logger>--- 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 _ -> " <msger:"   <> build n <> ">"-        RequestBodyStream      n _ -> " <stream:"  <> build n <> ">"--        RequestBodyLBS lbs-            | n <= 4096            -> build lbs-            | otherwise            -> " <lazy:" <> build n <> ">"-          where-            n = LBS.length lbs--        RequestBodyBS bs-            | n <= 4096            -> build bs-            | otherwise            -> " <strict:" <> build n <> ">"-          where-            n = BS.length bs--        _                          -> " <chunked>"--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)-        , "}"-        ]

@@ -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 <brendan.g.hay@gmail.com>--- 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"