mateamt/src/Model/Settings.hs

78 lines
2 KiB
Haskell
Raw Normal View History

2022-02-22 17:24:13 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Arrows #-}
module Model.Settings where
import Control.Arrow
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
2022-07-24 23:31:16 +00:00
import Data.Profunctor.Product (p3)
2022-02-22 17:24:13 +00:00
import qualified Database.PostgreSQL.Simple as PGS
import Opaleye as O
-- internal imports
import Types
import Classes
2022-07-24 14:49:41 +00:00
-- | This function does (as opposed to all other init functions) create just the table,
-- but also creates a first settings object with default values.
2022-02-22 17:24:13 +00:00
initSettings :: PGS.Query
initSettings = mconcat
[ "CREATE TABLE IF NOT EXISTS \"settings\" ("
, "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false,"
2023-07-07 22:16:05 +00:00
, "settings_imprint TEXT DEFAULT \'\',"
2022-07-24 23:31:16 +00:00
, "settings_idle_time INTEGER NOT NULL DEFAULT 30"
2022-02-22 17:24:13 +00:00
, ");"
, "INSERT INTO \"settings\" DEFAULT VALUES"
]
settingsTable :: Table
( Field SqlBool
, FieldNullable SqlText
2022-07-24 23:31:16 +00:00
, Field SqlInt4
2022-02-22 17:24:13 +00:00
)
( Field SqlBool
, FieldNullable SqlText
2022-07-24 23:31:16 +00:00
, Field SqlInt4
2022-02-22 17:24:13 +00:00
)
settingsTable = table "settings" (
2022-07-24 23:31:16 +00:00
p3
2022-02-22 17:24:13 +00:00
( tableField "settings_signup_blocked"
, tableField "settings_imprint"
2022-07-24 23:31:16 +00:00
, tableField "settings_idle_time"
2022-02-22 17:24:13 +00:00
)
)
2022-07-24 14:49:41 +00:00
selectSettings :: PGS.Connection -> MateHandler Settings
selectSettings conn = liftIO $ do
2022-02-22 17:24:13 +00:00
head . map fromDatabase <$> runSelect conn
( proc () -> do
ret <- limit 1 $ selectTable settingsTable -< ()
returnA -< ret
) :: IO Settings
2022-07-24 23:31:16 +00:00
selectIdleTime :: PGS.Connection -> MateHandler Int
selectIdleTime conn = settingsIdleTime <$> selectSettings conn
2022-07-26 18:25:55 +00:00
selectSignupBlocked :: PGS.Connection -> MateHandler Bool
selectSignupBlocked conn = settingsBlockRegistration <$> selectSettings conn
2022-02-22 17:24:13 +00:00
updateSettings :: Settings -> PGS.Connection -> MateHandler ()
2022-07-24 23:31:16 +00:00
updateSettings (Settings block imprint idleTime) conn = do
2022-02-22 17:24:13 +00:00
void $ liftIO $ runUpdate_ conn $ Update
{ uTable = settingsTable
2022-07-24 23:31:16 +00:00
, uUpdateWith = updateEasy (\(_, _, _) ->
2022-02-22 17:24:13 +00:00
( toFields block
, toFields imprint
2022-07-24 23:31:16 +00:00
, toFields idleTime
2022-02-22 17:24:13 +00:00
)
)
, uWhere = const (sqlBool True)
, uReturning = rCount
}