From 25f9ee95b1a94dc53c133f1ef1bccc0df5d14ad8 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sun, 14 Jan 2024 18:39:57 +0100 Subject: [PATCH] redirecting to client via javascript --- app/Main.hs | 2 +- src/LoginForm.hs | 15 +++++++++------ src/Server.hs | 27 ++++++++++++++------------- 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c6b6876..28ffe38 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -12,7 +12,7 @@ main :: IO () main = do args <- getArgs >>= flip buildArgs M.empty port <- determinePort args - putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=localhost" + putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F" runMockServer port where buildArgs :: [String] -> M.Map String String -> IO (M.Map String String) diff --git a/src/LoginForm.hs b/src/LoginForm.hs index 054e21c..18202fb 100644 --- a/src/LoginForm.hs +++ b/src/LoginForm.hs @@ -47,15 +47,18 @@ loginPage headers = docTypeHtml $ head' >> body' script $ [I.i| #{buttonID}.onclick = async (e) => { - let headers = new Headers(#{headers'}); - let formData = new FormData(#{formID}); - let creds = formData.get('#{emailID}') + ':' + ''; + const headers = new Headers(#{headers'}); + const formData = new FormData(#{formID}); + const creds = formData.get('#{emailID}') + ':' + ''; headers.append('Authorization', btoa(creds)); alert(creds); - alert(headers.get('Authorization')); e.preventDefault(); - await fetch('../code', { + fetch('../code', { method: 'GET', headers: headers - })}; + }) + .then(response => response.text()) + .then(url => window.location.replace(url.substring(1, url.length - 1))); + // Response.redirect(url); + }; |] \ No newline at end of file diff --git a/src/Server.hs b/src/Server.hs index f152a30..7c252ac 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -25,6 +25,7 @@ import Data.List (find, elemIndex) import Data.Maybe (fromMaybe, fromJust, isJust, isNothing) import Data.String (IsString (..)) import Data.Text hiding (elem, find, head, length, map, null, splitAt, tail, words) +import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding.Base64 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime) @@ -84,7 +85,7 @@ instance Read ResponseType where type QScope = String type QClient = String type QResType = String -type QRedirect = String +type QRedirect = Text type QState = Text type QAuth = Text @@ -113,7 +114,7 @@ type AuthCode = "code" :> HeaderR "OA2_Client_ID" QClient :> HeaderR "OA2_Redirect_URI" QRedirect :> Header "OA2_State" QState - :> Get '[JSON] () -- returns auth code + :> Get '[JSON] Text -- returns auth code type AuthHandler user = ReaderT (AuthState user) Handler @@ -137,7 +138,7 @@ loginServer = handleAuth headers = Map.fromList @Text @Text [ ("OA2_Scope", pack scopes) , ("OA2_Client_ID", pack client) - , ("OA2_Redirect_URI", pack url)] + , ("OA2_Redirect_URI", url)] headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" } return $ loginPage headers' @@ -150,7 +151,7 @@ codeServer = handleCreds -> QClient -> QRedirect -> Maybe QState - -> AuthHandler user () + -> AuthHandler user Text handleCreds creds scopes client url mState = do unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client throwError $ err404 { errBody = "Not a trusted client."} @@ -161,21 +162,21 @@ codeServer = handleCreds mUser <- liftIO $ lookupUser @user @userData userName password unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."} let u = fromJust mUser - mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') url) >>= liftIO + mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO liftIO $ print mAuthCode liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes') redirect $ addParams url mAuthCode mState - redirect :: Maybe ByteString -> AuthHandler user () - redirect (Just url) = liftIO (print url) >> throwError err303 { errHeaders = [("Location", url)]} + redirect :: Maybe Text -> AuthHandler user Text + redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]} redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."} - addParams :: String -> Maybe Text -> Maybe Text -> Maybe ByteString + addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text addParams url Nothing _ = Nothing addParams url (Just code) mState = - let qPos = fromMaybe (length url) $ elemIndex '?' url - (pre, post) = splitAt qPos url - rState = case mState of {Just s -> "&state=" ++ (unpack . replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""} - post' = if not (null post) then '&' : tail post else post - in Just . fromString $ pre ++ "?code=" ++ (unpack code) ++ post' ++ rState + let urlParts = splitOn "?" url + (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "") + rState = case mState of {Just s -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""} + post' = if not (T.null post) then "&" <> T.tail post else post + in Just $ pre <> "?code=" <> code <> post' <> rState