Save tokens into database

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

messages/en.msg

@@ -1,3 +1,4 @@
+InvalidStoreType: Invalid store type
 Initialization: Initialization
 StoreType: Store type
 UserSession: User session

messages/fr.msg

@@ -1,3 +1,4 @@
+InvalidStoreType: Type de stockage invalide
 Initialization: Initialisation
 StoreType: Type de stockage
 UserSession: Session utilisateur

messages/ro.msg

@@ -1,3 +1,4 @@
+InvalidStoreType: Tip de stocare nevalid
 Initialization: Inițializare
 StoreType: Tipul de stocare
 UserSession: Sesiunea de utilizator

messages/ru.msg

@@ -1,3 +1,4 @@
+InvalidStoreType: Неверный тип хранилища
 Initialization: Инициализация
 StoreType: Тип хранилища
 UserSession: Пользовательская сессия

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"
 

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"

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

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