diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index a4643f4..4aeda23 100644 --- a/Handler/CreateChallenge.hs +++ b/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, diff --git a/Handler/Query.hs b/Handler/Query.hs index ab93854..4e0ca18 100644 --- a/Handler/Query.hs +++ b/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 diff --git a/Handler/Shared.hs b/Handler/Shared.hs index b2ecaca..f8a4b83 100644 --- a/Handler/Shared.hs +++ b/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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 2305978..5ba3b39 100644 --- a/Handler/Tables.hs +++ b/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|#{textLimited softLimit $ textFun v}|]) + +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 diff --git a/config/models b/config/models index 6e1c623..2b0f2e8 100644 --- a/config/models +++ b/config/models @@ -41,6 +41,7 @@ Challenge starred Bool archived Bool Maybe version SHA1 + sensitive Bool Maybe -- challenge version Version -- introduced later, hence Maybe diff --git a/templates/view-output.hamlet b/templates/view-output.hamlet index 85244ea..183789c 100644 --- a/templates/view-output.hamlet +++ b/templates/view-output.hamlet @@ -6,3 +6,7 @@
#{testSet} / #{outputSha1AsText} ^{Table.buildBootstrap (outputEvaluationsTable entry) tests'} + $maybe result <- mResult +

worst items + ^{Table.buildBootstrap (lineByLineTable mainTest theStamp) result} + $nothing