From c43d54a6bee51875618e41f6cb6360aba79e01af Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Mon, 22 Feb 2021 12:44:33 +0100 Subject: [PATCH] Add extra fields to leaderboard entries --- Handler/JWT.hs | 66 ++++++++++++++++++++++++++++++++++++++ Handler/ShowChallenge.hs | 68 +++++----------------------------------- Handler/Tables.hs | 21 ++++++++++--- gonito.cabal | 1 + 4 files changed, 91 insertions(+), 65 deletions(-) create mode 100644 Handler/JWT.hs diff --git a/Handler/JWT.hs b/Handler/JWT.hs new file mode 100644 index 0000000..e58d86f --- /dev/null +++ b/Handler/JWT.hs @@ -0,0 +1,66 @@ +module Handler.JWT where + +import Import hiding (Proxy, fromList) + +import qualified Data.ByteString as BS +import Data.Word8 (isSpace, toLower) +import Network.Wai (requestHeaders) +import qualified Jose.Jwt as JWT +import qualified Jose.Jwa as JWA + +import Data.Aeson + +data JwtAuthInfo = JwtAuthInfo Text + deriving (Show, Eq) + +instance FromJSON JwtAuthInfo where + parseJSON (Object v) = + JwtAuthInfo <$> v .: "preferred_username" + parseJSON _ = mzero + +jwtAuthInfoIdent :: JwtAuthInfo -> Text +jwtAuthInfoIdent (JwtAuthInfo ident) = ident + +authorizationTokenAuth :: Handler (Maybe JwtAuthInfo) +authorizationTokenAuth = do + app <- getYesod + let mJwk = appJSONWebKey $ appSettings app + + case mJwk of + Just jwk -> do + req <- waiRequest + case lookup "Authorization" (Network.Wai.requestHeaders req) of + Nothing -> return Nothing + Just authHead -> case BS.break isSpace authHead of + (strategy, token') + | BS.map Data.Word8.toLower strategy == "bearer" -> do + let token = BS.filter (/= 32) token' + einfo <- liftIO $ JWT.decode [jwk] (Just (JWT.JwsEncoding JWA.RS256)) token + return $ case einfo of + Right (JWT.Jws (_, infos)) -> decode $ fromStrict infos + _ -> Nothing + | otherwise -> return Nothing + Nothing -> return Nothing + +maybeAuthPossiblyByToken :: Handler (Maybe (Entity User)) +maybeAuthPossiblyByToken = do + mInfo <- authorizationTokenAuth + case mInfo of + Just infos -> do + x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos + case x of + Just entUser -> return $ Just entUser + Nothing -> maybeAuth + Nothing -> maybeAuth + + +requireAuthPossiblyByToken :: Handler (Entity User) +requireAuthPossiblyByToken = do + mInfo <- authorizationTokenAuth + case mInfo of + Just infos -> do + x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos + case x of + Just entUser -> return entUser + Nothing -> requireAuth + Nothing -> requireAuth diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 52e3d77..df8c11b 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -21,16 +21,12 @@ import Handler.MakePublic import Handler.Dashboard import Handler.Common import Handler.Evaluate +import Handler.JWT import Database.Persist.Sql (fromSqlKey) import qualified Data.Map as Map -import qualified Data.ByteString as BS -import Data.Word8 (isSpace, toLower) -import Network.Wai (requestHeaders) -import qualified Jose.Jwt as JWT -import qualified Jose.Jwa as JWA import Data.Maybe (fromJust) @@ -79,6 +75,9 @@ instance ToJSON LeaderboardEntry where (leaderboardParams entry) , "times" .= leaderboardNumberOfSubmissions entry , "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry) + , "isPublic" .= (submissionIsPublic $ leaderboardBestSubmission entry) + , "isReevaluable" .= (leaderboardIsReevaluable entry) + , "isVisible" .= (leaderboardIsVisible entry) ] declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger @@ -161,6 +160,7 @@ instance ToSchema LeaderboardEntryView where declareNamedSchema _ = do stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String) intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int) + boolSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Bool) evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView]) return $ NamedSchema (Just "LeaderboardEntry") $ mempty & type_ .~ SwaggerObject @@ -172,6 +172,9 @@ instance ToSchema LeaderboardEntryView where , ("times", intSchema) , ("hash", stringSchema) , ("evaluations", evaluationsSchema) + , ("isPublic", boolSchema) + , ("isReevaluable", boolSchema) + , ("isVisible", boolSchema) ] & required .~ [ "submitter", "when", "version", "description", "times", "hash", "evaluations" ] @@ -890,61 +893,6 @@ submissionForm defaultUrl defBranch defaultGitAnnexRemote = renderBootstrap3 Boo <*> areq textField (bfs MsgSubmissionBranch) defBranch <*> aopt textField (bfs MsgSubmissionGitAnnexRemote) (Just defaultGitAnnexRemote)) -data JwtAuthInfo = JwtAuthInfo Text - deriving (Show, Eq) - -instance FromJSON JwtAuthInfo where - parseJSON (Object v) = - JwtAuthInfo <$> v .: "preferred_username" - parseJSON _ = mzero - -jwtAuthInfoIdent :: JwtAuthInfo -> Text -jwtAuthInfoIdent (JwtAuthInfo ident) = ident - -authorizationTokenAuth :: Handler (Maybe JwtAuthInfo) -authorizationTokenAuth = do - app <- getYesod - let mJwk = appJSONWebKey $ appSettings app - - case mJwk of - Just jwk -> do - req <- waiRequest - case lookup "Authorization" (Network.Wai.requestHeaders req) of - Nothing -> return Nothing - Just authHead -> case BS.break isSpace authHead of - (strategy, token') - | BS.map Data.Word8.toLower strategy == "bearer" -> do - let token = BS.filter (/= 32) token' - einfo <- liftIO $ JWT.decode [jwk] (Just (JWT.JwsEncoding JWA.RS256)) token - return $ case einfo of - Right (JWT.Jws (_, infos)) -> decode $ fromStrict infos - _ -> Nothing - | otherwise -> return Nothing - Nothing -> return Nothing - -maybeAuthPossiblyByToken :: Handler (Maybe (Entity User)) -maybeAuthPossiblyByToken = do - mInfo <- authorizationTokenAuth - case mInfo of - Just infos -> do - x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos - case x of - Just entUser -> return $ Just entUser - Nothing -> maybeAuth - Nothing -> maybeAuth - - -requireAuthPossiblyByToken :: Handler (Entity User) -requireAuthPossiblyByToken = do - mInfo <- authorizationTokenAuth - case mInfo of - Just infos -> do - x <- runDB $ getBy $ UniqueUser $ jwtAuthInfoIdent infos - case x of - Just entUser -> return entUser - Nothing -> requireAuth - Nothing -> requireAuth - getUserInfoR :: Handler Value getUserInfoR = do (Entity _ user) <- requireAuthPossiblyByToken diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 74193f8..aa0f94f 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -7,6 +7,7 @@ import Handler.Shared import Handler.Evaluate import Handler.SubmissionView import Handler.TagUtils +import Handler.JWT import Data.Diff @@ -70,7 +71,9 @@ data LeaderboardEntry = LeaderboardEntry { leaderboardNumberOfSubmissions :: Int, leaderboardTags :: [(Entity Import.Tag, Entity SubmissionTag)], leaderboardParams :: [Parameter], - leaderboardVersion :: (Int, Int, Int) + leaderboardVersion :: (Int, Int, Int), + leaderboardIsVisible :: Bool, + leaderboardIsReevaluable :: Bool } data TableEntry = TableEntry { @@ -329,14 +332,14 @@ getLeaderboardEntriesByCriterion maxPriority challengeId condition preselector s return (entries, (evaluationMaps, mainTests)) -toLeaderboardEntry :: (Foldable t, YesodPersist site, PersistQueryRead (YesodPersistBackend site), PersistUniqueRead (YesodPersistBackend site), BaseBackend (YesodPersistBackend site) ~ SqlBackend) => Key Challenge -> [Entity Test] -> t TableEntry -> HandlerFor site LeaderboardEntry +toLeaderboardEntry :: Foldable t => Key Challenge -> [Entity Test] -> t TableEntry -> Handler LeaderboardEntry toLeaderboardEntry challengeId tests ss = do let bestOne = DL.maximumBy submissionComparator ss let (TableEntry bestSubmission bestVariant user evals _ _ _ _) = bestOne let submissionId = entityKey bestSubmission tagEnts <- runDB $ getTags submissionId - parameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName] + theParameters <- runDB $ selectList [ParameterVariant ==. (entityKey bestVariant)] [Asc ParameterName] submission <- runDB $ get404 submissionId (Just (Entity _ version)) <- runDB $ getBy $ UniqueVersionByCommit $ submissionVersion submission @@ -349,6 +352,12 @@ toLeaderboardEntry challengeId tests ss = do allUserSubmissions <- runDB $ selectList [SubmissionChallenge ==. challengeId, SubmissionSubmitter ==. entityKey user] [Desc SubmissionStamp] + + mUserId <- maybeAuthPossiblyByToken + + isReevaluable <- runDB $ canBeReevaluated $ entityKey $ tableEntrySubmission bestOne + isVisible <- runDB $ checkWhetherVisible submission (entityKey <$> mUserId) + return $ LeaderboardEntry { leaderboardUser = entityVal user, leaderboardUserId = entityKey user, @@ -359,8 +368,10 @@ toLeaderboardEntry challengeId tests ss = do leaderboardEvaluationMap = evals, leaderboardNumberOfSubmissions = length allUserSubmissions, leaderboardTags = tagEnts, - leaderboardParams = map entityVal parameters, - leaderboardVersion = theVersion + leaderboardParams = map entityVal theParameters, + leaderboardVersion = theVersion, + leaderboardIsReevaluable = isReevaluable, + leaderboardIsVisible = isVisible } where mainTestEnt@(Entity _ mainTest) = getMainTest tests mainTestRef = getTestReference mainTestEnt diff --git a/gonito.cabal b/gonito.cabal index 08dfdc2..26612d5 100644 --- a/gonito.cabal +++ b/gonito.cabal @@ -60,6 +60,7 @@ library Gonito.ExtractMetadata Data.Diff Handler.Swagger + Handler.JWT if flag(dev) || flag(library-only) cpp-options: -DDEVELOPMENT