diff --git a/app/UniWorX.hs b/app/UniWorX.hs index f373ef5..d49547b 100644 --- a/app/UniWorX.hs +++ b/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) - readScope = read - showScope = show - userScope (Entity _ User{..}) ID = M.singleton "id" userEmail - userScope (Entity _ User{..}) Profile = M.fromList [(key, val) | (key, Just val) <- - [ ("firstName", Just userFirstName) - , ("surname", Just userSurname) - , ("email", Just userEmail) - , ("matriculationNumber", userMatricNumber) + type UserID (Entity User) = Key User + data CustomScope (Entity User) = UWX deriving (Read, Show, Eq) + userScope (Entity _ User{..}) (Left OpenID) = M.singleton "id" userEmail + userScope (Entity _ User{..}) (Left Profile) = M.fromList $ catM + [ ("name", Just $ userFirstName <> " " <> userSurname) + , ("given_name", Just userFirstName) + , ("family_name", Just userSurname) + , ("middle_name", Nothing) + , ("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) - ]] - lookupUser email _ = runDB $ do - user <- selectList [UserEmail ==. email] [] + ] + userScope (Entity _ User{..}) _ = M.empty + lookupUser UserQuery{..} = runDB $ do + 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 ] diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index 6214f61..dc435b8 100644 --- a/oauth2-mock-server.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 27500e6..4834bd2 100644 --- a/package.yaml +++ b/package.yaml @@ -44,6 +44,7 @@ dependencies: - blaze-html - http-media - string-interpolate +- cookie ghc-options: - -Wall diff --git a/src/AuthCode.hs b/src/AuthCode.hs index da21caf..6f366be 100644 --- a/src/AuthCode.hs +++ b/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 u scopes state = do +mkToken :: forall user userData . UserData user userData + => 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) } - return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken) + Jwt iToken = fromRight undefined encodedIT + 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 t state = decodeToken t state >>= \case +renewToken :: forall user userData . UserData user userData + => 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 diff --git a/src/Server.hs b/src/Server.hs index f995719..6804bc9 100644 --- a/src/Server.hs +++ b/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 - :> Get '[JSON] Text -- returns auth code + :> Header "OA2_State" QState + :> 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 - -> QClient - -> QResType - -> QRedirect - -> Maybe QState - -> AuthHandler user Html - handleAuth scopes client responseType url mState = do - let - responseType' = read @ResponseType responseType - headers = Map.fromList @Text @Text - [ ("OA2_Scope", pack scopes) - , ("OA2_Client_ID", pack client) - , ("OA2_Redirect_URI", url)] - headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers - unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" } - return $ loginPage headers' + decideLogin scopes client responseType url mState mNonce mCookies + | Just nonce <- mNonce, Just cookies <- mCookies = handleOIDC nonce cookies + | Nothing <- (mNonce >> mCookies) = handleLogin + | otherwise = throwError err500 { errBody = "Either cookie or nonce missing" } + where + -- | Retrieve user id from cookie + handleOIDC :: QNonce + -> QCookie + -> AuthHandler user Html + handleOIDC nonce cookies = case read @ResponseType responseType of -- TODO nonce can also occur if user is not logged in yet + IDToken -> do + let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookies + unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" } + url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState (Just nonce) + throwError err303 { errHeaders = [("Location", encodeUtf8 url')]} + _ -> 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 - where - handleCreds :: QAuth - -> QScope - -> QClient - -> QRedirect - -> Maybe QState - -> AuthHandler user Text - handleCreds creds scopes client url mState = do - 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 - throwError $ err404 { errBody = "Not a trusted client."} - let - scopes' = map (readScope @user @userData) $ words scopes - [userName, password] = splitOn ":" $ decodeBase64Lenient creds - liftIO $ print userName - mUser <- liftIO $ lookupUser @user @userData userName (Just password) - unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."} - let u = fromJust mUser - mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO - liftIO $ print mAuthCode - liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes') - redirect $ addParams url mAuthCode mState - redirect :: Maybe Text -> AuthHandler user Text - redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]} - redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."} - addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text - addParams url Nothing _ = Nothing - addParams url (Just code) mState = - let urlParts = splitOn "?" url - (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "") - 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 +codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=" <> creds) <$> + handleCreds @user @userData creds scopes client url mState Nothing + +handleCreds :: forall user userData . UserData user userData + => QAuth + -> QScope + -> QClient + -> QRedirect + -> Maybe QState + -> Maybe QNonce + -> AuthHandler user Text +handleCreds creds scopes client url mState mNonce = do + 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 + throwError $ err404 { errBody = "Not a trusted client."} + let scopes' = map (read @(Scope' user)) $ words scopes + [userName, password] = splitOn ":" $ decodeBase64Lenient creds + mUser <- liftIO $ lookupUser @user @userData (UserQuery (Just userName) (Just password) Nothing) + unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."} + let u = fromJust mUser + mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes' mNonce) (unpack url)) >>= liftIO + liftIO $ print mAuthCode + liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map show scopes') + redirect $ addParams url mAuthCode mState + where + redirect :: Maybe Text -> AuthHandler user Text + redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]} + redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."} + addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text + addParams url Nothing _ = Nothing + addParams url (Just code) mState = + let urlParts = splitOn "?" url + (pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "") + 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 user scopes) >>= liftIO + token <- asks (mkToken @user @userData (fromJust mUser) cid) >>= 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 u -> return $ QRight [mconcat $ map (userScope @user @userData u) (snd admin)] -- TODO support queries that fit for multiple users + Just (_, scopes, _) -> liftIO $ lookupUser @user @userData (UserQuery (Just userID) Nothing Nothing) >>= \case + Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) scopes] -- TODO support queries that fit for multiple users Nothing -> return . QLeft $ QError "UserDoesNotExist" diff --git a/src/User.hs b/src/User.hs index b1d0aea..ffae304 100644 --- a/src/User.hs +++ b/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 - data Scope u - readScope :: String -> Scope u - showScope :: Scope u -> String - userScope :: u -> Scope u -> a - lookupUser :: UserName -> Maybe Password -> IO (Maybe u) +-- | OIDC scope +data Scope = OpenID + | Profile + | Email + | Address + | 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 +