Show result tables

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)
 

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
 

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

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

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

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

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] []
+  outs <- selectList [OutVariant ==. variantId] []
-  user <- runDB $ get404 $ submissionSubmitter submission
+  user <- get404 $ submissionSubmitter submission
-  maybeEvaluations <- runDB $ mapM (\(Entity _ o) -> getBy $ UniqueEvaluationTestChecksum (outTest o) (outChecksum o)) outs
+  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

templates/query-result.hamlet

@@ -17,4 +17,7 @@
     <dd><a href="#{browsableUrl}">#{browsableUrl}</a>
     <dt>clone by
     <dd><code>git clone --single-branch #{publicSubmissionRepo} -b #{publicSubmissionBranch}</code>
+
+^{resultTable (Entity (fsiSubmissionId submission) (fsiSubmission submission))}
+
 <hr>

templates/result-table.hamlet

@@ -0,0 +1,5 @@
+<div id="t#{resultId}">
+  $if null tableEntries
+     <p>No results available. The submission is probably broken.
+  $else
+     ^{Table.buildBootstrap (paramTable paramNames tests) tableEntries}

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})
+       });
+  } );