diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes index 059a759..275be8a 100644 --- a/config/routes.yesodroutes +++ b/config/routes.yesodroutes @@ -203,4 +203,5 @@ /favicon.ico FaviconR GET /robots.txt RobotsR GET -/sitemap.xml SitemapR GET \ No newline at end of file +/manifest.json WebAppManifestR GET +/sitemap.xml SitemapR GET \ No newline at end of file diff --git a/src/Admin/Billing.hs b/src/Admin/Billing.hs index 975ebbd..d8667a0 100644 --- a/src/Admin/Billing.hs +++ b/src/Admin/Billing.hs @@ -39,7 +39,7 @@ import qualified Control.Lens as L ((^.), (^?)) import Control.Monad (join, forM) import Control.Monad.IO.Class (liftIO) import Data.Aeson (object, (.=)) -import Data.Aeson.Lens (AsValue(_String), key, AsNumber (_Integer)) +import Data.Aeson.Lens (AsValue(_String), key) import Data.Bifunctor (Bifunctor(first, second)) import Data.ByteString (toStrict) import qualified Data.ByteString.Lazy as BSL (ByteString) @@ -81,6 +81,7 @@ import Network.Wreq ( post, FormParam ((:=)), responseBody, responseStatus, statusCode , postWith, defaults, auth, oauth2Bearer ) +import System.Directory (doesFileExist) import Text.Blaze.Html (preEscapedToHtml, toHtml) import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Printf (printf) @@ -217,13 +218,8 @@ getBillingMailHookR = do , "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 setSession gmailAccessToken accessToken setSession gmailRefreshToken refreshToken @@ -379,12 +375,19 @@ postAdmInvoiceSendmailR iid = do x <- from $ table @Token where_ $ x ^. TokenApi ==. val gmail return x + + let at = "/at/gmail_access_token" + rt = "/rt/gmail_refresh_token" + + secrets <- liftIO $ and <$> forM [at,rt] doesFileExist - accessToken <- case store of - Just (Entity _ (Token _ StoreTypeGoogleSecretManager)) -> do - Just . pack <$> liftIO ( readFile "/at/gmail_access_token" ) + accessToken <- case (store,secrets) of + (Nothing,True) -> Just . pack <$> liftIO ( readFile at ) + + (Just (Entity _ (Token _ StoreTypeGoogleSecretManager)),True) -> do + Just . pack <$> liftIO ( readFile at ) - Just (Entity tid (Token _ StoreTypeDatabase)) -> (unValue <$>) <$> runDB ( selectOne $ do + (Just (Entity tid (Token _ StoreTypeDatabase)),_) -> (unValue <$>) <$> runDB ( selectOne $ do x <- from $ table @Store where_ $ x ^. StoreToken ==. val tid where_ $ x ^. StoreKey ==. val gmailAccessToken @@ -392,11 +395,12 @@ postAdmInvoiceSendmailR iid = do _otherwise -> lookupSession gmailAccessToken - refreshToken <- case store of - Just (Entity _ (Token _ StoreTypeGoogleSecretManager)) -> do - Just . pack <$> liftIO ( readFile "/rt/gmail_refresh_token" ) + refreshToken <- case (store,secrets) of + (Nothing,True) -> Just . pack <$> liftIO ( readFile rt ) + (Just (Entity _ (Token _ StoreTypeGoogleSecretManager)),True) -> do + Just . pack <$> liftIO ( readFile rt ) - Just (Entity tid (Token _ StoreTypeDatabase)) -> (unValue <$>) <$> runDB ( selectOne $ do + (Just (Entity tid (Token _ StoreTypeDatabase)),_) -> (unValue <$>) <$> runDB ( selectOne $ do x <- from $ table @Store where_ $ x ^. StoreToken ==. val tid where_ $ x ^. StoreKey ==. val gmailRefreshToken diff --git a/src/Admin/Tokens.hs b/src/Admin/Tokens.hs index 3cec039..450f0b6 100644 --- a/src/Admin/Tokens.hs +++ b/src/Admin/Tokens.hs @@ -45,7 +45,7 @@ import Foundation import Network.Wreq ( FormParam ((:=)), post, responseStatus, statusCode, responseBody, defaults - , auth, oauth2Bearer, postWith + , auth, oauth2Bearer, postWith, deleteWith ) import Text.Blaze.Html (preEscapedToHtml) @@ -81,6 +81,8 @@ import Model import Menu (menu) import Settings (widgetFile, AppSettings (appGoogleClientId, appGoogleClientSecret)) +import Text.Printf (printf) +import Data.Bifunctor (Bifunctor(first)) getGMailApiHookR :: Handler Html @@ -123,18 +125,27 @@ getGMailApiHookR = do addMessageI info MsgRecordEdited redirect $ AdminR TokensR Just x@StoreTypeGoogleSecretManager -> do - - let apis = [ ( "https://secretmanager.googleapis.com/v1/projects/salon-395815/secrets/gmail_access_token:addVersion" - , accessToken - ) - , ( "https://secretmanager.googleapis.com/v1/projects/salon-395815/secrets/gmail_refresh_token:addVersion" - , refreshToken - ) - ] let opts = defaults & auth L.?~ oauth2Bearer (encodeUtf8 accessToken) - forM_ apis $ \(api,secret) -> do + let apic :: [String] + apic = printf "https://secretmanager.googleapis.com/v1/projects/salon-395815/secrets?secretId=%s" + <$> [ "gmail_access_token" :: String + , "gmail_refresh_token" :: String + ] + + forM_ apic $ \api -> do + liftIO $ tryAny $ postWith opts api + (object [ "replication" .= object [ "automatic" .= object []] ]) + + + let apiv :: [(String,Text)] + apiv = first (printf "https://secretmanager.googleapis.com/v1/projects/salon-395815/secrets/%s:addVersion") + <$> [ ("gmail_access_token",accessToken) :: (String,Text) + , ("gmail_refresh_token",refreshToken) :: (String,Text) + ] + + forM_ apiv $ \(api,secret) -> do liftIO $ tryAny $ postWith opts api (object [ "payload" .= object [ "data" .= decodeUtf8 (B64.encode (encodeUtf8 secret)) ]]) @@ -167,7 +178,18 @@ postTokensGMailClearR = do addMessageI info MsgRecordDeleted redirect $ AdminR TokensR (FormSuccess (),Just (Entity tid (Token _ StoreTypeGoogleSecretManager))) -> do - undefined + let accessToken = undefined + let opts = defaults & auth L.?~ oauth2Bearer (encodeUtf8 accessToken) + + let apic :: [String] + apic = printf "https://secretmanager.googleapis.com/v1/projects/salon-395815/secrets/%s" + <$> [ "gmail_access_token" :: String + , "gmail_refresh_token" :: String + ] + + forM_ apic $ \api -> do + liftIO $ tryAny $ deleteWith opts api + runDB $ delete tid addMessageI info MsgRecordDeleted redirect $ AdminR TokensR diff --git a/src/Application.hs b/src/Application.hs index 037728a..4f3d4fe 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -58,7 +58,6 @@ import Demo.DemoDataEN (populateEN) -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! -import Handler.Sitemap (getSitemapR) import Handler.Scratch ( getScratchInitR @@ -212,6 +211,7 @@ import Admin.Services ) import Handler.Common ( getFaviconR, getRobotsR, getPhotoPlaceholderR + , getSitemapR, getWebAppManifestR ) diff --git a/src/Demo/DemoDataEN.hs b/src/Demo/DemoDataEN.hs index 460140b..d03aec6 100644 --- a/src/Demo/DemoDataEN.hs +++ b/src/Demo/DemoDataEN.hs @@ -104,7 +104,7 @@ populateEN = do , businessTz = "Europe/London" , businessPhone = Just "020-7736-6600" , businessMobile = Just "567-274-7469" - , businessEmail = Just "salon@mail.uk" + , businessEmail = Just "ciukstar@gmail.com" } b <- insert business diff --git a/src/Demo/DemoDataFR.hs b/src/Demo/DemoDataFR.hs index 0db2b79..e245b87 100644 --- a/src/Demo/DemoDataFR.hs +++ b/src/Demo/DemoDataFR.hs @@ -104,7 +104,7 @@ populateFR = do , businessTz = "Europe/Paris" , businessPhone = Just "+33-775-552-652" , businessMobile = Just "+33-655-537-079" - , businessEmail = Just "salon@mail.fr" + , businessEmail = Just "ciukstar@gmail.com" } b <- insert business diff --git a/src/Demo/DemoDataRO.hs b/src/Demo/DemoDataRO.hs index 78d5c4c..7e4e4a7 100644 --- a/src/Demo/DemoDataRO.hs +++ b/src/Demo/DemoDataRO.hs @@ -102,7 +102,7 @@ populateRO = do , businessTz = "Europe/Bucharest" , businessPhone = Just "+40768469474" , businessMobile = Just "+40769859190" - , businessEmail = Just "salon@mail.ro" + , businessEmail = Just "ciukstar@gmail.com" } b <- insert business diff --git a/src/Demo/DemoDataRU.hs b/src/Demo/DemoDataRU.hs index f205f07..540bd71 100644 --- a/src/Demo/DemoDataRU.hs +++ b/src/Demo/DemoDataRU.hs @@ -96,7 +96,7 @@ populateRU = do , businessTz = "Europe/Moscow" , businessPhone = Just "+7 (958) 759-52-25" , businessMobile = Just "940(8537)418-74-67" - , businessEmail = Just "salon@mail.ru" + , businessEmail = Just "ciukstar@gmail.com" } b <- insert business diff --git a/src/Foundation.hs b/src/Foundation.hs index 0fdc317..23827c2 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -130,7 +130,8 @@ instance Yesod App where isAuthorized (StaticR _) _ = return Authorized isAuthorized (AuthR _) _ = return Authorized - + + isAuthorized WebAppManifestR _ = return Authorized isAuthorized SitemapR _ = return Authorized isAuthorized HomeR _ = return Authorized isAuthorized FaviconR _ = return Authorized @@ -145,7 +146,6 @@ instance Yesod App where isAuthorized r@(StatsR (AovDetailsR {})) _ = setUltDest r >> isAnalyst - isAuthorized BillingMailHookR _ = return Authorized isAuthorized (AdminR GMailApiHookR) _ = return Authorized diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 6dffc83..2946c91 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -2,15 +2,83 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} -module Handler.Common where +module Handler.Common + ( getWebAppManifestR + , getSitemapR + , getPhotoPlaceholderR + , getFaviconR + , getRobotsR + ) where +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (object, (.=), Value (String)) +import Data.Conduit (yield) import Data.FileEmbed (embedFile) -import Foundation ( Handler ) +import Data.Time.Clock (getCurrentTime, UTCTime (utctDay)) +import Data.Time.Calendar (toGregorian) +import Data.Time.Calendar.Month (pattern YearMonth) +import Foundation + ( Handler + , Route + ( HomeR, ServicesR, BookOffersR, BookingsCalendarR, AboutUsR + , ContactR, ResourcesR, StaticR + ) + , ResourcesR (DocsR), AppMessage (MsgAppName, MsgMetaDescription) + ) +import Settings.StaticFiles + (img_salon_512_png, img_salon_1024_png, img_salon_512_maskable_png) import Yesod.Core ( TypedContent (TypedContent), ToContent (toContent) , typePlain, cacheSeconds, typeSvg ) +import Yesod.Core.Handler (selectRep, getUrlRender, getMessageRender) +import Yesod.Core.Json (provideJson, array) +import Yesod.Sitemap + (sitemap, SitemapUrl (SitemapUrl), SitemapChangeFreq (Monthly)) + + +getWebAppManifestR :: Handler TypedContent +getWebAppManifestR = do + urlRender <- getUrlRender + msgRender <- getMessageRender + selectRep $ provideJson $ object + [ "name" .= msgRender MsgAppName + , "short_name" .= msgRender MsgAppName + , "description" .= msgRender MsgMetaDescription + , "categories" .= array [String "beauty"] + , "start_url" .= urlRender HomeR + , "theme_color" .= String "#FFFFFF" + , "background_color" .= String "#FFFFFF" + , "display" .= String "standalone" + , "icons" .= array [ object [ "src" .= urlRender (StaticR img_salon_512_png) + , "type" .= String "image/png" + , "sizes" .= String "512x512" + ] + , object [ "src" .= urlRender (StaticR img_salon_512_maskable_png) + , "type" .= String "image/png" + , "sizes" .= String "512x512" + , "purpose" .= String "maskable" + ] + ] + ] + + +getSitemapR :: Handler TypedContent +getSitemapR = sitemap $ do + yield $ SitemapUrl (ResourcesR DocsR) Nothing (Just Monthly) (Just 1.0) + yield $ SitemapUrl HomeR Nothing (Just Monthly) (Just 1.0) + yield $ SitemapUrl ServicesR Nothing (Just Monthly) (Just 0.9) + yield $ SitemapUrl BookOffersR Nothing (Just Monthly) (Just 0.8) + + today <- utctDay <$> liftIO getCurrentTime + let (y,m,_) = toGregorian today + month = YearMonth y m + + yield $ SitemapUrl (BookingsCalendarR month) Nothing (Just Monthly) (Just 0.7) + yield $ SitemapUrl AboutUsR Nothing (Just Monthly) (Just 0.6) + yield $ SitemapUrl ContactR Nothing (Just Monthly) (Just 0.6) getPhotoPlaceholderR :: Handler TypedContent diff --git a/src/Handler/Sitemap.hs b/src/Handler/Sitemap.hs deleted file mode 100644 index 1407f63..0000000 --- a/src/Handler/Sitemap.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Handler.Sitemap (getSitemapR) where - -import Control.Monad.IO.Class (liftIO) -import Foundation - ( Handler - , Route - ( HomeR, ServicesR, BookOffersR, BookingsCalendarR, AboutUsR - , ContactR, ResourcesR - ) - , ResourcesR (DocsR) - ) -import Yesod.Core.Types (TypedContent) -import Yesod.Sitemap - (sitemap, SitemapUrl (SitemapUrl), SitemapChangeFreq (Monthly)) -import Data.Conduit (yield) -import Data.Time.Clock (getCurrentTime, UTCTime (utctDay)) -import Data.Time.Calendar (toGregorian) -import Data.Time.Calendar.Month (pattern YearMonth) - - -getSitemapR :: Handler TypedContent -getSitemapR = sitemap $ do - yield $ SitemapUrl (ResourcesR DocsR) Nothing (Just Monthly) (Just 1.0) - yield $ SitemapUrl HomeR Nothing (Just Monthly) (Just 1.0) - yield $ SitemapUrl ServicesR Nothing (Just Monthly) (Just 0.9) - yield $ SitemapUrl BookOffersR Nothing (Just Monthly) (Just 0.8) - - today <- utctDay <$> liftIO getCurrentTime - let (y,m,_) = toGregorian today - month = YearMonth y m - - yield $ SitemapUrl (BookingsCalendarR month) Nothing (Just Monthly) (Just 0.7) - yield $ SitemapUrl AboutUsR Nothing (Just Monthly) (Just 0.6) - yield $ SitemapUrl ContactR Nothing (Just Monthly) (Just 0.6) - diff --git a/static/img/Salon-ERD.svg b/static/img/Salon-ERD.svg index 6b923cb..1d4955b 100644 --- a/static/img/Salon-ERD.svg +++ b/static/img/Salon-ERD.svg @@ -123,34 +123,34 @@ >offertimeaddrtzotzpay_methodstatusbookinvoice_mailstore_typestoretokenkeyvalstorecustomergroup + + + + + + + + + diff --git a/static/img/salon_512.png b/static/img/salon_512.png new file mode 100644 index 0000000..8286ca1 Binary files /dev/null and b/static/img/salon_512.png differ diff --git a/static/img/salon_512.svg b/static/img/salon_512.svg new file mode 100644 index 0000000..cbffbdf --- /dev/null +++ b/static/img/salon_512.svg @@ -0,0 +1,47 @@ + + + + + + + + + + diff --git a/static/img/salon_512_maskable.png b/static/img/salon_512_maskable.png new file mode 100644 index 0000000..8286ca1 Binary files /dev/null and b/static/img/salon_512_maskable.png differ diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index 24be6c0..d4b06af 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -11,6 +11,7 @@ $doctype 5 + $maybe Entity rid (Brand bid _ _ _ _ _ _ ico mime _) <- brand $maybe _ <- ico $maybe mime <- mime