From 45debf40cd171f78a4de38f608a6cfd3be73b91a Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 18 Feb 2024 22:58:02 +0000 Subject: [PATCH 1/9] added SSO test link route --- app/Main.hs | 3 +- app/SSO.hs | 42 +++++++ flake.nix | 4 +- oauth2-mock-server.cabal | 1 + package.yaml | 3 + src/Server.hs | 60 +++++----- users.yaml | 231 +++++++++++++++++++++++++++++++++++++++ 7 files changed, 310 insertions(+), 34 deletions(-) create mode 100644 app/SSO.hs diff --git a/app/Main.hs b/app/Main.hs index 4fc8172..52a7adb 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,6 +9,7 @@ module Main (main) where import UniWorX import Server +import SSO (SSOTest, routes) import Control.Applicative ((<|>)) import Database.Persist (Entity(..)) import System.Environment (lookupEnv) @@ -20,7 +21,7 @@ main = do port <- determinePort putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F" initDB - runMockServer @(Entity User) @(M.Map T.Text T.Text) port + runMockServerWithRoutes @(Entity User) @(M.Map T.Text T.Text) @SSOTest port routes where determinePort :: IO Int determinePort = do diff --git a/app/SSO.hs b/app/SSO.hs new file mode 100644 index 0000000..75d4631 --- /dev/null +++ b/app/SSO.hs @@ -0,0 +1,42 @@ +-- SPDX-FileCopyrightText: 2024 UniWorX Systems +-- SPDX-FileContributor: David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# Language DataKinds, TypeOperators, OverloadedStrings #-} + +module SSO (SSOTest, routes) where + +import Prelude hiding (head) + +import UniWorX +import Server + +import Data.String (IsString(..)) +import Data.Text (Text) + +import Database.Persist (Entity(..)) + +import Servant.API + +import Text.Blaze.Html5 +import qualified Text.Blaze.Html5.Attributes as A + + +type SSOTest = "test-sso" :> Get '[HTML] Html + +routes :: AuthServer (Entity User) SSOTest +routes = return ssoLink + where + ssoLink :: Html + ssoLink = docTypeHtml $ head' >> body' + where + t = "OIDC SSO Test" + head' = head $ do + meta ! A.charset "UTF-8" + meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0" + title t + body' = body $ do + h1 t + a ! A.href "https:..." $ "Go to FraDrive" + diff --git a/flake.nix b/flake.nix index 4e81d4e..58a405c 100644 --- a/flake.nix +++ b/flake.nix @@ -41,11 +41,12 @@ LD_LIBRARY_PATH=${libPath} mkdir -p $HOME/.stack stack build --verbose + rm -rf $HOME/.stack ''; installPhase = '' mkdir -p $out/bin mv .stack-work/install/${system}/*/*/bin/${name}-exe $out/bin/${name} - echo "moved" + rm -rf .stack-work ''; }; mkDB = builtins.readFile ./mkDB.sh; @@ -77,6 +78,7 @@ ${mkDB} zsh ${killDB} + exit ''; }; }; diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index 37004ba..6214f61 100644 --- a/oauth2-mock-server.cabal +++ b/oauth2-mock-server.cabal @@ -56,6 +56,7 @@ library executable oauth2-mock-server-exe main-is: Main.hs other-modules: + SSO UniWorX Paths_oauth2_mock_server autogen-modules: diff --git a/package.yaml b/package.yaml index 158730d..27500e6 100644 --- a/package.yaml +++ b/package.yaml @@ -76,6 +76,9 @@ executables: - conduit - mtl - yaml + - servant + - servant-server + - blaze-html tests: oauth2-mock-server-test: diff --git a/src/Server.hs b/src/Server.hs index 6942e9b..f995719 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -12,13 +12,18 @@ , RecordWildCards , AllowAmbiguousTypes , LambdaCase + , FlexibleContexts #-} module Server -{-( insecureOAuthMock' +( insecureOAuthMock , runMockServer --- , runMockServer' -)-} where +, runMockServerWithRoutes +, HTML +, Html +, AuthServer +, AuthHandler +) where import AuthCode import LoginForm @@ -101,14 +106,6 @@ type QAuth = Text type QParam = QueryParam' [Required, Strict] --- 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 Auth = "auth" :> QParam "scope" QScope :> QParam "client_id" QClient @@ -339,35 +336,34 @@ routing = loginServer @user @userData --- insecureOAuthMock :: Application --- insecureOAuthMock = authAPI `serve` exampleAuthServer - -insecureOAuthMock' :: forall user userData . UserData user userData => AuthState user -> Application -insecureOAuthMock' s = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData) +insecureOAuthMock :: forall user userData routes . + (UserData user userData, HasServer routes '[]) + => AuthState user + -> AuthServer user routes + -> Application +insecureOAuthMock s r = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData :<|> r) where - authAPI = Proxy @(Routing user userData) + authAPI = Proxy @(Routing user userData :<|> routes) --- 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 (Map.Map Text Text) --- frontend ba = client authAPI ba "[ID]" "42" "code" "" - -runMockServer :: forall user userData . UserData user userData => Int -> IO () -runMockServer port = do +runMockServerWithRoutes :: forall user userData routes . + (UserData user userData, HasServer routes '[]) + => Int + -> AuthServer user routes + -> IO () +runMockServerWithRoutes port server = do state <- mkState @user @userData - run port $ insecureOAuthMock' @user @userData state + run port $ insecureOAuthMock @user @userData @routes state server + +runMockServer :: forall user userData . UserData user userData + => Int + -> IO () +runMockServer port = runMockServerWithRoutes @user @userData @EmptyAPI port emptyServer -- runMockServer' :: Int -> IO () -- runMockServer' port = do -- mgr <- newManager defaultManagerSettings -- state <- mkState --- bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ -> +-- bracket (forkIO . run port $ insecureOAuthMock testUsers state) killThread $ \_ -> -- runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port "")) -- >>= print diff --git a/users.yaml b/users.yaml index e69de29..17ea6d1 100644 --- a/users.yaml +++ b/users.yaml @@ -0,0 +1,231 @@ +# SPDX-FileCopyrightText: 2024 David Mosbach +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +special-users: + + - default: &default-user + userIdent: null + userAuthentication: AuthLDAP + userLastAuthentication: null + userTokensIssuedAfter: null + userMatrikelnummer: null + userEmail: "" + userDisplayEmail: null + userDisplayName: null + userSurname: "" + userFirstName: "" + userTitle: null + userMaxFavourites: userDefaultMaxFavourites + userMaxFavouriteTerms: userDefaultMaxFavouriteTerms + userTheme: ThemeDefault + userDateTimeFormat: userDefaultDateTimeFormat + userDateFormat: userDefaultDateFormat + userTimeFormat: userDefaultTimeFormat + userDownloadFiles: userDefaultDownloadFiles + userWarningDays: userDefaultWarningDays + userLanguages: null + userCreated: now + userNotificationSettings: def + userLastLdapSynchronisation: null + userLdapPrimaryKey: null + userCsvOptions: def + userSex: null + userBirthday: null + userShowSex: userDefaultShowSex + userTelephone: null + userMobile: null + userCompanyPersonalNumber: null + userCompanyDepartment: null + userPinPassword: null + userPostAddress: null + userPostLastUpdate: null + userPrefersPostal: true + userExamOfficeGetSynced: userDefaultExamOfficeGetSynced + userExamOfficeGetLabels: userDefaultExamOfficeGetLabels + + - gkleen: + <<: *default-user + userIdent: "G.Kleen@campus.lmu.de" + userLastAuthentication: now + userTokensIssuedAfter: now + userEmail: "G.Kleen@campus.lmu.de" + userDisplayEmail: "gregor.kleen@ifi.lmu.de" + userDisplayName: "Gregor Kleen" + userSurname: "Kleen" + userFirstName: "Gregor Julius Arthur" + userMaxFavourites: 6 + userMaxFavouriteTerms: 1 + userLanguages: ["en"] + # userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC } + userSex: SexMale + userCompanyPersonalNumber: "00000" + userPostAddress: "Büro 127 \nMathematisches Institut der Ludwig-Maximilians-Universität München \nTheresienstr. 39 \nD-80333 München" + + - fhamann: + <<: *default-user + userIdent: "felix.hamann@campus.lmu.de" + userEmail: "noEmailKnown" + userDisplayEmail: "felix.hamann@campus.lmu.de" + userDisplayName: "Felix Hamann" + userSurname: "Hamann" + userFirstName: "Felix" + # userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel } + userSex: SexMale + userPinPassword: "tomatenmarmelade" + userPostAddress: "Erdbeerweg 24 \n12345 Schlumpfhausen \nTraumland" + + - jost: + <<: *default-user + userIdent: "jost@tcs.ifi.lmu.de" + userAuthentication: pwSimple + userMatrikelnummer: "12345678" + userEmail: "S.Jost@Fraport.de" + userDisplayEmail: "jost@tcs.ifi.lmu.de" + userDisplayName: "Steffen Jost" + userSurname: "Jost" + userFirstName: "Steffen" + userTitle: "Dr." + userMaxFavourites: 14 + userMaxFavouriteTerms: 4 + userTheme: ThemeMossGreen + userSex: SexMale + # userBirthday = Just $ n_day $ 35 * (-365) + userTelephone: "+49 69 690-71706" + userMobile: "0173 69 99 646" + userCompanyPersonalNumber: "57138" + userCompanyDepartment: "AVN-AR2" + + - maxMuster: + <<: *default-user + userIdent: "max@campus.lmu.de" + userLastAuthentication: now + userMatrikelnummer: "1299" + userEmail: "max@campus.lmu.de" + userDisplayEmail: "max@max.com" + userDisplayName: "Max Musterstudent" + userSurname: "Musterstudent" + userFirstName: "Max" + userMaxFavourites: 7 + userTheme: ThemeAberdeenReds + userLanguages: ["de"] + userSex: SexMale + # userBirthday = Just $ n_day $ 27 * (-365) + userPrefersPostal: false + + - tinaTester: + <<: *default-user + userIdent: "tester@campus.lmu.de" + userAuthentication: null + userMatrikelnummer: "999" + userEmail: "tester@campus.lmu.de" + userDisplayEmail: "tina@tester.example" + userDisplayName: "Tina Tester" + userSurname: "vön Tërrör¿" + userFirstName: "Sabrina" + userTitle: "Magister" + userMaxFavourites: 5 + userTheme: ThemeAberdeenReds + userLanguages: ["sn"] + userSex: SexNotApplicable + # userBirthday = Just $ n_day 3 + userCompanyPersonalNumber: "12345" + userPrefersPostal: false + + - svaupel: + <<: *default-user + userIdent: "vaupel.sarah@campus.lmu.de" + userEmail: "vaupel.sarah@campus.lmu.de" + userDisplayEmail: "vaupel.sarah@campus.lmu.de" + userDisplayName: "Sarah Vaupel" + userSurname: "Vaupel" + userFirstName: "Sarah" + userMaxFavourites: 14 + userMaxFavouriteTerms: 4 + userTheme: ThemeMossGreen + userLanguages: null + userSex: SexFemale + userPrefersPostal: false + + - sbarth: + <<: *default-user + userIdent: "Stephan.Barth@campus.lmu.de" + userEmail: "Stephan.Barth@lmu.de" + userDisplayEmail: "stephan.barth@ifi.lmu.de" + userDisplayName: "Stephan Barth" + userSurname: "Barth" + userFirstName: "Stephan" + userTheme: ThemeMossGreen + userSex: SexMale + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + - _stranger1: + userIdent: "AVSID:996699" + userEmail: "E996699@fraport.de" + userDisplayEmail: "" + userDisplayName: "Stranger One" + userSurname: "One" + userFirstName: "Stranger" + userTheme: ThemeMossGreen + userSex: SexMale + userCompanyPersonalNumber: "E996699" + userCompanyDepartment: "AVN-Strange" + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + - _stranger2: + userIdent: "AVSID:669966" + userEmail: "E669966@fraport.de" + userDisplayEmail: "" + userDisplayName: "Stranger Two" + userSurname: "Stranger" + userFirstName: "Two" + userTheme: ThemeMossGreen + userSex: SexMale + userCompanyPersonalNumber: "669966" + userCompanyDepartment: "AVN-Strange" + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + - _stranger3: + userIdent: "AVSID:6969" + userEmail: "E6969@fraport.de" + userDisplayEmail: "" + userDisplayName: "Stranger 3 Three" + userSurname: "Three" + userFirstName: "Stranger" + userTheme: ThemeMossGreen + userSex: SexMale + userCompanyPersonalNumber: "E996699" + userCompanyDepartment: "AVN-Strange" + userPostAddress: "Kartoffelweg 12 \n666 Höllensumpf \nFreiland" + userPrefersPostal: false + userExamOfficeGetSynced: false + userExamOfficeGetLabels: true + + +random-users: + firstNames: [ "James", "John", "Robert", "Michael" + , "William", "David", "Mary", "Richard" + , "Joseph", "Thomas", "Charles", "Daniel" + , "Matthew", "Patricia", "Jennifer", "Linda" + , "Elizabeth", "Barbara", "Anthony", "Donald" + , "Mark", "Paul", "Steven", "Andrew" + , "Kenneth", "Joshua", "George", "Kevin" + , "Brian", "Edward", "Susan", "Ronald" + ] + surnames: [ "Smith", "Johnson", "Williams", "Brown" + , "Jones", "Miller", "Davis", "Garcia" + , "Rodriguez", "Wilson", "Martinez", "Anderson" + , "Taylor", "Thomas", "Hernandez", "Moore" + , "Martin", "Jackson", "Thompson", "White" + , "Lopez", "Lee", "Gonzalez", "Harris" + , "Clark", "Lewis", "Robinson", "Walker" + , "Perez", "Hall", "Young", "Allen" + ] + middlenames: [ null, "Jamesson" ] + From ba9bc7f784aa594ccab25f308c7b3c5ee673f8bf Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sat, 2 Mar 2024 20:30:33 +0000 Subject: [PATCH 2/9] issuing of id tokens --- app/UniWorX.hs | 60 +++++++++++----- oauth2-mock-server.cabal | 3 + package.yaml | 1 + src/AuthCode.hs | 104 ++++++++++++++++++++++----- src/Server.hs | 148 +++++++++++++++++++++++---------------- src/User.hs | 72 ++++++++++++++++--- 6 files changed, 280 insertions(+), 108 deletions(-) diff --git a/app/UniWorX.hs b/app/UniWorX.hs index f373ef5..d49547b 100644 --- a/app/UniWorX.hs +++ b/app/UniWorX.hs @@ -31,6 +31,7 @@ import Control.Monad.Reader (ReaderT) import Conduit (ResourceT) import Data.Map (Map(..)) +import Data.Maybe (fromJust) import Data.String (IsString(..)) import Data.Text (Text(..)) import Data.Yaml (decodeFileThrow, FromJSON(..), Value(..), (.:), (.:?)) @@ -51,7 +52,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| email Text matricNumber Text Maybe title Text Maybe - sex Text Maybe + gender Text Maybe birthday Text Maybe telephone Text Maybe mobile Text Maybe @@ -68,7 +69,7 @@ instance FromJSON User where <*> o .: "userEmail" <*> o .:? "userMatrikelnummer" <*> o .:? "userTitle" - <*> o .:? "userSex" + <*> o .:? "userGender" <*> o .:? "userBirthday" <*> o .:? "userTelephone" <*> o .:? "userMobile" @@ -107,28 +108,49 @@ initDB = do instance UserData (Entity User) (Map Text Text) where - data Scope (Entity User) = ID | Profile deriving (Show, Read, Eq) - readScope = read - showScope = show - userScope (Entity _ User{..}) ID = M.singleton "id" userEmail - userScope (Entity _ User{..}) Profile = M.fromList [(key, val) | (key, Just val) <- - [ ("firstName", Just userFirstName) - , ("surname", Just userSurname) - , ("email", Just userEmail) - , ("matriculationNumber", userMatricNumber) + type UserID (Entity User) = Key User + data CustomScope (Entity User) = UWX deriving (Read, Show, Eq) + userScope (Entity _ User{..}) (Left OpenID) = M.singleton "id" userEmail + userScope (Entity _ User{..}) (Left Profile) = M.fromList $ catM + [ ("name", Just $ userFirstName <> " " <> userSurname) + , ("given_name", Just userFirstName) + , ("family_name", Just userSurname) + , ("middle_name", Nothing) + , ("nickname", Nothing) + , ("preferred_username", Nothing) + , ("profile", Nothing) + , ("picture", Nothing) + , ("website", Nothing) + , ("gender", userGender) + , ("birthdate", userBirthday) + , ("zoneinfo", Nothing) + , ("locale", Nothing) + , ("updated_at", Nothing) + ] + userScope (Entity _ User{..}) (Left Email) = M.fromList [("email", userEmail), ("email_verified", userEmail)] + userScope (Entity _ User{..}) (Left Address) = case userPostAddress of + Just address -> M.singleton "address" address + Nothing -> M.empty + userScope (Entity _ User{..}) (Left Phone) = M.fromList $ catM [("phone_number", userMobile), ("phone_number_verified", userTelephone)] + userScope (Entity _ User{..}) (Right UWX) = M.fromList $ catM + [ ("matriculationNumber", userMatricNumber) , ("title", userTitle) - , ("sex", userSex) - , ("birthday", userBirthday) - , ("telephone", userTelephone) - , ("mobile", userMobile) , ("companyPersonalNumber", userCompPersNumber) , ("companyDepartment", userCompDepartment) - , ("postAddress", userPostAddress) - ]] - lookupUser email _ = runDB $ do - user <- selectList [UserEmail ==. email] [] + ] + userScope (Entity _ User{..}) _ = M.empty + lookupUser UserQuery{..} = runDB $ do + let filters = map fst $ catM [(UserEmail ==. fromJust email, email)] + keyFilter = case key of + Just k -> \(Entity x _) -> (T.pack $ show x) == k + Nothing -> \_ -> True + user <- filter keyFilter <$> selectList filters [] case user of [entity] -> return $ Just entity [] -> return Nothing _ -> error "Oauth2 Mock Server: Ambiguous User." + userID (Entity x _) = x + +catM :: [(a, Maybe b)] -> [(a, b)] +catM l = [ (x,y) | (x, Just y) <- l ] diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index 6214f61..dc435b8 100644 --- a/oauth2-mock-server.cabal +++ b/oauth2-mock-server.cabal @@ -37,6 +37,7 @@ library , blaze-html , bytestring , containers + , cookie , http-api-data , http-client , http-media @@ -72,6 +73,7 @@ executable oauth2-mock-server-exe , bytestring , conduit , containers + , cookie , http-api-data , http-client , http-media @@ -112,6 +114,7 @@ test-suite oauth2-mock-server-test , blaze-html , bytestring , containers + , cookie , http-api-data , http-client , http-media diff --git a/package.yaml b/package.yaml index 27500e6..4834bd2 100644 --- a/package.yaml +++ b/package.yaml @@ -44,6 +44,7 @@ dependencies: - blaze-html - http-media - string-interpolate +- cookie ghc-options: - -Wall diff --git a/src/AuthCode.hs b/src/AuthCode.hs index da21caf..6f366be 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -3,12 +3,13 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase, DeriveGeneric, AllowAmbiguousTypes #-} module AuthCode ( State(..) , AuthState , AuthRequest(..) +, TokenParams(..) , JWT(..) , JWTWrapper(..) , genUnencryptedCode @@ -18,18 +19,23 @@ module AuthCode , renewToken ) where +import Prelude hiding (exp) + import User import Data.Aeson +import Data.Bool (bool) import Data.ByteString (ByteString (..), fromStrict, toStrict) import Data.Either (fromRight) +import Data.List ((\\)) import Data.Map.Strict (Map) -import Data.Maybe (isJust, fromMaybe, fromJust) +import Data.Maybe (isJust, fromMaybe, fromJust, catMaybes) +import Data.Time.Calendar import Data.Time.Clock import Data.Text (pack, replace, Text, stripPrefix) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding.Base64 -import Data.UUID +import Data.UUID hiding (null) import Data.UUID.V4 import qualified Data.ByteString.Char8 as BS @@ -40,13 +46,22 @@ import Control.Concurrent.STM.TVar import Control.Monad (void, (>=>)) import Control.Monad.STM +import GHC.Generics + import Jose.Jwa import Jose.Jwe import Jose.Jwk (Jwk(..)) import Jose.Jwt hiding (decode, encode) +import qualified Jose.Jws as Jws import Servant.API (FromHttpApiData(..)) +import System.Environment (getEnv) + + + -------------- +---- Tokens ---- + -------------- data JWT = JWT { issuer :: Text @@ -60,25 +75,41 @@ instance ToJSON JWT where instance FromJSON JWT where parseJSON (Object o) = JWT <$> o .: "iss" <*> o .: "exp" <*> o .: "jti" +data IDToken = IDT + { iss :: Text + , sub :: Text + , aud :: [Text] + , exp :: NominalDiffTime + , iat :: NominalDiffTime + , auth_time :: Maybe NominalDiffTime + , nonce :: Maybe Text + } deriving (Generic, Show) + +instance ToJSON IDToken +instance FromJSON IDToken + data JWTWrapper = JWTW { acessToken :: String , expiresIn :: NominalDiffTime , refreshToken :: Maybe String + , idToken :: Maybe String } deriving (Show) instance ToJSON JWTWrapper where - toJSON (JWTW a e r) = object + toJSON (JWTW a e r i) = object [ "access_token" .= a , "token_type" .= ("JWT" :: Text) , "expires_in" .= fromEnum e - , "refresh_token" .= r ] + , "refresh_token" .= r + , "id_token" .= i ] instance FromJSON JWTWrapper where parseJSON (Object o) = JWTW <$> o .: "access_token" <*> o .: "expires_in" <*> o .:? "refresh_token" + <*> o .:? "id_token" instance FromHttpApiData JWTWrapper where parseHeader bs = case decode (fromStrict bs) of @@ -86,24 +117,33 @@ instance FromHttpApiData JWTWrapper where Nothing -> Left "Invalid JWT wrapper" + ------------- +---- State ---- + ------------- + data AuthRequest user = AuthRequest { client :: String , codeExpiration :: NominalDiffTime , user :: user - , scopes :: [Scope user] + , scopes :: [Scope' user] + , rNonce :: Maybe Text } - +type TokenParams user = (user, [Scope' user], Maybe Text) data State user = State { activeCodes :: Map Text (AuthRequest user) - , activeTokens :: Map UUID (user, [Scope user]) + , activeTokens :: Map UUID (TokenParams user) , publicKey :: Jwk , privateKey :: Jwk } type AuthState user = TVar (State user) + ----------------- +---- Functions ---- + ----------------- + genUnencryptedCode :: AuthRequest user -> String -> AuthState user @@ -127,7 +167,10 @@ genUnencryptedCode req url state = do atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes } -verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user])) +verify :: Text + -> Maybe String + -> AuthState user + -> IO (Maybe (TokenParams user)) verify code mClientID state = do now <- getCurrentTime mData <- atomically $ do @@ -135,28 +178,48 @@ verify code mClientID state = do modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes } return result return $ case mData of - Just (AuthRequest clientID' _ u s) -> if (fromMaybe clientID' mClientID) == clientID' then Just (u, s) else Nothing + Just (AuthRequest clientID' _ u s n) -> if (fromMaybe clientID' mClientID) == clientID' + then Just (u, s, n) + else Nothing _ -> Nothing -mkToken :: user -> [Scope user] -> AuthState user -> IO JWTWrapper -mkToken u scopes state = do +mkToken :: forall user userData . UserData user userData + => TokenParams user + -> Maybe Text -- client_id + -> AuthState user + -> IO JWTWrapper +mkToken (u, scopes, nonce) clientID state = do pubKey <- atomically $ readTVar state >>= return . publicKey now <- getCurrentTime uuid <- nextRandom + port <- pack <$> getEnv "OAUTH2_SERVER_PORT" let lifetimeAT = 3600 :: NominalDiffTime -- TODO make configurable lifetimeRT = nominalDay -- TODO make configurable + lifetimeIT = 3600 :: NominalDiffTime -- TODO make configurable + itRefDate = UTCTime (fromGregorian 1970 1 1) 0 at = JWT "Oauth2MockServer" (lifetimeAT `addUTCTime` now) uuid rt = JWT "Oauth2MockServer" (lifetimeRT `addUTCTime` now) uuid + it = IDT + { iss = "http://localhost:" <> port -- TODO maybe make configurable + , sub = pack . show $ userID @user @userData u + , aud = catMaybes [clientID] + , exp = (lifetimeIT `addUTCTime` now) `diffUTCTime` itRefDate + , iat = now `diffUTCTime` itRefDate + , auth_time = Just $ now `diffUTCTime` itRefDate + , nonce = nonce + } encodedAT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode at) encodedRT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode rt) - case encodedAT >> encodedRT of + encodedIT <- Jws.jwkEncode RS256 pubKey (Nested . Jwt . toStrict $ encode it) + case encodedAT >> encodedRT >> encodedIT of Right _ -> do let Jwt aToken = fromRight undefined encodedAT Jwt rToken = fromRight undefined encodedRT - atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes) (activeTokens s) } - return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken) + Jwt iToken = fromRight undefined encodedIT + atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes, nonce) (activeTokens s) } + return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken) (Just $ BS.unpack iToken) Left e -> error $ show e decodeToken :: Text -> AuthState user -> IO (Either JwtError JwtContent) @@ -164,8 +227,13 @@ decodeToken token state = do prKey <- atomically $ readTVar state >>= return . privateKey jwkDecode prKey $ encodeUtf8 token -renewToken :: Text -> AuthState user -> IO (Maybe JWTWrapper) -renewToken t state = decodeToken t state >>= \case +renewToken :: forall user userData . UserData user userData + => Text -- ^ token + -> [Scope' user] + -> Maybe Text -- ^ client_id + -> AuthState user + -> IO (Maybe JWTWrapper) -- TODO more descriptive failures +renewToken t scopes clientID state = decodeToken t state >>= \case Right (Jwe (header, body)) -> do let jwt = fromJust . decode @JWT $ fromStrict body now <- getCurrentTime @@ -174,7 +242,7 @@ renewToken t state = decodeToken t state >>= \case let (key, tokens) = M.updateLookupWithKey (\_ _ -> Nothing) (jti jwt) s.activeTokens in (key, s { activeTokens = tokens }) case mUser of - Just (u, scopes) -> Just <$> mkToken u scopes state + Just (u, scopes', nonce) -> bool (pure Nothing) (Just <$> mkToken @user @userData (u, scopes, nonce) clientID state) (null $ scopes \\ scopes') Nothing -> return Nothing Left _ -> return Nothing diff --git a/src/Server.hs b/src/Server.hs index f995719..6804bc9 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -40,12 +40,13 @@ import Control.Monad.Trans.Error (Error(..)) import Control.Monad.Trans.Reader import Data.Aeson -import Data.ByteString (fromStrict) +import Data.ByteString (fromStrict, ByteString) 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 (encodeUtf8) import Data.Text.Encoding.Base64 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime) @@ -60,13 +61,14 @@ import Network.HTTP.Client (newManager, defaultManagerSettings) import Network.Wai.Handler.Warp import Servant -import Servant.Client +import Servant.Client hiding (client) import Servant.API import Text.ParserCombinators.ReadPrec (look, pfail) import qualified Text.Read.Lex as Lex +import Web.Cookie (parseCookiesText) import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..)) @@ -102,7 +104,9 @@ type QClient = String type QResType = String type QRedirect = Text type QState = Text +type QNonce = Text type QAuth = Text +type QCookie = Text type QParam = QueryParam' [Required, Strict] @@ -112,15 +116,17 @@ type Auth = "auth" :> QParam "response_type" QResType :> QParam "redirect_uri" QRedirect :> QueryParam "state" QState - :> Get '[HTML] Html -- login + :> QueryParam "nonce" QNonce + :> Header "Cookie" QCookie + :> 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 + :> Header "OA2_State" QState + :> Get '[JSON] (Headers '[Header "Set-Cookie" Text] Text) -- ^ returns auth code type AuthHandler user = ReaderT (AuthState user) Handler @@ -130,59 +136,76 @@ toHandler :: forall user userData a . UserData user userData => AuthState user - toHandler s h = runReaderT h s loginServer :: forall user userData . UserData user userData => AuthServer user Auth -loginServer = handleAuth +loginServer = decideLogin where - handleAuth :: QScope - -> QClient - -> QResType - -> QRedirect - -> Maybe QState - -> 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' + decideLogin scopes client responseType url mState mNonce mCookies + | Just nonce <- mNonce, Just cookies <- mCookies = handleOIDC nonce cookies + | Nothing <- (mNonce >> mCookies) = handleLogin + | otherwise = throwError err500 { errBody = "Either cookie or nonce missing" } + where + -- | Retrieve user id from cookie + handleOIDC :: QNonce + -> QCookie + -> AuthHandler user Html + handleOIDC nonce cookies = case read @ResponseType responseType of -- TODO nonce can also occur if user is not logged in yet + IDToken -> do + let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookies + unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" } + url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState (Just nonce) + throwError err303 { errHeaders = [("Location", encodeUtf8 url')]} + _ -> throwError err500 { errBody = "Unsupported response type" } + + -- | Html login form + handleLogin :: AuthHandler user Html + handleLogin = do + let + responseType' = read @ResponseType responseType + headers = Map.fromList @Text @Text $ + [ ("OA2_Scope", pack scopes) + , ("OA2_Client_ID", pack client) + , ("OA2_Redirect_URI", url) + ] ++ [(x,y) | (x, Just y) <- [("OA2_State", mState)]] + case responseType' of + Code -> return $ loginPage headers + _ -> throwError err500 { errBody = "Unsupported response type" } + 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 - scopes' = map (readScope @user @userData) $ words scopes - [userName, password] = splitOn ":" $ decodeBase64Lenient creds - liftIO $ print userName - mUser <- liftIO $ lookupUser @user @userData userName (Just 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 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 :: Text -> Maybe Text -> Maybe Text -> Maybe Text - addParams url Nothing _ = Nothing - addParams url (Just code) mState = - 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 +codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=" <> creds) <$> + handleCreds @user @userData creds scopes client url mState Nothing + +handleCreds :: forall user userData . UserData user userData + => QAuth + -> QScope + -> QClient + -> QRedirect + -> Maybe QState + -> Maybe QNonce + -> AuthHandler user Text +handleCreds creds scopes client url mState mNonce = 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 scopes' = map (read @(Scope' user)) $ words scopes + [userName, password] = splitOn ":" $ decodeBase64Lenient creds + mUser <- liftIO $ lookupUser @user @userData (UserQuery (Just userName) (Just password) Nothing) + unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."} + let u = fromJust mUser + mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes' mNonce) (unpack url)) >>= liftIO + liftIO $ print mAuthCode + liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map show scopes') + redirect $ addParams url mAuthCode mState + where + 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 :: Text -> Maybe Text -> Maybe Text -> Maybe Text + addParams url Nothing _ = Nothing + addParams url (Just code) mState = + 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 @@ -233,20 +256,21 @@ tokenEndpoint = provideToken unless (isNothing (clientID client >> clientSecret client) || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) . throwError $ err500 { errBody = "Invalid client" } + let cid = pack <$> clientID client case authID client of Left (ACode authCode) -> do unless (grantType client == "authorization_code") . throwError $ err500 { errBody = "Invalid grant_type" } mUser <- asks (verify (pack authCode) (clientID client)) >>= liftIO -- TODO verify redirect url here unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" } -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay} - let (user, scopes) = fromJust mUser - token <- asks (mkToken @user user scopes) >>= liftIO + token <- asks (mkToken @user @userData (fromJust mUser) cid) >>= liftIO liftIO . putStrLn $ "token: " ++ show token return token Right (RToken jwtw) -> do + let scopes = [] -- TODO read query param for this unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" } liftIO $ putStrLn "... checking refresh token" - mToken <- asks (renewToken @user jwtw) >>= liftIO + mToken <- asks (renewToken @user @userData jwtw scopes cid) >>= liftIO case mToken of Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token Nothing -> throwError $ err500 { errBody = "Invalid refresh token" } @@ -282,7 +306,7 @@ instance ToJSON result => ToJSON (QueryResult result) where toJSON (QRight x) = toJSON x -verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user])) +verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (TokenParams user)) verifyToken jwtw = do let mToken = stripPrefix "Bearer " jwtw unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" } @@ -302,7 +326,7 @@ userEndpoint = handleUserData where handleUserData :: Text -> AuthHandler user (QueryResult userData) handleUserData jwtw = verifyToken @user @userData jwtw >>= \case - Just (u, scopes) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes + Just (u, scopes, _) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes Nothing -> return . QLeft $ QError "UnknownToken" @@ -312,8 +336,8 @@ userListEndpoint = handleUserData handleUserData :: Text -> Text -> AuthHandler user (QueryResult [userData]) handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed query other users Nothing -> return . QLeft $ QError "UnknownToken" - Just admin -> liftIO $ lookupUser @user @userData userID Nothing >>= \case - Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) (snd admin)] -- TODO support queries that fit for multiple users + Just (_, scopes, _) -> liftIO $ lookupUser @user @userData (UserQuery (Just userID) Nothing Nothing) >>= \case + Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) scopes] -- TODO support queries that fit for multiple users Nothing -> return . QLeft $ QError "UserDoesNotExist" diff --git a/src/User.hs b/src/User.hs index b1d0aea..ffae304 100644 --- a/src/User.hs +++ b/src/User.hs @@ -3,21 +3,75 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, TypeApplications, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, AllowAmbiguousTypes, RankNTypes, OverlappingInstances, ScopedTypeVariables #-} -module User ( UserData(..) ) where +module User +( UserData(..) +, Scope(..) +, Scope'(..) +, UserQuery(..) +) where +import Control.Applicative ((<|>)) import Data.Aeson +import Data.Char (toUpper, toLower) import Data.Map.Strict import Data.Maybe -import Data.Text +import Data.Text hiding (head, tail, toUpper, toLower) + +import GHC.Read (readPrec, lexP) + +import Text.ParserCombinators.ReadPrec (look, pfail) +import qualified Text.Read.Lex as Lex type UserName = Text type Password = Text -class (Eq u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary - data Scope u - readScope :: String -> Scope u - showScope :: Scope u -> String - userScope :: u -> Scope u -> a - lookupUser :: UserName -> Maybe Password -> IO (Maybe u) +-- | OIDC scope +data Scope = OpenID + | Profile + | Email + | Address + | Phone + | OfflineAccess + deriving (Show, Eq) + +instance Read Scope where + readPrec = do + Lex.Ident str <- lexP + Lex.EOF <- lexP + return $ case str of + "openid" -> OpenID + "profile" -> Profile + "email" -> Email + "address" -> Address + "phone" -> Phone + "offline_access" -> OfflineAccess + + +type Scope' user = Either Scope (CustomScope user) + +instance forall user . Read (CustomScope user) => Read (Scope' user) where + readPrec = (Left <$> readPrec @Scope) <|> (Right <$> readPrec @(CustomScope user)) + +data UserQuery = UserQuery + { email :: Maybe Text + , password :: Maybe Text + , key :: Maybe Text + } deriving (Show) + +class ( Eq u + , Show u -- TODO Show maybe not necessary + , Show (UserID u) + , Read (CustomScope u) + , Show (CustomScope u) + , Eq (CustomScope u) + , ToJSON a + , Monoid a + ) => UserData u a where + type UserID u + data CustomScope u + userScope :: u -> Scope' u -> a + lookupUser :: UserQuery -> IO (Maybe u) + userID :: u -> UserID u + From 26d2255c252284560770d8c4268d376df85cdeb9 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sat, 2 Mar 2024 21:05:25 +0000 Subject: [PATCH 3/9] added logout endpoint --- src/LoginForm.hs | 21 +++++++++++++++++++-- src/Server.hs | 25 ++++++++++++++++++++++++- 2 files changed, 43 insertions(+), 3 deletions(-) diff --git a/src/LoginForm.hs b/src/LoginForm.hs index 45d38c7..34ed22d 100644 --- a/src/LoginForm.hs +++ b/src/LoginForm.hs @@ -5,7 +5,12 @@ {-# Language OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, QuasiQuotes #-} -module LoginForm (HTML(..), Html, loginPage) where +module LoginForm +( HTML(..) +, Html +, loginPage +, logoutPage +) where import Prelude hiding (head) @@ -66,4 +71,16 @@ loginPage headers = docTypeHtml $ head' >> body' .then(url => window.location.replace(url.substring(1, url.length - 1))); // Response.redirect(url); }; - |] \ No newline at end of file + |] + + +logoutPage :: Html +logoutPage = docTypeHtml $ head' >> body' + where + 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" + p "Logout successful." \ No newline at end of file diff --git a/src/Server.hs b/src/Server.hs index 6804bc9..877ff45 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -171,7 +171,7 @@ loginServer = decideLogin codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode -codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=" <> creds) <$> +codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$> handleCreds @user @userData creds scopes client url mState Nothing handleCreds :: forall user userData . UserData user userData @@ -341,6 +341,29 @@ userListEndpoint = handleUserData Nothing -> return . QLeft $ QError "UserDoesNotExist" + -------------- +---- Logout ---- + -------------- + +type Logout = "logout" + :> QueryParam "post_logout_redirect_uri" QRedirect + :> HeaderR "Cookie" QCookie + :> Get '[HTML] (Headers '[Header "Set-Cookie" Text] Html) + +logoutEndpoint :: forall user userData . UserData user userData => AuthServer user Logout +logoutEndpoint = logout + where + logout :: Maybe QRedirect + -> QCookie + -> AuthHandler user (Headers '[Header "Set-Cookie" Text] Html) + logout mUri cookie = do + let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookie + unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" } + addHeader "oa2_auth_cookie=\"\"" <$> case mUri of + Just uri -> throwError err303 { errHeaders = [("Location", encodeUtf8 uri)]} + Nothing -> return logoutPage + + ------------------- ---- Server Main ---- ------------------- From 2530a2dad6d914823fc3a048ec3ac0accb64a2b3 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 3 Mar 2024 21:02:57 +0000 Subject: [PATCH 4/9] fixed signing of id tokens --- src/AuthCode.hs | 21 +++++++----- src/Server.hs | 91 +++++++++++++++++++++++++++++-------------------- 2 files changed, 67 insertions(+), 45 deletions(-) diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 6f366be..f836724 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -132,10 +132,10 @@ data AuthRequest user = AuthRequest type TokenParams user = (user, [Scope' user], Maybe Text) data State user = State - { activeCodes :: Map Text (AuthRequest user) + { activeCodes :: Map Text (AuthRequest user) , activeTokens :: Map UUID (TokenParams user) - , publicKey :: Jwk - , privateKey :: Jwk + , publicKey :: Jwk + , privateKey :: Jwk } type AuthState user = TVar (State user) @@ -190,7 +190,7 @@ mkToken :: forall user userData . UserData user userData -> AuthState user -> IO JWTWrapper mkToken (u, scopes, nonce) clientID state = do - pubKey <- atomically $ readTVar state >>= return . publicKey + (pubKey, privKey) <- atomically $ readTVar state >>= return . ((,) <$> publicKey <*> privateKey) now <- getCurrentTime uuid <- nextRandom port <- pack <$> getEnv "OAUTH2_SERVER_PORT" @@ -212,20 +212,25 @@ mkToken (u, scopes, nonce) clientID state = do } encodedAT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode at) encodedRT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode rt) - encodedIT <- Jws.jwkEncode RS256 pubKey (Nested . Jwt . toStrict $ encode it) + encodedIT <- Jws.jwkEncode RS256 privKey (Nested . Jwt . toStrict $ encode it) case encodedAT >> encodedRT >> encodedIT of Right _ -> do let Jwt aToken = fromRight undefined encodedAT Jwt rToken = fromRight undefined encodedRT Jwt iToken = fromRight undefined encodedIT atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes, nonce) (activeTokens s) } - return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken) (Just $ BS.unpack iToken) + return $ JWTW + { acessToken = BS.unpack aToken + , expiresIn = lifetimeAT + , refreshToken = Just $ BS.unpack rToken + , idToken = if Left OpenID `elem` scopes then Nothing else Just $ BS.unpack iToken + } Left e -> error $ show e decodeToken :: Text -> AuthState user -> IO (Either JwtError JwtContent) decodeToken token state = do - prKey <- atomically $ readTVar state >>= return . privateKey - jwkDecode prKey $ encodeUtf8 token + key <- atomically $ readTVar state >>= return . privateKey + jwkDecode key $ encodeUtf8 token renewToken :: forall user userData . UserData user userData => Text -- ^ token diff --git a/src/Server.hs b/src/Server.hs index 877ff45..dd6f619 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -54,7 +54,7 @@ import qualified Data.Map.Strict as Map import GHC.Read (readPrec, lexP) -import Jose.Jwk (generateRsaKeyPair, KeyUse(Enc), KeyId) +import Jose.Jwk (generateRsaKeyPair, KeyUse(..), KeyId) import Jose.Jwt hiding (decode, encode) import Network.HTTP.Client (newManager, defaultManagerSettings) @@ -65,6 +65,7 @@ import Servant.Client hiding (client) import Servant.API import Text.ParserCombinators.ReadPrec (look, pfail) +import Text.Read (readMaybe) import qualified Text.Read.Lex as Lex @@ -81,10 +82,11 @@ data AuthClient = Client trustedClients :: [AuthClient] -- TODO move to db trustedClients = [Client "42" "shhh"] -data ResponseType = Code -- ^ authorisation code grant - | Token -- ^ implicit grant via access token - | IDToken -- ^ implicit grant via access token & ID token +data ResponseType = Code -- ^ authorisation code flow + | Token -- ^ implicit flow via access token + | IDToken -- ^ implicit flow via access token & ID token deriving (Eq, Show) + instance Read ResponseType where readPrec = do Lex.Ident str <- lexP @@ -107,6 +109,7 @@ type QState = Text type QNonce = Text type QAuth = Text type QCookie = Text +type QPrompt = Text type QParam = QueryParam' [Required, Strict] @@ -117,15 +120,17 @@ type Auth = "auth" :> QParam "redirect_uri" QRedirect :> QueryParam "state" QState :> QueryParam "nonce" QNonce + :> QueryParam "prompt" QPrompt :> Header "Cookie" QCookie :> Get '[HTML] Html -- ^ login type AuthCode = "code" - :> HeaderR "Authorization" QAuth + :> HeaderR "Authorization" QAuth --TODO store in cookie instead of passing as headers :> HeaderR "OA2_Scope" QScope :> HeaderR "OA2_Client_ID" QClient :> HeaderR "OA2_Redirect_URI" QRedirect :> Header "OA2_State" QState + :> Header "OA2_Nonce" QNonce :> Get '[JSON] (Headers '[Header "Set-Cookie" Text] Text) -- ^ returns auth code @@ -138,41 +143,47 @@ toHandler s h = runReaderT h s loginServer :: forall user userData . UserData user userData => AuthServer user Auth loginServer = decideLogin where - decideLogin scopes client responseType url mState mNonce mCookies - | Just nonce <- mNonce, Just cookies <- mCookies = handleOIDC nonce cookies - | Nothing <- (mNonce >> mCookies) = handleLogin - | otherwise = throwError err500 { errBody = "Either cookie or nonce missing" } + decideLogin scopes client responseType url mState mNonce mPrompt mCookies + | Nothing <- responseType' = throwError err401 { errBody = "Unsupported response type" } + | not validOIDC = throwError err401 { errBody = "For OIDC, the 'openid' scope and the 'id_token' response type must be given" } + | Just "none" <- mPrompt = handleSSO + | Just "login" <- mPrompt = handleLogin + | Nothing <- mPrompt = handleLogin + | otherwise = throwError err401 { errBody = "Prompt not supported" } where + responseType' = readMaybe @ResponseType responseType + validOIDC :: Bool + validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes + in (Left OpenID `elem` scopes') == (responseType' == Just IDToken) -- | Retrieve user id from cookie - handleOIDC :: QNonce - -> QCookie - -> AuthHandler user Html - handleOIDC nonce cookies = case read @ResponseType responseType of -- TODO nonce can also occur if user is not logged in yet - IDToken -> do - let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookies - unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" } - url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState (Just nonce) - throwError err303 { errHeaders = [("Location", encodeUtf8 url')]} - _ -> throwError err500 { errBody = "Unsupported response type" } + handleSSO :: AuthHandler user Html + handleSSO = do -- TODO check openid scope + liftIO $ putStrLn "login via SSO..." + unless (read @ResponseType responseType == IDToken) $ throwError err500 { errBody = "Unsupported response type" } + unless (isJust mCookies) $ throwError err500 { errBody = "Missing cookie" } + let mCreds = lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 $ fromJust mCookies + unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" } + url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce + liftIO $ putStrLn "SSO successful" + throwError err303 { errHeaders = [("Location", encodeUtf8 url')]} -- | Html login form handleLogin :: AuthHandler user Html - handleLogin = do - let - responseType' = read @ResponseType responseType - headers = Map.fromList @Text @Text $ - [ ("OA2_Scope", pack scopes) - , ("OA2_Client_ID", pack client) - , ("OA2_Redirect_URI", url) - ] ++ [(x,y) | (x, Just y) <- [("OA2_State", mState)]] - case responseType' of - Code -> return $ loginPage headers - _ -> throwError err500 { errBody = "Unsupported response type" } + handleLogin = + let headers = Map.fromList @Text @Text $ + [ ("OA2_Scope", pack scopes) + , ("OA2_Client_ID", pack client) + , ("OA2_Redirect_URI", url) + ] ++ [(x,y) | (x, Just y) <- + [ ("OA2_State", mState) + , ("OA2_Nonce", mNonce) + ]] + in return $ loginPage headers codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode -codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$> - handleCreds @user @userData creds scopes client url mState Nothing +codeServer creds scopes client url mState mNonce = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$> + handleCreds @user @userData creds scopes client url mState mNonce handleCreds :: forall user userData . UserData user userData => QAuth @@ -187,6 +198,7 @@ handleCreds creds scopes client url mState mNonce = do throwError $ err404 { errBody = "Not a trusted client."} let scopes' = map (read @(Scope' user)) $ words scopes [userName, password] = splitOn ":" $ decodeBase64Lenient creds + liftIO . putStrLn $ "\acreds: " <> show userName mUser <- liftIO $ lookupUser @user @userData (UserQuery (Just userName) (Just password) Nothing) unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."} let u = fromJust mUser @@ -222,6 +234,7 @@ data ClientData = ClientData --TODO support other flows , clientID :: Maybe String , clientSecret :: Maybe String , redirect :: Maybe String + , scopeSubset :: Maybe QScope } deriving Show data AuthFlow = AuthFlow @@ -232,11 +245,12 @@ instance FromHttpApiData AuthFlow where instance FromForm ClientData where fromForm f = ClientData - <$> ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f))) + <$> ((Left . ACode <$> parseUnique "code" f) <|> (Right . RToken <$> parseUnique "refresh_token" f)) <*> parseUnique "grant_type" f <*> parseMaybe "client_id" f <*> parseMaybe "client_secret" f <*> parseMaybe "redirect_uri" f + <*> parseMaybe "scope" f instance Error Text where strMsg = pack @@ -267,10 +281,11 @@ tokenEndpoint = provideToken liftIO . putStrLn $ "token: " ++ show token return token Right (RToken jwtw) -> do - let scopes = [] -- TODO read query param for this + let scopes' = (map (read @(Scope' user)) . words) <$> scopeSubset client + liftIO . putStrLn $ "\aSCOPES: " ++ show scopes' unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" } liftIO $ putStrLn "... checking refresh token" - mToken <- asks (renewToken @user @userData jwtw scopes cid) >>= liftIO + mToken <- asks (renewToken @user @userData jwtw (fromMaybe [] scopes') cid) >>= liftIO case mToken of Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token Nothing -> throwError $ err500 { errBody = "Invalid refresh token" } @@ -334,7 +349,7 @@ userListEndpoint :: forall user userData . UserData user userData => AuthServer userListEndpoint = handleUserData where handleUserData :: Text -> Text -> AuthHandler user (QueryResult [userData]) - handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed query other users + handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed to query other users Nothing -> return . QLeft $ QError "UnknownToken" Just (_, scopes, _) -> liftIO $ lookupUser @user @userData (UserQuery (Just userID) Nothing Nothing) >>= \case Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) scopes] -- TODO support queries that fit for multiple users @@ -373,6 +388,7 @@ type Routing user userData = Auth :<|> Token :<|> Me userData :<|> UserList userData + :<|> Logout routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData) routing = loginServer @user @userData @@ -380,6 +396,7 @@ routing = loginServer @user @userData :<|> tokenEndpoint @user @userData :<|> userEndpoint @user @userData :<|> userListEndpoint @user @userData + :<|> logoutEndpoint @user @userData @@ -416,7 +433,7 @@ runMockServer port = runMockServerWithRoutes @user @userData @EmptyAPI port empt mkState :: forall user userData . UserData user userData => IO (AuthState user) mkState = do - (publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockKey") Enc Nothing + (publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockJWT") Enc Nothing let activeCodes = Map.empty activeTokens = Map.empty From 8c0cd0099ca6050b906c2ed7f5f878fd0f7f1a99 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 3 Mar 2024 21:18:28 +0000 Subject: [PATCH 5/9] added sso support for auth requests without prompt parameter --- src/Server.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index dd6f619..72d2b8d 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -148,10 +148,11 @@ loginServer = decideLogin | not validOIDC = throwError err401 { errBody = "For OIDC, the 'openid' scope and the 'id_token' response type must be given" } | Just "none" <- mPrompt = handleSSO | Just "login" <- mPrompt = handleLogin - | Nothing <- mPrompt = handleLogin + | Nothing <- mPrompt = if isJust mCreds then handleSSO else handleLogin | otherwise = throwError err401 { errBody = "Prompt not supported" } where responseType' = readMaybe @ResponseType responseType + mCreds = mCookies >>= lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 validOIDC :: Bool validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes in (Left OpenID `elem` scopes') == (responseType' == Just IDToken) @@ -160,8 +161,6 @@ loginServer = decideLogin handleSSO = do -- TODO check openid scope liftIO $ putStrLn "login via SSO..." unless (read @ResponseType responseType == IDToken) $ throwError err500 { errBody = "Unsupported response type" } - unless (isJust mCookies) $ throwError err500 { errBody = "Missing cookie" } - let mCreds = lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 $ fromJust mCookies unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" } url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce liftIO $ putStrLn "SSO successful" From 3d8f77861aa59a2d62501841b8aa0ebab94d9765 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 3 Mar 2024 21:34:56 +0000 Subject: [PATCH 6/9] ignore empty auth cookie --- src/Server.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index 72d2b8d..14a427d 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -152,7 +152,7 @@ loginServer = decideLogin | otherwise = throwError err401 { errBody = "Prompt not supported" } where responseType' = readMaybe @ResponseType responseType - mCreds = mCookies >>= lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 + mCreds = mCookies >>= lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c validOIDC :: Bool validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes in (Left OpenID `elem` scopes') == (responseType' == Just IDToken) @@ -160,6 +160,7 @@ loginServer = decideLogin handleSSO :: AuthHandler user Html handleSSO = do -- TODO check openid scope liftIO $ putStrLn "login via SSO..." + liftIO . putStrLn $ "creds: " ++ show mCreds unless (read @ResponseType responseType == IDToken) $ throwError err500 { errBody = "Unsupported response type" } unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" } url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce From 8fb2d81ac037e712bff7d58b7d40d5d8dcefd1cf Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 5 Mar 2024 23:58:39 +0000 Subject: [PATCH 7/9] allow combined response types --- src/Server.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Server.hs b/src/Server.hs index 14a427d..b0aa4ef 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -34,7 +34,7 @@ import Control.Concurrent import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (newTVarIO, readTVar, modifyTVar) import Control.Exception (bracket) -import Control.Monad (unless, (>=>)) +import Control.Monad (unless, (>=>), foldM) import Control.Monad.IO.Class import Control.Monad.Trans.Error (Error(..)) import Control.Monad.Trans.Reader @@ -151,17 +151,16 @@ loginServer = decideLogin | Nothing <- mPrompt = if isJust mCreds then handleSSO else handleLogin | otherwise = throwError err401 { errBody = "Prompt not supported" } where - responseType' = readMaybe @ResponseType responseType + responseType' = foldM (\acc x -> readMaybe @ResponseType x >>= return . (: acc)) [] $ words responseType mCreds = mCookies >>= lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c validOIDC :: Bool validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes - in (Left OpenID `elem` scopes') == (responseType' == Just IDToken) + in (Left OpenID `elem` scopes') == (IDToken `elem` fromJust responseType') -- | Retrieve user id from cookie handleSSO :: AuthHandler user Html handleSSO = do -- TODO check openid scope liftIO $ putStrLn "login via SSO..." liftIO . putStrLn $ "creds: " ++ show mCreds - unless (read @ResponseType responseType == IDToken) $ throwError err500 { errBody = "Unsupported response type" } unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" } url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce liftIO $ putStrLn "SSO successful" @@ -169,7 +168,8 @@ loginServer = decideLogin -- | Html login form handleLogin :: AuthHandler user Html - handleLogin = + handleLogin = do + unless (Code `elem` fromJust responseType') $ throwError err401 { errBody = "response type 'code' missing" } let headers = Map.fromList @Text @Text $ [ ("OA2_Scope", pack scopes) , ("OA2_Client_ID", pack client) @@ -178,7 +178,7 @@ loginServer = decideLogin [ ("OA2_State", mState) , ("OA2_Nonce", mNonce) ]] - in return $ loginPage headers + return $ loginPage headers codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode From 83d99e55303f5b1cd6cde30b2936d61419268f8c Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Wed, 6 Mar 2024 04:20:12 +0000 Subject: [PATCH 8/9] added login to sso test link --- app/Main.hs | 4 +-- app/SSO.hs | 92 +++++++++++++++++++++++++++++++++++++++--------- src/LoginForm.hs | 6 ++-- src/Server.hs | 14 +++++--- 4 files changed, 90 insertions(+), 26 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 52a7adb..af76893 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,7 +9,7 @@ module Main (main) where import UniWorX import Server -import SSO (SSOTest, routes) +import SSO (CustomRoutes, customRoutes) import Control.Applicative ((<|>)) import Database.Persist (Entity(..)) import System.Environment (lookupEnv) @@ -21,7 +21,7 @@ main = do port <- determinePort putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F" initDB - runMockServerWithRoutes @(Entity User) @(M.Map T.Text T.Text) @SSOTest port routes + runMockServerWithRoutes @(Entity User) @(M.Map T.Text T.Text) @CustomRoutes port customRoutes where determinePort :: IO Int determinePort = do diff --git a/app/SSO.hs b/app/SSO.hs index 75d4631..0285c89 100644 --- a/app/SSO.hs +++ b/app/SSO.hs @@ -3,40 +3,100 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# Language DataKinds, TypeOperators, OverloadedStrings #-} +{-# Language DataKinds, TypeOperators, OverloadedStrings, LambdaCase, TypeApplications, QuasiQuotes #-} -module SSO (SSOTest, routes) where +module SSO (CustomRoutes, customRoutes) where import Prelude hiding (head) import UniWorX import Server +import User +import LoginForm +import Control.Monad.IO.Class (liftIO) + +import Data.Map (Map, empty) +import Data.Maybe (fromMaybe) import Data.String (IsString(..)) -import Data.Text (Text) +import Data.Text (Text, splitOn) +import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding.Base64 +import qualified Data.String.Interpolate as I import Database.Persist (Entity(..)) +import Servant import Servant.API import Text.Blaze.Html5 import qualified Text.Blaze.Html5.Attributes as A +import Web.Cookie (parseCookiesText) -type SSOTest = "test-sso" :> Get '[HTML] Html + +type CustomRoutes = Login :<|> SSOTest + +customRoutes = login :<|> routes + +type Login = "login" + :> QueryParam' [Strict, Required] "redirect" Text + :> Header' [Strict, Required] "Authorization" Text + :> Verb 'GET 303 '[HTML] (Headers '[ Header "Set-Cookie" Text + , Header "Location" Text + ] Html) + +login :: AuthServer (Entity User) Login +login redirect creds = addHeader (authCookie <> "=\"" <> creds <> "\"") . addHeader redirect <$> do + liftIO . putStrLn $ "\nREDIRECT: " ++ show redirect + (liftIO . getUser $ Just creds) >>= \case + Just user -> return mempty + Nothing -> throwError err500 { errBody = "Unknown user" } + +successMsg :: Html +successMsg = do + head $ do + meta ! A.charset "UTF-8" + meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0" + title "Success" + body $ do + h1 "OIDC SSO Test" + p "Login successful." + + +getUser :: Maybe Text -> IO (Maybe (Entity User)) +getUser (Just creds) = do + putStrLn $ "\nCREDS: " ++ (show $ decodeBase64Lenient creds) + let [username, password] = splitOn ":" $ decodeBase64Lenient creds + lookupUser @(Entity User) @(Map Text Text) $ UserQuery (Just username) (Just password) Nothing +getUser Nothing = return Nothing + + +type SSOTest = "test-sso" + :> QueryParam "redirect" String + :> Header "Cookie" Text + :> Get '[HTML] Html routes :: AuthServer (Entity User) SSOTest -routes = return ssoLink +routes redirect mCookies = do + (liftIO $ getUser mCreds) >>= \case + Just user -> return $ ssoLink redirect + Nothing -> return $ loginPage route empty where - ssoLink :: Html - ssoLink = docTypeHtml $ head' >> body' - where - t = "OIDC SSO Test" - head' = head $ do - meta ! A.charset "UTF-8" - meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0" - title t - body' = body $ do - h1 t - a ! A.href "https:..." $ "Go to FraDrive" + mCreds = mCookies >>= lookup authCookie . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c + route = "../login?redirect=-" -- TODO hacky "../login?redirect=..%2Ftest-sso%3Fredirect%3D" <> fromMaybe "" redirect + +ssoLink :: Maybe String -> Html +ssoLink redirect = docTypeHtml $ head' >> body' + where + t = "OIDC SSO Test" + head' = head $ do + meta ! A.charset "UTF-8" + meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0" + title t + body' = body $ do + h1 t + case redirect of + Just r -> a ! A.href (fromString r) $ "Go to FraDrive" + Nothing -> b "Redirect link is missing." diff --git a/src/LoginForm.hs b/src/LoginForm.hs index 34ed22d..7d62044 100644 --- a/src/LoginForm.hs +++ b/src/LoginForm.hs @@ -37,8 +37,8 @@ instance Accept HTML where instance MimeRender HTML Html where mimeRender _ = renderHtml -loginPage :: M.Map Text Text -> Html -loginPage headers = docTypeHtml $ head' >> body' +loginPage :: String -> M.Map Text Text -> Html +loginPage uri headers = docTypeHtml $ head' >> body' where headers' = encode headers formID = "loginForm" :: String @@ -63,7 +63,7 @@ loginPage headers = docTypeHtml $ head' >> body' headers.append('Authorization', btoa(creds)); //alert(creds); e.preventDefault(); - fetch('../code', { + fetch('#{uri}', { method: 'GET', headers: headers }) diff --git a/src/Server.hs b/src/Server.hs index b0aa4ef..997917d 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -23,6 +23,7 @@ module Server , Html , AuthServer , AuthHandler +, authCookie ) where import AuthCode @@ -74,6 +75,9 @@ import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form( +authCookie :: Text +authCookie = "oa2_auth_cookie" + data AuthClient = Client { ident :: Text , secret :: Text @@ -152,7 +156,7 @@ loginServer = decideLogin | otherwise = throwError err401 { errBody = "Prompt not supported" } where responseType' = foldM (\acc x -> readMaybe @ResponseType x >>= return . (: acc)) [] $ words responseType - mCreds = mCookies >>= lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c + mCreds = mCookies >>= lookup authCookie . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c validOIDC :: Bool validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes in (Left OpenID `elem` scopes') == (IDToken `elem` fromJust responseType') @@ -178,11 +182,11 @@ loginServer = decideLogin [ ("OA2_State", mState) , ("OA2_Nonce", mNonce) ]] - return $ loginPage headers + return $ loginPage "../code" headers codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode -codeServer creds scopes client url mState mNonce = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$> +codeServer creds scopes client url mState mNonce = addHeader (authCookie <> "=\"" <> creds <> "\"") <$> handleCreds @user @userData creds scopes client url mState mNonce handleCreds :: forall user userData . UserData user userData @@ -372,9 +376,9 @@ logoutEndpoint = logout -> QCookie -> AuthHandler user (Headers '[Header "Set-Cookie" Text] Html) logout mUri cookie = do - let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookie + let mCreds = lookup authCookie . parseCookiesText $ encodeUtf8 cookie unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" } - addHeader "oa2_auth_cookie=\"\"" <$> case mUri of + addHeader (authCookie <> "=\"\"") <$> case mUri of Just uri -> throwError err303 { errHeaders = [("Location", encodeUtf8 uri)]} Nothing -> return logoutPage From 2a2813fef22abf584cc66006f7077086454b41a8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 10 Mar 2024 19:46:12 +0000 Subject: [PATCH 9/9] show logout success before redirecting --- oauth2-mock-server.cabal | 3 ++ package.yaml | 1 + src/LoginForm.hs | 20 ++++++++---- src/Server.hs | 68 ++++++++++++++++++++++++++++++++++------ 4 files changed, 76 insertions(+), 16 deletions(-) diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index dc435b8..ef0de9b 100644 --- a/oauth2-mock-server.cabal +++ b/oauth2-mock-server.cabal @@ -38,6 +38,7 @@ library , bytestring , containers , cookie + , ghc , http-api-data , http-client , http-media @@ -74,6 +75,7 @@ executable oauth2-mock-server-exe , conduit , containers , cookie + , ghc , http-api-data , http-client , http-media @@ -115,6 +117,7 @@ test-suite oauth2-mock-server-test , bytestring , containers , cookie + , ghc , http-api-data , http-client , http-media diff --git a/package.yaml b/package.yaml index 4834bd2..2c7238d 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,7 @@ description: Please see the README # on GitHub at = 4.7 && < 5 +- ghc - servant - servant-server - servant-client diff --git a/src/LoginForm.hs b/src/LoginForm.hs index 7d62044..31e651e 100644 --- a/src/LoginForm.hs +++ b/src/LoginForm.hs @@ -14,11 +14,13 @@ module LoginForm 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 Data.Text (Text, unpack) +import qualified Data.Map as M +import qualified Data.String.Interpolate as I + +import GHC.Data.Maybe (whenIsJust) import Network.HTTP.Media ((//), (/:)) @@ -74,8 +76,8 @@ loginPage uri headers = docTypeHtml $ head' >> body' |] -logoutPage :: Html -logoutPage = docTypeHtml $ head' >> body' +logoutPage :: Maybe Text -> Html +logoutPage mUri = docTypeHtml $ head' >> body' where head' = head $ do meta ! A.charset "UTF-8" @@ -83,4 +85,10 @@ logoutPage = docTypeHtml $ head' >> body' title "UniWorX Oauth2 Mock Server" body' = body $ do h1 "UniWorX Oauth2 Mock Server" - p "Logout successful." \ No newline at end of file + p "Logout successful." + whenIsJust mUri $ \uri -> do + a ! A.href (fromString $ unpack uri) $ "Continue" + script $ + [I.i| + setTimeout(_ => window.location.replace('#{uri}'), 2000); |] + \ No newline at end of file diff --git a/src/Server.hs b/src/Server.hs index 997917d..7c9c8de 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -13,6 +13,7 @@ , AllowAmbiguousTypes , LambdaCase , FlexibleContexts + , KindSignatures #-} module Server @@ -35,19 +36,19 @@ import Control.Concurrent import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (newTVarIO, readTVar, modifyTVar) import Control.Exception (bracket) -import Control.Monad (unless, (>=>), foldM) +import Control.Monad (unless, (>=>), foldM, void) import Control.Monad.IO.Class import Control.Monad.Trans.Error (Error(..)) import Control.Monad.Trans.Reader import Data.Aeson -import Data.ByteString (fromStrict, ByteString) +import Data.ByteString (fromStrict, toStrict, ByteString) 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 (encodeUtf8) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding.Base64 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime) @@ -58,20 +59,22 @@ import GHC.Read (readPrec, lexP) import Jose.Jwk (generateRsaKeyPair, KeyUse(..), KeyId) import Jose.Jwt hiding (decode, encode) -import Network.HTTP.Client (newManager, defaultManagerSettings) +import Network.HTTP.Client (newManager, defaultManagerSettings, httpLbs, parseRequest) import Network.Wai.Handler.Warp import Servant import Servant.Client hiding (client) import Servant.API +import System.Environment (getEnv) + import Text.ParserCombinators.ReadPrec (look, pfail) import Text.Read (readMaybe) import qualified Text.Read.Lex as Lex import Web.Cookie (parseCookiesText) -import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..)) +import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..), urlEncodeParams) @@ -364,23 +367,66 @@ userListEndpoint = handleUserData ---- Logout ---- -------------- +{-type Redirect (cs :: [*]) (hs :: [*]) a = Verb 'GET 303 cs (Headers (Header "Location" Text : hs) a) + +type CookieLogout = "clogout" + :> QParam "redirect" QRedirect + :> Redirect '[HTML] '[] Text +clogoutEndpoint :: forall user userData . UserData user userData => AuthServer user CookieLogout +clogoutEndpoint uri = do + return $ addHeader uri ""-} + + type Logout = "logout" :> QueryParam "post_logout_redirect_uri" QRedirect :> HeaderR "Cookie" QCookie :> Get '[HTML] (Headers '[Header "Set-Cookie" Text] Html) + {- :> Redirect '[HTML] '[Header "Set-Cookie" Text] NoContent + :<|> "logout" + :> HeaderR "Cookie" QCookie + :> Get '[HTML] (Headers '[Header "Set-Cookie" Text] Html) -} logoutEndpoint :: forall user userData . UserData user userData => AuthServer user Logout -logoutEndpoint = logout +logoutEndpoint = logout -- rLogout :<|> logout where logout :: Maybe QRedirect -> QCookie -> AuthHandler user (Headers '[Header "Set-Cookie" Text] Html) - logout mUri cookie = do + logout mRedir cookie = do let mCreds = lookup authCookie . parseCookiesText $ encodeUtf8 cookie unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" } - addHeader (authCookie <> "=\"\"") <$> case mUri of - Just uri -> throwError err303 { errHeaders = [("Location", encodeUtf8 uri)]} - Nothing -> return logoutPage + liftIO . putStrLn $ "\nLOGOUT\n " + return . addHeader (authCookie <> "=\"\"") $ logoutPage mRedir + + {- checkCookie :: QCookie -> AuthHandler user () + checkCookie cookie = do + let mCreds = lookup authCookie . parseCookiesText $ encodeUtf8 cookie + unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" } + return () + + rLogout :: QRedirect + -> QCookie + -> AuthHandler user (Headers '[ Header "Location" Text + , Header "Set-Cookie" Text + ] NoContent) + rLogout uri cookie = do + liftIO . putStrLn $ "\nLOGOUT with uri " <> show uri <> "\n" + checkCookie cookie + let param = decodeUtf8 . toStrict $ urlEncodeParams [("redirect", uri)] + uri' = "../clogout?" <> param + addHeader uri' . addHeader (authCookie <> "=\"\"") <$> return NoContent + + logout :: QCookie + -> AuthHandler user (Headers '[Header "Set-Cookie" Text] Html) + logout cookie = do + liftIO . putStrLn $ "\nLOGOUT\n " + checkCookie cookie + return . addHeader (authCookie <> "=\"\"")$ logoutPage Nothing + -- liftIO $ do + -- port <- getEnv "OAUTH2_SERVER_PORT" + -- manager <- newManager defaultManagerSettings + -- req <- parseRequest $ "GET http://localhost:" ++ port ++ "/clogout" -- TODO get root + -- void $ httpLbs req manager -} ------------------- @@ -392,6 +438,7 @@ type Routing user userData = Auth :<|> Token :<|> Me userData :<|> UserList userData + -- :<|> CookieLogout :<|> Logout routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData) @@ -400,6 +447,7 @@ routing = loginServer @user @userData :<|> tokenEndpoint @user @userData :<|> userEndpoint @user @userData :<|> userListEndpoint @user @userData + -- :<|> clogoutEndpoint @user @userData :<|> logoutEndpoint @user @userData