goggles 0.1.0.3 → 0.2

raw patch · 12 files changed

+145/−341 lines, 12 filesdep ~reqPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: req

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• README.md +13/−2
• goggles.cabal +10/−7
• src/Network/Goggles.hs +13/−23
• src/Network/Goggles/Auth.hs +6/−0
• src/Network/Goggles/Auth/JWT.hs +0/−72
• src/Network/Goggles/Auth/TokenExchange.hs +0/−144
• src/Network/Goggles/Cloud.hs +66/−67
• src/Network/Goggles/Control/Exceptions.hs +1/−0
• src/Network/Goggles/Types.hs +1/−20
• src/Network/Utils/HTTP.hs +6/−6
• test/LibSpec.hs +26/−0

@@ -0,0 +1,3 @@+	0.2+	* Rename Cloud to WebApiM+	* Stackage LTS 10.5 (ghc 8.2.2)

@@ -1,10 +1,19 @@ # goggles -[![Build Status](https://travis-ci.org/ocramz/goggles.png)](https://travis-ci.org/ocramz/goggles)+[![Build Status](https://travis-ci.org/ocramz/goggles.png)](https://travis-ci.org/ocramz/goggles) [![Hackage version](https://img.shields.io/hackage/v/goggles.svg?label=Hackage)](https://hackage.haskell.org/package/goggles) [![Stackage version](https://www.stackage.org/package/goggles/badge/lts?label=Stackage)](https://www.stackage.org/package/goggles) -Haskell Interface to the Google Cloud APIs +Extensible Haskell interface to web APIs. +The library provides a type, `WebApiM`, and a set of helper functions useful for interfacing with remote services.++Features:++* Easily extensible+* Automatic handling of session tokens with finite expiry time+++ ## Instructions and examples  All instructions and API documentation are available as Haddocks in the main module, `Network.Goggles`@@ -16,4 +25,6 @@  * [`google-cloud`](hackage.haskell.org/package/google-cloud) * [`gogol`](hackage.haskell.org/package/gogol)++ 

@@ -1,5 +1,5 @@ name:                goggles-version:             0.1.0.3+version:             0.2 synopsis:            Interface to Google Cloud APIs description:         High-level, extensible interface to Google Cloud APIs.  homepage:            https://github.com/ocramz/goggles@@ -11,6 +11,7 @@ category:            Network build-type:          Simple extra-source-files:  README.md+                     CHANGELOG.md cabal-version:       >=1.10 tested-with:         GHC == 8.2 @@ -19,20 +20,21 @@   ghc-options:         -Wall   hs-source-dirs:      src   exposed-modules:     Network.Goggles+                       Network.Goggles.Auth   other-modules:       Data.Keys                        Network.Goggles.Cloud                        Network.Utils.HTTP                        Network.Goggles.Types-                       Network.Goggles.Auth.JWT+                       -- Network.Goggles.Auth.JWT                        Network.Goggles.Auth.OAuth2-                       Network.Goggles.Auth.TokenExchange+                       -- Network.Goggles.Auth.TokenExchange                        Network.Goggles.Control.Exceptions   build-depends:       base >= 4.7 && < 5                      , binary                      , scientific                      , attoparsec                      , aeson-                     , req >= 0.3+                     , req >= 0.5                      , http-client                      , http-client-tls                      , http-types@@ -53,9 +55,9 @@                      , containers                      , exceptions                      , filepath-                     -- * DEBUG-                     , hspec-                     , QuickCheck+                     -- -- * DEBUG+                     -- , hspec+                     -- , QuickCheck       @@ -73,6 +75,7 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test   main-is:             Spec.hs+  other-modules:       LibSpec   build-depends:       base                      , goggles                      , hspec

@@ -1,8 +1,5 @@-{-| This module is the entry point to the @goggles@ library, which is a Haskell interface to the cloud services hosted by Google (e.g. storage, compute, mail, etc.: <https://cloud.google.com/>) .--Most Google Cloud Platform (GCP) functionality requires authentication, which must be obtained beforehand from the website either with a free trial or a paid plan.--From now on, we'll assume the user has such credentials and is able to load them alongside this library.+{-|+== /Dependencies/  The examples require the following declarations (which in turn mean that the @req@ and @bytestring@ libraries are imported by the user's project). You will also need the @OverloadedStrings@ language extension : @@ -27,28 +24,21 @@ >   pvtkey <- parseRSAPrivateKey key >   let creds = GCPServiceAccount pvtkey usr Nothing "" >   hdl <- createHandle creds scopesDefault->   responseBody <$> evalCloudIO hdl (listObjects bucket)+>   responseBody <$> evalWebApiIO hdl (listObjects bucket)   -} module Network.Goggles (-  -- * API endpoints-  -- ** Google Cloud Storage-    getObject-  , listObjects-  , putObject-  -- ** GCP Authentication scopes-  , scopesDefault-  -- ** Running Cloud programs-  , createHandle    -  , evalCloudIO-  -- *** Executing IO actions within 'Cloud'-  , liftCloudIO+  -- ** Running WebApiM programs+    createHandle    +  , evalWebApiIO+  -- *** "Lifting" IO programs into 'WebApiM'+  , liftWebApiIO   -- * Types-  , GCP-  , GCPServiceAccount(..)-  , GCPTokenOptions(..)-  , Cloud(..)+  -- , GCP+  -- , GCPServiceAccount(..)+  -- , GCPTokenOptions(..)+  , WebApiM(..)   -- ** Authentication   , HasCredentials(..)   , Token(..)@@ -68,7 +58,7 @@ import Network.Goggles.Control.Exceptions  import Network.Goggles.Cloud import Network.Goggles.Types-import Network.Goggles.Auth.TokenExchange+-- import Network.Goggles.Auth.TokenExchange import Data.Keys  -- import System.Environment (lookupEnv) 

@@ -0,0 +1,6 @@+{-# language OverloadedStrings, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# language RankNTypes #-}+module Network.Goggles.Auth where++import Network.Goggles.Auth.OAuth2+-- import Network.Goggles.Auth.JWT

@@ -1,72 +0,0 @@-{-# 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

@@ -1,144 +0,0 @@-{-# 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")

@@ -2,9 +2,9 @@ {-# language FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable #-} {-# language UndecidableInstances #-} module Network.Goggles.Cloud (-    Cloud(..)-  , evalCloudIO-  , liftCloudIO+    WebApiM(..)+  , evalWebApiIO+  , liftWebApiIO   , HasCredentials(..)   , Token(..)   , accessToken@@ -32,7 +32,7 @@   type Credentials c   type Options c   type TokenContent c -  tokenFetch :: Cloud c (Token c)+  tokenFetch :: WebApiM c (Token c)  -- | An authentication 'Token' with an expiry date data Token c = Token {@@ -52,48 +52,14 @@   }  --- | `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+newtype WebApiM c a = WebApiM {+  runWebApiM :: ReaderT (Handle c) IO a   } deriving (Functor, Applicative, Monad)  -instance HasCredentials c => Alternative (Cloud c) where+instance HasCredentials c => Alternative (WebApiM c) where     empty = throwM $ UnknownError "empty"     a1 <|> a2 = do       ra <- try a1@@ -115,46 +81,41 @@   --- | 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 'WebApiM' monad+liftWebApiIO_ :: IO a -> WebApiM c a+liftWebApiIO_ m = WebApiM $ 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 +-- | Lift an `IO a` action into the 'WebApiM' monad, and catch synchronous exceptions, while rethrowing the asynchronous ones to IO+liftWebApiIO :: HasCredentials c => IO a -> WebApiM c a+liftWebApiIO m = do+  liftWebApiIO_ m `catch` \e -> case fromException e of      Just asy -> throwM (asy :: AsyncException)     Nothing -> throwM $ IOError (show e)    -  ---- | Evaluate a 'Cloud' action, given a 'Handle'.+ +-- | Evaluate a 'WebApiM' 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 +evalWebApiIO :: Handle c -> WebApiM c a -> IO a+evalWebApiIO r (WebApiM 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 => MonadIO (WebApiM c) where+  liftIO = liftWebApiIO -instance HasCredentials c => MonadThrow (Cloud c) where+instance HasCredentials c => MonadThrow (WebApiM 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+instance HasCredentials c => MonadCatch (WebApiM c) where+  catch (WebApiM (ReaderT m)) c =+    WebApiM $ ReaderT $ \r -> m r `catch` \e -> runReaderT (runWebApiM $ c e) r    {- | the whole point of this parametrization is to have a distinct MonadHttp for each API provider/DSP @@ -162,9 +123,47 @@   handleHttpException = throwM -} -instance HasCredentials c => MonadRandom (Cloud c) where+instance HasCredentials c => MonadRandom (WebApiM 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)+instance HasCredentials c => MonadReader (Handle c) (WebApiM c) where+  ask = WebApiM RT.ask+  local f m = WebApiM $ RT.local f (runWebApiM m)+++++-- | `cacheToken tok hdl` : Overwrite the token TVar `tv` containing a token if `tok` carries a more recent timestamp.+cacheToken ::+  HasCredentials c => Token c -> WebApiM c (Token c)+cacheToken tok = do+  tv <- asks token+  liftWebApiIO $ 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 => WebApiM 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 => WebApiM c (TokenContent c)+accessToken = do+    tokenTVar <- asks token +    mbToken <- liftWebApiIO $ atomically $ readTVar tokenTVar+    tToken <$> case mbToken of+        Nothing -> refreshToken +        Just t -> do+            now <- liftWebApiIO $ 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

@@ -37,6 +37,7 @@   | IOError !String   | TimeoutError !String   | JsonDecodeError !String+  | XMLDecodeError !String   deriving (Show, Typeable) instance Exception CloudException 

@@ -1,24 +1,5 @@ {-# language TypeFamilies, FlexibleInstances #-}-module Network.Goggles.Types (-    GCPServiceAccount(..)-  , GCPTokenOptions(..) ) where+module Network.Goggles.Types 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)

@@ -11,16 +11,16 @@   -getLbs :: (HasCredentials c, MonadHttp (Cloud c)) =>-               Url scheme -> Option scheme -> Cloud c LbsResponse+getLbs :: (HasCredentials c, MonadHttp (WebApiM c)) =>+               Url scheme -> Option scheme -> WebApiM 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 :: (HasCredentials c, MonadHttp (WebApiM c)) =>+               Url scheme -> Option scheme -> LB.ByteString -> WebApiM 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 :: (HasCredentials c, MonadHttp (WebApiM c)) =>+               Url scheme -> Option scheme -> LB.ByteString -> WebApiM c LbsResponse putLbs uri opts body = req PUT uri (ReqBodyLbs body) lbsResponse opts  

@@ -0,0 +1,26 @@+{-# language OverloadedStrings #-}+module LibSpec where++import Test.Hspec++-- import Test.Hspec.QuickCheck++-- import Network.Goggles++++main :: IO ()+main = hspec spec++spec :: Spec+spec =+  describe "Lib" $ do+    it "works" $ do+      True `shouldBe` True+    -- prop "ourAdd is commutative" $ \x y ->+    --   ourAdd x y `shouldBe` ourAdd y x++++  +