diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). 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/google-server-api.cabal b/google-server-api.cabal new file mode 100644 --- /dev/null +++ b/google-server-api.cabal @@ -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 diff --git a/src/Google/Client.hs b/src/Google/Client.hs new file mode 100644 --- /dev/null +++ b/src/Google/Client.hs @@ -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 diff --git a/src/Google/Form.hs b/src/Google/Form.hs new file mode 100644 --- /dev/null +++ b/src/Google/Form.hs @@ -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 diff --git a/src/Google/JWT.hs b/src/Google/JWT.hs new file mode 100644 --- /dev/null +++ b/src/Google/JWT.hs @@ -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 diff --git a/src/Google/Response.hs b/src/Google/Response.hs new file mode 100644 --- /dev/null +++ b/src/Google/Response.hs @@ -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