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