forked from filipg/gonito
Modify leaderboard end-point to be more similar to other end-points
This commit is contained in:
parent
bb28d2c590
commit
3a5db1cc53
@ -8,6 +8,8 @@ import Text.Markdown
|
|||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
import qualified Data.HashMap.Strict as HMS
|
||||||
|
|
||||||
import qualified Yesod.Table as Table
|
import qualified Yesod.Table as Table
|
||||||
|
|
||||||
import Handler.Extract
|
import Handler.Extract
|
||||||
@ -79,29 +81,12 @@ instance ToJSON LeaderboardEntry where
|
|||||||
, "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry)
|
, "hash" .= (fromSHA1ToText $ submissionCommit $ leaderboardBestSubmission entry)
|
||||||
]
|
]
|
||||||
|
|
||||||
instance ToSchema LeaderboardEntry where
|
|
||||||
declareNamedSchema _ = do
|
|
||||||
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
|
||||||
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
|
|
||||||
return $ NamedSchema (Just "LeaderboardEntry") $ mempty
|
|
||||||
& type_ .~ SwaggerObject
|
|
||||||
& properties .~
|
|
||||||
fromList [ ("submitter", stringSchema)
|
|
||||||
, ("when", stringSchema)
|
|
||||||
, ("version", stringSchema)
|
|
||||||
, ("description", stringSchema)
|
|
||||||
, ("times", intSchema)
|
|
||||||
, ("hash", stringSchema)
|
|
||||||
]
|
|
||||||
& required .~ [ "submitter", "when", "version", "description", "times", "hash" ]
|
|
||||||
|
|
||||||
|
|
||||||
declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger
|
declareLeaderboardSwagger :: Declare (Definitions Schema) Swagger
|
||||||
declareLeaderboardSwagger = do
|
declareLeaderboardSwagger = do
|
||||||
-- param schemas
|
-- param schemas
|
||||||
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
|
let challengeNameSchema = toParamSchema (Proxy :: Proxy String)
|
||||||
|
|
||||||
leaderboardResponse <- declareResponse (Proxy :: Proxy [LeaderboardEntry])
|
leaderboardResponse <- declareResponse (Proxy :: Proxy LeaderboardView)
|
||||||
|
|
||||||
return $ mempty
|
return $ mempty
|
||||||
& paths .~
|
& paths .~
|
||||||
@ -124,7 +109,28 @@ leaderboardApi = spec & definitions .~ defs
|
|||||||
where
|
where
|
||||||
(defs, spec) = runDeclare declareLeaderboardSwagger mempty
|
(defs, spec) = runDeclare declareLeaderboardSwagger mempty
|
||||||
|
|
||||||
|
data LeaderboardView = LeaderboardView {
|
||||||
|
leaderboardViewTests :: [Entity Test],
|
||||||
|
leaderboardViewEntries :: [LeaderboardEntryView]
|
||||||
|
}
|
||||||
|
|
||||||
|
instance ToJSON LeaderboardView where
|
||||||
|
toJSON v = object
|
||||||
|
[ "tests" .= (map getTestReference $ leaderboardViewTests v)
|
||||||
|
, "entries" .= leaderboardViewEntries v
|
||||||
|
]
|
||||||
|
|
||||||
|
instance ToSchema LeaderboardView where
|
||||||
|
declareNamedSchema _ = do
|
||||||
|
testsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [TestReference])
|
||||||
|
entriesSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [LeaderboardEntryView])
|
||||||
|
return $ NamedSchema (Just "Leaderboard") $ mempty
|
||||||
|
& type_ .~ SwaggerObject
|
||||||
|
& properties .~
|
||||||
|
fromList [ ("tests", testsSchema)
|
||||||
|
, ("entries", entriesSchema)
|
||||||
|
]
|
||||||
|
& required .~ [ "tests", "entries" ]
|
||||||
|
|
||||||
getLeaderboardJsonR :: Text -> Handler Value
|
getLeaderboardJsonR :: Text -> Handler Value
|
||||||
getLeaderboardJsonR challengeName = do
|
getLeaderboardJsonR challengeName = do
|
||||||
@ -133,15 +139,48 @@ getLeaderboardJsonR challengeName = do
|
|||||||
|
|
||||||
Entity challengeId _ <- runDB $ getBy404 $ UniqueName challengeName
|
Entity challengeId _ <- runDB $ getBy404 $ UniqueName challengeName
|
||||||
(leaderboard, (_, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
|
(leaderboard, (_, tests)) <- getLeaderboardEntries 1 leaderboardStyle challengeId
|
||||||
return $ array $ map (leaderboardEntryJson tests) leaderboard
|
return $ toJSON $ LeaderboardView {
|
||||||
|
leaderboardViewTests = tests,
|
||||||
|
leaderboardViewEntries = map (toLeaderboardEntryView tests) leaderboard }
|
||||||
|
|
||||||
leaderboardEntryJson :: (ToJSON (f Value), Functor f) => f (Entity Test) -> LeaderboardEntry -> Value
|
data LeaderboardEntryView = LeaderboardEntryView {
|
||||||
leaderboardEntryJson tests entry = object [
|
leaderboardEntryViewEntry :: LeaderboardEntry,
|
||||||
"metadata" .= entry,
|
leaderboardEntryViewEvaluations :: [EvaluationView]
|
||||||
"metrics" .=
|
}
|
||||||
map (\e@(Entity _ t) -> object [
|
|
||||||
"metric" .= testName t,
|
addJsonKey :: Text -> Value -> Value -> Value
|
||||||
"score" .= (formatTruncatedScore (getTestFormattingOpts t) $ extractScoreFromLeaderboardEntry (getTestReference e) entry)]) tests]
|
addJsonKey key val (Object xs) = Object $ HMS.insert key val xs
|
||||||
|
addJsonKey _ _ xs = xs
|
||||||
|
|
||||||
|
instance ToJSON LeaderboardEntryView where
|
||||||
|
toJSON v = addJsonKey "evaluations"
|
||||||
|
(toJSON $ leaderboardEntryViewEvaluations v)
|
||||||
|
(toJSON $ leaderboardEntryViewEntry v)
|
||||||
|
|
||||||
|
instance ToSchema LeaderboardEntryView where
|
||||||
|
declareNamedSchema _ = do
|
||||||
|
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
|
||||||
|
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy Int)
|
||||||
|
evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
|
||||||
|
return $ NamedSchema (Just "LeaderboardEntry") $ mempty
|
||||||
|
& type_ .~ SwaggerObject
|
||||||
|
& properties .~
|
||||||
|
fromList [ ("submitter", stringSchema)
|
||||||
|
, ("when", stringSchema)
|
||||||
|
, ("version", stringSchema)
|
||||||
|
, ("description", stringSchema)
|
||||||
|
, ("times", intSchema)
|
||||||
|
, ("hash", stringSchema)
|
||||||
|
, ("evaluations", evaluationsSchema)
|
||||||
|
]
|
||||||
|
& required .~ [ "submitter", "when", "version", "description", "times", "hash", "evaluations" ]
|
||||||
|
|
||||||
|
toLeaderboardEntryView :: [(Entity Test)] -> LeaderboardEntry -> LeaderboardEntryView
|
||||||
|
toLeaderboardEntryView tests entry = LeaderboardEntryView {
|
||||||
|
leaderboardEntryViewEntry = entry,
|
||||||
|
leaderboardEntryViewEvaluations = catMaybes $
|
||||||
|
map (convertEvaluationToView (leaderboardEvaluationMap entry)) tests
|
||||||
|
}
|
||||||
|
|
||||||
getShowChallengeR :: Text -> Handler Html
|
getShowChallengeR :: Text -> Handler Html
|
||||||
getShowChallengeR challengeName = do
|
getShowChallengeR challengeName = do
|
||||||
|
Loading…
Reference in New Issue
Block a user