diff --git a/src/Server.hs b/src/Server.hs index 053070e..6942e9b 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -3,7 +3,16 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards, AllowAmbiguousTypes #-} +{-# LANGUAGE + DataKinds + , TypeOperators + , OverloadedStrings + , ScopedTypeVariables + , TypeApplications + , RecordWildCards + , AllowAmbiguousTypes + , LambdaCase +#-} module Server {-( insecureOAuthMock' @@ -214,18 +223,16 @@ instance Error Text where type Token = "token" - :> ReqBody '[FormUrlEncoded] Form --ClientData + :> ReqBody '[FormUrlEncoded] ClientData :> Post '[JSON] JWTWrapper tokenEndpoint :: forall user userData . UserData user userData => AuthServer user Token tokenEndpoint = provideToken where - provideToken :: Form -> AuthHandler user JWTWrapper - provideToken clienty = do - liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show clienty - liftIO . print $ fromForm @ClientData clienty - let Right client = fromForm @ClientData clienty + provideToken :: ClientData -> AuthHandler user JWTWrapper + provideToken client = do + liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show client unless (isNothing (clientID client >> clientSecret client) || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) . throwError $ err500 { errBody = "Invalid client" } @@ -243,7 +250,6 @@ tokenEndpoint = provideToken unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" } liftIO $ putStrLn "... checking refresh token" mToken <- asks (renewToken @user jwtw) >>= liftIO - liftIO $ putStrLn "woohoo" case mToken of Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token Nothing -> throwError $ err500 { errBody = "Invalid refresh token" } @@ -260,13 +266,23 @@ type HeaderR = Header' [Strict, Required] type Me userData = Users :> "me" :> HeaderR "Authorization" Text - :> Get '[JSON] (Maybe userData) + :> Get '[JSON] (QueryResult userData) type UserList userData = Users :> "query" :> HeaderR "Authorization" Text :> QParam "id" Text - :> Get '[JSON] [userData] + :> Get '[JSON] (QueryResult [userData]) + +data QueryResult result = QLeft QueryError | QRight result +newtype QueryError = QError Text + +instance ToJSON QueryError where + toJSON (QError code) = object ["error" .= object ["code" .= code]] + +instance ToJSON result => ToJSON (QueryResult result) where + toJSON (QLeft x) = toJSON x + toJSON (QRight x) = toJSON x verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user])) @@ -287,26 +303,21 @@ verifyToken jwtw = do userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData) userEndpoint = handleUserData where - handleUserData :: Text -> AuthHandler user (Maybe userData) - handleUserData jwtw = do - mUser <- verifyToken @user @userData jwtw - case mUser of - Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes - Nothing -> throwError $ err500 { errBody = "Unknown token" } + 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 + Nothing -> return . QLeft $ QError "UnknownToken" userListEndpoint :: forall user userData . UserData user userData => AuthServer user (UserList userData) userListEndpoint = handleUserData where - handleUserData :: Text -> Text -> AuthHandler user [userData] - handleUserData jwtw userID = do - mAdmin <- verifyToken @user @userData jwtw - unless (isJust mAdmin) . throwError $ err500 { errBody = "Unknown token" } - -- TODO check if this user is allowed query other users - mUser <- liftIO $ lookupUser @user @userData userID Nothing - case mUser of - Just u -> return [mconcat $ map (userScope @user @userData u) (snd $ fromJust mAdmin)] -- TODO support queries that fit for multiple users - Nothing -> throwError $ err500 { errBody = "This user does not exist" } + 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 + Nothing -> return . QLeft $ QError "UserDoesNotExist" -------------------