uniworx/oauth2-mock-server
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

mock login without passwords

Browse Source
This commit is contained in:
David Mosbach 2024-01-14 04:16:01 +01:00
parent c8835c1d45
commit 7bb209cb56
5 changed files with 155 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
oauth2-mock-server.cabal
View File

@ -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

3
package.yaml
View File

@ -37,6 +37,9 @@ dependencies:
- base64
- http-api-data
- uuid
- blaze-html
- http-media
- string-interpolate
ghc-options:
- -Wall

61
src/LoginForm.hs Normal file
View File

@ -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
})};
|]

82
src/Server.hs
View File

@ -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"
-- type Oauth2Params = QParam "scope" QScope
-- :> QParam "client_id" QClient
-- :> QParam "response_type" QResType
-- :> QParam "redirect_uri" QRedirect
-- :> QueryParam "state" QState
-- 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 '[JSON] userData
:> Get '[HTML] Html -- login
-- type Insert = "insert" :> Post '[JSON] User
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
@ -145,6 +178,7 @@ authServer = handleAuth
in Just . fromString $ pre ++ "?code=" ++ (unpack code) ++ post' ++ rState
----------------------
---- Token Endpoint ----
----------------------
@ -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

15
src/User.hs
View File

@ -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,6 +32,12 @@ 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)
@ -33,3 +45,4 @@ instance UserData User (Map Text Text) where
showScope = show
userScope User{..} ID = singleton "id" uID
userScope User{..} Profile = fromList [("name", name), ("email", email)]
lookupUser e _ = return $ find (\User{..} -> email == e) testUsers