103 lines
3.2 KiB
Haskell
103 lines
3.2 KiB
Haskell
-- SPDX-FileCopyrightText: 2024 UniWorX Systems
|
|
-- SPDX-FileContributor: David Mosbach <david.mosbach@uniworx.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# Language DataKinds, TypeOperators, OverloadedStrings, LambdaCase, TypeApplications, QuasiQuotes #-}
|
|
|
|
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, 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 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 redirect mCookies = do
|
|
(liftIO $ getUser mCreds) >>= \case
|
|
Just user -> return $ ssoLink redirect
|
|
Nothing -> return $ loginPage route empty
|
|
where
|
|
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."
|
|
|