fixed checking refresh tokens

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
+

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