more playing
This commit is contained in:
parent
109b6867f4
commit
7b6ea276b4
4 changed files with 22 additions and 21 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
8
src/Util/Random.hs
Normal 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)
|
Loading…
Add table
Reference in a new issue