Add extra fields to leaderboard entries

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

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

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

gonito.cabal

@@ -60,6 +60,7 @@ library
                      Gonito.ExtractMetadata
                      Data.Diff
                      Handler.Swagger
+                     Handler.JWT
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT