From 35ab85288253c5c75beea50396aca904ceabc5f4 Mon Sep 17 00:00:00 2001
From: David Mosbach <david.mosbach@live.de>
Date: Sat, 23 Dec 2023 00:54:25 +0100
Subject: [PATCH] added remaining required query params

---
 app/Main.hs   |  2 +-
 src/Server.hs | 64 ++++++++++++++++++++++++++++++++++++++++-----------
 src/User.hs   |  2 +-
 3 files changed, 53 insertions(+), 15 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 602b018..2b73882 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -3,4 +3,4 @@ module Main (main) where
 import Server
 
 main :: IO ()
-main = putStrLn "Try: http://localhost:8080/auth?scopes=[ID,Profile]" >> runMockServer 8080
+main = putStrLn "Try: http://localhost:8080/auth?scope=[ID,Profile]&client_id=42&response_type=code&redirect_uri=localhost" >> runMockServer 8080
diff --git a/src/Server.hs b/src/Server.hs
index 1a266ce..ef238af 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -10,11 +10,12 @@ import User
 
 import Control.Concurrent
 import Control.Exception (bracket)
+import Control.Monad (unless)
 import Control.Monad.IO.Class
 
 import Data.Aeson
 import Data.List (find)
-import Data.Text hiding (find, head, map)
+import Data.Text hiding (elem, find, head, map)
 import Data.Text.Encoding (decodeUtf8)
 
 import qualified Data.Map.Strict as Map
@@ -24,31 +25,68 @@ import Network.Wai.Handler.Warp
 
 import Servant
 import Servant.Client
--- import Servant.API
+import Servant.API
+
+import Text.ParserCombinators.ReadPrec (look)
+import Text.Read (readPrec)
 
 
-testUsers :: [User]
+testUsers :: [User] -- TODO move to db
 testUsers =
   [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"}
   , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"}
   , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}]
 
+trustedClients :: [Text] -- TODO move to db
+trustedClients = ["42"]
+
+data ResponseType = Code -- ^ authorisation code grant
+                  | Token -- ^ implicit grant via access token
+                  | IDToken -- ^ implicit grant via access token & ID token
+                  deriving (Eq, Show)
+instance Read ResponseType where
+  readPrec = look >>= \str -> return $ case str of
+    "code" -> Code
+    "token" -> Token
+    "id_token" -> IDToken
+
+type QScope    = String
+type QClient   = String
+type QResType  = String
+type QRedirect = String
+
+type QParam = QueryParam' [Required, Strict]
+
+type Auth user userData = BasicAuth "login" user
+                       :> "auth"
+                       :> QParam "scope" QScope
+                       :> QParam "client_id" QClient
+                       :> QParam "response_type" QResType
+                       :> QParam "redirect_uri" QRedirect
+                       :> Get '[JSON] userData
 
-type Auth user userData = BasicAuth "login" user :> "auth" :> QueryParam "scopes" String :> Get '[JSON] (Maybe userData) -- TODO also parametrise "auth" to (auth :: Symbol)
 type Token = "token" :> Post '[JSON] Text -- TODO post jwt token
 -- type Insert = "insert" :> Post '[JSON] User
 
 authServer :: forall user userData . UserData user userData => Server (Auth user userData)
 authServer = handleAuth
   where
-    handleAuth :: user -> Maybe String -> Handler (Maybe userData)
-    handleAuth _ Nothing = liftIO (putStrLn "no query param given") >> return Nothing
-    handleAuth u (Just x) = do
+    handleAuth :: user
+               -> QScope
+               -> QClient
+               -> QResType
+               -> QRedirect
+               -> Handler userData
+    handleAuth u scopes client responseType url = do
+      unless (pack client `elem` trustedClients) . -- TODO fetch trusted clients from db
+        throwError $ err404 { errBody = "Not a trusted client."}
       let
-        scopes = readScopes @user @userData x 
-        ud = mconcat $ map (userScope @user @userData u) scopes
-      liftIO (putStrLn $ "query param: " ++ showScopes @user @userData scopes)
-      return $ Just ud
+        scopes' = readScopes @user @userData scopes
+        uData = mconcat $ map (userScope @user @userData u) scopes'
+        responseType' = read @ResponseType responseType
+
+      liftIO (putStrLn $ "user: " ++ show u ++ " | scopes: " ++ showScopes @user @userData scopes')
+      return uData
 
 exampleAuthServer :: Server (Auth User (Map.Map Text Text))
 exampleAuthServer = authServer
@@ -71,8 +109,8 @@ authenticate users = BasicAuthCheck $ \authData -> do
     Nothing -> return NoSuchUser
     Just u  -> return $ if uPass == password u then Authorized u else BadPassword
 
-frontend :: BasicAuthData -> ClientM (Maybe (Map.Map Text Text))
-frontend ba = client authAPI ba $ Just "[ID]"
+frontend :: BasicAuthData -> ClientM (Map.Map Text Text)
+frontend ba = client authAPI ba "[ID]" "42" "code" ""
 
 runMockServer :: Int -> IO ()
 runMockServer port = run port $ insecureOAuthMock' testUsers
diff --git a/src/User.hs b/src/User.hs
index 955236f..292223b 100644
--- a/src/User.hs
+++ b/src/User.hs
@@ -12,7 +12,7 @@ import Data.Text hiding (singleton)
 import GHC.Generics
 
 
-class (Eq u, ToJSON a, Monoid a) => UserData u a where -- TODO Eq maybe not necessary, but currently needed for TypeApplications
+class (Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary, but currently needed for TypeApplications
   data Scope u
   readScopes :: String -> [Scope u]
   showScopes :: [Scope u] -> String