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 -> MateHandler AuthInfo
authGet (TicketRequest uid method) = do authGet (TicketRequest uid method) = do
mai <- getUserAuthInfo uid method getUserAuthInfo uid method
case mai of
Just ai -> (return ai :: MateHandler AuthInfo)
Nothing -> throwError $ err404
{ errBody = "No such user"
}
authSend :: AuthRequest -> MateHandler AuthResult authSend :: AuthRequest -> MateHandler AuthResult
authSend = processAuthRequest authSend = processAuthRequest

View file

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

View file

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