Make persistent a local deps and increase connectionPoolConfigIdleTim…

…eout from 600 to 1200 (20min > 15min grace time)
ciukstar · Oct 28, 2023 · 69cc578 · 69cc578
1 parent 6f44faf
commit 69cc578
Show file tree

Hide file tree

Showing 16 changed files with 67 additions and 45 deletions.
diff --git a/config/settings.yml b/config/settings.yml
@@ -35,6 +35,7 @@ database:
   # See config/test-settings.yml for an override during tests
   database: "_env:YESOD_SQLITE_DATABASE:':memory:'"
   poolsize: "_env:YESOD_SQLITE_POOLSIZE:1"
+idle-timeout: "_env:YESOD_SQLITE_IDLETIMEOUT:1200"
 
 copyright: Insert copyright statement here
 #analytics: UA-YOURCODE
diff --git a/package.yaml b/package.yaml
@@ -15,7 +15,6 @@ dependencies:
 - classy-prelude-yesod
 - bytestring
 - text
-- persistent
 - persistent-sqlite
 - persistent-template
 - template-haskell
@@ -49,6 +48,7 @@ dependencies:
 - base64-bytestring
 - transformers
 - blaze-html
+- persistent
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

diff --git a/src/Admin/Business.hs b/src/Admin/Business.hs
@@ -239,6 +239,7 @@ getBusinessCalendarR bid = do
     langs <- languages
     user <- maybeAuth
     curr <- getCurrentRoute
+    setUltDestCurrent
     msgs <- getMessages
 
     pivot <- utctDay <$> liftIO getCurrentTime
@@ -364,6 +365,7 @@ getBusinessHoursR bid = do
         return x
     user <- maybeAuth
     curr <- getCurrentRoute
+    setUltDestCurrent
     msgs <- getMessages
     fabBusinessHoursCreate <- newIdent
     defaultLayout $ do

diff --git a/src/Application.hs b/src/Application.hs
@@ -21,30 +21,39 @@ module Application
     , db
     ) where
 
-import Control.Monad.Logger                 (liftLoc, runLoggingT)
-import Database.Persist.Sqlite              (createSqlitePool, runSqlPool,
-                                             sqlDatabase, sqlPoolSize)
+
 import Import
-import Language.Haskell.TH.Syntax           (qLocation)
-import Network.HTTP.Client.TLS              (getGlobalManager)
+import Control.Monad.Logger (liftLoc, runLoggingT)
+import Database.Persist.Sql
+    ( ConnectionPoolConfig
+      ( ConnectionPoolConfig, connectionPoolConfigStripes
+      , connectionPoolConfigIdleTimeout, connectionPoolConfigSize
+      )
+    )
+import Database.Persist.Sqlite
+    ( createSqlitePoolWithConfig, runSqlPool, sqlDatabase, sqlPoolSize )
+import Language.Haskell.TH.Syntax (qLocation)
+import Network.HTTP.Client.TLS (getGlobalManager)
 import Network.Wai (Middleware)
-import Network.Wai.Handler.Warp             (Settings, defaultSettings,
-                                             defaultShouldDisplayException,
-                                             runSettings, setHost,
-                                             setOnException, setPort, getPort)
-import Network.Wai.Middleware.RequestLogger (Destination (Logger),
-                                             IPAddrSource (..),
-                                             OutputFormat (..), destination,
-                                             mkRequestLogger, outputFormat)
-import Network.Wai.Middleware.Gzip (gzip, GzipSettings (gzipFiles), GzipFiles (GzipCompress))
-import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
-                                             toLogStr)
+import Network.Wai.Handler.Warp
+    ( Settings, defaultSettings, defaultShouldDisplayException,runSettings
+    , setHost, setOnException, setPort, getPort
+    )
+import Network.Wai.Middleware.RequestLogger
+    ( Destination (Logger), IPAddrSource (..), OutputFormat (..), destination
+    , mkRequestLogger, outputFormat
+    )
+import Network.Wai.Middleware.Gzip
+    ( gzip, GzipSettings (gzipFiles), GzipFiles (GzipCompress) )
+import System.Environment.Blank (getEnv)
+import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
+
+
 
 import Demo.DemoDataFR (populateFR)
 import Demo.DemoDataRO (populateRO)
 import Demo.DemoDataRU (populateRU)
 import Demo.DemoDataEN (populateEN)
-import System.Environment.Blank (getEnv)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -61,7 +70,7 @@ import Handler.Appointments
     , postAppointmentR, postAppointmentCancelR, getAppointmentHistR
     , getAppointmentRescheduleR, postAppointmentApproveR
     )
-    
+
 import Handler.Contacts (getContactR)
 import Handler.Book
     ( getBookOffersR, postBookOffersR
@@ -122,12 +131,12 @@ import Admin.Contacts
     , postAdmContactsEditR
     , postAdmContactsDeleteR
     )
-    
+
 import Admin.About
     ( getAdmAboutR, getAdmAboutCreateR, postAdmAboutR
     , getAdmAboutEditR, postAdmAboutEditR, postAdmAboutDeleteR
     )
-    
+
 import Admin.Staff
     ( getAdmStaffR, getAdmStaffCreateR, getAdmStaffPhotoR
     , getAdmEmplR, postAdmEmplR, getAdmStaffEditR, getAdmScheduleR
@@ -164,6 +173,7 @@ import Handler.Common
     ( getFaviconR, getRobotsR, getPhotoPlaceholderR
     )
 
+
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
 -- comments there for more details.
@@ -196,9 +206,12 @@ makeFoundation appSettings = do
         logFunc = messageLoggerSource tempFoundation appLogger
 
     -- Create the database connection pool
-    pool <- flip runLoggingT logFunc $ createSqlitePool
+    pool <- flip runLoggingT logFunc $ createSqlitePoolWithConfig
         (sqlDatabase $ appDatabaseConf appSettings)
-        (sqlPoolSize $ appDatabaseConf appSettings)
+        ConnectionPoolConfig { connectionPoolConfigStripes = 1
+                             , connectionPoolConfigIdleTimeout = appIdleTimeout appSettings
+                             , connectionPoolConfigSize = sqlPoolSize $ appDatabaseConf appSettings
+                             }
 
     -- Perform database migration using our application's logging settings.
     flip runLoggingT logFunc $ flip runSqlPool pool $ do

diff --git a/src/Settings.hs b/src/Settings.hs
@@ -15,13 +15,14 @@ import qualified Control.Exception as Exception
 import Data.Aeson                  (Result (..), fromJSON, withObject, (.!=),
                                     (.:?))
 import Data.FileEmbed              (embedFile)
+import Data.Time.Clock (NominalDiffTime)
 import Data.Yaml                   (decodeEither')
 import Database.Persist.Sqlite     (SqliteConf)
 import Language.Haskell.TH.Syntax  (Exp, Name, Q)
 import Network.Wai.Handler.Warp    (HostPreference)
 import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
-import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
-                                    widgetFileReload)
+import Yesod.Default.Util
+    ( WidgetFileSettings, widgetFileNoReload, widgetFileReload )
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
@@ -30,6 +31,7 @@ data AppSettings = AppSettings
     { appStaticDir              :: String
     -- ^ Directory from which to serve static files.
     , appDatabaseConf           :: SqliteConf
+    , appIdleTimeout            :: NominalDiffTime
     -- ^ Configuration settings for accessing the database.
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
@@ -73,6 +75,7 @@ instance FromJSON AppSettings where
 #endif
         appStaticDir              <- o .: "static-dir"
         appDatabaseConf           <- o .: "database"
+        appIdleTimeout            <- o .: "idle-timeout"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"

diff --git a/stack.yaml b/stack.yaml
@@ -31,6 +31,9 @@ resolver:
 #   - wai
 packages:
 - .
+- ../../github-forks/persistent/persistent
+- ../../github-forks/persistent/persistent-sqlite
+
 # Dependency packages to be pulled from upstream that are not in the resolver.
 # These entries can reference officially published versions as well as
 # forks / in-progress versions pinned to a git hash. For example:

diff --git a/templates/book/customer/banner.hamlet b/templates/book/customer/banner.hamlet
@@ -13,7 +13,7 @@
         <div style="white-space:inherit;overflow:inherit;text-overflow:inherit;line-height:inherit">
           _{MsgCustomerInformation}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       $maybe Entity uid _ <- user
         <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{ProfileR} role=button>
           <span.mdc-icon-button__ripple>

diff --git a/templates/book/customer/customer.hamlet b/templates/book/customer/customer.hamlet
@@ -13,7 +13,7 @@
         <div style="white-space:inherit;overflow:inherit;text-overflow:inherit;line-height:inherit">
           _{MsgCustomerInformation}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       $maybe Entity uid _ <- user
         <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{ProfileR} role=button>
           <span.mdc-icon-button__ripple>
@@ -60,7 +60,7 @@
             $maybe fname <- fname
               #{fname}
 
-      <div.hint style="margin:1rem;text-align:end;font-size:small;color:var(--mdc-theme-text-hint-on-background)">
+      <div.hint style="margin:1rem;text-align:end;font-size:small;color:var(--theme-text-small-hint-on-light)">
         <span>_{MsgNotYourAccount}?
         <a href=@{AuthR LoginR}>_{MsgLogin}
   $nothing
@@ -71,7 +71,8 @@
         <span.mdc-button__label>_{MsgSignUp}
       <div style="display:inherit;flex-direction:inherit">
         <div style="text-align:center;margin-bottom:0.3rem">
-          <small.hint style="color:var(--mdc-theme-text-hint-on-background)">_{MsgAlreadyHaveAnAccount}?
+          <small.hint style="color:var(--theme-text-small-hint-on-light)">
+            _{MsgAlreadyHaveAnAccount}?
         <a.mdc-button.mdc-button--outlined href=@{AuthR LoginR} role=button>
           <span.mdc-button__ripple>
           <span.mdc-button__focus-ring>

diff --git a/templates/book/end.hamlet b/templates/book/end.hamlet
@@ -8,7 +8,7 @@
       <span.mdc-top-app-bar__title.mdc-theme--text-primary-on-light>
         _{MsgEnd}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       $maybe Entity uid _ <- user
         <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{ProfileR} role=button>
           <span.mdc-icon-button__ripple>

diff --git a/templates/book/offers/banner.hamlet b/templates/book/offers/banner.hamlet
@@ -13,7 +13,7 @@
         <div style="white-space:inherit;overflow:inherit;text-overflow:inherit;line-height:inherit">
           _{MsgChooseServicesToBook}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{BookSearchR} role=button title=_{MsgSearch}>
         <span.mdc-icon-button__ripple>
         <span.mdc-icon-button__focus-ring>

diff --git a/templates/book/offers/items.cassius b/templates/book/offers/items.cassius
@@ -3,8 +3,5 @@ ul.mdc-list##{theId}
     span.mdc-list-item__content
       div.mdc-list-item__primary-text
         color: var(--theme-accent)
-      div.mdc-list-item__secondary-text
-        color: var(--theme-accent)
-        opacity: 0.6
 
 
diff --git a/templates/book/staff/banner.hamlet b/templates/book/staff/banner.hamlet
@@ -13,7 +13,7 @@
         <div style="white-space:inherit;overflow:inherit;text-overflow:inherit;line-height:inherit">
           _{MsgSelectStaff}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       $maybe Entity uid _ <- user
         <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{ProfileR} role=button>
           <span.mdc-icon-button__ripple>

diff --git a/templates/book/staff/empls.hamlet b/templates/book/staff/empls.hamlet
@@ -1,5 +1,5 @@
-<ul.mdc-list role=listbox ##{theId} tabindex=-1 data-mdc-auto-init=MDCList>
-  <li.mdc-list-item.mdc-list-item--with-leading-image
+<ul.mdc-list role=listbox ##{theId} tabindex=-1 data-mdc-auto-init=MDCList aria-label=_{MsgStaff}>
+  <li.mdc-list-item.mdc-list-item--with-leading-image role=option
     .mdc-list-item--with-three-lines.mdc-list-item--with-trailing-radio
     :isLeft eval:aria-checked=true :not (isLeft eval):aria-checked=false>
     <span.mdc-list-item__ripple>
@@ -13,16 +13,17 @@
       <div.mdc-list-item__secondary-text>
     <span.mdc-list-item__end>
       <div.mdc-radio tabindex=-1 data-mdc-auto-init=MDCRadio>
-        <input.mdc-radio__native-control type=radio name=#{name} value *{attrs} :isLeft eval:checked>
+        <input.mdc-radio__native-control aria-label=_{MsgNoPreference}
+          type=radio name=#{name} value *{attrs} :isLeft eval:checked>
         <div.mdc-radio__background>
           <div.mdc-radio__outer-circle>
           <div.mdc-radio__inner-circle>
         <div.mdc-radio__ripple>
         <div.mdc-radio__focus-ring>
-  <div.mdc-list-divider role=separator>
+  <div.mdc-list-divider role=none>
   $forall e@(Entity sid (Staff sname _ _ _ _ _), Entity rid (Role _ _ rname rating)) <- options
     $with checked <- isChecked eval e
-      <li.mdc-list-item.mdc-list-item--with-leading-image
+      <li.mdc-list-item.mdc-list-item--with-leading-image role=option
         .mdc-list-item--with-three-lines.mdc-list-item--with-trailing-radio
         :checked:aria-checked=true :not checked:aria-checked=false>
         <span.mdc-list-item__ripple>
@@ -41,10 +42,11 @@
                 &starf;
         <span.mdc-list-item__end>
           <div.mdc-radio tabindex=-1 data-mdc-auto-init=MDCRadio>
-            <input.mdc-radio__native-control type=radio name=#{name} value=#{fromSqlKey rid} *{attrs} :checked:checked>
+            <input.mdc-radio__native-control aria-label=#{sname}
+              type=radio name=#{name} value=#{fromSqlKey rid} *{attrs} :checked:checked>
             <div.mdc-radio__background>
               <div.mdc-radio__outer-circle>
               <div.mdc-radio__inner-circle>
             <div.mdc-radio__ripple>
             <div.mdc-radio__focus-ring>
-      <div.mdc-list-divider role=separator>
+      <div.mdc-list-divider role=none>
diff --git a/templates/book/staff/staff.hamlet b/templates/book/staff/staff.hamlet
@@ -13,7 +13,7 @@
         <div style="white-space:inherit;overflow:inherit;text-overflow:inherit;line-height:inherit">
           _{MsgSelectStaff}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       $maybe Entity uid _ <- user
         <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{ProfileR} role=button>
           <span.mdc-icon-button__ripple>

diff --git a/templates/book/time/banner.hamlet b/templates/book/time/banner.hamlet
@@ -13,7 +13,7 @@
         <div style="white-space:inherit;overflow:inherit;text-overflow:inherit;line-height:inherit">
           _{MsgAppointmentTime}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       $maybe Entity uid _ <- user
         <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{ProfileR} role=button>
           <span.mdc-icon-button__ripple>

diff --git a/templates/book/time/time.hamlet b/templates/book/time/time.hamlet
@@ -13,7 +13,7 @@
         <div style="white-space:inherit;overflow:inherit;text-overflow:inherit;line-height:inherit">
           _{MsgAppointmentTime}
 
-    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end role=toolbar>
+    <section.mdc-top-app-bar__section.mdc-top-app-bar__section--align-end>
       $maybe Entity uid _ <- user
         <a.mdc-top-app-bar__action-item.mdc-icon-button href=@{ProfileR} role=button>
           <span.mdc-icon-button__ripple>