make user idle time configurable

This commit is contained in:
nek0 2022-07-25 01:31:16 +02:00
parent e7e1305b6a
commit 92a71e518f
6 changed files with 27 additions and 15 deletions

View file

@ -27,7 +27,7 @@
- [ ] Manage further metadata - [ ] Manage further metadata
(E-mail, avatar, (XMPP?)) (E-mail, avatar, (XMPP?))
- [ ] Make idle for users time configurable - [x] Make idle for users time configurable
- [ ] Close and delete account - [ ] Close and delete account
- [ ] Imlement Challenge-Response security mechanism - [ ] Imlement Challenge-Response security mechanism

View file

@ -55,14 +55,14 @@ buy auth pds = do
Just (auid, _) -> do Just (auid, _) -> do
void $ addToUserBalance auid (-price) conn void $ addToUserBalance auid (-price) conn
newBalance <- userBalanceSelect conn auid newBalance <- userBalanceSelect conn auid
userUpdateTimestamp auth void $ userUpdateTimestamp auth
let result = PurchaseResult let result = PurchaseResult
( if newBalance < 0 ( if newBalance < 0
then PurchaseDebtful then PurchaseDebtful
else PurchaseOK else PurchaseOK
) )
missing missing
userNotify auth real result void $ userNotify auth real result
return result return result
Nothing -> do Nothing -> do
void $ insertNewJournalEntry void $ insertNewJournalEntry

View file

@ -113,7 +113,8 @@ userList
-> MateHandler [UserSummary] -> MateHandler [UserSummary]
userList ref = do userList ref = do
conn <- asks rsConnection conn <- asks rsConnection
userSelect (fromMaybe ActiveUsers ref) conn idleTime <- selectIdleTime conn
userSelect (fromMaybe ActiveUsers ref) idleTime conn
userRecharge userRecharge
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
@ -163,7 +164,8 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = do
throwError $ err400 throwError $ err400
{ errBody = "Not enough credit balance." { 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) $ when (null mtarget) $
throwError $ err400 throwError $ err400
{ errBody = "Target user not found." { errBody = "Target user not found."

View file

@ -8,7 +8,7 @@ import Control.Monad (void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.Profunctor.Product (p2) import Data.Profunctor.Product (p3)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
@ -26,6 +26,7 @@ initSettings = mconcat
[ "CREATE TABLE IF NOT EXISTS \"settings\" (" [ "CREATE TABLE IF NOT EXISTS \"settings\" ("
, "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false," , "settings_signup_blocked BOOLEAN NOT NULL DEFAULT false,"
, "settings_imprint TEXT DEFAULT \'\'" , "settings_imprint TEXT DEFAULT \'\'"
, "settings_idle_time INTEGER NOT NULL DEFAULT 30"
, ");" , ");"
, "INSERT INTO \"settings\" DEFAULT VALUES" , "INSERT INTO \"settings\" DEFAULT VALUES"
] ]
@ -33,14 +34,17 @@ initSettings = mconcat
settingsTable :: Table settingsTable :: Table
( Field SqlBool ( Field SqlBool
, FieldNullable SqlText , FieldNullable SqlText
, Field SqlInt4
) )
( Field SqlBool ( Field SqlBool
, FieldNullable SqlText , FieldNullable SqlText
, Field SqlInt4
) )
settingsTable = table "settings" ( settingsTable = table "settings" (
p2 p3
( tableField "settings_signup_blocked" ( tableField "settings_signup_blocked"
, tableField "settings_imprint" , tableField "settings_imprint"
, tableField "settings_idle_time"
) )
) )
@ -52,13 +56,17 @@ selectSettings conn = liftIO $ do
returnA -< ret returnA -< ret
) :: IO Settings ) :: IO Settings
selectIdleTime :: PGS.Connection -> MateHandler Int
selectIdleTime conn = settingsIdleTime <$> selectSettings conn
updateSettings :: Settings -> PGS.Connection -> MateHandler () updateSettings :: Settings -> PGS.Connection -> MateHandler ()
updateSettings (Settings block imprint) conn = do updateSettings (Settings block imprint idleTime) conn = do
void $ liftIO $ runUpdate_ conn $ Update void $ liftIO $ runUpdate_ conn $ Update
{ uTable = settingsTable { uTable = settingsTable
, uUpdateWith = updateEasy (\(_, _) -> , uUpdateWith = updateEasy (\(_, _, _) ->
( toFields block ( toFields block
, toFields imprint , toFields imprint
, toFields idleTime
) )
) )
, uWhere = const (sqlBool True) , uWhere = const (sqlBool True)

View file

@ -65,9 +65,10 @@ userTable = table "user" (
userSelect userSelect
:: UserRefine :: UserRefine
-> Int
-> PGS.Connection -> PGS.Connection
-> MateHandler [UserSummary] -> MateHandler [UserSummary]
userSelect ref conn = do userSelect ref idleTime conn = do
today <- utctDay <$> liftIO getCurrentTime today <- utctDay <$> liftIO getCurrentTime
users <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do users <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do
stuff@(_, _, _, ts, _, _) <- orderBy (asc (\(_, ident, _, _, _, _) -> ident)) stuff@(_, _, _, ts, _, _) <- orderBy (asc (\(_, ident, _, _, _, _) -> ident))
@ -76,9 +77,9 @@ userSelect ref conn = do
AllUsers -> AllUsers ->
toFields True toFields True
ActiveUsers -> ActiveUsers ->
ts .>= toFields (addDays (-30) today) ts .>= toFields (addDays (- (fromIntegral idleTime)) today)
OldUsers -> OldUsers ->
ts .< toFields (addDays (-30) today) ts .< toFields (addDays (- (fromIntegral idleTime)) today)
returnA -< stuff returnA -< stuff
) :: MateHandler [User] ) :: MateHandler [User]
mapM mapM

View file

@ -16,20 +16,21 @@ import Classes
data Settings = Settings data Settings = Settings
{ settingsBlockRegistration :: Bool { settingsBlockRegistration :: Bool
, settingsImprintText :: Maybe T.Text , settingsImprintText :: Maybe T.Text
, settingsIdleTime :: Int
} }
deriving (Show, Generic) deriving (Show, Generic)
instance DatabaseRepresentation Settings where instance DatabaseRepresentation Settings where
type Representation Settings = (Bool, Maybe T.Text) type Representation Settings = (Bool, Maybe T.Text, Int)
instance ToDatabase Settings where instance ToDatabase Settings where
toDatabase (Settings reg imprint) = (reg, imprint) toDatabase (Settings reg imprint idleTime) = (reg, imprint, idleTime)
instance FromDatabase Settings where instance FromDatabase Settings where
fromDatabase (reg, imprint) = Settings reg imprint fromDatabase (reg, imprint, idleTime) = Settings reg imprint idleTime
instance FromJSON Settings instance FromJSON Settings