added login to sso test link

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

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
+    mCreds = mCookies >>= lookup authCookie . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c
-    ssoLink = docTypeHtml $ head' >> body'
+    route = "../login?redirect=-" -- TODO hacky "../login?redirect=..%2Ftest-sso%3Fredirect%3D" <> fromMaybe "" redirect
-      where
+
-        t = "OIDC SSO Test"
+ssoLink :: Maybe String -> Html
-        head' = head $ do
+ssoLink redirect = docTypeHtml $ head' >> body'
-          meta ! A.charset "UTF-8"
+  where
-          meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0"
+    t = "OIDC SSO Test"
-          title t
+    head' = head $ do
-        body' = body $ do
+      meta ! A.charset "UTF-8"
-          h1 t
+      meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0"
-          a ! A.href "https:..." $ "Go to FraDrive"
+      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."
 

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 :: String -> M.Map Text Text -> Html
-loginPage headers = docTypeHtml $ head' >> body'
+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
             })

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