packages feed

goggles (empty) → 0.1.0.0

raw patch · 14 files changed

+814/−0 lines, 14 filesdep +QuickCheckdep +aesondep +attoparsecsetup-changed

Dependencies added: QuickCheck, aeson, attoparsec, base, base64-bytestring, binary, bytestring, containers, cryptonite, exceptions, filepath, goggles, hspec, http-client, http-client-tls, http-types, memory, mtl, pem, req, scientific, stm, text, time, transformers, unix-time, x509, x509-store

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Marco Zocca (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marco Zocca nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,17 @@+# goggles++<img src="goggles1.png" style="width: 300px;"/>++[![Build Status](https://travis-ci.org/ocramz/goggles.png)](https://travis-ci.org/ocramz/goggles)++Interface to Google Cloud APIs++++### Inspiration++Networking and authentication :++* [`google-cloud`](hackage.haskell.org/package/google-cloud)+* [`gogol`](hackage.haskell.org/package/gogol)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ goggles.cabal view
@@ -0,0 +1,83 @@+name:                goggles+version:             0.1.0.0+synopsis:            Interface to Google Cloud APIs+description:         Interface to Google Cloud APIs+homepage:            https://github.com/ocramz/goggles+license:             BSD3+license-file:        LICENSE+author:              Marco Zocca+maintainer:          zocca.marco gmail+copyright:           2017 Marco Zocca+category:            Network+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10+tested-with:         GHC == 8.2++library+  default-language:    Haskell2010+  ghc-options:         -Wall+  hs-source-dirs:      src+  exposed-modules:     Network.Goggles+  other-modules:       Data.Keys+                       Network.Goggles.Cloud+                       Network.Utils.HTTP+                       Network.Goggles.Types+                       Network.Goggles.Auth.JWT+                       Network.Goggles.Auth.OAuth2+                       Network.Goggles.Auth.TokenExchange+                       Network.Goggles.Control.Exceptions+  build-depends:       base >= 4.7 && < 5+                     , binary+                     , scientific+                     , attoparsec+                     , aeson+                     , req >= 0.3+                     , http-client+                     , http-client-tls+                     , http-types+                     , cryptonite+                     , memory+                     , pem+                     , x509+                     , x509-store+                     , unix-time+                     , mtl+                     , transformers+                     , text+                     , bytestring+                     , base64-bytestring+                     , time+                     , stm+                     -- , envy+                     , containers+                     , exceptions+                     , filepath+                     -- * DEBUG+                     , hspec+                     , QuickCheck+  +  ++-- executable goggles+--   default-language:    Haskell2010+--   ghc-options:         -threaded -rtsopts -with-rtsopts=-N+--   hs-source-dirs:      app+--   main-is:             Test.hs+--   build-depends:       base+--                      , goggles++test-suite spec+  default-language:    Haskell2010+  ghc-options:         -Wall+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , goggles+                     , hspec+                     , QuickCheck++source-repository head+  type:     git+  location: https://github.com/ocramz/goggles
+ src/Data/Keys.hs view
@@ -0,0 +1,36 @@+{-# language OverloadedStrings #-}+module Data.Keys (parseRSAPrivateKey) where++import Data.Monoid ((<>))++import qualified Data.Text as T+import           Data.Text.Encoding         (encodeUtf8)+-- import qualified Data.Text.IO as T++import Control.Monad.Catch+-- import Control.Monad.IO.Class++import Data.X509 +import Data.X509.Memory (readKeyFileFromMemory)+import Crypto.PubKey.RSA.Types++import Network.Goggles.Control.Exceptions+++-- | Parse a chunk of text into an RSA private key. For Google Cloud Platform , this is the private key associated with the user's "service account" (for server-to-server API use)+--+-- > https://console.cloud.google.com/apis/credentials+--+-- Note: do /not/ supply the RSA header and footer or any newlines (they will be inserted by this function).+parseRSAPrivateKey :: MonadThrow m => T.Text -> m PrivateKey+parseRSAPrivateKey k =+  case parseRSAPrivateKey_helper k of [] -> throwM $ NoParsePK "Cannot parse RSA key"+                                      (PrivKeyRSA ok:_) -> return ok+                                      _ -> throwM $ NoRSAKey "Found key is not a RSA private key"+++parseRSAPrivateKey_helper :: T.Text -> [PrivKey]+parseRSAPrivateKey_helper = readKeyFileFromMemory . withPEMheaders encodeUtf8 where+  withPEMheaders encf k = b1 <> encf k <> b2 where+      b1 = encf $ T.pack "-----BEGIN RSA PRIVATE KEY-----\n"+      b2 = encf $ T.pack "\n-----END RSA PRIVATE KEY-----\n"
+ src/Network/Goggles.hs view
@@ -0,0 +1,44 @@+module Network.Goggles (+  -- * Google Cloud Storage+    getObject+  , listObjects+  , putObject+  -- ** GCP Authentication scopes+  , scopesDefault+  -- ** Running Cloud programs+  , evalCloudIO+  , liftCloudIO+  , createHandle  +  -- * Types+  , GCP+  , GCPServiceAccount(..)+  , Cloud(..)+  -- ** Authentication+  , HasCredentials(..)+  , Token(..)+  -- , accessToken+  -- , refreshToken+  , Handle(..)+  -- * Private key +  , parseRSAPrivateKey+  -- * Exceptions+  , KeyException(..)+  , JWTError(..)+  , TokenExchangeException(..)+  , CloudException(..)  +  ) where+++import Network.Goggles.Control.Exceptions +import Network.Goggles.Cloud+import Network.Goggles.Types+import Network.Goggles.Auth.TokenExchange+import Data.Keys +-- import System.Environment (lookupEnv)+++++++
+ src/Network/Goggles/Auth/JWT.hs view
@@ -0,0 +1,72 @@+{-# language OverloadedStrings, FlexibleContexts, RecordWildCards #-}+module Network.Goggles.Auth.JWT where++import qualified Data.ByteString.Lazy            as LB+import qualified Data.ByteString.Char8            as B8+import qualified Data.Text                  as T+++import qualified Data.Aeson as J+import Data.Aeson ((.=))+import qualified Data.Aeson.Types as J (Pair)++import           Data.Monoid ((<>))++import           Data.UnixTime (getUnixTime, utSeconds, UnixTime(..))+import           Foreign.C.Types++import Control.Monad.Except+import Control.Monad.Trans (liftIO)+import Control.Monad.Catch++import qualified Crypto.Hash.Algorithms as CR+import qualified Crypto.PubKey.RSA.PKCS15 as CR (signSafer) +import qualified Crypto.Random.Types as CR+++import Data.ByteArray+import Data.ByteArray.Encoding++import Network.Goggles.Types+import Network.Goggles.Control.Exceptions++++-- | Returns a bytestring with the signed JWT-encoded token request. +-- adapted from https://github.com/brendanhay/gogol/blob/master/gogol/src/Network/Google/Auth/ServiceAccount.hs+encodeBearerJWT :: (MonadThrow m, CR.MonadRandom m, MonadIO m) =>+                   GCPServiceAccount+                -> GCPTokenOptions+                -> m B8.ByteString+encodeBearerJWT s opts = do+    i <- input <$> liftIO getUnixTime+    r <- CR.signSafer (Just CR.SHA256) (_servicePrivateKey s) i+    either failure (pure . concat' i) r+  where+    concat' i x = i <> "." <> signature (base64 x)+    failure e = throwM $ CryptoSignError (show e)+    signature bs = case B8.unsnoc bs of+            Nothing         -> mempty+            Just (bs', x)+                | x == '='  -> bs'+                | otherwise -> bs+    input t = header <> "." <> payload+      where+        header = base64Encode+            [ "alg" .= ("RS256" :: T.Text)+            , "typ" .= ("JWT"   :: T.Text) ]+        payload = base64Encode $+            [ "aud"   .= T.pack "https://www.googleapis.com/oauth2/v4/token" +            , "scope" .= (T.intercalate " " $ _tokenOptionsScopes opts)+            , "iat"   .= toT (utSeconds t)+            , "exp"   .= toT (CTime 3600 + utSeconds t)+            , "iss"   .= _serviceEmail s+            ] <> maybe [] (\sub -> ["sub" .= sub]) (_serviceAccountUser s)+        toT = T.pack . show+++base64Encode :: [J.Pair] -> B8.ByteString+base64Encode = base64 . LB.toStrict . J.encode . J.object++base64 :: ByteArray a => a -> B8.ByteString+base64 = convertToBase Base64URLUnpadded
+ src/Network/Goggles/Auth/OAuth2.hs view
@@ -0,0 +1,85 @@+{-# language OverloadedStrings, DeriveGeneric #-}+module Network.Goggles.Auth.OAuth2+  (+    requestOAuth2Token+  , OAuth2Token(..)+  , OAuth2TokenUTC(..)+  , mkOAuth2TokenUTC+                                )+  where+++import Network.HTTP.Req+import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO(..), liftIO)+import GHC.Generics+import qualified Data.Text as T+-- import qualified Data.Text.Encoding as T (encodeUtf8)+-- import qualified Data.ByteString.Char8            as B8+-- import qualified Data.ByteString.Lazy as LB+import qualified Data.Aeson as J+import Data.Aeson ((.:), (.:?))+import Network.Utils.HTTP+import Data.Time++import Network.Goggles.Control.Exceptions++++data OAuth2TokenUTC = OAuth2TokenUTC {+    oauTokenExpiry :: UTCTime+  , oauTokenString :: T.Text+  , oauTokenType :: Maybe T.Text+                                     } deriving (Eq, Show)++mkOAuth2TokenUTC :: (MonadIO m, Integral t) => t -> OAuth2Token -> m OAuth2TokenUTC+mkOAuth2TokenUTC delta oa2 = liftIO $+  OAuth2TokenUTC <$>+  tokenExpiryTime delta (oaTokenExpirySeconds oa2) <*>+  pure (oaTokenString oa2) <*>+  pure (oaTokenType oa2)+++data OAuth2Token = OAuth2Token {+    oaTokenExpirySeconds :: Int+  , oaTokenString :: T.Text+  , oaTokenType :: Maybe T.Text+  } deriving (Eq, Show, Generic)++instance J.FromJSON OAuth2Token where+  parseJSON = J.withObject "OAuth2Token" $ \js -> OAuth2Token+    <$> js .: "expires_in"+    <*> js .: "access_token"+    <*> js .:? "token_type"+++-- | send a POST request over HTTPS to a given URI that will return a OAuth2Token+requestOAuth2Token+  :: (MonadHttp m, MonadThrow m) =>+     Url scheme         -- ^ Request URI+  -> [(T.Text, T.Text)] -- ^ parameter list as a list of (key, value) pairs+  -> Option scheme      -- ^ request options (e.g. headers)     +  -> m OAuth2Token+requestOAuth2Token uri args httpOpts = do+  let payload = encodeHttpParametersLB args+  r <- req POST+         uri+         (ReqBodyLbs payload)+         lbsResponse+         httpOpts+  maybe (throwM $ NotFound "Something went wrong with the token request") pure (J.decode (responseBody r) :: Maybe OAuth2Token)+++++-- | Returns the UTCTime (absolute) related to a delay in seconds from the time this function is executed. We need this helper function because the "expires_in" field in the OAuth2 response means "seconds from now".+tokenExpiryTime ::+  (Integral t, Integral t1) =>+     t          -- ^ Correction for system delays (e.g. processing and network time). Positive+  -> t1         -- ^ "seconds from now" parameter. Positive +  -> IO UTCTime +tokenExpiryTime delta s = do+  tnow <- getCurrentTime+  let sd = fromIntegral s+      sdelta = fromIntegral delta+  return $ addUTCTime (sd - sdelta) tnow
+ src/Network/Goggles/Auth/TokenExchange.hs view
@@ -0,0 +1,144 @@+{-# language OverloadedStrings, DeriveGeneric, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# language FlexibleContexts, MultiParamTypeClasses, DataKinds, FlexibleInstances #-}+module Network.Goggles.Auth.TokenExchange (+    scopesDefault+  , GCP+  , requestTokenGCP+  , getObject+  , getObjectMetadata+  , putObject+  , listObjects+                                          ) where++import Data.Monoid ((<>))++import Network.HTTP.Req+import Control.Monad.Catch+import Control.Monad.Reader+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Text.Encoding as T (encodeUtf8, decodeUtf8)+import qualified Crypto.Random.Types as CR++import Network.Goggles.Cloud+import Network.Goggles.Types+import Network.Goggles.Auth.OAuth2+import Network.Goggles.Auth.JWT+import Network.Utils.HTTP (putLbs, getLbs, urlEncode)+++++-- * The GCP type++data GCP++instance HasCredentials GCP where+  type Credentials GCP = GCPServiceAccount+  type Options GCP = [T.Text]+  type TokenContent GCP = T.Text+  tokenFetch = requestTokenGCP++instance Show (Token GCP) where+  show (Token tok time) = unwords ["GCP Token :", T.unpack tok, "; expires at :", show time]++-- | We can provide a custom http exception handler rather than throwing exceptions with this instance  +instance MonadHttp (Cloud GCP) where+  handleHttpException = throwM++++++-- * Constants++-- | OAuth2 scopes for the various Google Cloud Platform services.+--+-- Please refer to +--+-- > https://developers.google.com/identity/protocols/googlescopes+-- +-- for the full list+scopesDefault :: [T.Text]+scopesDefault = ["https://www.googleapis.com/auth/cloud-platform"]++uriBase :: Url 'Https+uriBase = https "www.googleapis.com"++++-- * Google Cloud Storage (GCS)++-- | `getObject b p` retrieves the contents of a GCS object (of full path `p`) in bucket `b`+getObject :: T.Text -> T.Text -> Cloud GCP LbsResponse+getObject b p = do+  tok <- accessToken +  let+    opts = oAuth2Bearer (T.encodeUtf8 tok) <>+           altMedia+    uri = uriBase /: "storage" /: "v1" /: "b" /: b /: "o" /: p+  getLbs uri opts++-- | `getObjectMetadata b p` retrieves the metadata of a GCS object (of full path `p`) in bucket `b`+getObjectMetadata :: T.Text -> T.Text -> Cloud GCP LbsResponse+getObjectMetadata b p = do+  tok <- accessToken +  let+    opts = oAuth2Bearer (T.encodeUtf8 tok)+    uri = uriBase /: "storage" /: "v1" /: "b" /: b /: "o" /: p+  getLbs uri opts++--+-- GET https://www.googleapis.com/storage/v1/b/bucket/o+-- | `listObjects b` retrieves a list of objects stored in bucket `b`+listObjects :: T.Text -> Cloud GCP LbsResponse+listObjects b = do+  tok <- accessToken +  let+    opts = oAuth2Bearer (T.encodeUtf8 tok)+    uri = uriBase /: "storage" /: "v1" /: "b" /: b /: "o"+  getLbs uri opts++-- | `putObject b p body` uploads a bytestring `body` into a GCS object (of full path `p`) in bucket `b`+putObject :: T.Text -> T.Text -> LB.ByteString -> Cloud GCP LbsResponse+putObject b objName body = do+  tok <- accessToken+  let+    opts = oAuth2Bearer (T.encodeUtf8 tok) <>+           ulMedia <>+           ("name" =: objName)+    uri = uriBase /: "upload" /: "storage" /: "v1" /: "b" /: b /: "o"+  putLbs uri opts body +++  +-- | Constant request parameters required by GCS calls+altMedia, ulMedia :: Option 'Https+altMedia = "alt" =: ("media" :: T.Text)+ulMedia = "uploadType" =: ("media" :: T.Text)++  ++++-- | Implementation of `tokenFetch`+requestTokenGCP :: Cloud GCP (Token GCP)+requestTokenGCP = do+   saOk <- asks credentials+   scopes <- asks options+   let opts = GCPTokenOptions scopes+   t0 <- requestGcpOAuth2Token saOk opts+   tutc <- mkOAuth2TokenUTC (2 :: Int) t0+   return (Token (oauTokenString tutc) (oauTokenExpiry tutc))+++-- | Request an OAuth2Token+requestGcpOAuth2Token :: (MonadThrow m, CR.MonadRandom m, MonadHttp m) =>+     GCPServiceAccount -> GCPTokenOptions -> m OAuth2Token+requestGcpOAuth2Token serviceAcct opts = do+  jwt <- T.decodeUtf8 <$> encodeBearerJWT serviceAcct opts+  requestOAuth2Token+      (uriBase /: "oauth2" /: "v4" /: "token")+      [("grant_type", T.pack $ urlEncode "urn:ietf:params:oauth:grant-type:jwt-bearer"),+       ("assertion", jwt)]+      (header "Content-Type" "application/x-www-form-urlencoded; charset=utf-8")
+ src/Network/Goggles/Cloud.hs view
@@ -0,0 +1,164 @@+{-# language OverloadedStrings, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# language FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable #-}+{-# language UndecidableInstances #-}+module Network.Goggles.Cloud (+    Cloud(..)+  , evalCloudIO+  , liftCloudIO+  , HasCredentials(..)+  , Token(..)+  , accessToken+  , refreshToken+  , Handle(..)+  , createHandle+                             ) where++import Control.Applicative (Alternative(..))+import Control.Monad.IO.Class+import Control.Monad.Catch+import Control.Monad.Reader+import qualified Control.Monad.Trans.Reader as RT (ask, local)+import Crypto.Random.Types (MonadRandom(..))+import Crypto.Random.Entropy (getEntropy)+import Control.Exception (AsyncException, fromException)+import Control.Concurrent.STM+import Data.Time++import Network.Goggles.Control.Exceptions+++class HasCredentials c where+  type Credentials c+  type Options c+  type TokenContent c +  tokenFetch :: Cloud c (Token c)++-- | A 'Token' with an expiry date+data Token c = Token {+    tToken :: TokenContent c+  , tTime :: UTCTime+  }++data Handle c = Handle {+      credentials :: Credentials c+    , token :: TVar (Maybe (Token c))+    , options :: Options c+  }+++-- | `cacheToken tok hdl` : Overwrite the token TVar `tv` containing a token if `tok` carries a more recent timestamp.+cacheToken ::+  HasCredentials c => Token c -> Cloud c (Token c)+cacheToken tok = do+  tv <- asks token+  liftCloudIO $ atomically $ do+    current <- readTVar tv+    let new = case current of+          Nothing -> tok+          Just t -> if tTime t > tTime tok then t else tok+    writeTVar tv (Just new)+    return new++refreshToken :: HasCredentials c => Cloud c (Token c)+refreshToken = tokenFetch >>= cacheToken++++-- | Extract the token content (needed to authenticate subsequent requests). The token will be valid for at least 60 seconds+accessToken :: HasCredentials c => Cloud c (TokenContent c)+accessToken = do+    tokenTVar <- asks token +    mbToken <- liftCloudIO $ atomically $ readTVar tokenTVar+    tToken <$> case mbToken of+        Nothing -> refreshToken +        Just t -> do+            now <- liftCloudIO $ getCurrentTime+            if now > addUTCTime (- 60) (tTime t)+                then refreshToken +                else return t  +  +-- | Create a 'Handle' with an empty token+createHandle :: HasCredentials c => Credentials c -> Options c -> IO (Handle c) +createHandle sa opts = Handle <$> pure sa <*> newTVarIO Nothing <*> pure opts++-- | The main type of the library. It can easily be re-used in libraries that interface with more than one cloud API provider because its type parameter `c` lets us be declare distinct behaviours for each.+newtype Cloud c a = Cloud {+  runCloud :: ReaderT (Handle c) IO a+  } deriving (Functor, Applicative, Monad)+++instance HasCredentials c => Alternative (Cloud c) where+    empty = throwM $ UnknownError "empty"+    a1 <|> a2 = do+      ra <- try a1+      case ra of+        Right x -> pure x+        Left e -> case (fromException e) :: Maybe CloudException of+          Just _ -> a2+          Nothing -> throwM (UnknownError "Uncaught exception (not a CloudException)")+++-- -- | NB : this works similarly to <|> in the Alternative instance; it must discard information on which exception case occurred+-- tryOrElse :: MonadCatch m => m b -> m b -> m b+-- tryOrElse a1 a2 = do+--   ra <- try a1+--   case ra of+--     Right x -> pure x+--     Left e -> case (e :: CloudException) of _ -> a2+++++-- | Lift an `IO a` action into the 'Cloud' monad+liftCloudIO_ :: IO a -> Cloud c a+liftCloudIO_ m = Cloud $ ReaderT (const m)++-- | Lift an `IO a` action into the 'Cloud' monad, and catch synchronous exceptions, while rethrowing the asynchronous ones to IO+liftCloudIO :: HasCredentials c => IO a -> Cloud c a+liftCloudIO m = do+  liftCloudIO_ m `catch` \e -> case fromException e of +    Just asy -> throwM (asy :: AsyncException)+    Nothing -> throwM $ IOError (show e)+++++  ++-- | Evaluate a 'Cloud' action, given a 'Handle'.+--+-- NB : Assumes all exceptions are handled by `throwM`+evalCloudIO :: Handle c -> Cloud c a -> IO a+evalCloudIO r (Cloud b) = runReaderT b r `catch` \e -> case (e :: CloudException) of +  ex -> throwM ex++++++++++instance HasCredentials c => MonadIO (Cloud c) where+  liftIO = liftCloudIO++instance HasCredentials c => MonadThrow (Cloud c) where+  throwM = liftIO . throwM++instance HasCredentials c => MonadCatch (Cloud c) where+  catch (Cloud (ReaderT m)) c =+    Cloud $ ReaderT $ \r -> m r `catch` \e -> runReaderT (runCloud $ c e) r+  +{- | the whole point of this parametrization is to have a distinct MonadHttp for each API provider/DSP++instance HasCredentials c => MonadHttp (Boo c) where+  handleHttpException = throwM+-}++instance HasCredentials c => MonadRandom (Cloud c) where+  getRandomBytes = liftIO . getEntropy++instance HasCredentials c => MonadReader (Handle c) (Cloud c) where+  ask = Cloud RT.ask+  local f m = Cloud $ RT.local f (runCloud m)
+ src/Network/Goggles/Control/Exceptions.hs view
@@ -0,0 +1,43 @@+module Network.Goggles.Control.Exceptions (+    KeyException(..)+  , JWTError(..)+  , TokenExchangeException(..)+  , CloudException(..)+  )where++import Control.Exception+import Data.Typeable++-- | Authentication key exceptions+data KeyException =+    NoSecretFound !String+  | NoParsePK !String+  | NoRSAKey !String+  deriving (Eq, Show, Typeable)+instance Exception KeyException++-- | Errors associated with JWT-encoded token request+data JWTError =+    BadExpirationTime !String+  | CryptoSignError !String+  deriving (Show, Typeable)+instance Exception JWTError where+++-- | Token exchange exceptions+data TokenExchangeException =+    NotFound !String               -- ^ Something went wrong with the request, token not found+  | APICredentialsNotFound !String -- ^ +  deriving (Show, Typeable)+instance Exception TokenExchangeException++-- | Cloud API exception+data CloudException =+    UnknownError !String+  | IOError !String+  | TimeoutError !String+  | JsonDecodeError !String+  deriving (Show, Typeable)+instance Exception CloudException++
+ src/Network/Goggles/Types.hs view
@@ -0,0 +1,24 @@+{-# language TypeFamilies, FlexibleInstances #-}+module Network.Goggles.Types (+    GCPServiceAccount(..)+  , GCPTokenOptions(..) ) where++import qualified Data.Text as T+import Crypto.PubKey.RSA.Types+++++-- | Credentials for Google Cloud Platform+data GCPServiceAccount = GCPServiceAccount {+    _servicePrivateKey :: PrivateKey  -- ^ Private key (i.e. the PEM string obtained from the Google API Console)+  , _serviceEmail :: T.Text    -- ^ Email address of the service account (ending in .gserviceaccount.com )+  , _serviceAccountUser :: Maybe T.Text -- ^ email address of the user for which the application is requesting delegated access (defaults to the service account email if Nothing)+  , _gcpServiceAcctSecret :: T.Text -- ^ Service account secret+                                     } deriving (Eq, Show)++++data GCPTokenOptions = GCPTokenOptions {+    _tokenOptionsScopes :: [T.Text] -- ^ authentication scopes that the application requests+                                 } deriving (Eq, Show)
+ src/Network/Utils/HTTP.hs view
@@ -0,0 +1,69 @@+{-# language OverloadedStrings, FlexibleContexts #-}+module Network.Utils.HTTP where++import qualified Data.Text as T+import qualified Data.Text.Encoding as T (encodeUtf8)+import qualified Data.ByteString.Lazy as LB+import Data.Char ( isAscii, isAlphaNum, digitToInt )+import Network.HTTP.Req++import Network.Goggles.Cloud++++getLbs :: (HasCredentials c, MonadHttp (Cloud c)) =>+               Url scheme -> Option scheme -> Cloud c LbsResponse+getLbs uri opts = req GET uri NoReqBody lbsResponse opts ++postLbs :: (HasCredentials c, MonadHttp (Cloud c)) =>+               Url scheme -> Option scheme -> LB.ByteString -> Cloud c LbsResponse+postLbs uri opts body = req POST uri (ReqBodyLbs body) lbsResponse opts++putLbs :: (HasCredentials c, MonadHttp (Cloud c)) =>+               Url scheme -> Option scheme -> LB.ByteString -> Cloud c LbsResponse+putLbs uri opts body = req PUT uri (ReqBodyLbs body) lbsResponse opts++++++-- | produce a '&'-separated list of parameters that can be passed to an HTTP querty from a list of key, value pairs +encodeHttpParametersLB :: [(T.Text, T.Text)] -> LB.ByteString+encodeHttpParametersLB ps = LB.fromStrict $ T.encodeUtf8 $ T.intercalate "&" $ map ins ps where+  ins (k, v) = T.concat [k, "=", v]++encodeHttpParameters :: (QueryParam p, Monoid p) => [(T.Text, T.Text)] -> p+encodeHttpParameters ll = mconcat $ map ins ll where+  ins (a, b) = a =: b++++-- http://hackage.haskell.org/package/HTTP-4000.2.3/docs/src/Network-HTTP-Base.html++urlEncode :: String -> String+urlEncode     [] = []+urlEncode (ch:t) +  | (isAscii ch && isAlphaNum ch) || ch `elem` ("-_.~" :: String) = ch : urlEncode t+  | not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch))+  | otherwise = escape (fromEnum ch) (urlEncode t)+    where+     escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs)+     +     showH x xs+       | x <= 9    = toEnum (o_0 + x) : xs+       | otherwise = toEnum (o_A + (x-10)) : xs+      where+       o_0 = fromEnum '0'+       o_A = fromEnum 'A'++     eightBs :: [Int]  -> Int -> [Int]+     eightBs acc x+      | x <= 0xff = (x:acc)+      | otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256)+++urlDecode :: String -> String+urlDecode ('%':a:b:rest) = toEnum (16 * digitToInt a + digitToInt b)+                         : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}