From 2a2813fef22abf584cc66006f7077086454b41a8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 10 Mar 2024 19:46:12 +0000 Subject: [PATCH] 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