Showing worst lines

Handler/CreateChallenge.hs

@@ -314,7 +314,8 @@ addChallenge name publicRepoId privateRepoId deadline chan = do
     challengeImage=mImage,
     challengeStarred=False,
     challengeArchived=Just False,
-    challengeVersion=commit}
+    challengeVersion=commit,
+    challengeSensitive=Just False }
 
   _ <- runDB $ insert $ Version {
     versionChallenge=Just challengeId,

Handler/Query.hs

@@ -23,6 +23,12 @@ import Data.List.Extra (groupOn)
 
 import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
 
+import Data.Conduit.SmartSource (lookForCompressedFiles)
+import GEval.Core (GEvalSpecification(..), ResultOrdering(..))
+import GEval.LineByLine (runLineByLineGeneralized, LineRecord(..))
+import qualified Data.Conduit.List as CL
+import System.FilePath (takeFileName)
+
 rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
 rawCommitQuery sha1Prefix =
   rawSql "SELECT ?? FROM submission WHERE is_public AND cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
@@ -222,11 +228,69 @@ paramsTable = mempty
   ++ 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
+viewOutput entry tests (outputHash, testSet) = do
+  let tests'@(mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests
   let outputSha1AsText = fromSHA1ToText $ outputHash
+
+  mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir (entityKey $ tableEntrySubmission entry)
+  let variant = variantName $ entityVal $ tableEntryVariant entry
+
+  let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry
+  let isPublic = submissionIsPublic $ entityVal $ tableEntrySubmission entry
+  challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission entry
+  let isNonSensitive = challengeSensitive challenge == Just False
+
+  let shouldBeShown = not ("test-" `isInfixOf` testSet) && isPublic && isNonSensitive
+
+  let mainMetric = testMetric $ entityVal mainTest
+
+  mResult <-
+    if shouldBeShown
+      then
+        case mRepoDir of
+               Just repoDir -> do
+                 outFile' <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv")
+                 let outFile = takeFileName outFile'
+
+                 let spec = GEvalSpecification {
+                       gesOutDirectory = repoDir,
+                       gesExpectedDirectory = Nothing,
+                       gesTestName = (T.unpack testSet),
+                       gesSelector = Nothing,
+                       gesOutFile = outFile,
+                       gesExpectedFile = "expected.tsv",
+                       gesInputFile = "in.tsv",
+                       gesMetrics = [mainMetric],
+                       gesPrecision = Nothing,
+                       gesTokenizer = Nothing,
+                       gesGonitoHost = Nothing,
+                       gesToken = Nothing,
+                       gesGonitoGitAnnexRemote = Nothing,
+                       gesReferences = Nothing }
+
+                 result <- liftIO $ runLineByLineGeneralized FirstTheWorst spec (\_ -> CL.take 20)
+
+                 return $ Just $ zip [1..] result
+               Nothing -> return Nothing
+      else
+        return Nothing
   $(widgetFile "view-output")
 
+lineByLineTable :: Entity Test -> UTCTime -> Table.Table App (Int, LineRecord)
+lineByLineTable (Entity testId test) theStamp = mempty
+  ++ Table.int "#" fst
+  ++ theLimitedTextCell "input" (((\(LineRecord inp _ _ _ _) -> inp) . snd))
+  ++ theLimitedTextCell "expected output" ((\(LineRecord _ expected _ _ _) -> expected) . snd)
+  ++ theLimitedTextCell "actual output" ((\(LineRecord _ _ out _ _) -> out) . snd)
+  ++ resultCell test (fakeEvaluation . (\(LineRecord _ _ _ _ score) -> score) . snd)
+  where fakeEvaluation score = Just $ Evaluation {
+          evaluationTest = testId,
+          evaluationChecksum = testChecksum test,
+          evaluationScore = Just score,
+          evaluationErrorMessage = Nothing,
+          evaluationStamp = theStamp,
+          evaluationVersion = Nothing }
+
 resultTable :: Entity Submission -> WidgetFor App ()
 resultTable (Entity submissionId submission) = do
   (tableEntries, tests) <- handlerToWidget

Handler/Shared.hs

@@ -181,6 +181,10 @@ getSubmissionRepoDir submissionId chan = do
     ExitSuccess -> return (Just repoDir)
     ExitFailure _ -> return Nothing
 
+justGetSubmissionRepoDir :: SubmissionId -> Handler (Maybe FilePath)
+justGetSubmissionRepoDir submissionId = do
+  devNullChan <- liftIO newTChanIO
+  getSubmissionRepoDir submissionId devNullChan
 
 getHeadCommit :: FilePath -> Channel -> Handler (Maybe SHA1)
 getHeadCommit repoDir chan = do

Handler/Tables.hs

@@ -16,7 +16,7 @@ import           Database.Esqueleto      ((^.))
 
 import qualified Data.Map as Map
 
-import Data.Text (pack, unpack, unwords)
+import Data.Text (pack, unpack, unwords, take)
 
 import PersistSHA1
 
@@ -162,6 +162,22 @@ statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusC
 resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
 resultCell test fun = hoverTextCell (formatTestForHtml test) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
 
+textLimited :: Int -> Text -> Text
+textLimited limit t
+  | l < limit = t
+  | otherwise = (Data.Text.take limit t) <> "…"
+  where l = length t
+
+limitedTextCell :: Text -> Int -> Int -> (a -> Text) -> Table site a
+limitedTextCell h softLimit hardLimit textFun = Table.widget h (
+  \v -> [whamlet|<span title="#{textLimited hardLimit $ textFun v}"><tt>#{textLimited softLimit $ textFun v}</tt>|])
+
+theLimitedTextCell :: Text -> (a -> Text) -> Table site a
+theLimitedTextCell h textFun = limitedTextCell h softLimit hardLimit textFun
+  where softLimit = 80
+        hardLimit = 5 * softLimit
+
+
 statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, UserId, Maybe UserId) -> WidgetFor App ()
 statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, userId, mauthId) = do
   isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId

config/models

@@ -41,6 +41,7 @@ Challenge
     starred Bool
     archived Bool Maybe
     version SHA1
+    sensitive Bool Maybe
 -- challenge version
 Version
     -- introduced later, hence Maybe

templates/view-output.hamlet

@@ -6,3 +6,7 @@
    <div class="media-heading">
      <div .subm-commit>#{testSet} / #{outputSha1AsText}
      ^{Table.buildBootstrap (outputEvaluationsTable entry) tests'}
+     $maybe result <- mResult
+        <h4>worst items
+        ^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result}
+     $nothing