issuing of id tokens

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 ]
 

oauth2-mock-server.cabal

@@ -37,6 +37,7 @@ library
     , blaze-html
     , bytestring
     , containers
+    , cookie
     , http-api-data
     , http-client
     , http-media
@@ -72,6 +73,7 @@ executable oauth2-mock-server-exe
     , bytestring
     , conduit
     , containers
+    , cookie
     , http-api-data
     , http-client
     , http-media
@@ -112,6 +114,7 @@ test-suite oauth2-mock-server-test
     , blaze-html
     , bytestring
     , containers
+    , cookie
     , http-api-data
     , http-client
     , http-media

package.yaml

@@ -44,6 +44,7 @@ dependencies:
 - blaze-html
 - http-media
 - string-interpolate
+- cookie
 
 ghc-options:
 - -Wall

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.Encoding (decodeUtf8, encodeUtf8)
 import Data.Text.Encoding.Base64
-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)
-  , activeTokens :: Map UUID (user, [Scope user])
+  , activeTokens :: Map UUID (TokenParams user)
   , publicKey   :: Jwk
   , privateKey  :: Jwk
   }
 
 type AuthState user = TVar (State user)
 
+ -----------------
+---- Functions ----
+ -----------------
+
 genUnencryptedCode :: AuthRequest user
                    -> String
                    -> AuthState user
@@ -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,28 +178,48 @@ 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
+        -> Maybe Text -- client_id
+        -> AuthState user
+        -> IO JWTWrapper
+mkToken (u, scopes, nonce) clientID state = do
   pubKey <- atomically $ readTVar state >>= return . publicKey
   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 pubKey (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 (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken) (Just $ BS.unpack iToken)
     Left e -> error $ show e
 
 decodeToken :: Text -> AuthState user -> IO (Either JwtError JwtContent)
@@ -164,8 +227,13 @@ decodeToken token state = do
   prKey <- atomically $ readTVar state >>= return . privateKey
   jwkDecode prKey $ 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 (Maybe 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
@@ -174,7 +242,7 @@ renewToken t state = decodeToken t state >>= \case
         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 Nothing) (Just <$> mkToken @user @userData (u, scopes, nonce) clientID state) (null $ scopes \\ scopes')
         Nothing -> return Nothing
   Left _ -> return Nothing
 

src/Server.hs

@@ -40,12 +40,13 @@ import Control.Monad.Trans.Error (Error(..))
 import Control.Monad.Trans.Reader
 
 import Data.Aeson
-import Data.ByteString (fromStrict)
+import Data.ByteString (fromStrict, 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)
 import Data.Text.Encoding.Base64
 import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime)
 
@@ -60,13 +61,14 @@ import Network.HTTP.Client (newManager, defaultManagerSettings)
 import Network.Wai.Handler.Warp
 
 import Servant
-import Servant.Client
+import Servant.Client hiding (client)
 import Servant.API
 
 import Text.ParserCombinators.ReadPrec (look, pfail)
 
 import qualified Text.Read.Lex as Lex
 
+import Web.Cookie (parseCookiesText)
 import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..))
 
 
@@ -102,7 +104,9 @@ type QClient   = String
 type QResType  = String
 type QRedirect = Text
 type QState    = Text
+type QNonce    = Text
 type QAuth     = Text
+type QCookie   = Text
 
 type QParam = QueryParam' [Required, Strict]
 
@@ -112,15 +116,17 @@ type Auth = "auth"
          :> QParam "response_type" QResType
          :> QParam "redirect_uri" QRedirect
          :> QueryParam "state" QState
-         :> Get '[HTML] Html -- login
+         :> QueryParam "nonce" QNonce
+         :> Header "Cookie" QCookie
+         :> Get '[HTML] Html -- ^ login
 
 type AuthCode = "code"
              :> 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
-             :> Get '[JSON] Text -- returns auth code
+             :> Get '[JSON] (Headers '[Header "Set-Cookie" Text] Text) -- ^ returns auth code
 
 
 type AuthHandler user = ReaderT (AuthState user) Handler
@@ -130,59 +136,76 @@ 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 mCookies
-               -> QClient
+      | Just nonce <- mNonce, Just cookies <- mCookies = handleOIDC nonce cookies
-               -> QResType
+      | Nothing <- (mNonce >> mCookies) = handleLogin
-               -> QRedirect
+      | otherwise = throwError err500 { errBody = "Either cookie or nonce missing" }
-               -> Maybe QState
+      where
-               -> AuthHandler user Html
+        -- | Retrieve user id from cookie
-    handleAuth scopes client responseType url mState = do
+        handleOIDC :: QNonce
-      let
+                   -> QCookie
-        responseType' = read @ResponseType responseType
+                   -> AuthHandler user Html
-        headers = Map.fromList @Text @Text
+        handleOIDC nonce cookies = case read @ResponseType responseType of -- TODO nonce can also occur if user is not logged in yet
-          [ ("OA2_Scope", pack scopes)
+          IDToken -> do
-          , ("OA2_Client_ID", pack client)
+            let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookies
-          , ("OA2_Redirect_URI", url)]
+            unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" }
-        headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers
+            url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState (Just nonce)
-      unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }
+            throwError err303 { errHeaders = [("Location", encodeUtf8 url')]}
-      return $ loginPage headers'
+          _ -> throwError err500 { errBody = "Unsupported response type" }
+
+        -- | Html login form
+        handleLogin :: AuthHandler user Html
+        handleLogin = do
+          let
+            responseType' = read @ResponseType responseType
+            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)]]
+          case responseType' of
+            Code -> return $ loginPage headers
+            _ -> throwError err500 { errBody = "Unsupported response type" }
+      
 
 codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode
-codeServer  = handleCreds
+codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=" <> creds) <$>
-  where
+  handleCreds @user @userData creds scopes client url mState Nothing
-    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."}
+  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 -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
+            post' = if not (T.null post) then "&" <> T.tail post else post
+        in Just $ pre <> "?code=" <> code <> post' <> rState
     
 
 
@@ -233,20 +256,21 @@ 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 = [] -- TODO read query param for this
           unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" }
           liftIO $ putStrLn "... checking refresh token"
-          mToken <- asks (renewToken @user jwtw) >>= liftIO
+          mToken <- asks (renewToken @user @userData jwtw scopes cid) >>= liftIO
           case mToken of
             Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
             Nothing -> throwError $ err500 { errBody = "Invalid refresh token" }
@@ -282,7 +306,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" }
@@ -302,7 +326,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"
       
 
@@ -312,8 +336,8 @@ userListEndpoint = handleUserData
     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
       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"
 
 

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
+