Fix issue with unwanted messages

This commit is contained in:
Filip Graliński 2019-09-10 08:59:30 +02:00
parent 284d7e1acf
commit 0f4150a4a5
4 changed files with 26 additions and 9 deletions

View File

@ -4,7 +4,7 @@ import Import
import Handler.Tables import Handler.Tables
import Handler.Dashboard (indicatorToEntry, prettyIndicatorEntry, formatTarget, IndicatorEntry(..), TargetStatus(..), filterEntries, getTargetStatus) import Handler.Dashboard (indicatorToEntry, prettyIndicatorEntry, formatTarget, IndicatorEntry(..), TargetStatus(..), filterEntries, getTargetStatus)
import Handler.Shared (formatParameter, formatScore, getMainTest, compareFun) import Handler.Shared (formatParameter, formatScore, fetchMainTest, compareFun)
import Data.Maybe import Data.Maybe
import Data.List ((!!)) import Data.List ((!!))
import Database.Persist.Sql import Database.Persist.Sql
@ -88,8 +88,8 @@ submissionsToJSON condition challengeName = do
(\entry -> [entityKey $ tableEntrySubmission entry]) (\entry -> [entityKey $ tableEntrySubmission entry])
tests <- runDB $ selectList [TestChallenge ==. challengeId] [] entMainTest <- runDB $ fetchMainTest challengeId
let mainTestRef = getTestReference $ getMainTest tests let mainTestRef = getTestReference entMainTest
let naturalRange = getNaturalRange mainTestRef entries let naturalRange = getNaturalRange mainTestRef entries
let submissionIds = map leaderboardBestSubmissionId entries let submissionIds = map leaderboardBestSubmissionId entries

View File

@ -45,8 +45,7 @@ getApiTxtScoreR sha1Prefix = do
doGetScore :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Entity Submission -> HandlerFor site Text doGetScore :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Entity Submission -> HandlerFor site Text
doGetScore submission = do doGetScore submission = do
let challengeId = submissionChallenge $ entityVal submission let challengeId = submissionChallenge $ entityVal submission
tests <- runDB $ selectList [TestChallenge ==. challengeId] [] mainTest <- runDB $ fetchMainTest challengeId
let mainTest = getMainTest tests
let mainTestId = entityKey mainTest let mainTestId = entityKey mainTest
let submissionId = entityKey submission let submissionId = entityKey submission

View File

@ -362,6 +362,16 @@ thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ o2 = o2 thenCmp EQ o2 = o2
thenCmp o1 _ = o1 thenCmp o1 _ = o1
fetchMainTest :: (MonadIO m, PersistQueryRead backend, BaseBackend backend ~ SqlBackend) => Key Challenge -> ReaderT backend m (Entity Test)
fetchMainTest challengeId = do
challenge <- get404 challengeId
activeTests <- selectList [TestChallenge ==. challengeId,
TestActive ==. True,
TestCommit ==. challengeVersion challenge] []
return $ getMainTest activeTests
-- get the test with the highest priority -- get the test with the highest priority
getMainTest :: [Entity Test] -> Entity Test getMainTest :: [Entity Test] -> Entity Test
getMainTest tests = DL.maximumBy testComparator tests getMainTest tests = DL.maximumBy testComparator tests

View File

@ -278,21 +278,29 @@ doCreateSubmission' _ userId challengeId mDescription mTags repoSpec chan = do
relevantIndicators <- getOngoingTargets challengeId relevantIndicators <- getOngoingTargets challengeId
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] (Entity mainTestId mainTest) <- runDB $ fetchMainTest challengeId
let (Entity mainTestId mainTest) = getMainTest activeTests
(Entity _ currentVersion) <- runDB $ getBy404 $ UniqueVersionByCommit $ challengeVersion challenge
let submittedMajorVersion = versionMajor currentVersion
let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of let orderDirection = case getMetricOrdering (evaluationSchemeMetric $ testMetric mainTest) of
TheHigherTheBetter -> E.desc TheHigherTheBetter -> E.desc
TheLowerTheBetter -> E.asc TheLowerTheBetter -> E.asc
bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out) -> do bestResultSoFar <- runDB $ E.select $ E.from $ \(evaluation, submission, variant, out, test, version) -> do
E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId E.where_ (submission ^. SubmissionChallenge E.==. E.val challengeId
E.&&. submission ^. SubmissionIsHidden E.==. E.val False E.&&. submission ^. SubmissionIsHidden E.==. E.val False
E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId E.&&. variant ^. VariantSubmission E.==. submission ^. SubmissionId
E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum E.&&. evaluation ^. EvaluationChecksum E.==. out ^. OutChecksum
E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore))) E.&&. (E.not_ (E.isNothing (evaluation ^. EvaluationScore)))
E.&&. out ^. OutVariant E.==. variant ^. VariantId E.&&. out ^. OutVariant E.==. variant ^. VariantId
E.&&. evaluation ^. EvaluationTest E.==. E.val mainTestId) E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId
E.&&. test ^. TestChallenge E.==. E.val challengeId
E.&&. test ^. TestName E.==. E.val (testName mainTest)
E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest)
E.&&. test ^. TestActive
E.&&. version ^. VersionCommit E.==. test ^. TestCommit
E.&&. version ^. VersionMajor E.>=. E.val submittedMajorVersion)
E.orderBy [orderDirection (evaluation ^. EvaluationScore)] E.orderBy [orderDirection (evaluation ^. EvaluationScore)]
E.limit 1 E.limit 1
return evaluation return evaluation