Fix issue with unwanted messages
This commit is contained in:
parent
284d7e1acf
commit
0f4150a4a5
@ -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
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user