From 52f43c81ebb4fc68dab51ec3dbe8750598d8d484 Mon Sep 17 00:00:00 2001
From: David Mosbach <david.mosbach@live.de>
Date: Fri, 22 Dec 2023 04:21:41 +0100
Subject: [PATCH] added authentication logic

---
 app/Main.hs              |  4 +--
 oauth2-mock-server.cabal |  6 ++++
 package.yaml             |  2 ++
 src/Server.hs            | 59 ++++++++++++++++++++++++++++++++--------
 4 files changed, 57 insertions(+), 14 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 38f23cc..602b018 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -2,7 +2,5 @@ module Main (main) where
 
 import Server
 
-import Network.Wai.Handler.Warp
-
 main :: IO ()
-main = putStrLn "Try: http://localhost:8080/auth?scopes=[ID,Profile]" >> run 8080 insecureOAuthMock
+main = putStrLn "Try: http://localhost:8080/auth?scopes=[ID,Profile]" >> runMockServer 8080
diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal
index 605444e..4d754df 100644
--- a/oauth2-mock-server.cabal
+++ b/oauth2-mock-server.cabal
@@ -32,7 +32,9 @@ library
       aeson
     , base >=4.7 && <5
     , containers
+    , http-client
     , servant
+    , servant-client
     , servant-server
     , text
     , warp
@@ -51,8 +53,10 @@ executable oauth2-mock-server-exe
       aeson
     , base >=4.7 && <5
     , containers
+    , http-client
     , oauth2-mock-server
     , servant
+    , servant-client
     , servant-server
     , text
     , warp
@@ -72,8 +76,10 @@ test-suite oauth2-mock-server-test
       aeson
     , base >=4.7 && <5
     , containers
+    , http-client
     , oauth2-mock-server
     , servant
+    , servant-client
     , servant-server
     , text
     , warp
diff --git a/package.yaml b/package.yaml
index 06a20b5..94904fb 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,6 +23,8 @@ dependencies:
 - base >= 4.7 && < 5
 - servant
 - servant-server
+- servant-client
+- http-client
 - warp
 - aeson
 - text
diff --git a/src/Server.hs b/src/Server.hs
index 9764359..5e288c4 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -1,52 +1,89 @@
 {-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications #-}
 
 module Server
-( insecureOAuthMock
+( insecureOAuthMock'
+, runMockServer
+, runMockServer'
 ) where
 
 import User
 
+import Control.Concurrent
+import Control.Exception (bracket)
 import Control.Monad.IO.Class
 
 import Data.Aeson
 import Data.List (find)
 import Data.Text hiding (find, head, map)
+import Data.Text.Encoding (decodeUtf8)
 
 import qualified Data.Map.Strict as Map
 
+import Network.HTTP.Client (newManager, defaultManagerSettings)
+import Network.Wai.Handler.Warp
 
 import Servant
+import Servant.Client
 -- import Servant.API
 
+
 testUsers :: [User]
 testUsers =
-  [ User {name = "TestName", email = "foo@bar.com", uID = "1"}]
+  [ 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"}]
 
 
-type Auth userData = "auth" :> QueryParam "scopes" String :> Get '[JSON] (Maybe userData) -- TODO also parametrise "auth" to (auth :: Symbol)
+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 => [user] -> Server (Auth userData)
+authServer :: forall user userData . UserData user userData => [user] -> Server (Auth user userData)
 authServer testUsers = handleAuth
   where
-    handleAuth :: Maybe String -> Handler (Maybe userData)
-    handleAuth Nothing = liftIO (putStrLn "no query param given") >> return Nothing
-    handleAuth (Just x) = do
+    handleAuth :: user -> Maybe String -> Handler (Maybe userData)
+    handleAuth _ Nothing = liftIO (putStrLn "no query param given") >> return Nothing
+    handleAuth _ (Just x) = do
       let
         scopes = readScopes @user @userData x 
         ud = mconcat $ map (userScope @user @userData $ head testUsers) scopes
       liftIO (putStrLn $ "query param: " ++ showScopes @user @userData scopes)
       return $ Just ud
 
-exampleAuthServer :: Server (Auth (Map.Map Text Text))
+exampleAuthServer :: Server (Auth User (Map.Map Text Text))
 exampleAuthServer = authServer testUsers
 
-authAPI :: Proxy (Auth (Map.Map Text Text))
+authAPI :: Proxy (Auth User (Map.Map Text Text))
 authAPI = Proxy
 
-insecureOAuthMock :: Application
-insecureOAuthMock = authAPI `serve` exampleAuthServer
+-- insecureOAuthMock :: Application
+-- insecureOAuthMock = authAPI `serve` exampleAuthServer
+
+insecureOAuthMock' :: [User] -> Application
+insecureOAuthMock' testUsers = serveWithContext authAPI c exampleAuthServer
+  where c = authenticate testUsers :. EmptyContext
+
+authenticate :: [User] -> BasicAuthCheck User
+authenticate users = BasicAuthCheck $ \authData -> do
+  let
+    (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
+  case (find (\u -> email u == uEmail) users) of
+    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]"
+
+runMockServer :: Int -> IO ()
+runMockServer port = run port $ insecureOAuthMock' testUsers
+
+runMockServer' :: Int -> IO ()
+runMockServer' port = do
+  mgr <- newManager defaultManagerSettings
+  bracket (forkIO . run port $ insecureOAuthMock' testUsers) killThread $ \_ ->
+    runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
+      >>= print
+  
 
 tokenEndpoint :: Server Token
 tokenEndpoint = undefined