From ddba01059e446d9f4d7986396b1275ed6810b669 Mon Sep 17 00:00:00 2001 From: ciukstar Date: Tue, 26 Dec 2023 02:44:12 +0300 Subject: [PATCH] Save tokens into database --- config/routes.yesodroutes | 4 +- messages/en.msg | 1 + messages/fr.msg | 1 + messages/ro.msg | 1 + messages/ru.msg | 1 + src/Admin/Billing.hs | 58 ++++++----- src/Admin/Tokens.hs | 142 +++++++++++++++++++++++---- src/Application.hs | 2 +- src/Foundation.hs | 6 +- src/Model.hs | 28 ++++-- templates/admin/tokens/tokens.hamlet | 2 +- 11 files changed, 191 insertions(+), 55 deletions(-) diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes index 186c3c5..cdd8c74 100644 --- a/config/routes.yesodroutes +++ b/config/routes.yesodroutes @@ -84,7 +84,9 @@ /admin AdminR: - /tokens TokensR GET POST + /tokens/gmail/hook GMailApiHookR GET + /tokens/gmail TokensGMailR POST + /tokens TokensR GET /invoices/#InvoiceId/mail/#InvoiceMailId/delete AdmInvoiceMailDeleteR POST /invoices/#InvoiceId/mail/#InvoiceMailId AdmInvoiceMailR GET diff --git a/messages/en.msg b/messages/en.msg index 6546c3c..14a16ab 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -1,3 +1,4 @@ +InvalidStoreType: Invalid store type Initialization: Initialization StoreType: Store type UserSession: User session diff --git a/messages/fr.msg b/messages/fr.msg index 4f696a1..5eb090e 100644 --- a/messages/fr.msg +++ b/messages/fr.msg @@ -1,3 +1,4 @@ +InvalidStoreType: Type de stockage invalide Initialization: Initialisation StoreType: Type de stockage UserSession: Session utilisateur diff --git a/messages/ro.msg b/messages/ro.msg index e83e166..2aed2d9 100644 --- a/messages/ro.msg +++ b/messages/ro.msg @@ -1,3 +1,4 @@ +InvalidStoreType: Tip de stocare nevalid Initialization: Inițializare StoreType: Tipul de stocare UserSession: Sesiunea de utilizator diff --git a/messages/ru.msg b/messages/ru.msg index 250cfc2..e5cec95 100644 --- a/messages/ru.msg +++ b/messages/ru.msg @@ -1,3 +1,4 @@ +InvalidStoreType: Неверный тип хранилища Initialization: Инициализация StoreType: Тип хранилища UserSession: Пользовательская сессия diff --git a/src/Admin/Billing.hs b/src/Admin/Billing.hs index 46d97c8..12592b6 100644 --- a/src/Admin/Billing.hs +++ b/src/Admin/Billing.hs @@ -89,12 +89,11 @@ import Text.Hamlet (Html, HtmlUrlI18n, ihamlet) import Yesod.Auth (Route (LoginR), maybeAuth) import Yesod.Core - ( Yesod(defaultLayout), newIdent, SomeMessage (SomeMessage) + ( Yesod(defaultLayout), TypedContent, SomeMessage (SomeMessage) , MonadHandler (liftHandler), redirect, addMessageI, getMessages - , getCurrentRoute, lookupPostParam, whamlet, RenderMessage (renderMessage) - , getYesod, languages, lookupSession, getUrlRender, setSession - , getMessageRender, getUrlRenderParams, addMessage, TypedContent - , selectRep, provideRep, notFound + , getCurrentRoute, lookupPostParam, whamlet, getYesod, lookupSession + , getUrlRender, setSession, getMessageRender, getUrlRenderParams + , addMessage, selectRep, provideRep, notFound, newIdent ) import Yesod.Core.Widget (setTitleI) import Yesod.Form.Functions @@ -171,7 +170,7 @@ import Model , StaffUser, InvoiceNumber, ItemId, ItemInvoice, OfferService, ServiceId , ServiceName, ThumbnailService, ThumbnailAttribution, BusinessCurrency , OfferId, ItemOffer, ItemAmount, InvoiceMailId, InvoiceMailStatus - , InvoiceMailTimemark, InvoiceMailInvoice + , InvoiceMailTimemark, InvoiceMailInvoice, TokenApi, TokenStore, StoreToken, StoreVal, StoreKey ) , Staff (Staff, staffName, staffEmail), InvoiceId , Business (Business, businessEmail, businessFullName) @@ -189,6 +188,7 @@ import Model , InvoiceMailId , MailStatus (MailStatusDraft, MailStatusBounced, MailStatusDelivered) , _itemAmount, _itemCurrency, _itemVat, _itemTax, _itemQuantity + , gmailAccessToken, gmailRefreshToken, Token (Token), gmail, StoreType (StoreTypeSession, StoreTypeDatabase, StoreTypeGoogleSecretManager), Store (Store) ) import Menu (menu) @@ -266,7 +266,9 @@ getBillingMailHookR = do raw <- liftIO $ decodeUtf8 . toStrict . encode <$> renderMail' mail let opts = defaults & auth ?~ oauth2Bearer (encodeUtf8 accessToken) - response <- liftIO $ tryAny $ postWith opts (gmailApi $ unpack $ invoiceMailSender imail) (object ["raw" .= raw]) + response <- liftIO $ tryAny $ postWith opts + (gmailApi $ unpack $ invoiceMailSender imail) + (object ["raw" .= raw]) case response of Left e@(SomeException _) -> case fromException e of @@ -367,28 +369,46 @@ postAdmInvoiceSendmailR iid = do FormSuccess imail -> do mid <- runDB $ insert imail app <- getYesod - langs <- languages - - let transMsg = renderMessage app langs :: AppMessage -> Text let googleClientId = appGoogleClientId $ appSettings app googleClientSecret = appGoogleClientSecret $ appSettings app - accessToken <- lookupSession gmailAccessToken - refreshToken <- lookupSession gmailRefreshToken + store <- runDB $ selectOne $ do + x <- from $ table @Token + where_ $ x ^. TokenApi ==. val gmail + return x + + accessToken <- case store of + Just (Entity _ (Token _ StoreTypeGoogleSecretManager)) -> undefined + Just (Entity tid (Token _ StoreTypeDatabase)) -> (unValue <$>) <$> runDB ( selectOne $ do + x <- from $ table @Store + where_ $ x ^. StoreToken ==. val tid + where_ $ x ^. StoreKey ==. val gmailAccessToken + return $ x ^. StoreVal ) + + _otherwise -> lookupSession gmailAccessToken + + refreshToken <- case store of + Just (Entity _ (Token _ StoreTypeGoogleSecretManager)) -> undefined + Just (Entity tid (Token _ StoreTypeDatabase)) -> (unValue <$>) <$> runDB ( selectOne $ do + x <- from $ table @Store + where_ $ x ^. StoreToken ==. val tid + where_ $ x ^. StoreKey ==. val gmailRefreshToken + return $ x ^. StoreVal ) + _otherwise -> lookupSession gmailRefreshToken timesRoman <- liftIO $ mkStdFont Times_Roman timesBold <- liftIO $ mkStdFont Times_Bold case ((accessToken,refreshToken),(timesRoman,timesBold)) of ((Just atoken,Just rtoken),(Right fr,Right fb)) -> do - msgRndr <- (toHtml .) <$> getMessageRender + msgRender <- getMessageRender urlRndr <- getUrlRenderParams let html = if invoiceMailHtml imail - then Just $ renderIvoiceHtml customer employee invoice items msgRndr urlRndr + then Just $ renderIvoiceHtml customer employee invoice items (toHtml . msgRender) urlRndr else Nothing pdf = if invoiceMailPdf imail then pure $ renderIvoicePdf - ( invoicePdf customer employee invoice items transMsg (PDFRect 0 0 612 792) fr fb + ( invoicePdf customer employee invoice items msgRender (PDFRect 0 0 612 792) fr fb ) else Nothing mail = buildMail imail html pdf @@ -939,14 +959,6 @@ $maybe Entity _ (User uname _ _ _ _ _ cname cemail) <- customer currency = join $ items L.^? ix 0 . to entityVal . _itemCurrency -gmailAccessToken :: Text -gmailAccessToken = "gmail_access_token" - - -gmailRefreshToken :: Text -gmailRefreshToken = "gmail_refresh_token" - - gmailApi :: String -> String gmailApi = printf "https://gmail.googleapis.com/gmail/v1/users/%s/messages/send" diff --git a/src/Admin/Tokens.hs b/src/Admin/Tokens.hs index a0d9564..d7af555 100644 --- a/src/Admin/Tokens.hs +++ b/src/Admin/Tokens.hs @@ -1,60 +1,155 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} module Admin.Tokens ( getTokensR - , postTokensR + , postTokensGMailR + , getGMailApiHookR ) where -import Data.Text (Text) -import Database.Persist (Entity(Entity)) +import Control.Applicative ((<|>)) +import qualified Control.Lens as L ((^.), (^?)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson.Lens (key, AsValue (_String), AsNumber (_Integer)) +import Data.ByteString.Lazy (toStrict) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (decodeUtf8) + +import Database.Persist (Entity(Entity, entityVal), PersistUniqueWrite (upsert)) +import qualified Database.Persist as P ((=.)) import Foundation ( Handler, Widget , Route ( AuthR, PhotoPlaceholderR, AccountPhotoR, ProfileR, AdminR ) - , AdminR (TokensR) + , AdminR (TokensR, TokensGMailR, GMailApiHookR) , AppMessage ( MsgTokens, MsgNavigationMenu, MsgUserProfile, MsgPhoto, MsgLogin , MsgInitialize, MsgClearSettings, MsgDatabase, MsgUserSession , MsgGoogleSecretManager, MsgStoreType, MsgInitialization - , MsgInvalidFormData - ) + , MsgInvalidFormData, MsgRecordEdited, MsgInvalidStoreType + ), App (appSettings) ) -import Text.Hamlet (Html) + +import Network.Wreq + ( FormParam ((:=)), post, responseStatus, statusCode, responseBody + ) + +import Text.Blaze.Html (preEscapedToHtml) import Text.Cassius (cassius) +import Text.Hamlet (Html) +import Text.Read (readMaybe) import Yesod.Auth (maybeAuth, Route (LoginR)) import Yesod.Core ( Yesod(defaultLayout), SomeMessage (SomeMessage), getMessages, whamlet - , newIdent, toWidget, addMessageI + , newIdent, toWidget, addMessageI, redirect, setSession, getUrlRender, getYesod ) import Yesod.Core.Widget (setTitleI) -import Yesod.Form.Fields (OptionList, optionsPairs, withRadioField) +import Yesod.Form.Input (runInputGet, ireq) +import Yesod.Form.Fields (OptionList, optionsPairs, withRadioField, textField) import Yesod.Form.Functions (generateFormPost, mreq, runFormPost) import Yesod.Form.Types ( MForm, FormResult (FormSuccess), Field, FieldView (fvInput, fvId) , FieldSettings (FieldSettings, fsLabel, fsTooltip, fsId, fsName, fsAttrs) ) +import Yesod.Persist (YesodPersist(runDB)) +import Database.Esqueleto.Experimental + ( selectOne, from, table, where_, val + , (^.) ,(==.) + ) import Model ( StoreType (StoreTypeSession, StoreTypeDatabase, StoreTypeGoogleSecretManager) + , Token (Token, tokenStore), EntityField (TokenApi, TokenStore, StoreVal) + , gmailAccessToken, gmailRefreshToken, Store (Store), gmail ) import Menu (menu) -import Settings (widgetFile) +import Settings (widgetFile, AppSettings (appGoogleClientId, appGoogleClientSecret)) + + +getGMailApiHookR :: Handler Html +getGMailApiHookR = do + rndr <- getUrlRender + app <- appSettings <$> getYesod + let googleClientId = appGoogleClientId app + let googleClientSecret = appGoogleClientSecret app + + code <- runInputGet $ ireq textField "code" + store <- readMaybe . unpack <$> runInputGet (ireq textField "state") + + r <- liftIO $ post "https://oauth2.googleapis.com/token" + [ "code" := code + , "redirect_uri" := rndr (AdminR GMailApiHookR) + , "client_id" := googleClientId + , "client_secret" := googleClientSecret + , "grant_type" := ("authorization_code" :: Text) + ] + + let _status = r L.^. responseStatus . statusCode + + let accessToken = r L.^. responseBody . key "access_token" . _String + let refreshToken = r L.^. responseBody . key "refresh_token" . _String + let _tokenType = r L.^. responseBody . key "token_type" . _String + let _scope = r L.^. responseBody . key "scope" . _String + let _expiresIn = r L.^? responseBody . key "expires_in" . _Integer + + case store of + Just x@StoreTypeSession -> do + setSession gmailAccessToken accessToken + setSession gmailRefreshToken refreshToken + _ <- runDB $ upsert (Token gmail x) [TokenStore P.=. x] + addMessageI info MsgRecordEdited + redirect $ AdminR TokensR + Just x@StoreTypeDatabase -> do + Entity tid _ <- runDB $ upsert (Token gmail x) [TokenStore P.=. x] + _ <- runDB $ upsert (Store tid gmailAccessToken accessToken) [StoreVal P.=. accessToken] + _ <- runDB $ upsert (Store tid gmailRefreshToken refreshToken) [StoreVal P.=. refreshToken] + addMessageI info MsgRecordEdited + redirect $ AdminR TokensR + Just x@StoreTypeGoogleSecretManager -> do + _ <- runDB $ upsert (Token gmail x) [TokenStore P.=. x] + + + addMessageI info MsgRecordEdited + redirect $ AdminR TokensR + Nothing -> do + addMessageI warn MsgInvalidStoreType + redirect $ AdminR TokensR -postTokensR :: Handler Html -postTokensR = do + +postTokensGMailR :: Handler Html +postTokensGMailR = do user <- maybeAuth - ((fr,fw),et) <- runFormPost formGmailApi + + token <- runDB $ selectOne $ do + x <- from $ table @Token + where_ $ x ^. TokenApi ==. val gmail + return x + + ((fr,fw),et) <- runFormPost $ formGmailApi token formStoreType <- newIdent case fr of - FormSuccess StoreTypeDatabase -> undefined - FormSuccess StoreTypeGoogleSecretManager -> undefined + FormSuccess x -> do + app <- appSettings <$> getYesod + rndr <- getUrlRender + + r <- liftIO $ post "https://accounts.google.com/o/oauth2/v2/auth" + [ "redirect_uri" := rndr (AdminR GMailApiHookR) + , "response_type" := ("code" :: Text) + , "prompt" := ("consent" :: Text) + , "client_id" := appGoogleClientId app + , "scope" := ("https://www.googleapis.com/auth/gmail.send" :: Text) + , "access_type" := ("offline" :: Text) + , "state" := pack (show x) + ] + + return $ preEscapedToHtml $ decodeUtf8 $ toStrict (r L.^. responseBody) _otherwize -> do addMessageI warn MsgInvalidFormData msgs <- getMessages @@ -67,7 +162,12 @@ getTokensR :: Handler Html getTokensR = do user <- maybeAuth - (fw,et) <- generateFormPost formGmailApi + token <- runDB $ selectOne $ do + x <- from $ table @Token + where_ $ x ^. TokenApi ==. val gmail + return x + + (fw,et) <- generateFormPost $ formGmailApi token formStoreType <- newIdent msgs <- getMessages @@ -76,8 +176,8 @@ getTokensR = do $(widgetFile "admin/tokens/tokens") -formGmailApi :: Html -> MForm Handler (FormResult StoreType,Widget) -formGmailApi extra = do +formGmailApi :: Maybe (Entity Token) -> Html -> MForm Handler (FormResult StoreType,Widget) +formGmailApi token extra = do let storeTypes = [ (MsgGoogleSecretManager,StoreTypeGoogleSecretManager) , (MsgDatabase,StoreTypeDatabase) , (MsgUserSession,StoreTypeSession) @@ -86,7 +186,7 @@ formGmailApi extra = do { fsLabel = SomeMessage MsgStoreType , fsTooltip = Nothing, fsId = Nothing, fsName = Nothing , fsAttrs = [("class","mdc-radio__native-control")] - } (Just StoreTypeSession) + } ((tokenStore . entityVal <$> token) <|> Just StoreTypeSession) return (r, do toWidget [cassius| ##{fvId v} @@ -114,5 +214,9 @@ formGmailApi extra = do |]) +info :: Text +info = "info" + + warn :: Text warn = "warn" diff --git a/src/Application.hs b/src/Application.hs index 0252501..56bd4cb 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -113,7 +113,7 @@ import Handler.Stats , getStatsAovR, getAovDetailsR ) -import Admin.Tokens (getTokensR, postTokensR) +import Admin.Tokens (getTokensR, postTokensGMailR, getGMailApiHookR) import Admin.Billing ( getAdmInvoicesR diff --git a/src/Foundation.hs b/src/Foundation.hs index 462f4a4..b661c37 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -144,8 +144,10 @@ instance Yesod App where - isAuthorized BillingMailHookR _ = return Authorized - + isAuthorized BillingMailHookR _ = return Authorized + isAuthorized (AdminR GMailApiHookR) _ = return Authorized + + isAuthorized (AdminR TokensGMailR) _ = isAdmin isAuthorized r@(AdminR TokensR) _ = setUltDest r >> isAdmin isAuthorized (AdminR (AdmInvoiceMailDeleteR _ _)) _ = isAdmin diff --git a/src/Model.hs b/src/Model.hs index 5a807e1..02bbc8f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -285,14 +285,6 @@ data SortOrder = SortOrderAsc | SortOrderDesc instance SqlString Textarea -ultDestKey :: Text -ultDestKey = "_ULT" - - -mimePdf :: ContentType -mimePdf = "application/pdf" - - instance ToContent (PDF ()) where toContent :: PDF () -> Content toContent = toContent . pdfByteString @@ -312,3 +304,23 @@ instance ToTypedContent (PDF ()) where instance HasContentType (PDF ()) where getContentType :: Monad m => m (PDF ()) -> ContentType getContentType _ = mimePdf + + +ultDestKey :: Text +ultDestKey = "_ULT" + + +mimePdf :: ContentType +mimePdf = "application/pdf" + + +gmail :: Text +gmail = "GMAIL_API" + + +gmailAccessToken :: Text +gmailAccessToken = "gmail_access_token" + + +gmailRefreshToken :: Text +gmailRefreshToken = "gmail_refresh_token" diff --git a/templates/admin/tokens/tokens.hamlet b/templates/admin/tokens/tokens.hamlet index 52492ee..f7d983c 100644 --- a/templates/admin/tokens/tokens.hamlet +++ b/templates/admin/tokens/tokens.hamlet @@ -46,7 +46,7 @@ _{MsgStoreType} -
+ ^{fw}