fixed url encoding

OIDC

See merge request mosbach/oauth2-mock-server!5

app/Main.hs

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

app/SSO.hs

@@ -0,0 +1,102 @@
+-- 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,6 +31,7 @@ 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(..), (.:), (.:?))
@@ -51,7 +52,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
     email           Text
     matricNumber    Text Maybe
     title           Text Maybe
-    sex             Text Maybe
+    gender          Text Maybe
     birthday        Text Maybe
     telephone       Text Maybe
     mobile          Text Maybe
@@ -68,7 +69,7 @@ instance FromJSON User where
     <*> o .:  "userEmail"
     <*> o .:? "userMatrikelnummer"
     <*> o .:? "userTitle"
-    <*> o .:? "userSex"
+    <*> o .:? "userGender"
     <*> o .:? "userBirthday"
     <*> o .:? "userTelephone"
     <*> o .:? "userMobile"
@@ -107,28 +108,49 @@ initDB = do
 
 
 instance UserData (Entity User) (Map Text Text) where
-  data Scope (Entity User) = ID | Profile deriving (Show, Read, Eq)
+  type UserID (Entity User) = Key User
-  readScope = read
+  data CustomScope (Entity User) = UWX deriving (Read, Show, Eq)
-  showScope = show
+  userScope (Entity _ User{..}) (Left OpenID) = M.singleton "id" userEmail
-  userScope (Entity _ User{..}) ID = M.singleton "id" userEmail
+  userScope (Entity _ User{..}) (Left Profile) = M.fromList $ catM
-  userScope (Entity _ User{..}) Profile = M.fromList [(key, val) | (key, Just val) <-
+    [ ("name", Just $ userFirstName <> " " <> userSurname)
-    [ ("firstName", Just userFirstName)
+    , ("given_name", Just userFirstName)
-    , ("surname", Just userSurname)
+    , ("family_name", Just userSurname)
-    , ("email", Just userEmail)
+    , ("middle_name", Nothing)
-    , ("matriculationNumber", userMatricNumber)
+    , ("nickname", Nothing)
+    , ("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 email _ = runDB $ do
+  lookupUser UserQuery{..} = runDB $ do
-    user <- selectList [UserEmail ==. email] []
+    let filters = map fst $ catM [(UserEmail ==. fromJust email, 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,11 +41,12 @@
           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}
-          echo "moved"
+          rm -rf .stack-work
         '';
       };
       mkDB = builtins.readFile ./mkDB.sh;
@@ -77,6 +78,7 @@
           ${mkDB}
           zsh
           ${killDB}
+          exit
         '';
       };
     };

oauth2-mock-server.cabal

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

package.yaml

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

src/AuthCode.hs

@@ -3,12 +3,13 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase, DeriveGeneric, AllowAmbiguousTypes #-}
 
 module AuthCode
 ( State(..)
 , AuthState
 , AuthRequest(..)
+, TokenParams(..)
 , JWT(..)
 , JWTWrapper(..)
 , genUnencryptedCode
@@ -18,18 +19,23 @@ 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)
-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, replace, Text, stripPrefix)
+import Data.Text (pack, Text, stripPrefix)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-import Data.Text.Encoding.Base64
+import Data.Text.Encoding.Base64.URL
-import Data.UUID
+import Data.UUID hiding (null)
 import Data.UUID.V4
 
 import qualified Data.ByteString.Char8 as BS
@@ -40,13 +46,22 @@ 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
@@ -60,25 +75,41 @@ 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) = object
+  toJSON (JWTW a e r i) = 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
@@ -86,24 +117,33 @@ 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)
 
 data State user = State
-  { activeCodes :: Map Text (AuthRequest user)
+  { activeCodes  :: Map Text (AuthRequest user)
-  , activeTokens :: Map UUID (user, [Scope user])
+  , activeTokens :: Map UUID (TokenParams user)
-  , publicKey   :: Jwk
+  , publicKey    :: Jwk
-  , privateKey  :: Jwk
+  , privateKey   :: Jwk
   }
 
 type AuthState user = TVar (State user)
 
+ -----------------
+---- Functions ----
+ -----------------
+
 genUnencryptedCode :: AuthRequest user
                    -> String
                    -> AuthState user
@@ -112,7 +152,7 @@ genUnencryptedCode req url state = do
   now <- getCurrentTime
   let
     expiresAt = req.codeExpiration `addUTCTime` now
-    simpleCode = replace "/" "%2F" . replace "=" "%3D" . encodeBase64 . pack . filter (/= ' ') $ req.client <> url <> show now <> show expiresAt
+    simpleCode = encodeBase64Unpadded . pack $ req.client <> url <> show now <> show expiresAt
   success <- atomically . stateTVar state $ \s ->
     let mEntry = M.lookup simpleCode s.activeCodes
     in
@@ -127,7 +167,10 @@ genUnencryptedCode req url state = do
         atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
 
 
-verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user]))
+verify :: Text
+       -> Maybe String
+       -> AuthState user
+       -> IO (Maybe (TokenParams user))
 verify code mClientID state = do
   now <- getCurrentTime
   mData <- atomically $ do
@@ -135,46 +178,78 @@ verify code mClientID state = do
     modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
     return result
   return $ case mData of
-    Just (AuthRequest clientID' _ u s) -> if (fromMaybe clientID' mClientID) == clientID' then Just (u, s) else Nothing
+    Just (AuthRequest clientID' _ u s n) -> if (fromMaybe clientID' mClientID) == clientID'
+                                            then Just (u, s, n)
+                                            else Nothing
     _ -> Nothing
 
 
-mkToken :: user -> [Scope user] -> AuthState user -> IO JWTWrapper
+mkToken :: forall user userData . UserData user userData
-mkToken u scopes state = do
+        => TokenParams user
-  pubKey <- atomically $ readTVar state >>= return . publicKey
+        -> Maybe Text -- client_id
+        -> 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)
-  case encodedAT >> encodedRT of
+  encodedIT <- Jws.jwkEncode RS256 privKey (Nested . Jwt . toStrict $ encode it)
+  case encodedAT >> encodedRT >> encodedIT of
     Right _ -> do
       let Jwt aToken = fromRight undefined encodedAT
           Jwt rToken = fromRight undefined encodedRT
-      atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes) (activeTokens s) }
+          Jwt iToken = fromRight undefined encodedIT
-      return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken)
+      atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes, nonce) (activeTokens s) }
+      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
-  prKey <- atomically $ readTVar state >>= return . privateKey
+  key <- atomically $ readTVar state >>= return . privateKey
-  jwkDecode prKey $ encodeUtf8 token
+  jwkDecode key $ encodeUtf8 token
 
-renewToken :: Text -> AuthState user -> IO (Maybe JWTWrapper)
+renewToken :: forall user userData . UserData user userData
-renewToken t state = decodeToken t state >>= \case
+           => Text -- ^ token
+           -> [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 Nothing else do
+    if now >= expiration jwt then return (Left "token expired") 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) -> Just <$> mkToken u scopes state
+        Just (u, scopes', nonce) -> bool (pure $ Left "must not request new scopes")
-        Nothing -> return Nothing
+                                         (Right <$> mkToken @user @userData (u, scopes, nonce) clientID state)
-  Left _ -> return Nothing
+                                         (null $ scopes \\ scopes')
+        Nothing -> return $ Left "no user associated with this token"
+  Left _ -> return $ Left "could not decode token"
 

src/LoginForm.hs

@@ -5,15 +5,22 @@
 
 {-# Language OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, QuasiQuotes #-}
 
-module LoginForm (HTML(..), Html, loginPage) where
+module LoginForm
+( HTML(..)
+, Html
+, loginPage
+, logoutPage
+) where
 
 import Prelude hiding (head)
 
-import qualified Data.Map as M
 import Data.Aeson (encode)
-import qualified Data.String.Interpolate as I
 import Data.String (IsString(..))
-import Data.Text (Text)
+import Data.Text (Text, unpack)
+import qualified Data.Map as M
+import qualified Data.String.Interpolate as I
+
+import GHC.Data.Maybe (whenIsJust)
 
 import Network.HTTP.Media ((//), (/:))
 
@@ -32,8 +39,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
@@ -58,7 +65,7 @@ loginPage headers = docTypeHtml $ head' >> body'
             headers.append('Authorization', btoa(creds));
             //alert(creds);
             e.preventDefault();
-            fetch('../code', {
+            fetch('#{uri}', {
               method: 'GET',
               headers: headers
             })
@@ -66,4 +73,22 @@ loginPage 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,13 +12,20 @@
     , RecordWildCards
     , AllowAmbiguousTypes
     , LambdaCase
+    , FlexibleContexts
+    , KindSignatures
 #-}
 
 module Server
-{-( insecureOAuthMock'
+( insecureOAuthMock
 , runMockServer
--- , runMockServer'
+, runMockServerWithRoutes
-)-} where
+, HTML
+, Html
+, AuthServer
+, AuthHandler
+, authCookie
+) where
 
 import AuthCode
 import LoginForm
@@ -29,18 +36,19 @@ import Control.Concurrent
 import Control.Concurrent.STM (atomically)
 import Control.Concurrent.STM.TVar (newTVarIO, readTVar, modifyTVar)
 import Control.Exception (bracket)
-import Control.Monad (unless, (>=>))
+import Control.Monad (unless, (>=>), foldM, void)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Error (Error(..))
 import Control.Monad.Trans.Reader
 
 import Data.Aeson
-import Data.ByteString (fromStrict)
+import Data.ByteString (fromStrict, toStrict, ByteString)
 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)
 
@@ -48,24 +56,31 @@ import qualified Data.Map.Strict as Map
 
 import GHC.Read (readPrec, lexP)
 
-import Jose.Jwk (generateRsaKeyPair, KeyUse(Enc), KeyId)
+import Jose.Jwk (generateRsaKeyPair, KeyUse(..), KeyId)
 import Jose.Jwt hiding (decode, encode)
 
-import Network.HTTP.Client (newManager, defaultManagerSettings)
+import Network.HTTP.Client (newManager, defaultManagerSettings, httpLbs, parseRequest)
 import Network.Wai.Handler.Warp
 
 import Servant
-import Servant.Client
+import Servant.Client hiding (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.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..))
+import Web.Cookie (parseCookiesText)
+import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..), urlEncodeParams)
 
 
 
+authCookie :: Text
+authCookie = "oa2_auth_cookie"
+
 data AuthClient = Client
   { ident :: Text
   , secret :: Text
@@ -74,10 +89,11 @@ data AuthClient = Client
 trustedClients :: [AuthClient] -- TODO move to db
 trustedClients = [Client "42" "shhh"]
 
-data ResponseType = Code -- ^ authorisation code grant
+data ResponseType = Code -- ^ authorisation code flow
-                  | Token -- ^ implicit grant via access token
+                  | Token -- ^ implicit flow via access token
-                  | IDToken -- ^ implicit grant via access token & ID token
+                  | IDToken -- ^ implicit flow via access token & ID token
                   deriving (Eq, Show)
+
 instance Read ResponseType where
   readPrec = do
     Lex.Ident str <- lexP
@@ -97,33 +113,32 @@ 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
-         :> Get '[HTML] Html -- login
+         :> QueryParam "nonce" QNonce
+         :> QueryParam "prompt" QPrompt
+         :> Header "Cookie" QCookie
+         :> Get '[HTML] Html -- ^ login
 
 type AuthCode = "code"
-             :> HeaderR "Authorization" QAuth
+             :> HeaderR "Authorization" QAuth --TODO store in cookie instead of passing as headers
              :> HeaderR "OA2_Scope" QScope
              :> HeaderR "OA2_Client_ID" QClient
              :> HeaderR "OA2_Redirect_URI" QRedirect
-             :> Header "OA2_State" QState
+             :> Header  "OA2_State" QState
-             :> Get '[JSON] Text -- returns auth code
+             :> Header  "OA2_Nonce" QNonce
+             :> Get '[JSON] (Headers '[Header "Set-Cookie" Text] Text) -- ^ returns auth code
 
 
 type AuthHandler user = ReaderT (AuthState user) Handler
@@ -133,59 +148,83 @@ 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 = handleAuth
+loginServer = decideLogin
   where
-    handleAuth :: QScope
+    decideLogin scopes client responseType url mState mNonce mPrompt mCookies
-               -> QClient
+      | Nothing <- responseType' = throwError err401 { errBody = "Unsupported response type" }
-               -> QResType
+      | not validOIDC = throwError err401 { errBody = "For OIDC, the 'openid' scope and the 'id_token' response type must be given" }
-               -> QRedirect
+      | Just "none" <- mPrompt = handleSSO
-               -> Maybe QState
+      | Just "login" <- mPrompt = handleLogin
-               -> AuthHandler user Html
+      | Nothing <- mPrompt = if isJust mCreds then handleSSO else handleLogin
-    handleAuth scopes client responseType url mState = do
+      | otherwise = throwError err401 { errBody = "Prompt not supported" }
-      let
+      where
-        responseType' = read @ResponseType responseType
+        responseType' = foldM (\acc x -> readMaybe @ResponseType x >>= return . (: acc)) [] $ words responseType
-        headers = Map.fromList @Text @Text
+        mCreds = mCookies >>= lookup authCookie . parseCookiesText . encodeUtf8 >>= \c -> if c == "\"\"" then Nothing else Just c
-          [ ("OA2_Scope", pack scopes)
+        validOIDC :: Bool
-          , ("OA2_Client_ID", pack client)
+        validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes
-          , ("OA2_Redirect_URI", url)]
+                    in  (Left OpenID `elem` scopes') == (IDToken `elem` fromJust responseType')
-        headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers
+        -- | Retrieve user id from cookie
-      unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }
+        handleSSO :: AuthHandler user Html
-      return $ loginPage headers'
+        handleSSO = do -- TODO check openid scope
+          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  = handleCreds
+codeServer creds scopes client url mState mNonce = addHeader (authCookie <> "=\"" <> creds <> "\"") <$>
-  where
+  handleCreds @user @userData creds scopes client url mState mNonce
-    handleCreds :: QAuth
+
-                -> QScope
+handleCreds :: forall user userData . UserData user userData
-                -> QClient
+            => QAuth
-                -> QRedirect
+            -> QScope
-                -> Maybe QState
+            -> QClient
-                -> AuthHandler user Text
+            -> QRedirect
-    handleCreds creds scopes client url mState = do
+            -> Maybe QState
-      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
+            -> Maybe QNonce
-        throwError $ err404 { errBody = "Not a trusted client."}
+            -> AuthHandler user Text
-      let
+handleCreds creds scopes client url mState mNonce = do
-        scopes' = map (readScope @user @userData) $ words scopes
+  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
-        [userName, password] = splitOn ":" $ decodeBase64Lenient creds
+    throwError $ err404 { errBody = "Not a trusted client."}
-      liftIO $ print userName
+  let scopes' = map (read @(Scope' user)) $ words scopes
-      mUser <- liftIO $ lookupUser @user @userData userName (Just password)
+      [userName, password] = splitOn ":" $ decodeBase64Lenient creds
-      unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
+  liftIO . putStrLn $ "\acreds: " <> show userName
-      let u = fromJust mUser
+  mUser <- liftIO $ lookupUser @user @userData (UserQuery (Just userName) (Just password) Nothing)
-      mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO
+  unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
-      liftIO $ print mAuthCode
+  let u = fromJust mUser
-      liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
+  mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes' mNonce) (unpack url)) >>= liftIO
-      redirect $ addParams url mAuthCode mState
+  liftIO $ print mAuthCode
-    redirect :: Maybe Text -> AuthHandler user Text
+  liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map show scopes')
-    redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
+  redirect $ addParams url mAuthCode mState
-    redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
+    where
-    addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
+      redirect :: Maybe Text -> AuthHandler user Text
-    addParams url Nothing _ = Nothing
+      redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
-    addParams url (Just code) mState =
+      redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
-      let urlParts = splitOn "?" url
+      addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
-          (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
+      addParams url Nothing _ = Nothing
-          rState = case mState of {Just s -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
+      addParams url (Just code) mState =
-          post' = if not (T.null post) then "&" <> T.tail post else post
+        let urlParts = splitOn "?" url
-      in Just $ pre <> "?code=" <> code <> post' <> rState
+            (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
+            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
     
 
 
@@ -202,6 +241,7 @@ data ClientData = ClientData --TODO support other flows
   , clientID :: Maybe String
   , clientSecret :: Maybe String
   , redirect :: Maybe String
+  , scopeSubset :: Maybe QScope
   } deriving Show
 
 data AuthFlow = AuthFlow
@@ -212,11 +252,12 @@ instance FromHttpApiData AuthFlow where
 
 instance FromForm ClientData where
   fromForm f = ClientData
-    <$>  ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f)))
+    <$>  ((Left . ACode <$> parseUnique "code" 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
@@ -236,23 +277,25 @@ 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}
-          let (user, scopes) = fromJust mUser
+          token <- asks (mkToken @user @userData (fromJust mUser) cid) >>= liftIO
-          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"
-          mToken <- asks (renewToken @user jwtw) >>= liftIO
+          eToken <- asks (renewToken @user @userData jwtw (fromMaybe [] scopes') cid) >>= liftIO
-          case mToken of
+          case eToken of
-            Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
+            Right token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
-            Nothing -> throwError $ err500 { errBody = "Invalid refresh token" }
+            Left err -> throwError $ err500 { errBody = fromStrict $ encodeUtf8 err }
 
 
  ----------------------
@@ -285,7 +328,7 @@ instance ToJSON result => ToJSON (QueryResult result) where
   toJSON (QRight x) = toJSON x
 
 
-verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user]))
+verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (TokenParams user))
 verifyToken jwtw = do
   let mToken = stripPrefix "Bearer " jwtw
   unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" }
@@ -305,7 +348,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"
       
 
@@ -313,13 +356,79 @@ 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 query other users
+    handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed to query other users
       Nothing -> return . QLeft $ QError "UnknownToken"
-      Just admin -> liftIO $ lookupUser @user @userData userID Nothing >>= \case
+      Just (_, scopes, _) -> liftIO $ lookupUser @user @userData (UserQuery (Just userID) Nothing Nothing) >>= \case
-        Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) (snd admin)] -- TODO support queries that fit for multiple users
+        Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) scopes] -- 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 ----
  -------------------
@@ -329,6 +438,8 @@ 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
@@ -336,44 +447,45 @@ routing = loginServer @user @userData
      :<|> tokenEndpoint @user @userData
      :<|> userEndpoint @user @userData
      :<|> userListEndpoint @user @userData
+     -- :<|> clogoutEndpoint @user @userData
+     :<|> logoutEndpoint @user @userData
 
 
 
--- insecureOAuthMock :: Application
+insecureOAuthMock :: forall user userData routes .
--- insecureOAuthMock = authAPI `serve` exampleAuthServer
+                      (UserData user userData, HasServer routes '[])
-
+                        => AuthState user
-insecureOAuthMock' :: forall user userData . UserData user userData => AuthState user -> Application
+                        -> AuthServer user routes
-insecureOAuthMock' s = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData)
+                        -> Application
+insecureOAuthMock s r = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData :<|> r)
   where
-    authAPI = Proxy @(Routing user userData)
+    authAPI = Proxy @(Routing user userData :<|> routes)
 
--- authenticate :: [User] -> BasicAuthCheck User
+runMockServerWithRoutes :: forall user userData routes .
--- authenticate users = BasicAuthCheck $ \authData -> do
+                            (UserData user userData, HasServer routes '[])
---   let
+                              => Int
---     (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
+                              -> AuthServer user routes
---   case (find (\u -> email u == uEmail) users) of
+                              -> IO ()
---     Nothing -> return NoSuchUser
+runMockServerWithRoutes port server = do
---     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 state
+  run port $ insecureOAuthMock @user @userData @routes state server
+
+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 "Oauth2MockKey") Enc Nothing
+  (publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockJWT") Enc Nothing
   let
     activeCodes = Map.empty
     activeTokens = Map.empty

src/User.hs

@@ -3,21 +3,75 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-}
+{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, TypeApplications, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, AllowAmbiguousTypes, RankNTypes, OverlappingInstances, ScopedTypeVariables #-}
 
-module User ( UserData(..) ) where
+module User
+( 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
+import Data.Text hiding (head, tail, toUpper, toLower)
+
+import GHC.Read (readPrec, lexP)
+
+import Text.ParserCombinators.ReadPrec (look, pfail)
+import qualified Text.Read.Lex as Lex
 
 type UserName = Text
 type Password = Text
 
-class (Eq u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary
+-- | OIDC scope
-  data Scope u
+data Scope = OpenID
-  readScope :: String -> Scope u
+           | Profile
-  showScope :: Scope u -> String
+           | Email
-  userScope  :: u -> Scope u -> a
+           | Address
-  lookupUser :: UserName -> Maybe Password -> IO (Maybe u)
+           | Phone
+           | 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

@@ -0,0 +1,231 @@
+# 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" ]
+