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