tarpitting and deleting found expired tokens

This commit is contained in:
nek0 2019-05-17 18:37:35 +02:00
parent d806b8c3ff
commit 4599e2a7e9
3 changed files with 45 additions and 23 deletions

View file

@ -14,12 +14,16 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.Profunctor.Product (p3) import Data.Profunctor.Product (p3)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
import Data.Int (Int64)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Set as S import qualified Data.Set as S
@ -67,10 +71,12 @@ getUserAuthInfo
-> MateHandler AuthInfo -> MateHandler AuthInfo
getUserAuthInfo ident = do getUserAuthInfo ident = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn ( users <- liftIO $ do
void $ threadDelay $ 1 * 10 ^ 6
runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) -> keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant ident) <<< queryTable userTable uid .== C.constant ident) <<< queryTable userTable
) :: MateHandler ) :: IO
[ ( Int [ ( Int
, Text , Text
, Int , Int
@ -106,10 +112,15 @@ validateToken conn header = do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
if diffUTCTime stamp now > 0 if diffUTCTime stamp now > 0
then return $ Just uid then return $ Just uid
else throwError $ err401 else do
liftIO $ do
void $ forkIO $ void $ runDelete_ conn (deleteToken header)
threadDelay $ 1 * 10 ^ 6
throwError $ err401
{ errBody = "Your token expired!" { errBody = "Your token expired!"
} }
_ -> _ -> do
liftIO $ threadDelay $ 1 * 10 ^ 6
throwError $ err401 throwError $ err401
{ errBody = "No valid token found!" { errBody = "No valid token found!"
} }
@ -163,6 +174,15 @@ insertToken (Token tString tUser tExpiry) = Insert
, iOnConflict = Nothing , iOnConflict = Nothing
} }
deleteToken
:: ByteString
-> Opaleye.Delete Int64
deleteToken tstr = Delete
{ dTable = tokenTable
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr)
, dReturning = rCount
}
newTicket :: Int -> MateHandler AuthTicket newTicket :: Int -> MateHandler AuthTicket
newTicket ident = do newTicket ident = do
store <- rsTicketStore <$> ask store <- rsTicketStore <$> ask
@ -185,9 +205,12 @@ processAuthRequest (AuthRequest aticket hash) = do
case S.toList mticket of case S.toList mticket of
[ticket] -> do [ticket] -> do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
liftIO $ threadDelay $ 1 * 10 ^ 6
if now > ticketExpiry ticket if now > ticketExpiry ticket
then then
return Denied return Denied
else else
generateToken ticket hash generateToken ticket hash
_ -> return Denied _ -> do
liftIO $ threadDelay $ 1 * 10 ^ 6
return Denied

View file

@ -155,10 +155,10 @@ insertUser us now randSalt = Insert
updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64 updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64
updateUserDetails id uds now = Update updateUserDetails id uds now = Update
{ uTable = userTable { uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, _, _, _, _, i7, i8, _) -> , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) ->
( id_ ( id_
, C.constant (userDetailsSubmitIdent uds) , C.constant (userDetailsSubmitIdent uds)
, C.constant (userDetailsSubmitBalance uds) , i3
, C.constant now , C.constant now
, C.constant (userDetailsSubmitEmail uds) , C.constant (userDetailsSubmitEmail uds)
, C.constant (userDetailsSubmitAvatar uds) , C.constant (userDetailsSubmitAvatar uds)

View file

@ -70,7 +70,6 @@ instance FromJSON UserDetails
data UserDetailsSubmit = UserDetailsSubmit data UserDetailsSubmit = UserDetailsSubmit
{ userDetailsSubmitIdent :: T.Text { userDetailsSubmitIdent :: T.Text
, userDetailsSubmitBalance :: Int
, userDetailsSubmitEmail :: Maybe T.Text , userDetailsSubmitEmail :: Maybe T.Text
, userDetailsSubmitAvatar :: Maybe Int , userDetailsSubmitAvatar :: Maybe Int
, userDetailsSubmitHash :: Maybe AuthHash , userDetailsSubmitHash :: Maybe AuthHash