Enable PWA

config/routes.yesodroutes

@@ -203,4 +203,5 @@
 /favicon.ico FaviconR GET
 /robots.txt RobotsR GET
 
-/sitemap.xml SitemapR GET
+/manifest.json WebAppManifestR GET
+/sitemap.xml   SitemapR        GET

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,24 +375,32 @@ 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
                 return $ x ^. StoreVal )
 
             _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

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

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
     )
 
 

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 "[email protected]"
+                            , businessEmail = Just "[email protected]"
                             }
 
     b <- insert business

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 "[email protected]"
+                            , businessEmail = Just "[email protected]"
                             }
 
     b <- insert business

src/Demo/DemoDataRO.hs

@@ -102,7 +102,7 @@ populateRO = do
                             , businessTz = "Europe/Bucharest"
                             , businessPhone = Just "+40768469474"
                             , businessMobile = Just "+40769859190"
-                            , businessEmail = Just "[email protected]"
+                            , businessEmail = Just "[email protected]"
                             }
 
     b <- insert business

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 "[email protected]"
+                            , businessEmail = Just "[email protected]"
                             }
 
     b <- insert business

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
 

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