diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,1 @@ +# Change Log diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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/). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gogol.cabal b/gogol.cabal new file mode 100644 --- /dev/null +++ b/gogol.cabal @@ -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 +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 + category on Hackage for supported services. + . + To get started, import the desired @gogol-*@ library (such as + ) + and @Network.Google@ from this package. + . + /Warning:/ This is an experimental prototype/preview release which is still + under exploratory development and not intended for public use, caveat emptor! + . + GHC 7.10.2 and higher is officially supported. + +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 diff --git a/src/Network/Google.hs b/src/Network/Google.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google.hs @@ -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 +-- 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 . +-} + +{- $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 + or +. +-} diff --git a/src/Network/Google/Auth.hs b/src/Network/Google/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Auth.hs @@ -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 +-- 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 diff --git a/src/Network/Google/Compute/Metadata.hs b/src/Network/Google/Compute/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Compute/Metadata.hs @@ -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 +-- 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 . Specifically, provides +-- -- a list of external IPs served by forwarding rules that direct packets to this +-- -- instance. +-- getForwardedIPs +-- "instance/network-interfaces//forwarded-ips/" + +-- -- | A directory with the scheduling options for the instance. +-- getScheduling +-- "instance/scheduling/" + +-- -- | The instance's transparent maintenance event behavior setting. This value is +-- -- set with the @--on_host_maintenance@ flag or via the API. +-- getOnHostMaintenance +-- "instance/scheduling/on-host-maintenance" + +-- -- | The instance's automatic restart setting. This value is set with the +-- -- @‑‑automatic_restart@ flag or via the API. +-- getAutomaticRestart +-- "instance/scheduling/automatic-restart" + +-- -- | The path that indicates that a transparent maintenance event is affecting this instance. +-- -- See Transparent maintenance notice for details. +-- getMaintenanceEvent +-- "instance/maintenance-event" + +-- Metadata wait for change +-- curl "http://metadata.google.internal/computeMetadata/v1/instance/tags?wait_for_change=true" + +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 + } + diff --git a/src/Network/Google/Env.hs b/src/Network/Google/Env.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Env.hs @@ -0,0 +1,116 @@ +-- | +-- Module : Network.Google.Env +-- Copyright : (c) 2015 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +-- Environment and Google specific configuration for the 'Network.Google' monad. +module Network.Google.Env where + +import Control.Lens +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 diff --git a/src/Network/Google/Internal/HTTP.hs b/src/Network/Google/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Internal/HTTP.hs @@ -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 +-- 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 + ) diff --git a/src/Network/Google/Internal/Logger.hs b/src/Network/Google/Internal/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Internal/Logger.hs @@ -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 +-- 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 +-- or +-- +-- should be used in production code. +newLogger :: MonadIO m => LogLevel -> Handle -> m Logger +newLogger x hd = liftIO $ do + hSetBinaryMode hd True + hSetBuffering hd LineBuffering + return $ \y b -> + when (x >= y) $ + Build.hPutBuilder hd (b <> "\n") + +logError, logInfo, logDebug :: (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 _ -> " build n <> ">" + RequestBodyStream n _ -> " build n <> ">" + RequestBodyStreamChunked _ -> " " + + RequestBodyLBS lbs + | n <= 4096 -> build lbs + | otherwise -> " build n <> ">" + where + n = LBS.length lbs + + RequestBodyBS bs + | n <= 4096 -> build bs + | otherwise -> " build n <> ">" + where + n = BS.length bs + +instance ToLog HttpException where + build x = "[HttpException] {\n" <> build (show x) <> "\n}" + +instance ToLog Request where + build x = buildLines + [ "[Client Request] {" + , " host = " <> build (host x) <> ":" <> build (port x) + , " secure = " <> build (secure x) + , " method = " <> build (method x) + , " timeout = " <> build (responseTimeout x) + , " redirects = " <> build (redirectCount x) + , " path = " <> build (path x) + , " query = " <> build (queryString x) + , " headers = " <> build (requestHeaders x) + , " body = " <> build (requestBody x) + , "}" + ] + +instance ToLog (Response a) where + build x = buildLines + [ "[Client Response] {" + , " status = " <> build (responseStatus x) + , " headers = " <> build (responseHeaders x) + , "}" + ] diff --git a/src/Network/Google/Internal/Multipart.hs b/src/Network/Google/Internal/Multipart.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Internal/Multipart.hs @@ -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 +-- 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"