cleaning process defined
This commit is contained in:
parent
0252d67d83
commit
173c4f4ee7
3 changed files with 53 additions and 7 deletions
|
@ -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
|
||||
|
|
|
@ -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) $
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue