diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index e3cf611..0380f4e 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -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 diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 8206dbe..ed3a436 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 7f32b45..8ead9e9 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -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)