diff --git a/google-server-api.cabal b/google-server-api.cabal --- a/google-server-api.cabal +++ b/google-server-api.cabal @@ -1,88 +1,66 @@ -name: google-server-api -version: 0.2.0.1 -synopsis: Google APIs for server to server applications -description: - This library provides a way to use Google API for server to server applications. -homepage: https://github.com/arowM/haskell-google-server-api#readme -license: MIT -license-file: LICENSE -author: Kadzuya Okamoto -maintainer: arow.okamoto+github@gmail.com -copyright: 2018 Kadzuya Okamoto -category: Web -build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f103dcbf98029b7f6d92e1567345d75693b1ffe818a833de202c0c5225fb5777 -library - hs-source-dirs: src - exposed-modules: Google.Client - , Google.Form - , Google.JWT - , Google.Response - build-depends: base >= 4.9 && < 5 - , aeson >= 1.1 - , aeson-casing >= 0.1 - , base64-bytestring >= 1.0 - , bytestring >= 0.10 - , http-api-data >= 0.3 - , http-client >= 0.3 - , http-client-tls >= 0.3 - , HsOpenSSL >= 0.11 - , mime-mail >= 0.4 - , monad-control >= 1.0 - , monad-logger >= 0.3 - , mtl >= 2.2 - , RSA >= 2.3 - , servant >= 0.1 - , servant-client >= 0.2 - , text >= 1.2 - , time >= 1.6 - , transformers >= 0.5 - , transformers-base >= 0.4 - , unix-time >= 0.3 - , unordered-containers >= 0.2 - , wai >= 3.2 - , wai-extra >= 3.0 - , warp >= 3.2 - default-language: Haskell2010 - ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction - default-extensions: ConstraintKinds - , DataKinds - , DefaultSignatures - , DeriveDataTypeable - , DeriveFunctor - , DeriveGeneric - , DuplicateRecordFields - , EmptyDataDecls - , FlexibleContexts - , FlexibleInstances - , GADTs - , GeneralizedNewtypeDeriving - , InstanceSigs - , LambdaCase - , MultiParamTypeClasses - , NamedFieldPuns - , NoMonomorphismRestriction - , OverloadedLabels - , OverloadedStrings - , PackageImports - , PartialTypeSignatures - , PatternSynonyms - , PolyKinds - , RankNTypes - , RecordWildCards - , ScopedTypeVariables - , StandaloneDeriving - , TupleSections - , TypeApplications - , TypeFamilies - , TypeOperators - , ViewPatterns - other-extensions: OverloadedLists - , QuasiQuotes - , TemplateHaskell +name: google-server-api +version: 0.3.0.0 +synopsis: Google APIs for server to server applications +description: This library provides a way to use Google API for server to server applications. +category: Web +homepage: https://github.com/arowM/haskell-google-server-api#readme +bug-reports: https://github.com/arowM/haskell-google-server-api/issues +author: Kadzuya Okamoto +maintainer: arow.okamoto+github@gmail.com +copyright: 2018 Kadzuya Okamoto +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.md source-repository head - type: git + type: git location: https://github.com/arowM/haskell-google-server-api + +library + exposed-modules: + Google.Client + Google.Form + Google.JWT + Google.Response + other-modules: + Paths_google_server_api + hs-source-dirs: + src + default-extensions: AutoDeriveTypeable BangPatterns BinaryLiterals ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MonadFailDesugaring MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving Strict StrictData TupleSections TypeFamilies TypeSynonymInstances ViewPatterns + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + HsOpenSSL >=0.11.4.13 + , RSA >=2.3.0 + , aeson >=1.2.4.0 + , aeson-casing >=0.1.0.5 + , base >=4.9 && <5 + , base64-bytestring >=1.0.0.1 + , bytestring >=0.10.8.2 + , http-api-data >=0.3.7.2 + , http-client >=0.5.10 + , http-client-tls >=0.3.5.3 + , mime-mail >=0.4.14 + , monad-control >=1.0.2.3 + , monad-logger >=0.3.28.1 + , mtl >=2.2.2 + , servant >=0.13 + , servant-client >=0.13 + , text >=1.2.3.0 + , time >=1.8.0.2 + , transformers >=0.5.2.0 + , transformers-base >=0.4.4 + , unix-time >=0.3.8 + , unordered-containers >=0.2.9.0 + , wai >=3.2.1.1 + , wai-extra >=3.0.22.0 + , warp >=3.2.18.1 + default-language: Haskell2010 diff --git a/src/Google/Client.hs b/src/Google/Client.hs --- a/src/Google/Client.hs +++ b/src/Google/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} {- | Module : Google.Client @@ -9,17 +10,11 @@ ( getToken , postCalendarEvent , postGmailSend - , run ) where -import Control.Monad ((<=<)) -import Control.Monad.Except (ExceptT(..), MonadError, runExceptT, throwError) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Logger (MonadLogger, logError) -import Control.Monad.Reader (MonadReader, ask) -import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.Aeson (FromJSON, ToJSON) import Data.ByteString.Base64.URL (encode) +import qualified Data.ByteString.Lazy as LBS import Data.Data (Data) import Data.Monoid ((<>)) import Data.Proxy (Proxy(..)) @@ -27,7 +22,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Typeable (Typeable) import GHC.Generics (Generic) -import Network.HTTP.Client (HasHttpManager(..), newManager) +import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.Mail.Mime import Servant.API @@ -44,20 +39,16 @@ ) import Servant.Client ( BaseUrl(BaseUrl) - , ClientEnv(..) , ClientM , Scheme(..) , ServantError , client + , mkClientEnv , runClientM ) -import Google.JWT (JWT) - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T -import qualified Data.Text.IO as T import qualified Google.Form as Form +import Google.JWT (JWT) import qualified Google.JWT as JWT import qualified Google.Response as Response @@ -103,87 +94,47 @@ getToken' :<|> postCalendarEvent' :<|> postGmailSend' = client api getToken :: - (HasHttpManager r, MonadError ServantError m, MonadIO m, MonadReader r m) - => Maybe JWT.Email + Maybe JWT.Email -> JWT -> [JWT.Scope] - -> m Response.Token -getToken maccount jwt scopes = - (liftEither =<<) . runExceptT . ExceptT $ do - manager <- liftIO $ newManager tlsManagerSettings - Right a <- liftIO $ JWT.getSignedJWT jwt maccount scopes Nothing - liftIO $ - runClientM - (getToken' $ - Form.Token - { grantType = googleGrantType - , assertion = decodeUtf8 . JWT.unSignedJWT $ a - }) - (ClientEnv manager googleBaseUrl) + -> IO (Either ServantError Response.Token) +getToken maccount jwt scopes = do + manager <- newManager tlsManagerSettings + Right a <- JWT.getSignedJWT jwt maccount scopes Nothing + runClientM + (getToken' $ + Form.Token + { grantType = googleGrantType + , assertion = decodeUtf8 . JWT.unSignedJWT $ a + }) + (mkClientEnv manager googleBaseUrl) postCalendarEvent :: - (HasHttpManager r, MonadError ServantError m, MonadIO m, MonadReader r m) - => Response.Token + Response.Token -> Form.CalendarEvent - -> m Response.CalendarEvent -postCalendarEvent token event = - runExceptTIO . ExceptT $ do - manager <- newManager tlsManagerSettings - runClientM - (postCalendarEvent' - (Form.email . Form.creator $ event) - (pure . toBearer $ token) - event) - (ClientEnv manager googleBaseUrl) + -> IO (Either ServantError Response.CalendarEvent) +postCalendarEvent token event = do + manager <- newManager tlsManagerSettings + runClientM + (postCalendarEvent' + (Form.email . Form.creator $ event) + (pure . toBearer $ token) + event) + (mkClientEnv manager googleBaseUrl) postGmailSend :: - (HasHttpManager r, MonadError ServantError m, MonadIO m, MonadReader r m) - => Response.Token - -> Form.Email - -> m Response.GmailSend -postGmailSend token email = - runExceptTIO . ExceptT $ do - manager <- newManager tlsManagerSettings - mail <- liftIO (renderMail' =<< Form.toMail email) - let gmailSend = - Form.GmailSend {raw = decodeUtf8 $ encode $ LBS.toStrict mail} - T.putStrLn $ "gmailSend: " <> tshow gmailSend - T.putStrLn $ "from: " <> tshow (Form.to email) - runClientM - (postGmailSend' (pure . toBearer $ token) gmailSend) - (ClientEnv manager googleBaseUrl) + Response.Token -> Form.Email -> IO (Either ServantError Response.GmailSend) +postGmailSend token email = do + manager <- newManager tlsManagerSettings + mail <- (renderMail' =<< Form.toMail email) + let gmailSend = Form.GmailSend {raw = decodeUtf8 $ encode $ LBS.toStrict mail} + runClientM + (postGmailSend' (pure . toBearer $ token) gmailSend) + (mkClientEnv manager googleBaseUrl) toBearer :: Response.Token -> Bearer toBearer Response.Token {accessToken} = Bearer $ "Bearer " <> accessToken -{- | Convert `ServantError` to arbitrary error type. --} -run :: - forall r m a e. - ( HasHttpManager r - , MonadIO m - , MonadError e m - , MonadLogger m - , MonadReader r m - ) - => e - -> ReaderT r (ExceptT ServantError IO) a - -> m a -run err m = either doGoogleErr pure =<< run' m - where - doGoogleErr :: forall x. ServantError -> m x - doGoogleErr googleErr = do - $(logError) $ "Got error response from google API: " <> tshow googleErr - throwError err - -run' :: - forall r n e a. (HasHttpManager r, MonadIO n, MonadReader r n) - => ReaderT r (ExceptT e IO) a - -> n (Either e a) -run' m = do - r <- ask - liftIO . runExceptT $ runReaderT m r - {- ================= - Constant values - ================= -} @@ -192,15 +143,3 @@ googleBaseUrl :: BaseUrl googleBaseUrl = BaseUrl Https "www.googleapis.com" 443 "" - -{- ================= - - Helper functions - - ================= -} -liftEither :: (MonadError e m) => Either e a -> m a -liftEither = either throwError pure - -runExceptTIO :: (MonadError e m, MonadIO m) => ExceptT e IO a -> m a -runExceptTIO = liftEither <=< liftIO . runExceptT - -tshow :: Show a => a -> Text -tshow = T.pack . show diff --git a/src/Google/Form.hs b/src/Google/Form.hs --- a/src/Google/Form.hs +++ b/src/Google/Form.hs @@ -18,6 +18,7 @@ import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.Maybe (maybeToList) import Data.Monoid ((<>)) +import Data.String (IsString(..)) import Data.Text (Text) import Data.Text.Lazy (fromStrict) import Data.Time.Clock (UTCTime) @@ -34,6 +35,9 @@ } deriving (Eq, Generic, Show, Typeable) deriveJSON defaultOptions ''Account + +instance IsString Account where + fromString = Account . fromString data DateTime = DateTime { dateTime :: UTCTime