cleaning process defined

This commit is contained in:
nek0 2019-10-31 15:42:15 +01:00
parent 0252d67d83
commit 173c4f4ee7
3 changed files with 53 additions and 7 deletions

View file

@ -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

View file

@ -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) $

View file

@ -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