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 Model
import Util
import Util.Random
authGet
:: TicketRequest

View file

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

View file

@ -155,6 +155,3 @@ sendNotification mail = do
else
print ("Warning: sending notification failed: Sendmail not present!"
:: 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)