fix debug prints

app/Main.hs

@@ -9,7 +9,6 @@ module Main (main) where
 
 import UniWorX
 import Server
-import SSO (CustomRoutes, customRoutes)
 import Control.Applicative ((<|>))
 import Database.Persist (Entity(..))
 import System.Environment (lookupEnv)
@@ -21,7 +20,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) @CustomRoutes port customRoutes
+  runMockServer @(Entity User) @(M.Map T.Text T.Text) port
     where
       determinePort :: IO Int
       determinePort = do

app/SSO.hs

@@ -1,102 +0,0 @@
--- 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."
-

app/UniWorX.hs

@@ -31,7 +31,6 @@ import Control.Monad.Reader (ReaderT)
 import Conduit (ResourceT)
 
 import Data.Map (Map(..))
-import Data.Maybe (fromJust)
 import Data.String (IsString(..))
 import Data.Text (Text(..))
 import Data.Yaml (decodeFileThrow, FromJSON(..), Value(..), (.:), (.:?))
@@ -52,7 +51,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
     email           Text
     matricNumber    Text Maybe
     title           Text Maybe
-    gender          Text Maybe
+    sex             Text Maybe
     birthday        Text Maybe
     telephone       Text Maybe
     mobile          Text Maybe
@@ -69,7 +68,7 @@ instance FromJSON User where
     <*> o .:  "userEmail"
     <*> o .:? "userMatrikelnummer"
     <*> o .:? "userTitle"
-    <*> o .:? "userGender"
+    <*> o .:? "userSex"
     <*> o .:? "userBirthday"
     <*> o .:? "userTelephone"
     <*> o .:? "userMobile"
@@ -108,49 +107,28 @@ initDB = do
 
 
 instance UserData (Entity User) (Map Text Text) where
-  type UserID (Entity User) = Key User
+  data Scope (Entity User) = ID | Profile deriving (Show, Read, Eq)
-  data CustomScope (Entity User) = UWX deriving (Read, Show, Eq)
+  readScope = read
-  userScope (Entity _ User{..}) (Left OpenID) = M.singleton "id" userEmail
+  showScope = show
-  userScope (Entity _ User{..}) (Left Profile) = M.fromList $ catM
+  userScope (Entity _ User{..}) ID = M.singleton "id" userEmail
-    [ ("name", Just $ userFirstName <> " " <> userSurname)
+  userScope (Entity _ User{..}) Profile = M.fromList [(key, val) | (key, Just val) <-
-    , ("given_name", Just userFirstName)
+    [ ("firstName", Just userFirstName)
-    , ("family_name", Just userSurname)
+    , ("surname", Just userSurname)
-    , ("middle_name", Nothing)
+    , ("email", Just userEmail)
-    , ("nickname", Nothing)
+    , ("matriculationNumber", userMatricNumber)
-    , ("preferred_username", Nothing)
-    , ("profile", Nothing)
-    , ("picture", Nothing)
-    , ("website", Nothing)
-    , ("gender", userGender)
-    , ("birthdate", userBirthday)
-    , ("zoneinfo", Nothing)
-    , ("locale", Nothing)
-    , ("updated_at", Nothing)
-    ]
-  userScope (Entity _ User{..}) (Left Email) = M.fromList [("email", userEmail), ("email_verified", userEmail)]
-  userScope (Entity _ User{..}) (Left Address) = case userPostAddress of
-    Just address -> M.singleton "address" address
-    Nothing -> M.empty
-  userScope (Entity _ User{..}) (Left Phone) = M.fromList $ catM [("phone_number", userMobile), ("phone_number_verified", userTelephone)]
-  userScope (Entity _ User{..}) (Right UWX) = M.fromList $ catM
-    [ ("matriculationNumber", userMatricNumber)
     , ("title", userTitle)
+    , ("sex", userSex)
+    , ("birthday", userBirthday)
+    , ("telephone", userTelephone)
+    , ("mobile", userMobile)
     , ("companyPersonalNumber", userCompPersNumber)
     , ("companyDepartment", userCompDepartment)
-    ]
+    , ("postAddress", userPostAddress)
-  userScope (Entity _ User{..}) _ = M.empty
+    ]]
-  lookupUser UserQuery{..} = runDB $ do
+  lookupUser email _ = runDB $ do
-    let filters = map fst $ catM [(UserEmail ==. fromJust email, email)]
+    user <- selectList [UserEmail ==. email] []
-        keyFilter = case key of
-          Just k -> \(Entity x _) -> (T.pack $ show x) == k
-          Nothing -> \_ -> True
-    user <- filter keyFilter <$> selectList filters []
     case user of
       [entity] -> return $ Just entity
       [] -> return Nothing
       _ -> error "Oauth2 Mock Server: Ambiguous User."
-  userID (Entity x _) = x
-
-catM :: [(a, Maybe b)] -> [(a, b)]
-catM l = [ (x,y) | (x, Just y) <- l ]
 

flake.nix

@@ -41,12 +41,11 @@
           LD_LIBRARY_PATH=${libPath}
           mkdir -p $HOME/.stack
           stack build --verbose
-          rm -rf $HOME/.stack
         '';
         installPhase = ''
           mkdir -p $out/bin
           mv .stack-work/install/${system}/*/*/bin/${name}-exe $out/bin/${name}
-          rm -rf .stack-work
+          echo "moved"
         '';
       };
       mkDB = builtins.readFile ./mkDB.sh;
@@ -78,7 +77,6 @@
           ${mkDB}
           zsh
           ${killDB}
-          exit
         '';
       };
     };

oauth2-mock-server.cabal

@@ -37,8 +37,6 @@ library
     , blaze-html
     , bytestring
     , containers
-    , cookie
-    , ghc
     , http-api-data
     , http-client
     , http-media
@@ -58,7 +56,6 @@ library
 executable oauth2-mock-server-exe
   main-is: Main.hs
   other-modules:
-      SSO
       UniWorX
       Paths_oauth2_mock_server
   autogen-modules:
@@ -74,8 +71,6 @@ executable oauth2-mock-server-exe
     , bytestring
     , conduit
     , containers
-    , cookie
-    , ghc
     , http-api-data
     , http-client
     , http-media
@@ -116,8 +111,6 @@ test-suite oauth2-mock-server-test
     , blaze-html
     , bytestring
     , containers
-    , cookie
-    , ghc
     , http-api-data
     , http-client
     , http-media

package.yaml

@@ -25,7 +25,6 @@ description:         Please see the README # on GitHub at <https://github.com/gi
 
 dependencies:
 - base >= 4.7 && < 5
-- ghc
 - servant
 - servant-server
 - servant-client
@@ -45,7 +44,6 @@ dependencies:
 - blaze-html
 - http-media
 - string-interpolate
-- cookie
 
 ghc-options:
 - -Wall
@@ -78,9 +76,6 @@ executables:
     - conduit
     - mtl
     - yaml
-    - servant
-    - servant-server
-    - blaze-html
 
 tests:
   oauth2-mock-server-test:

src/AuthCode.hs

@@ -3,13 +3,12 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase, DeriveGeneric, AllowAmbiguousTypes #-}
+{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase, RecordWildCards #-}
 
 module AuthCode
 ( State(..)
 , AuthState
 , AuthRequest(..)
-, TokenParams(..)
 , JWT(..)
 , JWTWrapper(..)
 , genUnencryptedCode
@@ -19,23 +18,18 @@ module AuthCode
 , renewToken
 ) where
 
-import Prelude hiding (exp)
-
 import User
 
 import Data.Aeson
-import Data.Bool (bool)
 import Data.ByteString (ByteString (..), fromStrict, toStrict)
 import Data.Either (fromRight)
-import Data.List ((\\))
+import Data.Map.Strict (Map, assocs)
-import Data.Map.Strict (Map)
+import Data.Maybe (isJust, fromMaybe, fromJust)
-import Data.Maybe (isJust, fromMaybe, fromJust, catMaybes)
-import Data.Time.Calendar
 import Data.Time.Clock
-import Data.Text (pack, Text, stripPrefix)
+import Data.Text (pack, replace, Text, stripPrefix)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-import Data.Text.Encoding.Base64.URL
+import Data.Text.Encoding.Base64
-import Data.UUID hiding (null)
+import Data.UUID
 import Data.UUID.V4
 
 import qualified Data.ByteString.Char8 as BS
@@ -46,22 +40,13 @@ import Control.Concurrent.STM.TVar
 import Control.Monad (void, (>=>))
 import Control.Monad.STM
 
-import GHC.Generics
-
 import Jose.Jwa
 import Jose.Jwe
 import Jose.Jwk (Jwk(..))
 import Jose.Jwt hiding (decode, encode)
-import qualified Jose.Jws as Jws
 
 import Servant.API (FromHttpApiData(..))
 
-import System.Environment (getEnv)
-
-
- --------------
----- Tokens ----
- --------------
 
 data JWT = JWT
   { issuer :: Text
@@ -75,41 +60,25 @@ instance ToJSON JWT where
 instance FromJSON JWT where
   parseJSON (Object o) = JWT <$> o .: "iss" <*> o .: "exp" <*> o .: "jti"
 
-data IDToken = IDT
-  { iss       :: Text
-  , sub       :: Text
-  , aud       :: [Text]
-  , exp       :: NominalDiffTime
-  , iat       :: NominalDiffTime
-  , auth_time :: Maybe NominalDiffTime
-  , nonce     :: Maybe Text
-  } deriving (Generic, Show)
-
-instance ToJSON IDToken
-instance FromJSON IDToken
-
 
 data JWTWrapper = JWTW
   { acessToken   :: String
   , expiresIn    :: NominalDiffTime
   , refreshToken :: Maybe String
-  , idToken      :: Maybe String
   } deriving (Show)
 
 instance ToJSON JWTWrapper where
-  toJSON (JWTW a e r i) = object
+  toJSON (JWTW a e r) = object
     [ "access_token" .= a
     , "token_type" .= ("JWT" :: Text)
     , "expires_in" .= fromEnum e
-    , "refresh_token" .= r
+    , "refresh_token" .= r ]
-    , "id_token" .= i ]
 
 instance FromJSON JWTWrapper where
   parseJSON (Object o) = JWTW
     <$> o .:  "access_token"
     <*> o .:  "expires_in"
     <*> o .:? "refresh_token"
-    <*> o .:? "id_token"
 
 instance FromHttpApiData JWTWrapper where
   parseHeader bs = case decode (fromStrict bs) of
@@ -117,33 +86,26 @@ instance FromHttpApiData JWTWrapper where
     Nothing -> Left "Invalid JWT wrapper"
 
 
- -------------
----- State ----
- -------------
-
 data AuthRequest user = AuthRequest
   { client :: String
   , codeExpiration :: NominalDiffTime
   , user :: user
-  , scopes :: [Scope' user]
+  , scopes :: [Scope user]
-  , rNonce :: Maybe Text
   }
 
-type TokenParams user = (user, [Scope' user], Maybe Text)
+instance Show user => Show (AuthRequest user) where
+  show AuthRequest{..} = "AuthRequest{ codeExpiration = " ++ show codeExpiration ++ ", .. }"
+
 
 data State user = State
-  { activeCodes  :: Map Text (AuthRequest user)
+  { activeCodes :: Map Text (AuthRequest user)
-  , activeTokens :: Map UUID (TokenParams user)
+  , activeTokens :: Map UUID (user, [Scope user])
-  , publicKey    :: Jwk
+  , publicKey   :: Jwk
-  , privateKey   :: Jwk
+  , privateKey  :: Jwk
   }
 
 type AuthState user = TVar (State user)
 
- -----------------
----- Functions ----
- -----------------
-
 genUnencryptedCode :: AuthRequest user
                    -> String
                    -> AuthState user
@@ -152,7 +114,7 @@ genUnencryptedCode req url state = do
   now <- getCurrentTime
   let
     expiresAt = req.codeExpiration `addUTCTime` now
-    simpleCode = encodeBase64Unpadded . pack $ req.client <> url <> show now <> show expiresAt
+    simpleCode = replace "/" "%2F" . replace "=" "%3D" . encodeBase64 . pack . filter (/= ' ') $ req.client <> url <> show now <> show expiresAt
   success <- atomically . stateTVar state $ \s ->
     let mEntry = M.lookup simpleCode s.activeCodes
     in
@@ -167,89 +129,60 @@ genUnencryptedCode req url state = do
         atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
 
 
-verify :: Text
+verify :: (Show user) => Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user]))
-       -> Maybe String
-       -> AuthState user
-       -> IO (Maybe (TokenParams user))
 verify code mClientID state = do
   now <- getCurrentTime
+  (codes, tokens) <- atomically $ do
+    codes <- readTVar state >>= return . activeCodes
+    tokens <- readTVar state >>= return . activeTokens
+    return (codes, tokens)
+  print $ "activeCodes: " ++ show codes
+  -- print $ "activeTokens: " ++ show ((\(uuid,(usr,scps)) -> (uuid,(usr,showScope <$> scps))) <$> assocs tokens)
   mData <- atomically $ do
     result <- (readTVar >=> return . M.lookup code . activeCodes) state
     modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
     return result
   return $ case mData of
-    Just (AuthRequest clientID' _ u s n) -> if (fromMaybe clientID' mClientID) == clientID'
+    Just (AuthRequest clientID' _ u s) -> if (fromMaybe clientID' mClientID) == clientID' then Just (u, s) else Nothing
-                                            then Just (u, s, n)
-                                            else Nothing
     _ -> Nothing
 
 
-mkToken :: forall user userData . UserData user userData
+mkToken :: user -> [Scope user] -> AuthState user -> IO JWTWrapper
-        => TokenParams user
+mkToken u scopes state = do
-        -> Maybe Text -- client_id
+  pubKey <- atomically $ readTVar state >>= return . publicKey
-        -> AuthState user
-        -> IO JWTWrapper
-mkToken (u, scopes, nonce) clientID state = do
-  (pubKey, privKey) <- atomically $ readTVar state >>= return . ((,) <$> publicKey <*> privateKey)
   now <- getCurrentTime
   uuid <- nextRandom
-  port <- pack <$> getEnv "OAUTH2_SERVER_PORT"
   let
     lifetimeAT = 3600 :: NominalDiffTime -- TODO make configurable
     lifetimeRT = nominalDay -- TODO make configurable
-    lifetimeIT = 3600 :: NominalDiffTime -- TODO make configurable
-    itRefDate = UTCTime (fromGregorian 1970 1 1) 0
     at = JWT "Oauth2MockServer" (lifetimeAT `addUTCTime` now) uuid
     rt = JWT "Oauth2MockServer" (lifetimeRT `addUTCTime` now) uuid
-    it = IDT
-      { iss = "http://localhost:" <> port -- TODO maybe make configurable
-      , sub = pack . show $ userID @user @userData u
-      , aud = catMaybes [clientID]
-      , exp = (lifetimeIT `addUTCTime` now) `diffUTCTime` itRefDate
-      , iat = now `diffUTCTime` itRefDate
-      , auth_time = Just $ now `diffUTCTime` itRefDate
-      , nonce = nonce
-      }
   encodedAT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode at)
   encodedRT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode rt)
-  encodedIT <- Jws.jwkEncode RS256 privKey (Nested . Jwt . toStrict $ encode it)
+  case encodedAT >> encodedRT of
-  case encodedAT >> encodedRT >> encodedIT of
     Right _ -> do
       let Jwt aToken = fromRight undefined encodedAT
           Jwt rToken = fromRight undefined encodedRT
-          Jwt iToken = fromRight undefined encodedIT
+      atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes) (activeTokens s) }
-      atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes, nonce) (activeTokens s) }
+      return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken)
-      return $ JWTW
-        { acessToken = BS.unpack aToken
-        , expiresIn = lifetimeAT 
-        , refreshToken = Just $ BS.unpack rToken
-        , idToken = if Left OpenID `elem` scopes then Nothing else Just $ BS.unpack iToken
-        }
     Left e -> error $ show e
 
 decodeToken :: Text -> AuthState user -> IO (Either JwtError JwtContent)
 decodeToken token state = do
-  key <- atomically $ readTVar state >>= return . privateKey
+  prKey <- atomically $ readTVar state >>= return . privateKey
-  jwkDecode key $ encodeUtf8 token
+  jwkDecode prKey $ encodeUtf8 token
 
-renewToken :: forall user userData . UserData user userData
+renewToken :: Text -> AuthState user -> IO (Maybe JWTWrapper)
-           => Text -- ^ token
+renewToken t state = decodeToken t state >>= \case
-           -> [Scope' user]
-           -> Maybe Text -- ^ client_id
-           -> AuthState user
-           -> IO (Either Text JWTWrapper) -- TODO more descriptive failures
-renewToken t scopes clientID state = decodeToken t state >>= \case
   Right (Jwe (header, body)) -> do
     let jwt = fromJust . decode @JWT $ fromStrict body
     now <- getCurrentTime
-    if now >= expiration jwt then return (Left "token expired") else do
+    if now >= expiration jwt then return Nothing else do
       mUser <- atomically . stateTVar state $ \s ->
         let (key, tokens) = M.updateLookupWithKey (\_ _ -> Nothing) (jti jwt) s.activeTokens
         in  (key, s { activeTokens = tokens })
       case mUser of
-        Just (u, scopes', nonce) -> bool (pure $ Left "must not request new scopes")
+        Just (u, scopes) -> Just <$> mkToken u scopes state
-                                         (Right <$> mkToken @user @userData (u, scopes, nonce) clientID state)
+        Nothing -> return Nothing
-                                         (null $ scopes \\ scopes')
+  Left _ -> return Nothing
-        Nothing -> return $ Left "no user associated with this token"
-  Left _ -> return $ Left "could not decode token"
 

src/LoginForm.hs

@@ -5,22 +5,15 @@
 
 {-# Language OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, QuasiQuotes #-}
 
-module LoginForm
+module LoginForm (HTML(..), Html, loginPage) where
-( HTML(..)
-, Html
-, loginPage
-, logoutPage
-) where
 
 import Prelude hiding (head)
 
-import Data.Aeson (encode)
-import Data.String (IsString(..))
-import Data.Text (Text, unpack)
 import qualified Data.Map as M
+import Data.Aeson (encode)
 import qualified Data.String.Interpolate as I
-
+import Data.String (IsString(..))
-import GHC.Data.Maybe (whenIsJust)
+import Data.Text (Text)
 
 import Network.HTTP.Media ((//), (/:))
 
@@ -39,8 +32,8 @@ instance Accept HTML where
 instance MimeRender HTML Html where
   mimeRender _ = renderHtml
 
-loginPage :: String -> M.Map Text Text -> Html
+loginPage :: M.Map Text Text -> Html
-loginPage uri headers = docTypeHtml $ head' >> body'
+loginPage headers = docTypeHtml $ head' >> body'
   where
     headers' = encode headers
     formID = "loginForm" :: String
@@ -65,7 +58,7 @@ loginPage uri headers = docTypeHtml $ head' >> body'
             headers.append('Authorization', btoa(creds));
             //alert(creds);
             e.preventDefault();
-            fetch('#{uri}', {
+            fetch('../code', {
               method: 'GET',
               headers: headers
             })
@@ -73,22 +66,4 @@ loginPage uri headers = docTypeHtml $ head' >> body'
             .then(url => window.location.replace(url.substring(1, url.length - 1)));
             // Response.redirect(url);
           };
-        |]
+        |]
-
-
-logoutPage :: Maybe Text -> Html
-logoutPage mUri = docTypeHtml $ head' >> body'
-  where
-    head' = head $ do
-      meta ! A.charset "UTF-8"
-      meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1.0"
-      title "UniWorX Oauth2 Mock Server"
-    body' = body $ do
-      h1 "UniWorX Oauth2 Mock Server"
-      p "Logout successful."
-      whenIsJust mUri $ \uri -> do
-        a ! A.href (fromString $ unpack uri) $ "Continue"
-        script $
-          [I.i|
-            setTimeout(_ => window.location.replace('#{uri}'), 2000); |]
-            

src/Server.hs

@@ -12,20 +12,13 @@
     , RecordWildCards
     , AllowAmbiguousTypes
     , LambdaCase
-    , FlexibleContexts
-    , KindSignatures
 #-}
 
 module Server
-( insecureOAuthMock
+{-( insecureOAuthMock'
 , runMockServer
-, runMockServerWithRoutes
+-- , runMockServer'
-, HTML
+)-} where
-, Html
-, AuthServer
-, AuthHandler
-, authCookie
-) where
 
 import AuthCode
 import LoginForm
@@ -36,19 +29,18 @@ 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, void)
+import Control.Monad (unless, (>=>))
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Error (Error(..))
 import Control.Monad.Trans.Reader
 
 import Data.Aeson
-import Data.ByteString (fromStrict, toStrict, ByteString)
+import Data.ByteString (fromStrict)
 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, decodeUtf8)
 import Data.Text.Encoding.Base64
 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime)
 
@@ -56,31 +48,24 @@ import qualified Data.Map.Strict as Map
 
 import GHC.Read (readPrec, lexP)
 
-import Jose.Jwk (generateRsaKeyPair, KeyUse(..), KeyId)
+import Jose.Jwk (generateRsaKeyPair, KeyUse(Enc), KeyId)
 import Jose.Jwt hiding (decode, encode)
 
-import Network.HTTP.Client (newManager, defaultManagerSettings, httpLbs, parseRequest)
+import Network.HTTP.Client (newManager, defaultManagerSettings)
 import Network.Wai.Handler.Warp
 
 import Servant
-import Servant.Client hiding (client)
+import Servant.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)
 
 
 
-authCookie :: Text
-authCookie = "oa2_auth_cookie"
-
 data AuthClient = Client
   { ident :: Text
   , secret :: Text
@@ -89,11 +74,10 @@ data AuthClient = Client
 trustedClients :: [AuthClient] -- TODO move to db
 trustedClients = [Client "42" "shhh"]
 
-data ResponseType = Code -- ^ authorisation code flow
+data ResponseType = Code -- ^ authorisation code grant
-                  | Token -- ^ implicit flow via access token
+                  | Token -- ^ implicit grant via access token
-                  | IDToken -- ^ implicit flow via access token & ID token
+                  | IDToken -- ^ implicit grant via access token & ID token
                   deriving (Eq, Show)
-
 instance Read ResponseType where
   readPrec = do
     Lex.Ident str <- lexP
@@ -113,32 +97,33 @@ type QClient   = String
 type QResType  = String
 type QRedirect = Text
 type QState    = Text
-type QNonce    = Text
 type QAuth     = Text
-type QCookie   = Text
-type QPrompt   = Text
 
 type QParam = QueryParam' [Required, Strict]
 
+-- type Oauth2Params = QParam "scope" QScope
+--                  :> QParam "client_id" QClient
+--                  :> QParam "response_type" QResType
+--                  :> QParam "redirect_uri" QRedirect
+--                  :> QueryParam "state" QState
+
+-- type ProtectedAuth user = BasicAuth "login" user :> "auth" :> Auth -- Prompts for username & password
+-- type QuickAuth = "qauth" :> Auth -- Prompts for username only
 type Auth = "auth"
          :> QParam "scope" QScope
          :> QParam "client_id" QClient
          :> QParam "response_type" QResType
          :> QParam "redirect_uri" QRedirect
          :> QueryParam "state" QState
-         :> QueryParam "nonce" QNonce
+         :> Get '[HTML] Html -- login
-         :> QueryParam "prompt" QPrompt
-         :> Header "Cookie" QCookie
-         :> Get '[HTML] Html -- ^ login
 
 type AuthCode = "code"
-             :> HeaderR "Authorization" QAuth --TODO store in cookie instead of passing as headers
+             :> HeaderR "Authorization" QAuth
              :> HeaderR "OA2_Scope" QScope
              :> HeaderR "OA2_Client_ID" QClient
              :> HeaderR "OA2_Redirect_URI" QRedirect
-             :> Header  "OA2_State" QState
+             :> Header "OA2_State" QState
-             :> Header  "OA2_Nonce" QNonce
+             :> Get '[JSON] Text -- returns auth code
-             :> Get '[JSON] (Headers '[Header "Set-Cookie" Text] Text) -- ^ returns auth code
 
 
 type AuthHandler user = ReaderT (AuthState user) Handler
@@ -148,83 +133,59 @@ toHandler :: forall user userData a . UserData user userData => AuthState user -
 toHandler s h = runReaderT h s
 
 loginServer :: forall user userData . UserData user userData => AuthServer user Auth
-loginServer = decideLogin
+loginServer = handleAuth
   where
-    decideLogin scopes client responseType url mState mNonce mPrompt mCookies
+    handleAuth :: QScope
-      | Nothing <- responseType' = throwError err401 { errBody = "Unsupported response type" }
+               -> QClient
-      | not validOIDC = throwError err401 { errBody = "For OIDC, the 'openid' scope and the 'id_token' response type must be given" }
+               -> QResType
-      | Just "none" <- mPrompt = handleSSO
+               -> QRedirect
-      | Just "login" <- mPrompt = handleLogin
+               -> Maybe QState
-      | Nothing <- mPrompt = if isJust mCreds then handleSSO else handleLogin
+               -> AuthHandler user Html
-      | otherwise = throwError err401 { errBody = "Prompt not supported" }
+    handleAuth scopes client responseType url mState = do
-      where
+      let
-        responseType' = foldM (\acc x -> readMaybe @ResponseType x >>= return . (: acc)) [] $ words responseType
+        responseType' = read @ResponseType responseType
-        mCreds = mCookies >>= lookup authCookie . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c
+        headers = Map.fromList @Text @Text
-        validOIDC :: Bool
+          [ ("OA2_Scope", pack scopes)
-        validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes
+          , ("OA2_Client_ID", pack client)
-                    in  (Left OpenID `elem` scopes') == (IDToken `elem` fromJust responseType')
+          , ("OA2_Redirect_URI", url)]
-        -- | Retrieve user id from cookie
+        headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers
-        handleSSO :: AuthHandler user Html
+      unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }
-        handleSSO = do -- TODO check openid scope
+      return $ loginPage headers'
-          liftIO $ putStrLn "login via SSO..."
-          liftIO . putStrLn $ "creds: " ++ show mCreds
-          unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" }
-          url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce
-          liftIO $ putStrLn "SSO successful"
-          throwError err303 { errHeaders = [("Location", encodeUtf8 url')]}
-
-        -- | Html login form
-        handleLogin :: AuthHandler user Html
-        handleLogin = do
-          unless (Code `elem` fromJust responseType') $ throwError err401 { errBody = "response type 'code' missing" }
-          let headers = Map.fromList @Text @Text $
-                [ ("OA2_Scope", pack scopes)
-                , ("OA2_Client_ID", pack client)
-                , ("OA2_Redirect_URI", url)
-                ] ++ [(x,y) | (x, Just y) <-
-                      [ ("OA2_State", mState)
-                      , ("OA2_Nonce", mNonce)
-                      ]]
-          return $ loginPage "../code" headers
-      
 
 codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode
-codeServer creds scopes client url mState mNonce = addHeader (authCookie <> "=\"" <> creds <> "\"") <$>
+codeServer  = handleCreds
-  handleCreds @user @userData creds scopes client url mState mNonce
+  where
-
+    handleCreds :: QAuth
-handleCreds :: forall user userData . UserData user userData
+                -> QScope
-            => QAuth
+                -> QClient
-            -> QScope
+                -> QRedirect
-            -> QClient
+                -> Maybe QState
-            -> QRedirect
+                -> AuthHandler user Text
-            -> Maybe QState
+    handleCreds creds scopes client url mState = do
-            -> Maybe QNonce
+      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
-            -> AuthHandler user Text
+        throwError $ err404 { errBody = "Not a trusted client."}
-handleCreds creds scopes client url mState mNonce = do
+      let
-  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
+        scopes' = map (readScope @user @userData) $ words scopes
-    throwError $ err404 { errBody = "Not a trusted client."}
+        [userName, password] = splitOn ":" $ decodeBase64Lenient creds
-  let scopes' = map (read @(Scope' user)) $ words scopes
+      liftIO $ print userName
-      [userName, password] = splitOn ":" $ decodeBase64Lenient creds
+      mUser <- liftIO $ lookupUser @user @userData userName (Just password)
-  liftIO . putStrLn $ "\acreds: " <> show userName
+      unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
-  mUser <- liftIO $ lookupUser @user @userData (UserQuery (Just userName) (Just password) Nothing)
+      let u = fromJust mUser
-  unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
+      mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO
-  let u = fromJust mUser
+      liftIO $ print mAuthCode
-  mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes' mNonce) (unpack url)) >>= liftIO
+      liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
-  liftIO $ print mAuthCode
+      redirect $ addParams url mAuthCode mState
-  liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map show scopes')
+    redirect :: Maybe Text -> AuthHandler user Text
-  redirect $ addParams url mAuthCode mState
+    redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
-    where
+    redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
-      redirect :: Maybe Text -> AuthHandler user Text
+    addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
-      redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
+    addParams url Nothing _ = Nothing
-      redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
+    addParams url (Just code) mState =
-      addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
+      let urlParts = splitOn "?" url
-      addParams url Nothing _ = Nothing
+          (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
-      addParams url (Just code) mState =
+          rState = case mState of {Just s -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
-        let urlParts = splitOn "?" url
+          post' = if not (T.null post) then "&" <> T.tail post else post
-            (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
+      in Just $ pre <> "?code=" <> code <> post' <> rState
-            rState = case mState of {Just s -> "&" <> (decodeUtf8 . toStrict $ urlEncodeParams [("state", s)]) ; Nothing -> ""}
-            post' = if not (T.null post) then "&" <> T.tail post else post
-        in Just $ pre <> "?code=" <> code <> post' <> rState
     
 
 
@@ -241,7 +202,6 @@ data ClientData = ClientData --TODO support other flows
   , clientID :: Maybe String
   , clientSecret :: Maybe String
   , redirect :: Maybe String
-  , scopeSubset :: Maybe QScope
   } deriving Show
 
 data AuthFlow = AuthFlow
@@ -252,12 +212,11 @@ instance FromHttpApiData AuthFlow where
 
 instance FromForm ClientData where
   fromForm f = ClientData
-    <$>  ((Left . ACode <$> parseUnique "code" f) <|> (Right . RToken <$> parseUnique "refresh_token" f))
+    <$>  ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f)))
     <*> parseUnique "grant_type" f
     <*> parseMaybe "client_id" f
     <*> parseMaybe "client_secret" f
     <*> parseMaybe "redirect_uri" f
-    <*> parseMaybe "scope" f
 
 instance Error Text where
   strMsg = pack
@@ -277,25 +236,23 @@ tokenEndpoint = provideToken
       unless (isNothing (clientID client >> clientSecret client)
         || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
           throwError $ err500 { errBody = "Invalid client" }
-      let cid = pack <$> clientID client
       case authID client of
         Left (ACode authCode) -> do
           unless (grantType client == "authorization_code") . throwError $ err500 { errBody = "Invalid grant_type" }
           mUser <- asks (verify (pack authCode) (clientID client)) >>= liftIO -- TODO verify redirect url here
           unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" }
           -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
-          token <- asks (mkToken @user @userData (fromJust mUser) cid) >>= liftIO
+          let (user, scopes) = fromJust mUser
+          token <- asks (mkToken @user user scopes) >>= liftIO
           liftIO . putStrLn $ "token: " ++ show token
           return token
         Right (RToken jwtw) -> do
-          let scopes' = (map (read @(Scope' user)) . words) <$> scopeSubset client
-          liftIO . putStrLn $ "\aSCOPES: " ++ show scopes'
           unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" }
           liftIO $ putStrLn "... checking refresh token"
-          eToken <- asks (renewToken @user @userData jwtw (fromMaybe [] scopes') cid) >>= liftIO
+          mToken <- asks (renewToken @user jwtw) >>= liftIO
-          case eToken of
+          case mToken of
-            Right token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
+            Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
-            Left err -> throwError $ err500 { errBody = fromStrict $ encodeUtf8 err }
+            Nothing -> throwError $ err500 { errBody = "Invalid refresh token" }
 
 
  ----------------------
@@ -328,7 +285,7 @@ instance ToJSON result => ToJSON (QueryResult result) where
   toJSON (QRight x) = toJSON x
 
 
-verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (TokenParams user))
+verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user]))
 verifyToken jwtw = do
   let mToken = stripPrefix "Bearer " jwtw
   unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" }
@@ -348,7 +305,7 @@ userEndpoint = handleUserData
   where
     handleUserData :: Text -> AuthHandler user (QueryResult userData)
     handleUserData jwtw = verifyToken @user @userData jwtw >>= \case
-      Just (u, scopes, _) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes
+      Just (u, scopes) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes
       Nothing -> return . QLeft $ QError "UnknownToken"
       
 
@@ -356,79 +313,13 @@ userListEndpoint :: forall user userData . UserData user userData => AuthServer
 userListEndpoint = handleUserData
   where
     handleUserData :: Text -> Text -> AuthHandler user (QueryResult [userData])
-    handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed to query other users
+    handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed query other users
       Nothing -> return . QLeft $ QError "UnknownToken"
-      Just (_, scopes, _) -> liftIO $ lookupUser @user @userData (UserQuery (Just userID) Nothing Nothing) >>= \case
+      Just admin -> liftIO $ lookupUser @user @userData userID Nothing >>= \case
-        Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) scopes] -- TODO support queries that fit for multiple users
+        Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) (snd admin)] -- TODO support queries that fit for multiple users
         Nothing -> return . QLeft $ QError "UserDoesNotExist"
 
 
- --------------
----- 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 -- rLogout :<|> logout
-  where
-    logout :: Maybe QRedirect
-           -> QCookie
-           -> AuthHandler user (Headers '[Header "Set-Cookie" Text] Html)
-    logout mRedir cookie = do
-      let mCreds = lookup authCookie . parseCookiesText $ encodeUtf8 cookie
-      unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" }
-      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 -}
-
-
  -------------------
 ---- Server Main ----
  -------------------
@@ -438,8 +329,6 @@ type Routing user userData = Auth
                         :<|> Token
                         :<|> Me userData
                         :<|> UserList userData
-                        -- :<|> CookieLogout
-                        :<|> Logout
 
 routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
 routing = loginServer @user @userData
@@ -447,45 +336,44 @@ routing = loginServer @user @userData
      :<|> tokenEndpoint @user @userData
      :<|> userEndpoint @user @userData
      :<|> userListEndpoint @user @userData
-     -- :<|> clogoutEndpoint @user @userData
-     :<|> logoutEndpoint @user @userData
 
 
 
-insecureOAuthMock :: forall user userData routes .
+-- insecureOAuthMock :: Application
-                      (UserData user userData, HasServer routes '[])
+-- insecureOAuthMock = authAPI `serve` exampleAuthServer
-                        => AuthState user
+
-                        -> AuthServer user routes
+insecureOAuthMock' :: forall user userData . UserData user userData => AuthState user -> Application
-                        -> Application
+insecureOAuthMock' s = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData)
-insecureOAuthMock s r = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData :<|> r)
   where
-    authAPI = Proxy @(Routing user userData :<|> routes)
+    authAPI = Proxy @(Routing user userData)
 
-runMockServerWithRoutes :: forall user userData routes .
+-- authenticate :: [User] -> BasicAuthCheck User
-                            (UserData user userData, HasServer routes '[])
+-- authenticate users = BasicAuthCheck $ \authData -> do
-                              => Int
+--   let
-                              -> AuthServer user routes
+--     (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
-                              -> IO ()
+--   case (find (\u -> email u == uEmail) users) of
-runMockServerWithRoutes port server = do
+--     Nothing -> return NoSuchUser
+--     Just u  -> return $ if uPass == password u then Authorized u else BadPassword
+
+-- frontend :: BasicAuthData -> ClientM (Map.Map Text Text)
+-- frontend ba = client authAPI ba "[ID]" "42" "code" ""
+
+runMockServer :: forall user userData . UserData user userData => Int -> IO ()
+runMockServer port = do
   state <- mkState @user @userData
-  run port $ insecureOAuthMock @user @userData @routes state server
+  run port $ insecureOAuthMock' @user @userData state
-
-runMockServer :: forall user userData . UserData user userData
-              => Int
-              -> IO ()
-runMockServer port = runMockServerWithRoutes @user @userData @EmptyAPI port emptyServer
 
 -- runMockServer' :: Int -> IO ()
 -- runMockServer' port = do
 --   mgr <- newManager defaultManagerSettings
 --   state <- mkState
---   bracket (forkIO . run port $ insecureOAuthMock testUsers state) killThread $ \_ ->
+--   bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ ->
 --     runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
 --       >>= print
 
 mkState :: forall user userData . UserData user userData => IO (AuthState user)
 mkState = do
-  (publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockJWT") Enc Nothing
+  (publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockKey") Enc Nothing
   let
     activeCodes = Map.empty
     activeTokens = Map.empty

src/User.hs

@@ -3,75 +3,21 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, TypeApplications, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, AllowAmbiguousTypes, RankNTypes, OverlappingInstances, ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-}
 
-module User
+module User ( UserData(..) ) where
-( UserData(..)
-, Scope(..)
-, Scope'(..)
-, UserQuery(..)
-) where
 
-import Control.Applicative ((<|>))
 import Data.Aeson
-import Data.Char (toUpper, toLower)
 import Data.Map.Strict
 import Data.Maybe
-import Data.Text hiding (head, tail, toUpper, toLower)
+import Data.Text
-
-import GHC.Read (readPrec, lexP)
-
-import Text.ParserCombinators.ReadPrec (look, pfail)
-import qualified Text.Read.Lex as Lex
 
 type UserName = Text
 type Password = Text
 
--- | OIDC scope
+class (Eq u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary
-data Scope = OpenID
+  data Scope u
-           | Profile
+  readScope :: String -> Scope u
-           | Email
+  showScope :: Scope u -> String
-           | Address
+  userScope  :: u -> Scope u -> a
-           | Phone
+  lookupUser :: UserName -> Maybe Password -> IO (Maybe u)
-           | OfflineAccess
-           deriving (Show, Eq)
-
-instance Read Scope where
-  readPrec = do
-    Lex.Ident str <- lexP
-    Lex.EOF <- lexP
-    return $ case str of
-      "openid" -> OpenID
-      "profile" -> Profile
-      "email" -> Email
-      "address" -> Address
-      "phone" -> Phone
-      "offline_access" -> OfflineAccess
-
-
-type Scope' user = Either Scope (CustomScope user)
-
-instance forall user . Read (CustomScope user) => Read (Scope' user) where
-  readPrec = (Left <$> readPrec @Scope) <|> (Right <$> readPrec @(CustomScope user))
-
-data UserQuery = UserQuery
-  { email    :: Maybe Text
-  , password :: Maybe Text
-  , key      :: Maybe Text
-  } deriving (Show)
-
-class ( Eq u
-      , Show u -- TODO Show maybe not necessary
-      , Show (UserID u)
-      , Read (CustomScope u)
-      , Show (CustomScope u)
-      , Eq (CustomScope u)
-      , ToJSON a
-      , Monoid a
-      ) => UserData u a where
-  type UserID u
-  data CustomScope u
-  userScope  :: u -> Scope' u -> a
-  lookupUser :: UserQuery -> IO (Maybe u)
-  userID :: u -> UserID u
-

users.yaml

@@ -1,231 +0,0 @@
-# SPDX-FileCopyrightText: 2024 David Mosbach <david.mosbach@uniworx.de>
-#
-# SPDX-License-Identifier: AGPL-3.0-or-later
-
-special-users:
-
-  - default: &default-user
-      userIdent: null
-      userAuthentication: AuthLDAP
-      userLastAuthentication: null
-      userTokensIssuedAfter: null
-      userMatrikelnummer: null
-      userEmail: ""
-      userDisplayEmail: null
-      userDisplayName: null
-      userSurname: ""
-      userFirstName: ""
-      userTitle: null
-      userMaxFavourites: userDefaultMaxFavourites
-      userMaxFavouriteTerms: userDefaultMaxFavouriteTerms
-      userTheme: ThemeDefault
-      userDateTimeFormat: userDefaultDateTimeFormat
-      userDateFormat: userDefaultDateFormat
-      userTimeFormat: userDefaultTimeFormat
-      userDownloadFiles: userDefaultDownloadFiles
-      userWarningDays: userDefaultWarningDays
-      userLanguages: null
-      userCreated: now
-      userNotificationSettings: def
-      userLastLdapSynchronisation: null
-      userLdapPrimaryKey: null
-      userCsvOptions: def
-      userSex: null
-      userBirthday: null
-      userShowSex: userDefaultShowSex
-      userTelephone: null
-      userMobile: null
-      userCompanyPersonalNumber: null
-      userCompanyDepartment: null
-      userPinPassword: null
-      userPostAddress: null
-      userPostLastUpdate: null
-      userPrefersPostal: true
-      userExamOfficeGetSynced: userDefaultExamOfficeGetSynced
-      userExamOfficeGetLabels: userDefaultExamOfficeGetLabels
-
-  - gkleen:
-      <<: *default-user
-      userIdent: "G.Kleen@campus.lmu.de"
-      userLastAuthentication: now
-      userTokensIssuedAfter: now
-      userEmail: "G.Kleen@campus.lmu.de"
-      userDisplayEmail: "gregor.kleen@ifi.lmu.de"
-      userDisplayName: "Gregor Kleen"
-      userSurname: "Kleen"
-      userFirstName: "Gregor Julius Arthur"
-      userMaxFavourites: 6
-      userMaxFavouriteTerms: 1
-      userLanguages: ["en"]
-      # userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
-      userSex: SexMale
-      userCompanyPersonalNumber: "00000"
-      userPostAddress: "Büro 127   \nMathematisches Institut der Ludwig-Maximilians-Universität München   \nTheresienstr. 39   \nD-80333 München"
-
-  - fhamann:
-      <<: *default-user
-      userIdent: "felix.hamann@campus.lmu.de"
-      userEmail: "noEmailKnown"
-      userDisplayEmail: "felix.hamann@campus.lmu.de"
-      userDisplayName: "Felix Hamann"
-      userSurname: "Hamann"
-      userFirstName: "Felix"
-      # userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
-      userSex: SexMale
-      userPinPassword: "tomatenmarmelade"
-      userPostAddress: "Erdbeerweg 24  \n12345 Schlumpfhausen  \nTraumland"
-
-  - jost:
-      <<: *default-user
-      userIdent: "jost@tcs.ifi.lmu.de"
-      userAuthentication: pwSimple
-      userMatrikelnummer: "12345678"
-      userEmail: "S.Jost@Fraport.de"
-      userDisplayEmail: "jost@tcs.ifi.lmu.de"
-      userDisplayName: "Steffen Jost"
-      userSurname: "Jost"
-      userFirstName: "Steffen"
-      userTitle: "Dr."
-      userMaxFavourites: 14
-      userMaxFavouriteTerms: 4
-      userTheme: ThemeMossGreen
-      userSex: SexMale
-      # userBirthday = Just $ n_day $ 35 * (-365)
-      userTelephone: "+49 69 690-71706"
-      userMobile: "0173 69 99 646"
-      userCompanyPersonalNumber: "57138"
-      userCompanyDepartment: "AVN-AR2"
-
-  - maxMuster:
-      <<: *default-user
-      userIdent: "max@campus.lmu.de"
-      userLastAuthentication: now
-      userMatrikelnummer: "1299"
-      userEmail: "max@campus.lmu.de"
-      userDisplayEmail: "max@max.com"
-      userDisplayName: "Max Musterstudent"
-      userSurname: "Musterstudent"
-      userFirstName: "Max"
-      userMaxFavourites: 7
-      userTheme: ThemeAberdeenReds
-      userLanguages: ["de"]
-      userSex: SexMale
-      # userBirthday = Just $ n_day $ 27 * (-365)
-      userPrefersPostal: false
-
-  - tinaTester:
-      <<: *default-user
-      userIdent: "tester@campus.lmu.de"
-      userAuthentication: null
-      userMatrikelnummer: "999"
-      userEmail: "tester@campus.lmu.de"
-      userDisplayEmail: "tina@tester.example"
-      userDisplayName: "Tina Tester"
-      userSurname: "vön Tërrör¿"
-      userFirstName: "Sabrina"
-      userTitle: "Magister"
-      userMaxFavourites: 5
-      userTheme: ThemeAberdeenReds
-      userLanguages: ["sn"]
-      userSex: SexNotApplicable
-      # userBirthday = Just $ n_day 3
-      userCompanyPersonalNumber: "12345"
-      userPrefersPostal: false
-
-  - svaupel:
-      <<: *default-user
-      userIdent: "vaupel.sarah@campus.lmu.de"
-      userEmail: "vaupel.sarah@campus.lmu.de"
-      userDisplayEmail: "vaupel.sarah@campus.lmu.de"
-      userDisplayName: "Sarah Vaupel"
-      userSurname: "Vaupel"
-      userFirstName: "Sarah"
-      userMaxFavourites: 14
-      userMaxFavouriteTerms: 4
-      userTheme: ThemeMossGreen
-      userLanguages: null
-      userSex: SexFemale
-      userPrefersPostal: false
-
-  - sbarth:
-      <<: *default-user
-      userIdent: "Stephan.Barth@campus.lmu.de"
-      userEmail: "Stephan.Barth@lmu.de"
-      userDisplayEmail: "stephan.barth@ifi.lmu.de"
-      userDisplayName: "Stephan Barth"
-      userSurname: "Barth"
-      userFirstName: "Stephan"
-      userTheme: ThemeMossGreen
-      userSex: SexMale
-      userPrefersPostal: false
-      userExamOfficeGetSynced: false
-      userExamOfficeGetLabels: true
-
-  - _stranger1:
-      userIdent: "AVSID:996699"
-      userEmail: "E996699@fraport.de"
-      userDisplayEmail: ""
-      userDisplayName: "Stranger One"
-      userSurname: "One"
-      userFirstName: "Stranger"
-      userTheme: ThemeMossGreen
-      userSex: SexMale
-      userCompanyPersonalNumber: "E996699"
-      userCompanyDepartment: "AVN-Strange"
-      userPrefersPostal: false
-      userExamOfficeGetSynced: false
-      userExamOfficeGetLabels: true
-
-  - _stranger2:
-      userIdent: "AVSID:669966"
-      userEmail: "E669966@fraport.de"
-      userDisplayEmail: ""
-      userDisplayName: "Stranger Two"
-      userSurname: "Stranger"
-      userFirstName: "Two"
-      userTheme: ThemeMossGreen
-      userSex: SexMale
-      userCompanyPersonalNumber: "669966"
-      userCompanyDepartment: "AVN-Strange"
-      userPrefersPostal: false
-      userExamOfficeGetSynced: false
-      userExamOfficeGetLabels: true
-
-  - _stranger3:
-      userIdent: "AVSID:6969"
-      userEmail: "E6969@fraport.de"
-      userDisplayEmail: ""
-      userDisplayName: "Stranger 3 Three"
-      userSurname: "Three"
-      userFirstName: "Stranger"
-      userTheme: ThemeMossGreen
-      userSex: SexMale
-      userCompanyPersonalNumber: "E996699"
-      userCompanyDepartment: "AVN-Strange"
-      userPostAddress: "Kartoffelweg 12  \n666 Höllensumpf  \nFreiland"
-      userPrefersPostal: false
-      userExamOfficeGetSynced: false
-      userExamOfficeGetLabels: true
-
-
-random-users:
-  firstNames: [ "James", "John", "Robert", "Michael"
-              , "William", "David", "Mary", "Richard"
-              , "Joseph", "Thomas", "Charles", "Daniel"
-              , "Matthew", "Patricia", "Jennifer", "Linda"
-              , "Elizabeth", "Barbara", "Anthony", "Donald"
-              , "Mark", "Paul", "Steven", "Andrew"
-              , "Kenneth", "Joshua", "George", "Kevin"
-              , "Brian", "Edward", "Susan", "Ronald"
-              ]
-  surnames: [ "Smith", "Johnson", "Williams", "Brown"
-            , "Jones", "Miller", "Davis", "Garcia"
-            , "Rodriguez", "Wilson", "Martinez", "Anderson"
-            , "Taylor", "Thomas", "Hernandez", "Moore"
-            , "Martin", "Jackson", "Thompson", "White"
-            , "Lopez", "Lee", "Gonzalez", "Harris"
-            , "Clark", "Lewis", "Robinson", "Walker"
-            , "Perez", "Hall", "Young", "Allen"
-            ]
-  middlenames: [ null, "Jamesson" ]
-