From 7bb209cb5625b296d6509973ab6abcafdf078077 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 14 Jan 2024 04:16:01 +0100 Subject: [PATCH 1/2] mock login without passwords --- oauth2-mock-server.cabal | 10 +++++ package.yaml | 3 ++ src/LoginForm.hs | 61 ++++++++++++++++++++++++++ src/Server.hs | 92 ++++++++++++++++++++++++++++------------ src/User.hs | 17 +++++++- 5 files changed, 155 insertions(+), 28 deletions(-) create mode 100644 src/LoginForm.hs diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index 94639e3..240d473 100644 --- 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 diff --git a/package.yaml b/package.yaml index 9790ba0..448b44a 100644 --- 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 diff --git a/src/LoginForm.hs b/src/LoginForm.hs new file mode 100644 index 0000000..054e21c --- /dev/null +++ b/src/LoginForm.hs @@ -0,0 +1,61 @@ +{-# 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) => { + let headers = new Headers(#{headers'}); + let formData = new FormData(#{formID}); + let creds = formData.get('#{emailID}') + ':' + ''; + headers.append('Authorization', btoa(creds)); + alert(creds); + alert(headers.get('Authorization')); + e.preventDefault(); + await fetch('../code', { + method: 'GET', + headers: headers + })}; + |] \ No newline at end of file diff --git a/src/Server.hs b/src/Server.hs index 9adf940..f152a30 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -7,6 +7,7 @@ module Server )-} where import AuthCode +import LoginForm import User import Control.Applicative ((<|>)) @@ -25,6 +26,7 @@ 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 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 +54,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 @@ -89,19 +86,34 @@ type QClient = String type QResType = String type QRedirect = String 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] () -- returns auth code type AuthHandler user = ReaderT (AuthState user) Handler @@ -110,29 +122,50 @@ 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", pack 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 () + 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" } + [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') 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 :: Maybe ByteString -> AuthHandler user () redirect (Just url) = liftIO (print url) >> throwError err303 { errHeaders = [("Location", url)]} redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."} addParams :: String -> Maybe Text -> Maybe Text -> Maybe ByteString @@ -143,6 +176,7 @@ authServer = handleAuth 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 + ---------------------- @@ -284,16 +318,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 diff --git a/src/User.hs b/src/User.hs index 15b0a37..8c48fa5 100644 --- 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)] \ No newline at end of file + userScope User{..} Profile = fromList [("name", name), ("email", email)] + lookupUser e _ = return $ find (\User{..} -> email == e) testUsers \ No newline at end of file From 25f9ee95b1a94dc53c133f1ef1bccc0df5d14ad8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 14 Jan 2024 18:39:57 +0100 Subject: [PATCH 2/2] redirecting to client via javascript --- app/Main.hs | 2 +- src/LoginForm.hs | 15 +++++++++------ src/Server.hs | 27 ++++++++++++++------------- 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c6b6876..28ffe38 100644 --- 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) diff --git a/src/LoginForm.hs b/src/LoginForm.hs index 054e21c..18202fb 100644 --- a/src/LoginForm.hs +++ b/src/LoginForm.hs @@ -47,15 +47,18 @@ loginPage headers = docTypeHtml $ head' >> body' script $ [I.i| #{buttonID}.onclick = async (e) => { - let headers = new Headers(#{headers'}); - let formData = new FormData(#{formID}); - let creds = formData.get('#{emailID}') + ':' + ''; + const headers = new Headers(#{headers'}); + const formData = new FormData(#{formID}); + const creds = formData.get('#{emailID}') + ':' + ''; headers.append('Authorization', btoa(creds)); alert(creds); - alert(headers.get('Authorization')); e.preventDefault(); - await fetch('../code', { + fetch('../code', { method: 'GET', headers: headers - })}; + }) + .then(response => response.text()) + .then(url => window.location.replace(url.substring(1, url.length - 1))); + // Response.redirect(url); + }; |] \ No newline at end of file diff --git a/src/Server.hs b/src/Server.hs index f152a30..7c252ac 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -25,6 +25,7 @@ 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) @@ -84,7 +85,7 @@ 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 @@ -113,7 +114,7 @@ type AuthCode = "code" :> HeaderR "OA2_Client_ID" QClient :> HeaderR "OA2_Redirect_URI" QRedirect :> Header "OA2_State" QState - :> Get '[JSON] () -- returns auth code + :> Get '[JSON] Text -- returns auth code type AuthHandler user = ReaderT (AuthState user) Handler @@ -137,7 +138,7 @@ loginServer = handleAuth headers = Map.fromList @Text @Text [ ("OA2_Scope", pack scopes) , ("OA2_Client_ID", pack client) - , ("OA2_Redirect_URI", pack url)] + , ("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' @@ -150,7 +151,7 @@ codeServer = handleCreds -> QClient -> QRedirect -> Maybe QState - -> AuthHandler user () + -> 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."} @@ -161,21 +162,21 @@ codeServer = handleCreds 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') url) >>= liftIO + 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 () - 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