gogol (empty) → 0.0.1
raw patch · 12 files changed
+2014/−0 lines, 12 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, case-insensitive, cryptonite, data-default-class, directory, exceptions, filepath, gogol-core, http-client, http-conduit, http-media, http-types, lens, memory, monad-control, mtl, resourcet, text, time, transformers, transformers-base, unordered-containers, x509, x509-store
Files
- CHANGELOG.md +1/−0
- LICENSE +367/−0
- README.md +20/−0
- Setup.hs +2/−0
- gogol.cabal +78/−0
- src/Network/Google.hs +226/−0
- src/Network/Google/Auth.hs +555/−0
- src/Network/Google/Compute/Metadata.hs +245/−0
- src/Network/Google/Env.hs +116/−0
- src/Network/Google/Internal/HTTP.hs +129/−0
- src/Network/Google/Internal/Logger.hs +200/−0
- src/Network/Google/Internal/Multipart.hs +75/−0
+ CHANGELOG.md view
@@ -0,0 +1,1 @@+# Change Log
+ LICENSE view
@@ -0,0 +1,367 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.
+ README.md view
@@ -0,0 +1,20 @@+# Gogol++* [Description](#description)+* [Contribute](#contribute)+* [Licence](#licence)+++## Description++> TODO+++## Contribute++For any problems, comments, or feedback please create an issue [here on GitHub](https://github.com/brendanhay/gogol/issues).+++## Licence++Gogol is released under the [Mozilla Public License Version 2.0](http://www.mozilla.org/MPL/).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gogol.cabal view
@@ -0,0 +1,78 @@+name: gogol+version: 0.0.1+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 Brendan Hay+category: Network, Google, Cloud+build-type: Simple+extra-source-files: README.md CHANGELOG.md+cabal-version: >= 1.10++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.++source-repository head+ type: git+ location: git://github.com/brendanhay/gogol.git++library+ default-language: Haskell2010+ hs-source-dirs: src++ ghc-options: -Wall++ exposed-modules:+ Network.Google+ , Network.Google.Auth+ , Network.Google.Compute.Metadata+ , Network.Google.Env++ other-modules:+ Network.Google.Internal.HTTP+ , Network.Google.Internal.Logger+ , Network.Google.Internal.Multipart++ build-depends:+ aeson >= 0.8+ , base >= 4.7 && < 5+ , bytestring >= 0.9+ , case-insensitive >= 1.2+ , cryptonite >= 0.6+ , data-default-class >= 0.0.1+ , directory >= 1.2+ , exceptions >= 0.6+ , filepath >= 1.2+ , gogol-core == 0.0.1.*+ , http-client >= 0.4.4+ , http-conduit >= 2.1.4+ , http-media >= 0.6+ , http-types >= 0.8.6+ , lens >= 4.4+ , memory >= 0.8+ , monad-control >= 1+ , mtl >= 2.1.3.1+ , resourcet >= 1.1+ , text >= 1.1+ , time >= 1.2+ , transformers >= 0.2+ , transformers-base >= 0.4+ , unordered-containers >= 0.2.5+ , x509 >= 1.5+ , x509-store >= 1.5
+ src/Network/Google.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}++-- |+-- Module : Network.Google+-- 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)+--+-- This module provides a simple 'AWS' monad and a set of operations which+-- can be performed against remote Google Service APIs, for use with the types+-- supplied by the various @gogol-*@ libraries.+--+-- A 'MonadGoogle' typeclass is used as a function constraint to provide automatic+-- lifting of functions when embedding 'Google' as a layer inside your own+-- application stack.+module Network.Google+ (+ -- * Running Google Actions+ Google+ , MonadGoogle (..)+ , runGoogle+ , runResourceT++ -- * Authentication and Environment+ , newEnv+ , Env+ , HasEnv (..)++ -- ** Credential Discovery+ , Credentials (..)++ -- * Sending Requests+ , send++ -- ** Media Downloads+ , download++ -- ** Media Uploads+ , upload++ , ToBody (..)+ , RequestBody+ , requestBodySource+ , requestBodySourceChunked++ -- ** Service Configuration+ -- ** Overriding Defaults+ , configure+ , override++ -- *** Scoped Actions+ , reconfigure+ , timeout++ -- * Running Asynchronous Actions+ -- $async++ -- * Handling Errors+ , AsError (..)+ , AsAuthError (..)++ , trying+ , catching++ -- * Logging+ -- $logging++ , Logger+ , LogLevel (..)++ -- ** Constructing a Logger+ , newLogger++ -- * Re-exported Types+ , Proxy (..)+ , OctetStream+ , PlainText+ , JSON+ , module Network.Google.Types+ ) where++import Control.Applicative+import Control.Exception.Lens+import Control.Monad+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Reader+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+import Control.Monad.Trans.Control+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 qualified Control.Monad.Writer.Lazy as LW+import qualified Control.Monad.Writer.Strict as W+import Network.Google.Auth+import Network.Google.Env+import Network.Google.Internal.HTTP+import Network.Google.Internal.Logger+import Network.Google.Prelude+import Network.Google.Types+import Network.HTTP.Conduit (requestBodySource,+ requestBodySourceChunked)++newtype Google a = Google { unGoogle :: ReaderT Env (ResourceT IO) a }+ deriving+ ( Functor+ , Applicative+ , Alternative+ , Monad+ , MonadPlus+ , MonadIO+ , MonadThrow+ , MonadCatch+ , MonadMask+ , MonadBase IO+ , MonadReader Env+ , MonadResource+ )++instance MonadBaseControl IO Google where+ type StM Google a = StM (ReaderT Env (ResourceT IO)) a++ liftBaseWith f = Google . liftBaseWith $ \g -> f (g . unGoogle)+ restoreM = Google . restoreM++-- | Monads in which 'Google' actions may be embedded.+class ( Functor m+ , Applicative m+ , Monad m+ , MonadIO m+ , MonadCatch m+ ) => MonadGoogle m where+ -- | Lift a computation to the 'Google' monad.+ liftGoogle :: Google a -> m a++instance MonadGoogle Google where+ liftGoogle = id++instance MonadGoogle m => MonadGoogle (IdentityT m) where liftGoogle = lift . liftGoogle+instance MonadGoogle m => MonadGoogle (ListT m) where liftGoogle = lift . liftGoogle+instance MonadGoogle m => MonadGoogle (MaybeT m) where liftGoogle = lift . liftGoogle+instance MonadGoogle m => MonadGoogle (ExceptT e m) where liftGoogle = lift . liftGoogle+instance MonadGoogle m => MonadGoogle (ReaderT r m) where liftGoogle = lift . liftGoogle+instance MonadGoogle m => MonadGoogle (S.StateT s m) where liftGoogle = lift . liftGoogle+instance MonadGoogle m => MonadGoogle (LS.StateT s m) where liftGoogle = lift . liftGoogle++instance (Monoid w, MonadGoogle m) => MonadGoogle (W.WriterT w m) where+ liftGoogle = lift . liftGoogle++instance (Monoid w, MonadGoogle m) => MonadGoogle (LW.WriterT w m) where+ liftGoogle = lift . liftGoogle++instance (Monoid w, MonadGoogle m) => MonadGoogle (RW.RWST r w s m) where+ liftGoogle = lift . liftGoogle++instance (Monoid w, MonadGoogle m) => MonadGoogle (LRW.RWST r w s m) where+ liftGoogle = lift . liftGoogle++-- | Run a 'Google' aciton using the specified environment.+runGoogle :: (MonadResource m, HasEnv r) => r -> Google a -> m a+runGoogle e m = liftResourceT $ runReaderT (unGoogle m) (e ^. environment)++-- | Send a request, returning the associated response if successful.+--+-- Throws 'Error'.+send :: (MonadGoogle m, 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.+--+-- Throws 'Error'.+download :: (MonadGoogle m, GoogleRequest (MediaDownload a))+ => a+ -> m (Rs (MediaDownload a))+download = send . MediaDownload++-- | Send a request with an attached multipart/related media upload.+--+-- Throws 'Error'.+upload :: (MonadGoogle m, GoogleRequest (MediaUpload a))+ => a+ -> RequestBody+ -> m (Rs (MediaUpload a))+upload x = send . MediaUpload x++hoistError :: MonadThrow m => Either Error a -> m a+hoistError = either (throwingM _Error) return++{- $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>.+-}++{- $logging+The exposed logging interface is a primitive 'Logger' function which gets+threaded through service calls and serialisation routines. This allows the+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/tiny-log tiny-log> or+<http://hackage.haskell.org/package/fast-logger fast-logger>.+-}
+ src/Network/Google/Auth.hs view
@@ -0,0 +1,555 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module : Network.Google.Auth+-- 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)+--+-- Explicitly specify your Google credentials, or retrieve them+-- from the underlying OS.+module Network.Google.Auth+ (+ -- * Authentication+ -- ** Retrieving Authentication+ getAuth+ , Credentials (..)+ , Auth++ -- ** Authorising Requests+ , authorise++ -- ** Default Constants+ -- *** Google Compute Engine+ , checkGCEVar++ -- *** Cloud SDK+ , cloudSDKConfigDir+ , cloudSDKConfigPath++ -- *** Application Default Credentials+ , defaultCredentialsFile+ , defaultCredentialsPath++ -- ** Credentials+ , fromMetadata+ , fromFile+ , fromFilePath++ -- ** Handling Errors+ , AsAuthError (..)+ , AuthError (..)++ -- ** Re-exported Types+ , OAuthScope (..)+ , OAuthToken (..)+ , ServiceId (..)+ , ClientId (..)+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Exception.Lens+import Control.Lens hiding ((.=))+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Crypto.Hash.Algorithms (SHA256 (..))+import Crypto.PubKey.RSA.PKCS15 (signSafer)+import Crypto.PubKey.RSA.Types (PrivateKey)+import Data.Aeson+import Data.Aeson.Types+import Data.ByteArray+import Data.ByteArray.Encoding+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import Data.Default.Class (def)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time+import Data.Time.Clock.POSIX+import Data.Typeable+import Data.X509+import Data.X509.Memory+import Network.Google.Compute.Metadata+import Network.Google.Internal.Logger+import Network.Google.Prelude+import Network.HTTP.Conduit hiding (Request)+import qualified Network.HTTP.Conduit as Client+import Network.HTTP.Types+import System.Directory (doesFileExist,+ getHomeDirectory)+import System.Environment (lookupEnv)+import System.FilePath ((</>))+import System.Info (os)++-- | 1 hour in seconds.+maxTokenLifetimeSeconds :: Int+maxTokenLifetimeSeconds = 3600++-- | The environment variable name which is used to specify the directory+-- containing the @application_default_credentials.json@ generated by @gcloud init@.+--+-- /Default:/ @~\/.config\/gcloud\/application_default_credentials.json@.+cloudSDKConfigDir :: String+cloudSDKConfigDir = "CLOUDSDK_CONFIG"++-- | The environment variable pointing the file with local+-- Application Default Credentials.+defaultCredentialsFile :: String+defaultCredentialsFile = "GOOGLE_APPLICATION_CREDENTIALS"++-- | An error thrown when attempting to read AuthN/AuthZ information.+data AuthError+ = RetrievalError HttpException+ | MissingFileError FilePath+ | InvalidFileError FilePath Text+ | TokenRefreshError Status Text (Maybe Text)+ 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)++-- | Determines how AuthN/AuthZ information is retrieved.+data Credentials+ = FromToken !OAuthToken+ -- ^ Supply an explicit access token. See 'fromToken'.++ | FromFile !FilePath+ -- ^ Load the Application Default Credentials from a specific file path.+ -- The file can be formatted as either a @service_account@ or an @authorized_user@.++ | FromAccount !ServiceId+ -- ^ Retrieve the Application Default Credentials using the speicfic+ -- 'ServiceId' from the local metadata endpoint.++ | Discover+ -- ^ Attempt credentials discovery via the following steps:+ --+ -- * Read the default credentials from a file specified by+ -- the environment variable @GOOGLE_APPLICATION_CREDENTIALS@ if it exists.+ --+ -- * 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.+ --+ -- * Retrieve the default service account application credentials if+ -- running on GCE.+ deriving (Eq, Show)++-- | Retrieve authentication information via the specified 'Credentials' mechanism.+--+-- Throws 'AuthError' when environment variables or service account information+-- cannot be read, and credentials files are invalid or cannot be found.+getAuth :: (MonadIO m, MonadCatch m)+ => Credentials+ -> Logger+ -> Manager+ -> m Auth+getAuth c l m = case c of+ FromToken t -> pure (AuthToken t)+ FromFile f -> fromFilePath f l m+ FromAccount s -> fromMetadata s l m+ Discover ->+ catching _MissingFileError (fromFile l m) $ \f -> do+ p <- isGCE m+ unless p $+ throwingM _MissingFileError f+ fromMetadata "default" l m++-- | Refresh a token from the local GCE metadata endpoint for the specified+-- 'ServiceId'.+fromMetadata :: (MonadIO m, MonadCatch m)+ => ServiceId+ -> Logger+ -> Manager+ -> m Auth+fromMetadata s l = refresh s l >=> fmap AuthMeta . liftIO . newMVar++-- | Attempt to load either a @service_account@ or @authorized_user@ formatted+-- file to obtain the credentials neccessary to perform a token refresh.+fromFile :: (MonadIO m, MonadCatch m) => Logger -> Manager -> m Auth+fromFile l m = do+ f <- defaultCredentialsPath+ case f of+ Just x -> fromFilePath x l m+ Nothing -> do+ x <- cloudSDKConfigPath+ fromFilePath x l m++data Parse = SA !ServiceAccount | AU !AuthorisedUser++instance FromJSON Parse where+ parseJSON o = SA <$> parseJSON o <|> AU <$> parseJSON o++-- | 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.+fromFilePath :: (MonadIO m, MonadCatch m)+ => FilePath+ -> Logger+ -> Manager+ -> m Auth+fromFilePath f l m = do+ p <- liftIO (doesFileExist f)+ unless p $+ throwM (MissingFileError f)+ e <- liftIO (LBS.readFile f) >>=+ either (throwM . InvalidFileError f) pure . parseLBS+ case e of+ SA a -> refresh a l m >>= fmap AuthSign . liftIO . newMVar+ AU u -> refresh u l m >>= fmap AuthUser . liftIO . newMVar++-- | Lookup the @GOOGLE_APPLICATION_CREDENTIALS@ environment variable for the+-- default application credentials filepath.+defaultCredentialsPath :: MonadIO m => m (Maybe FilePath)+defaultCredentialsPath = liftIO (lookupEnv defaultCredentialsFile)++-- | 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"++getConfigDirectory :: MonadIO m => m FilePath+getConfigDirectory = do+ h <- liftIO getHomeDirectory+ if os == "windows"+ then pure h+ else pure $! h </> ".config"++data RefreshError = RefreshError+ { _error :: !Text+ , _description :: !(Maybe Text)+ }++instance FromJSON RefreshError where+ parseJSON = withObject "refresh_error" $ \o -> RefreshError+ <$> o .: "error"+ <*> o .:? "error_description"++data Expires a = Expires+ { _expiry :: !UTCTime+ , _token :: !OAuthToken+ , _details :: !a+ }++isValid :: MonadIO m => Expires a -> m Bool+isValid r = (< _expiry r) <$> liftIO getCurrentTime++data Auth+ = AuthToken !OAuthToken+ | AuthSign !(MVar (Expires ServiceAccount))+ | AuthMeta !(MVar (Expires ServiceId))+ | AuthUser !(MVar (Expires AuthorisedUser))++authorise :: (MonadIO m, MonadCatch m)+ => Logger+ -> Manager+ -> Client.Request+ -> Auth+ -> m Client.Request+authorise l m rq = \case+ AuthToken t -> pure $! authoriseBearer rq t+ AuthSign r -> authoriseToken l m r rq+ AuthMeta r -> authoriseToken l m r rq+ AuthUser r -> authoriseToken l m r rq++authoriseBearer :: Client.Request -> OAuthToken -> Client.Request+authoriseBearer rq t = rq+ { Client.requestHeaders = (hAuthorization, "Bearer " <> tokenToBS t)+ : Client.requestHeaders rq+ }++authoriseToken :: (MonadIO m, MonadCatch m, Refresh a)+ => Logger+ -> Manager+ -> MVar (Expires a)+ -> Client.Request+ -> m Client.Request+authoriseToken l m r rq = authoriseBearer rq <$> refreshToken l m r++refreshToken :: (MonadIO m, MonadCatch m, Refresh a)+ => Logger+ -> Manager+ -> MVar (Expires a)+ -> m OAuthToken+refreshToken l m r = do+ x <- liftIO (readMVar r)+ xv <- isValid x+ if xv+ then pure (_token x)+ else liftIO . modifyMVar r $ \y -> do+ yv <- isValid y+ if yv+ then pure (y, _token y)+ else do+ z <- refresh (_details y) l m+ pure (z, _token z)++-- {+-- "access_token": "sadsdasd",+-- "expires_in": 3600,+-- "id_token": "eyJhbGciOiJSd",+-- "refresh_token": "1/B3gq9K",+-- "token_type": "Bearer"+-- }++data Bearer = Bearer+ { _bearerAccess :: !OAuthToken+ , _bearerRefresh :: !(Maybe Text)+ , _bearerExpiry :: !UTCTime+ }++instance FromJSON (UTCTime -> Bearer) where+ parseJSON = withObject "bearer" $ \o -> do+ t <- o .: "access_token"+ r <- o .:? "refresh_token"+ e <- o .: "expires_in" <&> fromInteger+ pure (Bearer t r . addUTCTime e)++-- {+-- "private_key_id": "303ad77e5efdf2ce952DFa",+-- "private_key": "-----BEGIN PRIVATE KEY-----\nMIIE...\n",+-- "client_email": "01395191@gserviceaccount.com",+-- "client_id": "035-2-310eusercontent.com",+-- "type": "service_account"+-- }++data ServiceAccount = ServiceAccount+ { _serviceId :: !ClientId+ , _serviceEmail :: !Text+ , _serviceKeyId :: !Text+ , _serviceKey :: !PrivateKey+ }++instance FromJSON ServiceAccount where+ parseJSON = withObject "service_account" $ \o -> do+ bs <- Text.encodeUtf8 <$> o .: "private_key_id"+ ServiceAccount+ <$> o .: "client_id"+ <*> o .: "client_email"+ <*> o .: "private_key"+ <*> parseKey bs+ where+ parseKey bs =+ case listToMaybe (readKeyFileFromMemory bs) of+ Just (PrivKeyRSA k) -> pure k+ _ ->+ fail "Unable to parse key contents from 'private_key_id'"++-- {+-- "client_id": "32555940559.apps.googleusercontent.com",+-- "client_secret": "ZmssLNjJy2998hD4CTg2ejr2",+-- "refresh_token": "1/B3gqKM1xzVtqffS1n5w-rSJ",+-- "type": "authorized_user"+-- }++data AuthorisedUser = AuthorisedUser+ { _userId :: !ClientId+ , _userSecret :: !Text+ , _userRefresh :: !Text+ }++instance FromJSON AuthorisedUser where+ parseJSON = withObject "authorized_user" $ \o -> AuthorisedUser+ <$> o .: "client_id"+ <*> o .: "client_secret"+ <*> o .: "refresh_token"++class Refresh a where+ refresh :: (MonadIO m, MonadCatch m)+ => a+ -> Logger+ -> Manager+ -> m (Expires a)++instance Refresh ServiceAccount where+ refresh s l m = do+ b <- jwtEncode s+ let rq = accountsRequest+ { Client.requestBody = RequestBodyBS $+ "grant_type=urn:ietf:params:oauth:grant-type:jwt-bearer"+ <> "&assertion="+ <> b+ }+ refreshRequest s rq l m++jwtEncode :: (MonadIO m, MonadThrow m) => ServiceAccount -> m ByteString+jwtEncode s = liftIO $ do+ i <- input . truncate <$> getPOSIXTime+ r <- signSafer (Just SHA256) (_serviceKey s) i+ either failure (\x -> pure (i <> "." <> signature (base64 x))) r+ where+ 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" .= Text.decodeUtf8 (Client.host accountsRequest)+ , "scope" .= ([] :: [Text])+ , "iat" .= n+ , "exp" .= (n + maxTokenLifetimeSeconds)+ , "iss" .= _serviceEmail s+ ]++instance Refresh AuthorisedUser where+ refresh u@AuthorisedUser{..} = refreshRequest u $+ accountsRequest+ { Client.requestBody = RequestBodyBS . Text.encodeUtf8 $+ "grant_type=refresh_token"+ <> "&client_id=" <> clientIdToText _userId+ <> "&client_secret=" <> _userSecret+ <> "&refresh_token=" <> _userRefresh+ }++instance Refresh ServiceId where+ refresh sid = refreshRequest sid $+ metadataRequest+ { Client.path = "instance/service-accounts/"+ <> Text.encodeUtf8 (serviceIdToText sid)+ <> "/token"+ }++accountsRequest :: Client.Request+accountsRequest = def+ { Client.host = "accounts.google.com"+ , Client.port = 443+ , Client.secure = True+ , Client.checkStatus = \_ _ _ -> Nothing+ , Client.method = "POST"+ , Client.path = "/o/oauth2/token"+ , Client.requestHeaders = [(hContentType, "application/x-www-form-urlencoded")]+ }++refreshRequest :: (MonadIO m, MonadCatch m)+ => a+ -> Client.Request+ -> Logger+ -> Manager+ -> m (Expires a)+refreshRequest r rq l m = do+ logDebug l rq -- debug:ClientRequest++ rs <- liftIO (httpLbs rq m) `catch` (throwM . RetrievalError)++ logDebug l rs -- debug:ClientResponse++ let bs = responseBody rs+ s = responseStatus rs++ if fromEnum s == 200+ then success s bs+ else failure s+ where+ success s bs = do+ f <- parseErr s bs+ ts <- liftIO getCurrentTime+ let Bearer {..} = f ts+ pure $! Expires _bearerExpiry _bearerAccess r++ failure s = do+ let e = "Failure refreshing token from " <> host <> path+ logError l $ "[Refresh Error] " <> build e+ 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 :: ToJSON a =>+base64 :: ByteArray a => a -> ByteString+base64 = convertToBase Base64URLUnpadded
+ src/Network/Google/Compute/Metadata.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.Google.Compute.Metadata+-- 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)+--+-- 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' and not the 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+ , metadata+ , metadataRequest+ ) where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Char (toLower)+import Data.Default.Class (def)+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+import Network.HTTP.Conduit (HttpException (..), Manager, httpLbs,+ responseBody, responseHeaders,+ responseStatus)+import qualified Network.HTTP.Conduit as Client+import Network.HTTP.Types+import System.Environment (lookupEnv)++-- | @NO_GCE_CHECK@.+checkGCEVar :: String+checkGCEVar = "NO_GCE_CHECK"++-- | The @Metadata-Flavor@ header.+metadataFlavorHeader :: HeaderName+metadataFlavorHeader = "Metadata-Flavor"++-- | The desired metadata flavor.+metadataFlavorDesired :: ByteString+metadataFlavorDesired = "Google"++metadataRequest :: Client.Request+metadataRequest = def+ { Client.host = "metadata.google.internal"+ , Client.port = 80+ , Client.secure = False+ , Client.method = "GET"+ , Client.requestHeaders = [(metadataFlavorHeader, metadataFlavorDesired)]+ }++-- | 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 <$> 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 (responseStatus rs) == 200+ && (lookup metadataFlavorHeader (responseHeaders rs)+ == Just metadataFlavorDesired)++ failure :: HttpException -> IO Bool+ failure = const (pure False)++ rq = metadataRequest+ { Client.responseTimeout = Just 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 =+ metadataMaybe ("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 <- metadataMaybe "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 = metadataText "project/numeric-project-id"++-- | The project ID.+getProjectId :: MonadIO m => Manager -> m Text+getProjectId = metadataText "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 =+ metadataMaybe ("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 = metadataText "instance/description"++-- | The host name of the instance.+getHostname :: MonadIO m => Manager -> m Text+getHostname = metadataText "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 = metadataText "instance/id"++-- | The fully-qualified machine type name of the instance's host machine.+getMachineType :: MonadIO m => Manager -> m Text+getMachineType = metadataText "instance/machine-type"++-- | Any tags associated with the instance.+getTags :: MonadIO m => Manager -> m [Text]+getTags m = do+ rs <- metadata "instance/tags" [] m+ case eitherDecode' (responseBody rs) of+ Left _ -> pure []+ Right xs -> pure xs++-- | The instance's zone.+getZone :: MonadIO m => Manager -> m Text+getZone = metadataText "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"++metadataMaybe :: MonadIO m+ => ByteString+ -> Manager+ -> m (Maybe LBS.ByteString)+metadataMaybe path m = do+ rs <- metadata path [404] m+ if fromEnum (responseStatus rs) == 404+ then pure Nothing+ else pure $ Just (responseBody rs)++metadataText :: MonadIO m+ => ByteString+ -> Manager+ -> m Text+metadataText path m = LText.toStrict . LText.decodeUtf8 . responseBody+ <$> metadata path [] m++metadata :: MonadIO m+ => ByteString+ -> [Int]+ -> Manager+ -> m (Client.Response LBS.ByteString)+metadata path ss m =+ liftIO . flip httpLbs m $ metadataRequest+ { Client.path = "/computeMetadata/v1/" <> path+ , Client.checkStatus = \s hs cj ->+ let c = fromEnum s+ in if 200 <= c && c < 300 && notElem c ss+ then Nothing+ else Just . toException $ StatusCodeException s hs cj+ }+
+ src/Network/Google/Env.hs view
@@ -0,0 +1,116 @@+-- |+-- Module : Network.Google.Env+-- 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)+--+-- Environment and Google specific configuration for the 'Network.Google' monad.+module Network.Google.Env where++import Control.Lens+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Function (on)+import Data.Monoid+import Network.Google.Auth+import Network.Google.Internal.Logger+import Network.Google.Types+import Network.HTTP.Conduit++-- | The environment containing the parameters required to make Google requests.+data Env = Env+ { _envLogger :: !Logger+ , _envOverride :: !(Dual (Endo Service))+ , _envManager :: !Manager+ , _envAuth :: !Auth+ }++-- Note: The strictness annotations aobe are applied to ensure+-- total field initialisation.++class HasEnv a where+ environment :: Lens' a Env+ {-# MINIMAL environment #-}++ -- | The function used to output log messages.+ envLogger :: Lens' a Logger++ -- | The currently applied overrides to all 'Service' configuration.+ envOverride :: Lens' a (Dual (Endo Service))++ -- | The 'Manager' used to create and manage open HTTP connections.+ envManager :: Lens' a Manager++ -- | The credentials used to sign requests for authentication with Google.+ envAuth :: Lens' a Auth++ envLogger = environment . lens _envLogger (\s a -> s { _envLogger = a })+ envOverride = environment . lens _envOverride (\s a -> s { _envOverride = a })+ envManager = environment . lens _envManager (\s a -> s { _envManager = a })+ envAuth = environment . lens _envAuth (\s a -> s { _envAuth = a })++instance HasEnv Env where+ environment = id++-- | Provide a function which will be added to the existing stack+-- of overrides applied to all service configuration.+--+-- To override a specific service, it's suggested you use+-- either 'configure' or 'reconfigure' with a modified version of the default+-- service, such as @Network.Google.Gmail.gmailService@.+override :: HasEnv a => (Service -> Service) -> a -> a+override f = envOverride <>~ Dual (Endo f)++-- | Configure a specific service. All requests belonging to the+-- supplied service will use this configuration instead of the default.+--+-- It's suggested you use a modified version of the default service, such+-- as @Network.Google.Gmail.gmailService@.+--+-- /See:/ 'reconfigure'.+configure :: HasEnv a => Service -> a -> a+configure s = override f+ where+ f x | on (==) _svcId s x = s+ | otherwise = x++-- | Scope an action such that all requests belonging to the supplied service+-- will use this configuration instead of the default.+--+-- It's suggested you use a modified version of the default service, such+-- as @Network.Google.Gmail.gmailService@.+--+-- /See:/ 'configure'.+reconfigure :: (MonadReader r m, HasEnv r) => Service -> m a -> m a+reconfigure = local . configure++-- | 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. (Usually 70s)+--+-- * The 'envManager' timeout if set.+--+-- * The default 'ClientRequest' timeout. (Approximately 30s)+timeout :: (MonadReader r m, HasEnv r) => Seconds -> m a -> m a+timeout s = local (override (serviceTimeout ?~ s))++-- | Creates a new environment with a new 'Manager' without debug logging+-- and uses 'getAuth' to expand/discover the supplied 'Credentials'.+-- Lenses from 'HasEnv' can be used to further configure the resulting 'Env'.+--+-- /See:/ 'newEnvWith'.+newEnv :: (MonadIO m, MonadCatch m) => Credentials -> m Env+newEnv c = liftIO (newManager tlsManagerSettings) >>= newEnvWith c logger+ where+ logger _ _ = pure ()++-- | /See:/ 'newEnv'+newEnvWith :: (MonadIO m, MonadCatch m) => Credentials -> Logger -> Manager -> m Env+newEnvWith c l m = Env l mempty m <$> getAuth c l m
+ src/Network/Google/Internal/HTTP.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Network.Google.Internal.HTTP+-- 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)+--+module Network.Google.Internal.HTTP where+++import Control.Lens+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Data.Default.Class+import Data.Monoid+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Builder as Build+import GHC.Exts (toList)+import Network.Google.Auth+import Network.Google.Env (Env (..))+import Network.Google.Internal.Logger+import Network.Google.Internal.Multipart+import Network.Google.Types+import qualified Network.HTTP.Client.Conduit as Client+import Network.HTTP.Conduit+import Network.HTTP.Media+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++perform :: (MonadCatch m, MonadResource m, GoogleRequest a)+ => Env+ -> a+ -> m (Either Error (Rs a))+perform Env{..} x = catches go handlers+ where+ Request {..} = _cliRequest+ Service {..} = _cliService++ Client {..} = requestClient x+ & clientService %~ appEndo (getDual _envOverride)++ go = liftResourceT $ do+ (ct, b) <- getContent _rqBody+ rq <- authorise _envLogger _envManager (request ct b) _envAuth++ logDebug _envLogger rq -- debug:ClientRequest++ rs <- http rq _envManager++ logDebug _envLogger rs -- debug:ClientResponse++ 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 = def+ { Client.host = _svcHost+ , Client.port = _svcPort+ , Client.secure = _svcSecure+ , Client.checkStatus = status+ , 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)++ status s hs _+ | _cliCheck s = Nothing+ | otherwise = Just . toException . ServiceError $ ServiceError'+ { _serviceId = _svcId+ , _serviceStatus = s+ , _serviceHeaders = hs+ , _serviceBody = Nothing+ }++ timeout = microseconds <$> _svcTimeout++ handlers =+ [ Handler $ err+ , Handler $ err . TransportError+ ]+ where+ err e = return (Left e)++getContent :: MonadIO m+ => Maybe Payload+ -> m ([Header] -> [Header], RequestBody)+getContent = \case+ Nothing -> pure (id, mempty)+ Just (Body t s) -> pure (((hContentType, renderHeader t) :), s)+ Just (Related ps) -> do+ b <- genBoundary+ pure ( (multipartHeader b :)+ , renderParts b ps+ )
+ src/Network/Google/Internal/Logger.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Network.Google.Internal.Logger+-- 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)+--+-- 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++ -- * Building Messages+ , ToLog (..)+ , buildLines+ ) where++import Control.Monad+import Control.Monad.IO.Class+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+import Data.List (intersperse)+import Data.Monoid+import qualified Data.Text as Text+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+import Network.Google.Prelude hiding (Header, Request)+import Network.HTTP.Conduit+import Network.HTTP.Types+import Numeric+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.+ deriving (Eq, Ord, Enum, Show, Data, Typeable)++instance FromText LogLevel where+ fromText (Text.toLower -> t) =+ case t of+ "info" -> Just Info+ "error" -> Just Error+ "debug" -> Just Debug+ _ -> Nothing++instance ToText LogLevel where+ toText = \case+ Info -> "info"+ Error -> "error"+ Debug -> "debug"++-- | 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 :: (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++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 <> ">"+ RequestBodyStreamChunked _ -> " <chunked>"++ 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++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 (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)+ , "}"+ ]
+ src/Network/Google/Internal/Multipart.hs view
@@ -0,0 +1,75 @@+ {-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : Network.Google.Internal.Multipart+-- 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)+--+module Network.Google.Internal.Multipart where++import Control.Monad.IO.Class+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Builder.Extra+import qualified Data.CaseInsensitive as CI+import Data.Monoid+import Network.Google.Types+import Network.HTTP.Client+import Network.HTTP.Client.MultipartFormData (webkitBoundary)+import Network.HTTP.Media+import Network.HTTP.Types++-- 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 -> [Part] -> RequestBody+renderParts b = (<> part b) . foldMap go+ where+ go (Part ct hs x) =+ start b+ <> copy "Content-Type: "+ <> copy (renderHeader ct)+ <> foldMap (\(k, v) ->+ copy "\r\n"+ <> copy (CI.original k)+ <> copy ": "+ <> copy v) hs+ <> copy "\r\n\r\n"+ <> x+ <> copy "\r\n"