more playing

This commit is contained in:
nek0 2022-04-16 16:40:10 +02:00
parent 109b6867f4
commit 7b6ea276b4
4 changed files with 22 additions and 21 deletions

View file

@ -21,7 +21,7 @@ import Data.Text.Encoding
import Types import Types
import Model import Model
import Util import Util.Random
authGet authGet
:: TicketRequest :: TicketRequest

View file

@ -38,7 +38,7 @@ import Opaleye hiding (null)
import Types.Auth import Types.Auth
import Types.Reader import Types.Reader
import Classes import Classes
import Util.Random
initToken :: PGS.Query initToken :: PGS.Query
initToken = mconcat initToken = mconcat
@ -51,12 +51,12 @@ initToken = mconcat
] ]
tokenTable :: Table tokenTable :: Table
( Field SqlText ( Field SqlBytea
, Field SqlInt4 , Field SqlInt4
, Field SqlTimestamptz , Field SqlTimestamptz
, Field SqlInt4 , Field SqlInt4
) )
( Field SqlText ( Field SqlBytea
, Field SqlInt4 , Field SqlInt4
, Field SqlTimestamptz , Field SqlTimestamptz
, Field SqlInt4 , Field SqlInt4
@ -110,10 +110,6 @@ delayTime :: Int
delayTime = 1 * 10 ^ (6 :: Int) delayTime = 1 * 10 ^ (6 :: Int)
generateRandomText :: IO T.Text
generateRandomText = decodeUtf8 . B64.encode <$> random 23
selectAuthOverviews selectAuthOverviews
:: Int -- ^ User ID :: Int -- ^ User ID
-> PGS.Connection -- ^ Connection Handler -> PGS.Connection -- ^ Connection Handler
@ -160,9 +156,9 @@ getUserAuthInfo uid method conn = do
then then
-- generate mock AuthInfo -- generate mock AuthInfo
liftIO $ do liftIO $ do
rand1 <- generateRandomText rand1 <- decodeUtf8 <$> randomString
rand2 <- case method of rand2 <- case method of
ChallengeResponse -> Just <$> generateRandomText ChallengeResponse -> Just . decodeUtf8 <$> randomString
_ -> return Nothing _ -> return Nothing
return $ AuthInfo rand2 (AuthTicket rand1) return $ AuthInfo rand2 (AuthTicket rand1)
else else
@ -212,7 +208,7 @@ validateToken header conn = do
tokens <- liftIO $ map fromDatabase <$> runSelect conn ( tokens <- liftIO $ map fromDatabase <$> runSelect conn (
proc () -> do proc () -> do
stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< () stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
restrict -< toFields (decodeUtf8 header) .== tstr restrict -< toFields header .== tstr
returnA -< stuff returnA -< stuff
) )
case tokens of case tokens of
@ -221,7 +217,7 @@ validateToken header conn = do
if diffUTCTime stamp now_ > 0 if diffUTCTime stamp now_ > 0
then return $ Just (uid, method) then return $ Just (uid, method)
else do else do
void $ deleteToken (decodeUtf8 header) conn void $ deleteToken header conn
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
throwError $ err401 throwError $ err401
{ errBody = "Your token expired!" { errBody = "Your token expired!"
@ -256,7 +252,7 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
if authResult if authResult
then do then do
token <- liftIO $ Token token <- liftIO $ Token
<$> generateRandomText <$> (decodeUtf8 <$> randomString)
<*> pure tuid <*> pure tuid
<*> (addUTCTime (23*60) <$> getCurrentTime) <*> (addUTCTime (23*60) <$> getCurrentTime)
<*> pure method <*> pure method
@ -274,13 +270,13 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
insertToken insertToken
:: Token :: Token
-> PGS.Connection -> PGS.Connection
-> MateHandler T.Text -> MateHandler ByteString
insertToken (Token tString tUser tExpiry tMethod) conn = insertToken (Token tString tUser tExpiry tMethod) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = tokenTable { iTable = tokenTable
, iRows = , iRows =
[ [
( toFields tString ( toFields (encodeUtf8 tString)
, toFields tUser , toFields tUser
, toFields tExpiry , toFields tExpiry
, toFields (fromEnum tMethod) , toFields (fromEnum tMethod)
@ -292,7 +288,7 @@ insertToken (Token tString tUser tExpiry tMethod) conn =
deleteToken deleteToken
:: T.Text :: ByteString
-> PGS.Connection -> PGS.Connection
-> Handler Int64 -> Handler Int64
deleteToken tstr conn = deleteToken tstr conn =
@ -328,9 +324,9 @@ deleteOldTokens now_ conn = runDelete_ conn $ Delete
newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket) newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
newTicket ident method = do newTicket ident method = do
store <- asks rsTicketStore store <- asks rsTicketStore
rand1 <- liftIO generateRandomText rand1 <- liftIO (decodeUtf8 <$> randomString)
rand2 <- liftIO $ case method of rand2 <- liftIO $ case method of
ChallengeResponse -> Just <$> generateRandomText ChallengeResponse -> Just . decodeUtf8 <$> randomString
_ -> return Nothing _ -> return Nothing
later <- liftIO (addUTCTime 23 <$> getCurrentTime) later <- liftIO (addUTCTime 23 <$> getCurrentTime)
let ticket = Ticket let ticket = Ticket

View file

@ -155,6 +155,3 @@ sendNotification mail = do
else else
print ("Warning: sending notification failed: Sendmail not present!" print ("Warning: sending notification failed: Sendmail not present!"
:: String) :: String)
randomString :: IO BS.ByteString
randomString = uniformByteStringM 32 =<< newIOGenM (mkStdGen 23)

8
src/Util/Random.hs Normal file
View file

@ -0,0 +1,8 @@
module Util.Random where
import qualified Data.ByteString as BS
import System.Random.Stateful (uniformByteStringM, newIOGenM, mkStdGen)
randomString :: IO BS.ByteString
randomString = uniformByteStringM 32 =<< newIOGenM (mkStdGen 23)