From 101cf0ca99c40e25f69f44b16603e3528c0aade8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Wed, 31 Jan 2024 02:17:55 +0000 Subject: [PATCH] fixed checking refresh tokens --- src/AuthCode.hs | 29 ++++++++++++++--------------- src/Server.hs | 28 +++++++++++++++++++--------- 2 files changed, 33 insertions(+), 24 deletions(-) diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 101b232..da21caf 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -164,18 +164,17 @@ decodeToken token state = do prKey <- atomically $ readTVar state >>= return . privateKey jwkDecode prKey $ encodeUtf8 token -renewToken :: JWTWrapper -> AuthState user -> IO (Maybe JWTWrapper) -renewToken (JWTW _ _ rt) state = case rt >>= stripPrefix "Bearer " . pack of - Just t -> decodeToken t state >>= \case - Right (Jwe (header, body)) -> do - let jwt = fromJust . decode @JWT $ fromStrict body - now <- getCurrentTime - if now <= expiration jwt then return Nothing else do - mUser <- atomically . stateTVar state $ \s -> - let (key, tokens) = M.updateLookupWithKey (\_ _ -> Nothing) (jti jwt) s.activeTokens - in (key, s { activeTokens = tokens }) - case mUser of - Just (u, scopes) -> Just <$> mkToken u scopes state - Nothing -> return Nothing - Left _ -> return Nothing - Nothing -> return Nothing +renewToken :: Text -> AuthState user -> IO (Maybe JWTWrapper) +renewToken t state = decodeToken t state >>= \case + Right (Jwe (header, body)) -> do + let jwt = fromJust . decode @JWT $ fromStrict body + now <- getCurrentTime + if now >= expiration jwt then return Nothing else do + mUser <- atomically . stateTVar state $ \s -> + let (key, tokens) = M.updateLookupWithKey (\_ _ -> Nothing) (jti jwt) s.activeTokens + in (key, s { activeTokens = tokens }) + case mUser of + Just (u, scopes) -> Just <$> mkToken u scopes state + Nothing -> return Nothing + Left _ -> return Nothing + diff --git a/src/Server.hs b/src/Server.hs index dfdb44d..b233fee 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -53,7 +53,7 @@ import Text.ParserCombinators.ReadPrec (look, pfail) import qualified Text.Read.Lex as Lex -import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe) +import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..)) @@ -185,9 +185,11 @@ codeServer = handleCreds ---------------------- newtype ACode = ACode String deriving (Show) +newtype RToken = RToken Text deriving (Show) data ClientData = ClientData --TODO support other flows - { authID :: Either ACode JWTWrapper + { authID :: Either ACode RToken + , grantType :: Text , clientID :: Maybe String , clientSecret :: Maybe String , redirect :: Maybe String @@ -198,10 +200,11 @@ instance FromHttpApiData AuthFlow where parseQueryParam "authorization_code" = Right AuthFlow parseQueryParam x = Left x + instance FromForm ClientData where fromForm f = ClientData - <$> (((parseUnique @AuthFlow "grant_type" f) *> (Left . ACode <$> parseUnique "code" f)) - <|> ((parseUnique @String "grant_type" f >>= \p -> if p == "refresh_token" then Right p else Left (pack p)) *> (Right <$> parseUnique "refresh_token" f))) + <$> ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f))) + <*> parseUnique "grant_type" f <*> parseMaybe "client_id" f <*> parseMaybe "client_secret" f <*> parseMaybe "redirect_uri" f @@ -211,21 +214,24 @@ instance Error Text where type Token = "token" - :> ReqBody '[FormUrlEncoded] ClientData + :> ReqBody '[FormUrlEncoded] Form --ClientData :> Post '[JSON] JWTWrapper tokenEndpoint :: forall user userData . UserData user userData => AuthServer user Token tokenEndpoint = provideToken where - provideToken :: ClientData -> AuthHandler user JWTWrapper - provideToken client = do - liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show client + provideToken :: Form -> AuthHandler user JWTWrapper + provideToken clienty = do + liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show clienty + liftIO . print $ fromForm @ClientData clienty + let Right client = fromForm @ClientData clienty unless (isNothing (clientID client >> clientSecret client) || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) . throwError $ err500 { errBody = "Invalid client" } case authID client of Left (ACode authCode) -> do + unless (grantType client == "authorization_code") . throwError $ err500 { errBody = "Invalid grant_type" } mUser <- asks (verify (pack authCode) (clientID client)) >>= liftIO -- TODO verify redirect url here unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" } -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay} @@ -233,8 +239,11 @@ tokenEndpoint = provideToken token <- asks (mkToken @user user scopes) >>= liftIO liftIO . putStrLn $ "token: " ++ show token return token - Right jwtw -> do + Right (RToken jwtw) -> do + unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" } + liftIO $ putStrLn "... checking refresh token" mToken <- asks (renewToken @user jwtw) >>= liftIO + liftIO $ putStrLn "woohoo" case mToken of Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token Nothing -> throwError $ err500 { errBody = "Invalid refresh token" } @@ -291,6 +300,7 @@ userListEndpoint = handleUserData where handleUserData :: Text -> Text -> AuthHandler user [userData] handleUserData jwtw userID = do + liftIO $ putStrLn "\nHOEHOEHOEHOEHOEHOHEHJBSDKFJBSDKGHBSDKGHBK\a\n" mAdmin <- verifyToken @user @userData jwtw unless (isJust mAdmin) . throwError $ err500 { errBody = "Unknown token" } -- TODO check if this user is allowed query other users