First version of viewing a specific variant

This commit is contained in:
Filip Gralinski 2019-11-30 11:04:52 +01:00
parent c72cc274d5
commit c0a06ae112
9 changed files with 54 additions and 22 deletions

View File

@ -19,6 +19,8 @@ import Handler.Tables (timestampCell)
import GEval.Core (isBetter) import GEval.Core (isBetter)
import GEval.EvaluationScheme import GEval.EvaluationScheme
import Text.Blaze
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.)) import Database.Esqueleto ((^.))
@ -93,6 +95,7 @@ postEditIndicatorR indicatorId = do
doEditIndicator mUser indicatorId formWidget formEnctype doEditIndicator mUser indicatorId formWidget formEnctype
doEditIndicator :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> Key Indicator -> a2 -> a1 -> HandlerT App IO Html
doEditIndicator mUser indicatorId formWidget formEnctype = do doEditIndicator mUser indicatorId formWidget formEnctype = do
(addTargetformWidget, addTargetFormEnctype) <- generateFormPost addTargetForm (addTargetformWidget, addTargetFormEnctype) <- generateFormPost addTargetForm
@ -128,6 +131,7 @@ getDeleteTargetR targetId = do
doEditIndicator mUser (targetIndicator target) formWidget formEnctype doEditIndicator mUser (targetIndicator target) formWidget formEnctype
doDashboard :: (Text.Blaze.ToMarkup a1, ToWidget App a2) => Maybe (Entity User) -> a2 -> a1 -> HandlerFor App Html
doDashboard mUser formWidget formEnctype = do doDashboard mUser formWidget formEnctype = do
indicators <- runDB $ selectList [] [Asc IndicatorId] indicators <- runDB $ selectList [] [Asc IndicatorId]
@ -247,7 +251,7 @@ getOngoingTargets challengeId = do
return indicator return indicator
indicatorEntries <- mapM indicatorToEntry indicators indicatorEntries <- mapM indicatorToEntry indicators
theNow <- liftIO $ getCurrentTime theNow <- liftIO $ getCurrentTime
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId
let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries
return indicatorEntries' return indicatorEntries'

View File

@ -33,7 +33,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do
test <- runDB $ get404 testId test <- runDB $ get404 testId
let testRef = getTestReference (Entity testId test) let testRef = getTestReference (Entity testId test)
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) challengeId
let values = map (findParamValue paramName) entries let values = map (findParamValue paramName) entries
@ -162,7 +162,7 @@ getIndicatorGraphDataR indicatorId = do
test <- runDB $ get404 testId test <- runDB $ get404 testId
let mPrecision = testPrecision test let mPrecision = testPrecision test
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (testChallenge test) (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (const True) (testChallenge test)
theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line

View File

@ -36,7 +36,7 @@ getPresentation4RealR = do
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId))
(evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
let evaluationMaps = take 10 evaluationMaps' let evaluationMaps = take 10 evaluationMaps'
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName sampleLeaderboard <- getSampleLeaderboard sampleChallengeName
@ -57,7 +57,7 @@ getPresentationPSNC2019R = do
(Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent
let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId))
(evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
let evaluationMaps = take 10 evaluationMaps' let evaluationMaps = take 10 evaluationMaps'
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName sampleLeaderboard <- getSampleLeaderboard sampleChallengeName

View File

@ -100,6 +100,10 @@ getViewVariantR variantId = do
let theSubmissionId = variantSubmission variant let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId theSubmission <- runDB $ get404 theSubmissionId
([entry], tests) <- runDB $ getChallengeSubmissionInfos (\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
(submissionChallenge theSubmission)
if submissionIsPublic theSubmission || Just (submissionSubmitter theSubmission) == (entityKey <$> mauthId) if submissionIsPublic theSubmission || Just (submissionSubmitter theSubmission) == (entityKey <$> mauthId)
then then
do do
@ -112,7 +116,6 @@ getViewVariantR variantId = do
E.orderBy [] E.orderBy []
return (out, test) return (out, test)
let outputs = let outputs =
sortBy (\a b -> ((snd b) `compare` (snd a))) sortBy (\a b -> ((snd b) `compare` (snd a)))
$ nub $ nub
@ -124,15 +127,32 @@ getViewVariantR variantId = do
else else
error "Cannot access this submission variant" error "Cannot access this submission variant"
viewOutput :: (SHA1, Text) -> WidgetFor App ()
viewOutput (outputHash, test) = do outputEvaluationsTable :: TableEntry -> Table.Table App (Entity Test)
outputEvaluationsTable tableEntry = mempty
++ Table.text "Metric" (formatTestEvaluationScheme . entityVal)
++ Table.text "Score" (\test -> (formatTruncatedScore (testPrecision $ entityVal test)
$ extractScore (getTestReference test) tableEntry))
paramsTable :: Table.Table App Parameter
paramsTable = mempty
++ Table.text "Parameter" parameterName
++ Table.text "Value" parameterValue
viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
viewOutput entry tests (outputHash, testSet) = do
let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests
let outputSha1AsText = fromSHA1ToText $ outputHash let outputSha1AsText = fromSHA1ToText $ outputHash
$(widgetFile "view-output") $(widgetFile "view-output")
resultTable :: Entity Submission -> WidgetFor App () resultTable :: Entity Submission -> WidgetFor App ()
resultTable (Entity submissionId submission) = do resultTable (Entity submissionId submission) = do
(tableEntries, tests) <- handlerToWidget $ runDB $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId) (tableEntries, tests) <- handlerToWidget
(submissionChallenge submission) $ runDB
$ getChallengeSubmissionInfos (\s -> entityKey s == submissionId)
(const True)
(submissionChallenge submission)
let paramNames = let paramNames =
nub nub
$ map (parameterName . entityVal) $ map (parameterName . entityVal)

View File

@ -174,7 +174,7 @@ idToBeShown _ maybeUser =
defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text defaultRepo :: RepoScheme -> Text -> Challenge -> Repo -> Maybe (Entity User) -> Text
defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge) defaultRepo SelfHosted repoHost challenge _ maybeUser = repoHost ++ (idToBeShown challenge maybeUser) ++ "/" ++ (challengeName challenge)
defaultRepo Branches repoHost _ repo _ = repoUrl repo defaultRepo Branches _ _ repo _ = repoUrl repo
defaultBranch :: IsString a => RepoScheme -> Maybe a defaultBranch :: IsString a => RepoScheme -> Maybe a
defaultBranch SelfHosted = Just "master" defaultBranch SelfHosted = Just "master"
@ -430,7 +430,7 @@ checkIndicators user challengeId submissionId submissionLink relevantIndicators
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler () checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
(entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) challengeId (entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) (const True) challengeId
mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator) mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler () checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
@ -655,7 +655,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name
getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html
getChallengeSubmissions condition name = do getChallengeSubmissions condition name = do
Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name
(evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition challengeId (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
let tests = sortBy testComparator tests' let tests = sortBy testComparator tests'
mauth <- maybeAuth mauth <- maybeAuth
let muserId = (\(Entity uid _) -> uid) <$> mauth let muserId = (\(Entity uid _) -> uid) <$> mauth

View File

@ -77,8 +77,8 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
entityKey $ tableEntrySubmitter tableEntry, entityKey $ tableEntrySubmitter tableEntry,
mauthId)) mauthId))
paramTable :: [Text] -> [Entity Test] -> Table App TableEntry variantTable :: [Text] -> [Entity Test] -> Table App TableEntry
paramTable paramNames tests = mempty variantTable paramNames tests = mempty
++ Table.int "#" tableEntryRank ++ Table.int "#" tableEntryRank
++ mconcat (map paramExtractor paramNames) ++ mconcat (map paramExtractor paramNames)
++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests) ++ mconcat (map (\e@(Entity _ t) -> resultCell t (extractScore $ getTestReference e)) tests)
@ -203,7 +203,7 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge
-> (TableEntry -> [a]) -> (TableEntry -> [a])
-> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test]))
getLeaderboardEntriesByCriterion challengeId condition selector = do getLeaderboardEntriesByCriterion challengeId condition selector = do
(evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition (const True) challengeId
let mainTests = getMainTests tests let mainTests = getMainTests tests
let mainTestEnt = getMainTest tests let mainTestEnt = getMainTest tests
let mainTestRef = getTestReference mainTestEnt let mainTestRef = getTestReference mainTestEnt
@ -290,8 +290,8 @@ compareResult _ (Just _) Nothing = GT
compareResult _ Nothing (Just _) = LT compareResult _ Nothing (Just _) = LT
compareResult _ Nothing Nothing = EQ compareResult _ Nothing Nothing = EQ
getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test]) getChallengeSubmissionInfos :: (MonadIO m, PersistQueryRead backend, BackendCompatible SqlBackend backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) => (Entity Submission -> Bool) -> (Entity Variant -> Bool) -> Key Challenge -> ReaderT backend m ([TableEntry], [Entity Test])
getChallengeSubmissionInfos condition challengeId = do getChallengeSubmissionInfos condition variantCondition challengeId = do
challenge <- get404 challengeId challenge <- get404 challengeId
let commit = challengeVersion challenge let commit = challengeVersion challenge
@ -317,7 +317,8 @@ getChallengeSubmissionInfos condition challengeId = do
$ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1) $ sortBy (\(s1, _) (s2, _) -> compareResult (entityVal mainTest) s2 s1)
$ zip scores allSubmissionsVariants $ zip scores allSubmissionsVariants
evaluationMaps <- mapM getEvaluationMap allSubmissionsVariantsWithRanks evaluationMaps' <- mapM getEvaluationMap allSubmissionsVariantsWithRanks
let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps'
return (evaluationMaps, tests) return (evaluationMaps, tests)
getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double) getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double)

View File

@ -2,4 +2,4 @@
$if null tableEntries $if null tableEntries
<p>No results available. The submission is probably broken. <p>No results available. The submission is probably broken.
$else $else
^{Table.buildBootstrap (paramTable paramNames tests) tableEntries} ^{Table.buildBootstrap (variantTable paramNames tests) tableEntries}

View File

@ -4,4 +4,5 @@
<span class="glyphicon glyphicon-asterisk" aria-hidden="hidden"> <span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
<div class="media-body"> <div class="media-body">
<div class="media-heading"> <div class="media-heading">
<div .subm-commit>#{test} / #{outputSha1AsText} <div .subm-commit>#{testSet} / #{outputSha1AsText}
^{Table.buildBootstrap (outputEvaluationsTable entry) tests'}

View File

@ -4,5 +4,11 @@
<span class="glyphicon glyphicon-asterisk" aria-hidden="hidden"> <span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
<div class="media-body"> <div class="media-body">
^{submissionHeader fullSubmissionInfo} ^{submissionHeader fullSubmissionInfo}
$case tableEntryParams entry
$of []
$of _
^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)}
$forall output <- outputs $forall output <- outputs
^{viewOutput output} ^{viewOutput entry tests output}