From 3e2d07518c2a943868bccefec3c1c76b543ef3c2 Mon Sep 17 00:00:00 2001
From: David Mosbach <david.mosbach@live.de>
Date: Wed, 10 Jan 2024 16:28:22 +0100
Subject: [PATCH] ClientData type now only supports the auth code flow

---
 src/Server.hs | 51 ++++++++++++++++++---------------------------------
 1 file changed, 18 insertions(+), 33 deletions(-)

diff --git a/src/Server.hs b/src/Server.hs
index 80537c3..0bbb5b1 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -147,40 +147,26 @@ authServer = handleAuth
  ----------------------
 
 
-data ClientData = ClientData
-  { grantType :: GrantType
-  , grant :: String
-  , userName :: Maybe String
+data ClientData = ClientData --TODO support other flows
+  { authCode :: String
   , clientID :: Maybe String
   , clientSecret :: Maybe String
   , redirect :: Maybe String
   } deriving Show
 
+data AuthFlow = AuthFlow
+instance FromHttpApiData AuthFlow where
+  parseQueryParam "authorization_code" = Right AuthFlow
+  parseQueryParam x = Left x
 
 instance FromForm ClientData where
   fromForm f = ClientData
-    <$> parseUnique "grant_type" f
-    <*>  (parseUnique @String (ps PassCreds) f --TODO add alternatives
-      >> parseUnique @String (ps AuthCode) f
-      >> parseUnique @String (ps Implicit) f
-      >> parseUnique @String (ps ClientCreds) f)
-    <*> parseMaybe "username" f
+    <$> ((parseUnique @AuthFlow "grant_type" f) *> parseUnique "code" f)
     <*> parseMaybe "client_id" f
     <*> parseMaybe "client_secret" f
     <*> parseMaybe "redirect_uri" f
-      where ps = pack . show
 
-data GrantType = PassCreds | AuthCode | Implicit | ClientCreds deriving (Eq)
 
-instance Show GrantType where
-  show PassCreds = "password"
-  show AuthCode  = "code"
-  show _         = undefined --TODO support other flows
-
-instance FromHttpApiData GrantType where
-  parseQueryParam s
-    | s == pack (show AuthCode) = Right AuthCode
-    | otherwise = Left $ s <> " grant type not supported yet"
 
 data JWT = JWT
   { issuer :: Text
@@ -212,22 +198,21 @@ type Token = "token"
           :> ReqBody '[FormUrlEncoded] ClientData
           :> Post '[JSON] JWTWrapper
 
+
 tokenEndpoint :: AuthServer Token
 tokenEndpoint = provideToken
   where
     provideToken :: ClientData -> AuthHandler JWTWrapper
-    provideToken client = case (grantType client) of
-      AuthCode -> do
-        unless (isNothing (clientID client >> clientSecret client)
-          || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
-            throwError $ err500 { errBody = "Invalid client" }
-        valid <- asks (verify (pack $ grant client) (clientID client)) >>= liftIO -- TODO verify redirect url here
-        unless valid . throwError $ err500 { errBody = "Invalid authorisation code" }
-        -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
-        token <- asks mkToken >>= liftIO
-        liftIO . putStrLn $ "token: " ++ show token
-        return token 
-      x -> error $ show x ++ " not supported yet"
+    provideToken client = do
+      unless (isNothing (clientID client >> clientSecret client)
+        || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
+          throwError $ err500 { errBody = "Invalid client" }
+      valid <- asks (verify (pack $ authCode client) (clientID client)) >>= liftIO -- TODO verify redirect url here
+      unless valid . throwError $ err500 { errBody = "Invalid authorisation code" }
+      -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
+      token <- asks mkToken >>= liftIO
+      liftIO . putStrLn $ "token: " ++ show token
+      return token 
 
 
 mkToken :: AuthState -> IO JWTWrapper