Merge branch 'quick-auth' into 'main'

Login Form See merge request mosbach/oauth2-mock-server!1
2024-01-14 20:10:12 +00:00 · 2024-01-14 20:10:12 +00:00 · e6da28f7df
commit e6da28f7df
parent c8835c1d45 25f9ee95b1
6 changed files with 169 additions and 38 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -12,7 +12,7 @@ main :: IO ()
 main = do
  args <- getArgs >>= flip buildArgs M.empty
  port <- determinePort args
-  putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=localhost"
+  putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F"
  runMockServer port
    where
      buildArgs :: [String] -> M.Map String String -> IO (M.Map String String)
--- a/oauth2-mock-server.cabal
+++ b/oauth2-mock-server.cabal
@ -21,6 +21,7 @@ library
  exposed-modules:
      AuthCode
      DB
+      LoginForm
      Server
      User
  other-modules:
@ -34,15 +35,18 @@ library
      aeson
    , base >=4.7 && <5
    , base64
+    , blaze-html
    , bytestring
    , containers
    , http-api-data
    , http-client
+    , http-media
    , jose-jwt
    , servant
    , servant-client
    , servant-server
    , stm
+    , string-interpolate
    , text
    , time
    , transformers
@ -63,16 +67,19 @@ executable oauth2-mock-server-exe
      aeson
    , base >=4.7 && <5
    , base64
+    , blaze-html
    , bytestring
    , containers
    , http-api-data
    , http-client
+    , http-media
    , jose-jwt
    , oauth2-mock-server
    , servant
    , servant-client
    , servant-server
    , stm
+    , string-interpolate
    , text
    , time
    , transformers
@ -94,16 +101,19 @@ test-suite oauth2-mock-server-test
      aeson
    , base >=4.7 && <5
    , base64
+    , blaze-html
    , bytestring
    , containers
    , http-api-data
    , http-client
+    , http-media
    , jose-jwt
    , oauth2-mock-server
    , servant
    , servant-client
    , servant-server
    , stm
+    , string-interpolate
    , text
    , time
    , transformers
--- a/package.yaml
+++ b/package.yaml
@ -37,6 +37,9 @@ dependencies:
 - base64
 - http-api-data
 - uuid
+- blaze-html
+- http-media
+- string-interpolate

 ghc-options:
 - -Wall
--- a/src/LoginForm.hs
+++ b/src/LoginForm.hs
@ -0,0 +1,64 @@
+{-# Language OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, QuasiQuotes #-}
+
+module LoginForm (HTML(..), Html, loginPage) where
+
+import Prelude hiding (head)
+
+import qualified Data.Map as M
+import Data.Aeson (encode)
+import qualified Data.String.Interpolate as I
+import Data.String (IsString(..))
+import Data.Text (Text)
+
+import Network.HTTP.Media ((//), (/:))
+
+import Servant.API 
+
+-- import Text.Blaze
+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
+import Text.Blaze.Html5
+import qualified Text.Blaze.Html5.Attributes as A
+
+data HTML
+
+instance Accept HTML where
+  contentType _ = "text" // "html" /: ("charset", "utf-8")
+
+instance MimeRender HTML Html where
+  mimeRender _ = renderHtml
+
+loginPage :: M.Map Text Text -> Html
+loginPage headers = docTypeHtml $ head' >> body'
+  where
+    headers' = encode headers
+    formID = "loginForm" :: String
+    emailID = "email" :: String
+    buttonID = "loginButton" :: String
+    head' = head $ do
+      meta ! A.charset "UTF-8"
+      meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0"
+      title "UniWorX Oauth2 Mock Server"
+    body' = body $ do
+      h1 "UniWorX Oauth2 Mock Server"
+      form ! A.id (fromString formID) ! A.autocomplete "on" $ do
+        label ! A.for "email" $ "User"
+        input ! A.type_ "email" ! A.name "email" ! A.id (fromString emailID) ! A.autocomplete "email"
+      button ! A.type_ "button" ! A.id (fromString buttonID) $ "Login"
+      script $
+        [I.i|
+          #{buttonID}.onclick = async (e) => {
+            const headers = new Headers(#{headers'});
+            const formData = new FormData(#{formID});
+            const creds = formData.get('#{emailID}') + ':' + '';
+            headers.append('Authorization', btoa(creds));
+            alert(creds);
+            e.preventDefault();
+            fetch('../code', {
+              method: 'GET',
+              headers: headers
+            })
+            .then(response => response.text())
+            .then(url => window.location.replace(url.substring(1, url.length - 1)));
+            // Response.redirect(url);
+          };
+        |]
--- a/src/Server.hs
+++ b/src/Server.hs
@ -7,6 +7,7 @@ module Server
 )-} where

 import AuthCode
+import LoginForm
 import User

 import Control.Applicative ((<|>))
@ -24,7 +25,9 @@ import Data.List (find, elemIndex)
 import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)
 import Data.String (IsString (..))
 import Data.Text hiding (elem, find, head, length, map, null, splitAt, tail, words)
+import qualified Data.Text as T
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Text.Encoding.Base64
 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime)
 import Data.UUID.V4

@ -52,11 +55,6 @@ import qualified Text.Read.Lex as Lex
 import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe)


-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"}]

 data AuthClient = Client
  { ident :: Text
@ -87,21 +85,36 @@ instance Read ResponseType where
 type QScope    = String
 type QClient   = String
 type QResType  = String
-type QRedirect = String
+type QRedirect = Text
 type QState    = Text
+type QAuth     = Text

 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
-                       :> QueryParam "state" QState
-                       :> Get '[JSON] userData
+-- type Oauth2Params = QParam "scope" QScope
+--                  :> QParam "client_id" QClient
+--                  :> QParam "response_type" QResType
+--                  :> QParam "redirect_uri" QRedirect
+--                  :> QueryParam "state" QState

-- type Insert = "insert" :> Post '[JSON] User
+-- type ProtectedAuth user = BasicAuth "login" user :> "auth" :> Auth -- Prompts for username & password
+-- type QuickAuth = "qauth" :> Auth -- Prompts for username only
+type Foo user userData = BasicAuth "login" user :> "foo" :> Get '[JSON] userData
+type Auth = "auth"
+         :> QParam "scope" QScope
+         :> QParam "client_id" QClient
+         :> QParam "response_type" QResType
+         :> QParam "redirect_uri" QRedirect
+         :> QueryParam "state" QState
+         :> Get '[HTML] Html -- login
+
+type AuthCode = "code"
+             :> HeaderR "Authorization" QAuth
+             :> HeaderR "OA2_Scope" QScope
+             :> HeaderR "OA2_Client_ID" QClient
+             :> HeaderR "OA2_Redirect_URI" QRedirect
+             :> Header "OA2_State" QState
+             :> Get '[JSON] Text -- returns auth code


 type AuthHandler user = ReaderT (AuthState user) Handler
@ -110,39 +123,61 @@ type AuthServer user a = ServerT a (AuthHandler user)
 toHandler :: forall user userData a . UserData user userData => AuthState user -> AuthHandler user a -> Handler a
 toHandler s h = runReaderT h s

-authServer :: forall user userData . UserData user userData => AuthServer user (Auth user userData)
-authServer = handleAuth
+loginServer :: forall user userData . UserData user userData => AuthServer user Auth
+loginServer = handleAuth
  where
-    handleAuth :: user
-               -> QScope
+    handleAuth :: QScope
               -> QClient
               -> QResType
               -> QRedirect
               -> Maybe QState
-               -> AuthHandler user userData
-    handleAuth u scopes client responseType url mState = do
+               -> AuthHandler user Html
+    handleAuth scopes client responseType url mState = do
+      let
+        responseType' = read @ResponseType responseType
+        headers = Map.fromList @Text @Text
+          [ ("OA2_Scope", pack scopes)
+          , ("OA2_Client_ID", pack client)
+          , ("OA2_Redirect_URI", url)]
+        headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers
+      unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }
+      return $ loginPage headers'
+
+codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode
+codeServer  = handleCreds
+  where
+    handleCreds :: QAuth
+                -> QScope
+                -> QClient
+                -> QRedirect
+                -> Maybe QState
+                -> AuthHandler user Text
+    handleCreds creds scopes client url mState = do
      unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
        throwError $ err404 { errBody = "Not a trusted client."}
      let
-        responseType' = read @ResponseType responseType
        scopes' = map (readScope @user @userData) $ words scopes
-      liftIO $ print responseType'
-      unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }  
-      mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') url) >>= liftIO
+        [userName, password] = splitOn ":" $ decodeBase64Lenient creds
+      liftIO $ print userName
+      mUser <- liftIO $ lookupUser @user @userData userName password
+      unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
+      let u = fromJust mUser
+      mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO
      liftIO $ print mAuthCode
      liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
      redirect $ addParams url mAuthCode mState
-    redirect :: Maybe ByteString -> AuthHandler user userData
-    redirect (Just url) = liftIO (print url) >> throwError err303 { errHeaders = [("Location", url)]}
+    redirect :: Maybe Text -> AuthHandler user Text
+    redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
    redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
-    addParams :: String -> Maybe Text -> Maybe Text -> Maybe ByteString
+    addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
    addParams url Nothing _ = Nothing
    addParams url (Just code) mState =
-      let qPos = fromMaybe (length url) $ elemIndex '?' url
-          (pre, post) = splitAt qPos url
-          rState = case mState of {Just s -> "&state=" ++ (unpack . replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
-          post' = if not (null post) then '&' : tail post else post
-      in Just . fromString $ pre ++ "?code=" ++ (unpack code) ++ post' ++ rState
+      let urlParts = splitOn "?" url
+          (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
+          rState = case mState of {Just s -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
+          post' = if not (T.null post) then "&" <> T.tail post else post
+      in Just $ pre <> "?code=" <> code <> post' <> rState
+    


 ----------------------
@ -284,16 +319,22 @@ userListEndpoint = handleUserData
 ---- Server Main ----
 -------------------

-type Routing user userData = Auth user userData
+type Routing user userData = Auth
+                        :<|> AuthCode
                        :<|> Token
                        :<|> Me userData
                        :<|> UserList userData
+                        :<|> Foo user userData
+                        -- :<|> "qauth" :> Get '[HTML] Html

 routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
-routing = authServer @user @userData
+routing = loginServer @user @userData
+     :<|> codeServer @user @userData
     :<|> tokenEndpoint @user @userData
     :<|> userEndpoint @user @userData
     :<|> userListEndpoint @user @userData
+     :<|> undefined
+    --  :<|> return (loginPage "/foobar")

 exampleAuthServer :: AuthServer User (Routing User (Map.Map Text Text))
 exampleAuthServer = routing
--- a/src/User.hs
+++ b/src/User.hs
@ -3,20 +3,26 @@
 module User
 ( UserData(..)
 , User (..)
+, testUsers
 ) where

 import Data.Aeson
+import Data.List (find)
 import Data.Map.Strict
-import Data.Text hiding (singleton)
+import Data.Maybe
+import Data.Text hiding (singleton, find)

 import GHC.Generics

+type UserName = Text
+type Password = Text

 class (Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary, but currently needed for TypeApplications
  data Scope u
  readScope :: String -> Scope u
  showScope :: Scope u -> String
  userScope  :: u -> Scope u -> a
+  lookupUser :: UserName -> Password -> IO (Maybe u)


 data User = User
@ -26,10 +32,17 @@ data User = User
  , uID      :: Text
  } deriving (Eq, Show)

+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"}]
+

 instance UserData User (Map Text Text) where
  data Scope User = ID | Profile deriving (Show, Read, Eq)
  readScope = read
  showScope = show
  userScope User{..} ID = singleton "id" uID
-  userScope User{..} Profile = fromList [("name", name), ("email", email)]
+  userScope User{..} Profile = fromList [("name", name), ("email", email)]
+  lookupUser e _ = return $ find (\User{..} -> email == e) testUsers