cleaning process defined

app/Janitor.hs

@@ -1,16 +1,49 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Janitor where
 
+import qualified Database.PostgreSQL.Simple as PGS
+
+import Control.Monad (void)
+
+import Control.Concurrent (threadDelay, forkIO)
+import Control.Concurrent.STM (atomically, modifyTVar)
+
 import qualified Data.Set as S
+import Data.Time.Clock (getCurrentTime)
 
-forkCleanProcess :: IO ()
+-- internal imports
-forkCleanProcess =
-  return()
 
-cleanProcess conn store =
+import Model.Auth
-  return ()
+import Types.Auth
 
-cleanStore store =
+forkCleanProcess
+  :: PGS.Connection
+  -> TicketStore
+  -> IO ()
+forkCleanProcess conn store =
+  void $ forkIO $ cleanProcess conn store
+
+cleanProcess
+  :: PGS.Connection
+  -> TicketStore
+  -> IO ()
+cleanProcess conn store = do
+  threadDelay $ 20 * 10 ^ (6 :: Int)
+  cleanTokens conn
+  cleanTickets store
+  cleanProcess conn store
+
+cleanTickets
+  :: TicketStore
+  -> IO ()
+cleanTickets store = do
   now <- getCurrentTime
   atomically $
-    modifyTVar store (S.filter (\(Ticket _ _ exp _) -> exp >= now))
+    modifyTVar store (S.filter (\(Ticket _ _ expiry _) -> expiry >= now))
+
+cleanTokens
+  :: PGS.Connection
+  -> IO ()
+cleanTokens conn = do
+  now <- getCurrentTime
+  void $ deleteOldTokens now conn

app/Main.hs

@@ -34,6 +34,7 @@ import Model as M
 import AppTypes
 import Types
 import Control
+import Janitor
 
 main :: IO ()
 main = do
@@ -71,6 +72,7 @@ main = do
           void $ execute_ conn initAuthData
           void $ execute_ conn initAmount
           void $ execute_ conn initJournal
+          forkCleanProcess conn store
           withStdoutLogger $ \ilog -> do
             let settings = setPort (fromIntegral lport) $
                   setHost (fromString $ T.unpack lhost) $

src/Model/Auth.hs

@@ -332,6 +332,17 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
   }
 
 
+deleteOldTokens
+  :: UTCTime
+  -> PGS.Connection
+  -> IO Int64
+deleteOldTokens now conn = runDelete_ conn $ Delete
+  { dTable     = tokenTable
+  , dWhere     = \(_, _, expiry, _) -> expiry .< C.constant now
+  , dReturning = rCount
+  }
+
+
 newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
 newTicket ident method = do
   store <- asks rsTicketStore