From 28c6053df52b2867325299f4c0fe6cadd0127f22 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 22 Feb 2022 18:24:13 +0100 Subject: [PATCH] initialize Settings --- src/Model.hs | 1 + src/Model/Settings.hs | 64 +++++++++++++++++++++++++++++++++++++++++++ src/Types.hs | 1 + 3 files changed, 66 insertions(+) create mode 100644 src/Model/Settings.hs diff --git a/src/Model.hs b/src/Model.hs index 2dcca00..6c6226a 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -9,3 +9,4 @@ import Model.Amount as M import Model.Journal as M import Model.Avatar as M import Model.Role as M +import Model.Settings as M diff --git a/src/Model/Settings.hs b/src/Model/Settings.hs new file mode 100644 index 0000000..d704a65 --- /dev/null +++ b/src/Model/Settings.hs @@ -0,0 +1,64 @@ +{-# 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 (p2) + +import qualified Database.PostgreSQL.Simple as PGS + +import Opaleye as O + +-- internal imports + +import Types +import Classes + +initSettings :: PGS.Query +initSettings = mconcat + [ "CREATE TABLE IF NOT EXISTS \"settings\" (" + , "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false," + , "settings_imprint TEXT DEFAULT \'\'" + , ");" + , "INSERT INTO \"settings\" DEFAULT VALUES" + ] + +settingsTable :: Table + ( Field SqlBool + , FieldNullable SqlText + ) + ( Field SqlBool + , FieldNullable SqlText + ) +settingsTable = table "settings" ( + p2 + ( tableField "settings_signup_blocked" + , tableField "settings_imprint" + ) + ) + +getSettings :: PGS.Connection -> MateHandler Settings +getSettings conn = liftIO $ do + head . map fromDatabase <$> runSelect conn + ( proc () -> do + ret <- limit 1 $ selectTable settingsTable -< () + returnA -< ret + ) :: IO Settings + +updateSettings :: Settings -> PGS.Connection -> MateHandler () +updateSettings (Settings block imprint) conn = do + void $ liftIO $ runUpdate_ conn $ Update + { uTable = settingsTable + , uUpdateWith = updateEasy (\(_, _) -> + ( toFields block + , toFields imprint + ) + ) + , uWhere = const (sqlBool True) + , uReturning = rCount + } diff --git a/src/Types.hs b/src/Types.hs index 56ffe0b..45f0748 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -13,3 +13,4 @@ import Types.Journal as T import Types.Avatar as T import Types.Role as T import Types.Meta as T +import Types.Settings as T