From 0e8846b06c114259c027d3bb72f0611ba9e5d518 Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Mon, 12 Nov 2018 14:12:51 +0100 Subject: [PATCH] Show result tables --- Handler/EditSubmission.hs | 1 + Handler/Graph.hs | 4 ++-- Handler/Presentation.hs | 2 +- Handler/Query.hs | 37 ++++++++++++++++++++++++++++++++++ Handler/ShowChallenge.hs | 2 +- Handler/SubmissionView.hs | 13 +++--------- Handler/Tables.hs | 38 +++++++++++++++++++++++------------ templates/query-result.hamlet | 3 +++ templates/result-table.hamlet | 5 +++++ templates/result-table.julius | 8 ++++++++ 10 files changed, 86 insertions(+), 27 deletions(-) create mode 100644 templates/result-table.hamlet create mode 100644 templates/result-table.julius diff --git a/Handler/EditSubmission.hs b/Handler/EditSubmission.hs index 955726e..beda8aa 100644 --- a/Handler/EditSubmission.hs +++ b/Handler/EditSubmission.hs @@ -9,6 +9,7 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs) import Handler.TagUtils import Handler.MakePublic +import Handler.Query import Gonito.ExtractMetadata (parseTags) diff --git a/Handler/Graph.hs b/Handler/Graph.hs index c384e51..7b854b9 100644 --- a/Handler/Graph.hs +++ b/Handler/Graph.hs @@ -30,7 +30,7 @@ getChallengeParamGraphDataR challengeName testId paramName = do (Entity challengeId _) <- runDB $ getBy404 $ UniqueName challengeName test <- runDB $ get404 testId - (entries, _) <- getChallengeSubmissionInfos (const True) challengeId + (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId let values = map (findParamValue paramName) entries @@ -154,7 +154,7 @@ getIndicatorGraphDataR indicatorId = do test <- runDB $ get404 testId let mPrecision = testPrecision test - (entries, _) <- getChallengeSubmissionInfos (const True) (testChallenge test) + (entries, _) <- runDB $ getChallengeSubmissionInfos (const True) (testChallenge test) theNow <- liftIO $ getCurrentTime -- needed to draw the "now" vertical line diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index 12ef208..bdb8c80 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -33,7 +33,7 @@ getPresentation4RealR = do (Just (Entity sampleUserId _)) <- runDB $ getBy $ UniqueUser sampleUserIdent let condition = (\(Entity _ submission) -> (submissionSubmitter submission == sampleUserId)) - (evaluationMaps', tests) <- getChallengeSubmissionInfos condition challengeId + (evaluationMaps', tests) <- runDB $ getChallengeSubmissionInfos condition challengeId let evaluationMaps = take 10 evaluationMaps' sampleLeaderboard <- getSampleLeaderboard sampleChallengeName diff --git a/Handler/Query.hs b/Handler/Query.hs index e3a2ff4..fb56e2b 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -5,12 +5,22 @@ import Import import Handler.SubmissionView import Handler.Shared import Handler.TagUtils +import PersistSHA1 + +import Handler.Tables + +import qualified Yesod.Table as Table +import Yesod.Table (Table) import Database.Persist.Sql import qualified Database.Esqueleto as E import Database.Esqueleto ((^.)) +import qualified Data.Text as T + +import Data.List (nub) + import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a] @@ -83,5 +93,32 @@ processQuery query = do setTitle "query results" $(widgetFile "query-results") +resultTable :: Entity Submission -> WidgetFor App () +resultTable (Entity submissionId submission) = do + (tableEntries, tests) <- handlerToWidget $ runDB $ getChallengeSubmissionInfos (\s -> entityKey s == submissionId) + (submissionChallenge submission) + let paramNames = + nub + $ map (parameterName . entityVal) + $ concat + $ map tableEntryParams tableEntries + + let resultId = show $ fromSqlKey submissionId + let jsSelector = String $ T.pack ("#t" ++ resultId ++ " > table") + + let delta = Number $ fromIntegral ((length paramNames) + 1) + let higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests + + $(widgetFile "result-table") + +queryResult submission = do + $(widgetFile "query-result") + where commitSha1AsText = fromSHA1ToText $ submissionCommit $ fsiSubmission submission + submitter = formatSubmitter $ fsiUser submission + publicSubmissionBranch = getPublicSubmissionBranch $ fsiSubmissionId submission + publicSubmissionRepo = getReadOnlySubmissionUrl (fsiScheme submission) (fsiChallengeRepo submission) $ challengeName $ fsiChallenge submission + browsableUrl = browsableGitRepoBranch (fsiScheme submission) (fsiChallengeRepo submission) (challengeName $ fsiChallenge submission) publicSubmissionBranch + stamp = T.pack $ show $ submissionStamp $ fsiSubmission submission + queryForm :: Form Text queryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgGitCommitSha1) Nothing diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 85c0c98..f5e70c6 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -494,7 +494,7 @@ getChallengeAllSubmissionsR name = getChallengeSubmissions (\_ -> True) name getChallengeSubmissions :: ((Entity Submission) -> Bool) -> Text -> Handler Html getChallengeSubmissions condition name = do Entity challengeId challenge <- runDB $ getBy404 $ UniqueName name - (evaluationMaps, tests') <- getChallengeSubmissionInfos condition challengeId + (evaluationMaps, tests') <- runDB $ getChallengeSubmissionInfos condition challengeId let tests = sortBy testComparator tests' mauth <- maybeAuth let muserId = (\(Entity uid _) -> uid) <$> mauth diff --git a/Handler/SubmissionView.hs b/Handler/SubmissionView.hs index b5f8dce..d65cd57 100644 --- a/Handler/SubmissionView.hs +++ b/Handler/SubmissionView.hs @@ -7,6 +7,9 @@ import Handler.TagUtils import Data.Text as T(pack) +import qualified Yesod.Table as Table +import Yesod.Table (Table) + data FullSubmissionInfo = FullSubmissionInfo { fsiSubmissionId :: SubmissionId, fsiSubmission :: Submission, @@ -39,16 +42,6 @@ getFullInfo (Entity submissionId submission) = do fsiScheme = scheme, fsiTags = tags } - -queryResult submission = do - $(widgetFile "query-result") - where commitSha1AsText = fromSHA1ToText $ submissionCommit $ fsiSubmission submission - submitter = formatSubmitter $ fsiUser submission - publicSubmissionBranch = getPublicSubmissionBranch $ fsiSubmissionId submission - publicSubmissionRepo = getReadOnlySubmissionUrl (fsiScheme submission) (fsiChallengeRepo submission) $ challengeName $ fsiChallenge submission - browsableUrl = browsableGitRepoBranch (fsiScheme submission) (fsiChallengeRepo submission) (challengeName $ fsiChallenge submission) publicSubmissionBranch - stamp = T.pack $ show $ submissionStamp $ fsiSubmission submission - getTags submissionId = do sts <- selectList [SubmissionTagSubmission ==. submissionId] [] let tagIds = Import.map (submissionTagTag . entityVal) sts diff --git a/Handler/Tables.hs b/Handler/Tables.hs index d444b64..1386cfa 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -64,6 +64,21 @@ submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty entityKey $ tableEntrySubmitter tableEntry, mauthId)) +paramTable :: [Text] -> [Entity Test] -> Table App TableEntry +paramTable paramNames tests = mempty + ++ Table.int "#" tableEntryRank + ++ mconcat (map paramExtractor paramNames) + ++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests) + +paramExtractor :: Text -> Table App TableEntry +paramExtractor paramName = Table.text paramName (\entry -> + fromMaybe "" + $ listToMaybe + $ map parameterValue + $ filter (\p -> parameterName p == paramName) + $ map entityVal + $ tableEntryParams entry) + descriptionCell :: Maybe UserId -> Table App TableEntry descriptionCell mauthId = Table.widget "description" ( \(TableEntry (Entity _ s) (Entity _ v) (Entity u _) _ tagEnts paramEnts _) -> fragmentWithSubmissionTags @@ -166,7 +181,7 @@ getLeaderboardEntriesByCriterion :: (Ord a) => Key Challenge -> (TableEntry -> [a]) -> Handler ([LeaderboardEntry], ([TableEntry], [Entity Test])) getLeaderboardEntriesByCriterion challengeId condition selector = do - (evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId + (evaluationMaps, tests) <- runDB $ getChallengeSubmissionInfos condition challengeId let mainTests = getMainTests tests let mainTestEnt = getMainTest tests let (Entity mainTestId mainTest) = mainTestEnt @@ -233,20 +248,17 @@ compareResult _ (Just _) Nothing = GT compareResult _ Nothing (Just _) = LT compareResult _ Nothing Nothing = EQ -getChallengeSubmissionInfos :: ((Entity Submission) -> Bool) - -> Key Challenge - -> Handler ([TableEntry], [Entity Test]) getChallengeSubmissionInfos condition challengeId = do - tests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] + tests <- selectList [TestChallenge ==. challengeId, TestActive ==. True] [] let mainTest = getMainTest tests - allSubmissionsVariants <- runDB $ E.select $ E.from $ \(submission, variant) -> do + allSubmissionsVariants <- E.select $ E.from $ \(submission, variant) -> do E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId E.&&. submission ^. SubmissionIsHidden E.!=. E.val (Just True) E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId) return (submission, variant) - scores <- runDB $ mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants + scores <- mapM (getScore (entityKey mainTest)) $ map (entityKey . snd) allSubmissionsVariants let allSubmissionsVariantsWithRanks = sortBy (\(r1, (s1, _)) (r2, (s2, _)) -> (submissionStamp (entityVal s2) `compare` submissionStamp (entityVal s1)) @@ -272,15 +284,15 @@ getScore testId variantId = do (e:_) -> evaluationScore $ entityVal e [] -> Nothing -getEvaluationMap :: (Int, (Entity Submission, Entity Variant)) -> Handler TableEntry + getEvaluationMap (rank, (s@(Entity submissionId submission), v@(Entity variantId _))) = do - outs <- runDB $ selectList [OutVariant ==. variantId] [] - user <- runDB $ get404 $ submissionSubmitter submission - maybeEvaluations <- runDB $ mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs + outs <- selectList [OutVariant ==. variantId] [] + user <- get404 $ submissionSubmitter submission + maybeEvaluations <- mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs let evaluations = catMaybes maybeEvaluations let m = Map.fromList $ map (\(Entity _ e) -> (evaluationTest e, e)) evaluations - tagEnts <- runDB $ getTags submissionId + tagEnts <- getTags submissionId - parameters <- runDB $ selectList [ParameterVariant ==. variantId] [Asc ParameterName] + parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName] return $ TableEntry s v (Entity (submissionSubmitter submission) user) m tagEnts parameters rank diff --git a/templates/query-result.hamlet b/templates/query-result.hamlet index a3de93d..76bde7e 100644 --- a/templates/query-result.hamlet +++ b/templates/query-result.hamlet @@ -17,4 +17,7 @@
#{browsableUrl}
clone by
git clone --single-branch #{publicSubmissionRepo} -b #{publicSubmissionBranch} + +^{resultTable (Entity (fsiSubmissionId submission) (fsiSubmission submission))} +
diff --git a/templates/result-table.hamlet b/templates/result-table.hamlet new file mode 100644 index 0000000..3a7da1a --- /dev/null +++ b/templates/result-table.hamlet @@ -0,0 +1,5 @@ +
+ $if null tableEntries +

No results available. The submission is probably broken. + $else + ^{Table.buildBootstrap (paramTable paramNames tests) tableEntries} diff --git a/templates/result-table.julius b/templates/result-table.julius new file mode 100644 index 0000000..fe9b252 --- /dev/null +++ b/templates/result-table.julius @@ -0,0 +1,8 @@ + + $(document).ready(function() { + $(#{jsSelector}).DataTable({ + 'pageLength': 50, + 'order': [[0, 'asc'], [#{delta} + ($.fn.dataTable.getColumnDefs(#{delta}, #{higherTheBetterArray})).length-1, 'desc']], + 'columnDefs': $.fn.dataTable.getColumnDefs(#{delta}, #{higherTheBetterArray}) + }); + } );