diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 34a26da..f94e4ee 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -14,12 +14,16 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ask) +import Control.Concurrent (threadDelay, forkIO) + import Control.Concurrent.STM import Data.Profunctor.Product (p3) import qualified Database.PostgreSQL.Simple as PGS +import Data.Int (Int64) + import Data.Text (Text) import qualified Data.Set as S @@ -67,21 +71,23 @@ getUserAuthInfo -> MateHandler AuthInfo getUserAuthInfo ident = do conn <- rsConnection <$> ask - users <- liftIO $ runSelect conn ( - keepWhen (\(uid, _, _, _, _, _, _, _, _) -> - uid .== C.constant ident) <<< queryTable userTable - ) :: MateHandler - [ ( Int - , Text - , Int - , Day - , Maybe Text - , Maybe Int - , ByteString - , Maybe ByteString - , Maybe Int - ) - ] + users <- liftIO $ do + void $ threadDelay $ 1 * 10 ^ 6 + runSelect conn ( + keepWhen (\(uid, _, _, _, _, _, _, _, _) -> + uid .== C.constant ident) <<< queryTable userTable + ) :: IO + [ ( Int + , Text + , Int + , Day + , Maybe Text + , Maybe Int + , ByteString + , Maybe ByteString + , Maybe Int + ) + ] head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident ) @@ -106,10 +112,15 @@ validateToken conn header = do now <- liftIO $ getCurrentTime if diffUTCTime stamp now > 0 then return $ Just uid - else throwError $ err401 - { errBody = "Your token expired!" - } - _ -> + else do + liftIO $ do + void $ forkIO $ void $ runDelete_ conn (deleteToken header) + threadDelay $ 1 * 10 ^ 6 + throwError $ err401 + { errBody = "Your token expired!" + } + _ -> do + liftIO $ threadDelay $ 1 * 10 ^ 6 throwError $ err401 { errBody = "No valid token found!" } @@ -163,6 +174,15 @@ insertToken (Token tString tUser tExpiry) = Insert , 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 ident = do store <- rsTicketStore <$> ask @@ -185,9 +205,12 @@ processAuthRequest (AuthRequest aticket hash) = do case S.toList mticket of [ticket] -> do now <- liftIO $ getCurrentTime + liftIO $ threadDelay $ 1 * 10 ^ 6 if now > ticketExpiry ticket then return Denied else generateToken ticket hash - _ -> return Denied + _ -> do + liftIO $ threadDelay $ 1 * 10 ^ 6 + return Denied diff --git a/src/Model/User.hs b/src/Model/User.hs index 71d84d2..2e5b1fc 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -155,10 +155,10 @@ insertUser us now randSalt = Insert updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64 updateUserDetails id uds now = Update { uTable = userTable - , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, i7, i8, _) -> + , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) -> ( id_ , C.constant (userDetailsSubmitIdent uds) - , C.constant (userDetailsSubmitBalance uds) + , i3 , C.constant now , C.constant (userDetailsSubmitEmail uds) , C.constant (userDetailsSubmitAvatar uds) diff --git a/src/Types/User.hs b/src/Types/User.hs index e636143..1cd9bfb 100644 --- a/src/Types/User.hs +++ b/src/Types/User.hs @@ -70,7 +70,6 @@ instance FromJSON UserDetails data UserDetailsSubmit = UserDetailsSubmit { userDetailsSubmitIdent :: T.Text - , userDetailsSubmitBalance :: Int , userDetailsSubmitEmail :: Maybe T.Text , userDetailsSubmitAvatar :: Maybe Int , userDetailsSubmitHash :: Maybe AuthHash