make user idle time configurable

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
 

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

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."

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)

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

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