google-server-api (empty) → 0.1.0.0
raw patch · 8 files changed
+668/−0 lines, 8 filesdep +HsOpenSSLdep +RSAdep +aesonsetup-changed
Dependencies added: HsOpenSSL, RSA, aeson, aeson-casing, base, base64-bytestring, bytestring, http-api-data, http-client, http-client-tls, mime-mail, monad-control, monad-logger, mtl, read-env-var, servant, servant-client, text, time, transformers, transformers-base, unix-time, unordered-containers, wai, wai-extra, warp
Files
- LICENSE +65/−0
- README.md +3/−0
- Setup.hs +2/−0
- google-server-api.cabal +89/−0
- src/Google/Client.hs +205/−0
- src/Google/Form.hs +103/−0
- src/Google/JWT.hs +153/−0
- src/Google/Response.hs +48/−0
+ LICENSE view
@@ -0,0 +1,65 @@+Copyright Kadzuya Okamoto (c) 2018++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 Author name here 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.++Some codes in `Google.JWT` are copied from `google-oauth2-jwt` package.+(https://github.com/MichelBoucey/google-oauth2-jwt)+Here is original LICENSE for `google-oauth2-jwt`.++google-oauth2-jwt - Copyright Michel Boucey (c) 2016-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 Author Michel Boucey 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,3 @@+# google-server-api++This library provides functions to use [Google APIs for server to server applications](https://developers.google.com/identity/protocols/OAuth2ServiceAccount).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ google-server-api.cabal view
@@ -0,0 +1,89 @@+name: google-server-api+version: 0.1.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.+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++library+ hs-source-dirs: src+ exposed-modules: Google.Client+ , Google.Form+ , Google.JWT+ , Google.Response+ build-depends: base >= 4.7 && < 5+ , aeson+ , aeson-casing+ , base64-bytestring+ , bytestring+ , http-api-data+ , http-client+ , http-client-tls+ , HsOpenSSL+ , mime-mail+ , monad-control+ , monad-logger+ , mtl+ , read-env-var+ , RSA+ , servant+ , servant-client+ , text+ , time+ , transformers+ , transformers-base+ , unix-time+ , unordered-containers+ , wai+ , wai-extra+ , warp+ 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++source-repository head+ type: git+ location: https://github.com/arowM/haskell-google-server-api
+ src/Google/Client.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE TemplateHaskell #-}++{- |+Module : Google.Client++Define functions to call Google APIs.+-}+module Google.Client+ ( 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 Data.Data (Data)+import Data.Monoid ((<>))+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Network.HTTP.Client (HasHttpManager(..), newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.Mail.Mime+import Servant.API+ ( (:<|>)(..)+ , (:>)+ , Capture+ , FormUrlEncoded+ , FromHttpApiData+ , Header+ , JSON+ , Post+ , ReqBody+ , ToHttpApiData+ )+import Servant.Client+ ( BaseUrl(BaseUrl)+ , ClientEnv(..)+ , ClientM+ , Scheme(..)+ , ServantError+ , client+ , 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 qualified Google.JWT as JWT+import qualified Google.Response as Response++newtype Bearer = Bearer+ { _unBearer :: Text+ } deriving ( Data+ , Eq+ , FromHttpApiData+ , FromJSON+ , Generic+ , Ord+ , Show+ , ToHttpApiData+ , ToJSON+ , Typeable+ )++type API+ = "oauth2" :> "v4" :> "token" :>+ ReqBody '[ FormUrlEncoded] Form.Token :>+ Post '[ JSON] Response.Token+ :<|> "calendar" :> "v3" :> "calendars" :>+ Capture "calendarId" Text :>+ "events" :>+ Header "Authorization" Bearer :>+ ReqBody '[ JSON] Form.CalendarEvent :>+ Post '[ JSON] Response.CalendarEvent+ :<|> "gmail" :> "v1" :> "users" :> "me" :> "messages" :> "send" :>+ Header "Authorization" Bearer :>+ ReqBody '[ JSON] Form.GmailSend :>+ Post '[ JSON] Response.GmailSend++api :: Proxy API+api = Proxy++getToken' :: Form.Token -> ClientM Response.Token+postCalendarEvent' ::+ Text+ -> Maybe Bearer+ -> Form.CalendarEvent+ -> ClientM Response.CalendarEvent+postGmailSend' :: Maybe Bearer -> Form.GmailSend -> ClientM Response.GmailSend+getToken' :<|> postCalendarEvent' :<|> postGmailSend' = client api++getToken ::+ (HasHttpManager r, MonadError ServantError m, MonadIO m, MonadReader r m)+ => 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)++postCalendarEvent ::+ (HasHttpManager r, MonadError ServantError m, MonadIO m, MonadReader r m)+ => 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)++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)++toBearer :: Response.Token -> Bearer+toBearer Response.Token {accessToken} = Bearer $ "Bearer " <> accessToken++run ::+ forall r m a e.+ ( HasHttpManager r+ , MonadIO m+ , MonadError e m+ , MonadLogger m+ , MonadReader r m+ , Show e+ )+ => e+ -> ReaderT r (ExceptT e IO) a+ -> m a+run err m = either doGoogleErr pure =<< run' m+ where+ doGoogleErr :: forall x. e -> 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+ - ================= -}+googleGrantType :: Text+googleGrantType = "urn:ietf:params:oauth:grant-type:jwt-bearer"++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
+ src/Google/Form.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}++{- |+Module : Google.Form++Define data types to represent all of the requests that are sent to the API.+-}+module Google.Form+ ( CalendarEvent(..)+ , GmailSend(..)+ , Account(..)+ , DateTime(..)+ , Email(..)+ , toMail+ , Token(..)+ ) where++import Data.Aeson.TH (defaultOptions, deriveJSON)+import Data.Maybe (maybeToList)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Lazy (fromStrict)+import Data.Time.Clock (UTCTime)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Network.Mail.Mime (Address(..), Mail(..), renderAddress, simpleMail)+import Web.FormUrlEncoded (Form(..), ToForm(toForm))+import Web.Internal.HttpApiData (toQueryParam)++import qualified Data.HashMap.Strict as HashMap++data Account = Account+ { email :: Text+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON defaultOptions ''Account++data DateTime = DateTime+ { dateTime :: UTCTime+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON defaultOptions ''DateTime++data CalendarEvent = CalendarEvent+ { creator :: Account+ , attendees :: [Account]+ , summary :: Text+ , description :: Text+ , start :: DateTime+ , end :: DateTime+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON defaultOptions ''CalendarEvent++data Token = Token+ { grantType :: Text+ , assertion :: Text+ } deriving (Eq, Generic, Show, Typeable)++instance ToForm Token where+ toForm token =+ Form . HashMap.fromList $+ [ ("grant_type", [toQueryParam (grantType token)])+ , ("assertion", [toQueryParam (assertion token)])+ ]++data Email = Email+ { to :: Text+ , from :: Text+ , replyTo :: Maybe Text+ , ccs :: [Text]+ , subject :: Text+ , body :: Text+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON defaultOptions ''Email++toMail :: Email -> IO Mail+toMail Email {..} = do+ mail <-+ simpleMail+ (Address Nothing to)+ (Address Nothing from)+ subject+ body'+ body'+ []+ pure $+ mail+ { mailHeaders =+ mailHeaders mail <> do+ rt <- maybeToList replyTo+ pure ("Reply-To", renderAddress $ Address Nothing rt)+ , mailCc = map (Address Nothing) ccs+ }+ where+ body' = fromStrict body++data GmailSend = GmailSend+ { raw :: Text+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON defaultOptions ''GmailSend
+ src/Google/JWT.hs view
@@ -0,0 +1,153 @@+-- | Create a signed JWT needed to make the access token request+-- to gain access to Google APIs for server to server applications.+--+-- For all usage details, see https://developers.google.com/identity/protocols/OAuth2ServiceAccount+--+-- This module is borrowed from google-oauth2-jwt package.+module Google.JWT+ ( JWT+ , HasJWT(..)+ , readServiceKeyFile+ , SignedJWT(..)+ , Email(..)+ , Scope(..)+ , getSignedJWT+ ) where++import Codec.Crypto.RSA.Pure+ ( PrivateKey(..)+ , PublicKey(..)+ , hashSHA256+ , rsassa_pkcs1_v1_5_sign+ )+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Data.Aeson ((.:), decode)+import Data.Aeson.Types (parseMaybe)+import Data.ByteString (ByteString)+import Data.ByteString.Base64.URL (encode)+import qualified Data.ByteString.Lazy as LBS+import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.Maybe (fromJust, fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.UnixTime (getUnixTime, utSeconds)+import Foreign.C.Types (CTime(..))+import OpenSSL.EVP.PKey (toKeyPair)+import OpenSSL.PEM (PemPasswordSupply(PwNone), readPrivateKey)+import OpenSSL.RSA (rsaD, rsaE, rsaN, rsaP, rsaQ, rsaSize)++class HasJWT a where+ getJwt :: a -> JWT++instance HasJWT JWT where+ getJwt :: JWT -> JWT+ getJwt = id++data JWT = JWT+ { clientEmail :: Email+ , privateKey :: PrivateKey+ } deriving (Eq, Show, Read)++readServiceKeyFile :: FilePath -> IO (Maybe JWT)+readServiceKeyFile fp = do+ content <- LBS.readFile fp+ runMaybeT $ do+ result <- MaybeT . pure . decode $ content+ (pkey, clientEmail) <-+ MaybeT . pure . flip parseMaybe result $ \obj -> do+ pkey <- obj .: "private_key"+ clientEmail <- obj .: "client_email"+ pure (pkey, clientEmail)+ liftIO $ JWT <$> (pure $ Email clientEmail) <*> (fromPEMString pkey)++newtype SignedJWT = SignedJWT+ { unSignedJWT :: ByteString+ } deriving (Eq, Show, Read, Ord)++newtype Email = Email+ { unEmail :: Text+ } deriving (Eq, Show, Read, Ord)++data Scope+ = ScopeCalendarFull+ | ScopeCalendarRead+ | ScopeGmailSend+ deriving (Eq, Show, Read, Ord)++{-| Make sure if you added new scope, update configuration in page bellow.+ https://admin.google.com/uzuz.jp/AdminHome?chromeless=1#OGX:ManageOauthClients+-}+scopeUrl :: Scope -> Text+scopeUrl ScopeCalendarFull = "https://www.googleapis.com/auth/calendar"+scopeUrl ScopeCalendarRead = "https://www.googleapis.com/auth/calendar.readonly"+scopeUrl ScopeGmailSend = "https://www.googleapis.com/auth/gmail.send"++-- | Get the private key obtained from the+-- Google API Console from a PEM 'String'.+--+-- >fromPEMString "-----BEGIN PRIVATE KEY-----\nB9e [...] bMdF\n-----END PRIVATE KEY-----\n"+-- >+fromPEMString :: String -> IO PrivateKey+fromPEMString s =+ fromJust . toKeyPair <$> readPrivateKey s PwNone >>= \k ->+ return+ PrivateKey+ { private_pub =+ PublicKey+ {public_size = rsaSize k, public_n = rsaN k, public_e = rsaE k}+ , private_d = rsaD k+ , private_p = rsaP k+ , private_q = rsaQ k+ , private_dP = 0+ , private_dQ = 0+ , private_qinv = 0+ }++-- | Create the signed JWT ready for transmission+-- in the access token request as assertion value.+--+-- >grant_type=urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Ajwt-bearer&assertion=+--+getSignedJWT ::+ JWT+ -> Maybe Email+ -- ^ The email address of the user for which the+ -- application is requesting delegated access.+ -> [Scope]+ -- ^ The list of the permissions that the application requests.+ -> Maybe Int+ -- ^ Expiration time (maximum and default value is an hour, 3600).+ -> IO (Either String SignedJWT) -- ^ Either an error message or a signed JWT.+getSignedJWT JWT {..} msub scs mxt = do+ let xt = fromIntegral (fromMaybe 3600 mxt)+ unless (xt >= 1 && xt <= 3600) (fail "Bad expiration time")+ t <- getUnixTime+ let i =+ mconcat+ [ header+ , "."+ , toB64 $+ mconcat+ [ "{\"iss\":\"" <> unEmail clientEmail <> "\","+ , maybe mempty (\(Email sub) -> "\"sub\":\"" <> sub <> "\",") msub+ , "\"scope\":\"" <> T.intercalate " " (map scopeUrl scs) <> "\","+ , "\"aud\":\"https://www.googleapis.com/oauth2/v4/token\","+ , "\"exp\":" <> toT (utSeconds t + CTime xt) <> ","+ , "\"iat\":" <> toT (utSeconds t) <> "}"+ ]+ ]+ return $+ either+ (fail "RSAError")+ (\s -> return $ SignedJWT $ i <> "." <> encode (toStrict s))+ (rsassa_pkcs1_v1_5_sign hashSHA256 privateKey $ fromStrict i)+ where+ toT = T.pack . show+ header = toB64 "{\"alg\":\"RS256\",\"typ\":\"JWT\"}"++toB64 :: Text -> ByteString+toB64 = encode . encodeUtf8
+ src/Google/Response.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TemplateHaskell #-}++{- |+Module : Google.Response++Define data types to represent all of the responses that are received from the Google API.+-}+module Google.Response where++import Data.Aeson.Casing (snakeCase)+import Data.Aeson.TH (Options(..), defaultOptions, deriveJSON)+import Data.Text (Text)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Web.FormUrlEncoded (FromForm, ToForm)++data Token = Token+ { accessToken :: Text+ , tokenType :: Text+ , expiresIn :: Int+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON (defaultOptions {fieldLabelModifier = snakeCase}) ''Token++instance FromForm Token++instance ToForm Token++data CalendarEvent = CalendarEvent+ { status :: Text+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON defaultOptions ''CalendarEvent++instance FromForm CalendarEvent++instance ToForm CalendarEvent+++data GmailSend = GmailSend+ { id :: Text+ } deriving (Eq, Generic, Show, Typeable)++deriveJSON defaultOptions ''GmailSend++instance FromForm GmailSend++instance ToForm GmailSend