From 173c4f4ee79ea9f756318c6edf6a37c7f10bb676 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 31 Oct 2019 15:42:15 +0100 Subject: [PATCH] cleaning process defined --- app/Janitor.hs | 47 ++++++++++++++++++++++++++++++++++++++++------- app/Main.hs | 2 ++ src/Model/Auth.hs | 11 +++++++++++ 3 files changed, 53 insertions(+), 7 deletions(-) diff --git a/app/Janitor.hs b/app/Janitor.hs index ca5ae2c..91bddf2 100644 --- a/app/Janitor.hs +++ b/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 () -forkCleanProcess = - return() +-- internal imports -cleanProcess conn store = - return () +import Model.Auth +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 diff --git a/app/Main.hs b/app/Main.hs index 9736ba7..484bd1d 100644 --- a/app/Main.hs +++ b/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) $ diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 43e7e9f..08cb679 100644 --- a/src/Model/Auth.hs +++ b/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