twiddle on auth

This commit is contained in:
nek0 2019-09-15 11:01:47 +02:00
parent 2c4f949102
commit 39341751ee
3 changed files with 42 additions and 31 deletions

View File

@ -10,12 +10,7 @@ import Model
authGet :: TicketRequest -> MateHandler AuthInfo
authGet (TicketRequest uid method) = do
mai <- getUserAuthInfo uid method
case mai of
Just ai -> (return ai :: MateHandler AuthInfo)
Nothing -> throwError $ err404
{ errBody = "No such user"
}
getUserAuthInfo uid method
authSend :: AuthRequest -> MateHandler AuthResult
authSend = processAuthRequest

View File

@ -84,7 +84,7 @@ initAuthData = mconcat
, "auth_data_id SERIAL PRIMARY KEY,"
, "auth_data_user INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE,"
, "auth_data_method INTEGER NOT NULL,"
, "auth_data_payload TEXT"
, "auth_data_payload TEXT NOT NULL"
, ")"
]
@ -92,12 +92,12 @@ authDataTable :: Table
( Maybe (Field SqlInt4)
, Field SqlInt4
, Field SqlInt4
, FieldNullable SqlText
, Field SqlText
)
( Field SqlInt4
, Field SqlInt4
, Field SqlInt4
, FieldNullable SqlText
, Field SqlText
)
authDataTable = table "auth_data" (
p4
@ -115,7 +115,7 @@ delayTime = 1 * 10 ^ (6 :: Int)
getUserAuthInfo
:: Int
-> AuthMethod
-> MateHandler (Maybe AuthInfo)
-> MateHandler AuthInfo
getUserAuthInfo uid method = do
conn <- rsConnection <$> ask
authdata <- liftIO $ do
@ -128,17 +128,20 @@ getUserAuthInfo uid method = do
[ ( Int
, Int
, Int
, Maybe T.Text
, T.Text
)
]
if null authdata
then
return Nothing
-- generate mock AuthInfo
liftIO $ do
rand1 <- decodeUtf8 <$> random 23
rand2 <- case method of
ChallengeResponse -> Just <$> decodeUtf8 <$> random 23
_ -> return Nothing
return $ AuthInfo rand2 (AuthTicket rand1)
else
Just <$> head <$> mapM (\(_, _, _, payload) ->
AuthInfo payload <$> newTicket uid method
)
authdata
uncurry AuthInfo <$> newTicket uid method
validateToken
@ -178,20 +181,25 @@ generateToken
:: Ticket
-> AuthResponse
-> MateHandler AuthResult
generateToken (Ticket _ tuid _ method) (AuthResponse hash) = do
generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) = do
conn <- rsConnection <$> ask
authData <- liftIO $ runSelect conn (
keepWhen (\(_, auid, _, _) ->
auid .== C.constant tuid) <<< queryTable authDataTable
keepWhen (\(_, auid, amethod, _) ->
auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
<<< queryTable authDataTable
) :: MateHandler
[ ( Int
, Int
, Int
, Maybe T.Text
, T.Text
)
]
let userHash = head $ map (\(_, _, _, payload) -> payload) authData
if userHash == Nothing || userHash == Just hash
let userPayloads = map (\(_, _, _, payload) -> payload) authData
authResult = case method of
PrimaryPass -> validatePass response userPayloads
SecondaryPass -> validatePass response userPayloads
ChallengeResponse -> validateChallengeResponse response userPayloads
if authResult
then do
token <- liftIO $ Token
<$> (decodeUtf8 <$> random 23)
@ -202,6 +210,11 @@ generateToken (Ticket _ tuid _ method) (AuthResponse hash) = do
return $ Granted (AuthToken $ tokenString token)
else
return Denied
where
validatePass provided presents =
any (\present -> provided == present) presents
validateChallengeResponse provided presents =
error "Validation of challnge response authentication not yet implemented"
insertToken
@ -247,19 +260,22 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
}
newTicket :: Int -> AuthMethod -> MateHandler AuthTicket
newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
newTicket ident method = do
store <- rsTicketStore <$> ask
rand <- liftIO $ (decodeUtf8 <$> random 23)
rand1 <- liftIO $ (decodeUtf8 <$> random 23)
rand2 <- liftIO $ case method of
ChallengeResponse -> Just <$> (decodeUtf8 <$> random 23)
_ -> return Nothing
later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
let ticket = Ticket
{ ticketId = AuthTicket rand
{ ticketId = AuthTicket rand1
, ticketUser = ident
, ticketExpiry = later
, ticketMethod = method
, ticketMethod = (method, rand2)
}
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
return (AuthTicket rand)
return (rand2, AuthTicket rand1)
processAuthRequest
@ -280,7 +296,7 @@ processAuthRequest (AuthRequest aticket hash) = do
pure aticket <*>
pure 1 <*>
liftIO getCurrentTime <*>
pure PrimaryPass
pure (PrimaryPass, Nothing)
generateToken mockticket hash
#else
return Denied
@ -295,7 +311,7 @@ processAuthRequest (AuthRequest aticket hash) = do
pure aticket <*>
pure 1 <*>
liftIO getCurrentTime <*>
pure PrimaryPass
pure (PrimaryPass, Nothing)
generateToken mockticket hash
#else
return Denied

View File

@ -118,7 +118,7 @@ data Ticket = Ticket
{ ticketId :: AuthTicket
, ticketUser :: Int
, ticketExpiry :: UTCTime
, ticketMethod :: AuthMethod
, ticketMethod :: (AuthMethod, Maybe T.Text)
}
deriving (Show, Ord)
@ -130,6 +130,6 @@ data AuthData = AuthData
{ authDataId :: Int
, authDataUser :: Int
, authDataMethod :: AuthMethod
, authDataPayload :: Maybe T.Text
, authDataPayload :: T.Text
}
deriving (Show)