From 92a71e518f64bd9034397c086a11d096c284d775 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 25 Jul 2022 01:31:16 +0200 Subject: [PATCH] make user idle time configurable --- TODO.md | 2 +- src/Control/Buy.hs | 4 ++-- src/Control/User.hs | 6 ++++-- src/Model/Settings.hs | 16 ++++++++++++---- src/Model/User.hs | 7 ++++--- src/Types/Settings.hs | 7 ++++--- 6 files changed, 27 insertions(+), 15 deletions(-) diff --git a/TODO.md b/TODO.md index 974cfc0..1e30ca5 100644 --- a/TODO.md +++ b/TODO.md @@ -27,7 +27,7 @@ - [ ] Manage further metadata (E-mail, avatar, (XMPP?)) -- [ ] Make idle for users time configurable +- [x] Make idle for users time configurable - [ ] Close and delete account - [ ] Imlement Challenge-Response security mechanism diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index 5f9c4f5..183bbdb 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -55,14 +55,14 @@ buy auth pds = do Just (auid, _) -> do void $ addToUserBalance auid (-price) conn newBalance <- userBalanceSelect conn auid - userUpdateTimestamp auth + void $ userUpdateTimestamp auth let result = PurchaseResult ( if newBalance < 0 then PurchaseDebtful else PurchaseOK ) missing - userNotify auth real result + void $ userNotify auth real result return result Nothing -> do void $ insertNewJournalEntry diff --git a/src/Control/User.hs b/src/Control/User.hs index 84cc58a..fc3de31 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -113,7 +113,8 @@ userList -> MateHandler [UserSummary] userList ref = do conn <- asks rsConnection - userSelect (fromMaybe ActiveUsers ref) conn + idleTime <- selectIdleTime conn + userSelect (fromMaybe ActiveUsers ref) idleTime conn userRecharge :: Maybe (Int, AuthMethod) @@ -163,7 +164,8 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = do throwError $ err400 { errBody = "Not enough credit balance." } - mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn + -- Here, userSelect is called with a idle Time of 0, since it selects All users + mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers 0 conn when (null mtarget) $ throwError $ err400 { errBody = "Target user not found." diff --git a/src/Model/Settings.hs b/src/Model/Settings.hs index 648b7e4..8c7cf51 100644 --- a/src/Model/Settings.hs +++ b/src/Model/Settings.hs @@ -8,7 +8,7 @@ import Control.Monad (void) import Control.Monad.IO.Class (liftIO) -import Data.Profunctor.Product (p2) +import Data.Profunctor.Product (p3) import qualified Database.PostgreSQL.Simple as PGS @@ -26,6 +26,7 @@ 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" ] @@ -33,14 +34,17 @@ initSettings = mconcat settingsTable :: Table ( Field SqlBool , FieldNullable SqlText + , Field SqlInt4 ) ( Field SqlBool , FieldNullable SqlText + , Field SqlInt4 ) settingsTable = table "settings" ( - p2 + p3 ( tableField "settings_signup_blocked" , tableField "settings_imprint" + , tableField "settings_idle_time" ) ) @@ -52,13 +56,17 @@ selectSettings conn = liftIO $ do returnA -< ret ) :: IO Settings +selectIdleTime :: PGS.Connection -> MateHandler Int +selectIdleTime conn = settingsIdleTime <$> selectSettings conn + updateSettings :: Settings -> PGS.Connection -> MateHandler () -updateSettings (Settings block imprint) conn = do +updateSettings (Settings block imprint idleTime) conn = do void $ liftIO $ runUpdate_ conn $ Update { uTable = settingsTable - , uUpdateWith = updateEasy (\(_, _) -> + , uUpdateWith = updateEasy (\(_, _, _) -> ( toFields block , toFields imprint + , toFields idleTime ) ) , uWhere = const (sqlBool True) diff --git a/src/Model/User.hs b/src/Model/User.hs index 89f55b0..34a9d1d 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -65,9 +65,10 @@ userTable = table "user" ( userSelect :: UserRefine + -> Int -> PGS.Connection -> MateHandler [UserSummary] -userSelect ref conn = do +userSelect ref idleTime conn = do today <- utctDay <$> liftIO getCurrentTime users <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do stuff@(_, _, _, ts, _, _) <- orderBy (asc (\(_, ident, _, _, _, _) -> ident)) @@ -76,9 +77,9 @@ userSelect ref conn = do AllUsers -> toFields True ActiveUsers -> - ts .>= toFields (addDays (-30) today) + ts .>= toFields (addDays (- (fromIntegral idleTime)) today) OldUsers -> - ts .< toFields (addDays (-30) today) + ts .< toFields (addDays (- (fromIntegral idleTime)) today) returnA -< stuff ) :: MateHandler [User] mapM diff --git a/src/Types/Settings.hs b/src/Types/Settings.hs index bc6b1c7..d3ab00d 100644 --- a/src/Types/Settings.hs +++ b/src/Types/Settings.hs @@ -16,20 +16,21 @@ import Classes data Settings = Settings { settingsBlockRegistration :: Bool , settingsImprintText :: Maybe T.Text + , settingsIdleTime :: Int } deriving (Show, Generic) instance DatabaseRepresentation Settings where - type Representation Settings = (Bool, Maybe T.Text) + type Representation Settings = (Bool, Maybe T.Text, Int) instance ToDatabase Settings where - toDatabase (Settings reg imprint) = (reg, imprint) + toDatabase (Settings reg imprint idleTime) = (reg, imprint, idleTime) instance FromDatabase Settings where - fromDatabase (reg, imprint) = Settings reg imprint + fromDatabase (reg, imprint, idleTime) = Settings reg imprint idleTime instance FromJSON Settings