Check indicator targets

This commit is contained in:
Filip Graliński 2019-02-22 14:41:43 +01:00
parent 84212562bc
commit e424cc361f
2 changed files with 71 additions and 1 deletions

View File

@ -18,6 +18,9 @@ import qualified Data.Map as M
import Handler.Tables (timestampCell)
import GEval.Core (isBetter)
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
data IndicatorEntry = IndicatorEntry {
indicatorEntryIndicator :: Entity Indicator,
indicatorEntryTest :: Entity Test,
@ -30,6 +33,11 @@ data IndicatorEntry = IndicatorEntry {
data TargetStatus = TargetPassed | TargetFailed | TargetOngoing
deriving (Eq, Show)
isOngoingStatus :: TargetStatus -> Bool
isOngoingStatus TargetPassed = False
isOngoingStatus TargetFailed = False
isOngoingStatus TargetOngoing = True
getDashboardR :: Handler Html
getDashboardR = do
(formWidget, formEnctype) <- generateFormPost targetForm
@ -230,6 +238,23 @@ getTargetStatus theNow entries indicator target =
$ filterEntries (indicatorEntryTargetCondition indicator) entries
testId = entityKey $ indicatorEntryTest indicator
getOngoingTargets :: ChallengeId -> Handler [IndicatorEntry]
getOngoingTargets challengeId = do
indicators <- runDB $ E.select $ E.from $ \(test, indicator) -> do
E.where_ (test ^. TestChallenge E.==. E.val challengeId
E.&&. indicator ^. IndicatorTest E.==. test ^. TestId)
return indicator
indicatorEntries <- mapM indicatorToEntry indicators
theNow <- liftIO $ getCurrentTime
(entries, _) <- runDB $ getChallengeSubmissionInfos (const True) challengeId
let indicatorEntries' = map (onlyWithOngoingTargets theNow entries) indicatorEntries
return indicatorEntries'
onlyWithOngoingTargets :: UTCTime -> [TableEntry] -> IndicatorEntry -> IndicatorEntry
onlyWithOngoingTargets theNow entries indicatorEntry =
indicatorEntry { indicatorEntryTargets = filter (\t -> isOngoingStatus (getTargetStatus theNow entries indicatorEntry t)) (indicatorEntryTargets indicatorEntry) }
formatTargets :: IndicatorEntry -> Text
formatTargets entry = T.intercalate ", " $ (map (formatTarget (testPrecision $ entityVal $ indicatorEntryTest entry))) $ indicatorEntryTargets entry

View File

@ -17,6 +17,7 @@ import Handler.Runner
import Handler.Tables
import Handler.TagUtils
import Handler.MakePublic
import Handler.Dashboard
import Gonito.ExtractMetadata (ExtractionOptions(..),
extractMetadataFromRepoDir,
@ -247,6 +248,8 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
challenge <- runDB $ get404 challengeId
user <- runDB $ get404 userId
relevantIndicators <- getOngoingTargets challengeId
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
let (Entity mainTestId mainTest) = getMainTest activeTests
@ -320,12 +323,14 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
let compOp = case getMetricOrdering (testMetric mainTest) of
TheLowerTheBetter -> (<)
TheHigherTheBetter -> (>)
let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
case bestScoreSoFar of
Just b -> case newScores'' of
(s:_) -> if compOp s b
then
do
let submissionLink = slackLink app "submission" ("q/" ++ (fromSHA1ToText (repoCurrentCommit repo)))
let challengeLink = slackLink app (challengeTitle challenge) ("challenge/"
++ (challengeName challenge))
let message = ("Whoa! New best result for "
@ -359,8 +364,48 @@ doCreateSubmission userId challengeId mDescription mTags repoSpec chan = do
doMakePublic userId submissionId chan
else
return ()
if not (null relevantIndicators)
then
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan
else
return ()
Nothing -> return ()
checkIndicators :: User -> ChallengeId -> SubmissionId -> Text -> [IndicatorEntry] -> Channel -> Handler ()
checkIndicators user challengeId submissionId submissionLink relevantIndicators chan = do
msg chan "Checking indicators..."
theNow <- liftIO $ getCurrentTime
mapM_ (\indicator -> checkIndicator theNow user challengeId submissionId submissionLink indicator chan) relevantIndicators
checkIndicator :: UTCTime -> User -> ChallengeId -> SubmissionId -> Text -> IndicatorEntry -> Channel -> Handler ()
checkIndicator theNow user challengeId submissionId submissionLink indicator chan = do
(entries, _) <- runDB $ getChallengeSubmissionInfos (\(Entity sid _) -> sid == submissionId) challengeId
mapM_ (\t -> checkTarget theNow user submissionLink entries indicator t chan) (indicatorEntryTargets indicator)
checkTarget :: UTCTime -> User -> Text -> [TableEntry] -> IndicatorEntry -> Entity Target -> Channel -> Handler ()
checkTarget theNow user submissionLink entries indicator target chan = do
app <- getYesod
let status = getTargetStatus theNow entries indicator target
if status == TargetPassed
then
do
let message = "Congratulations!!! The target " ++ indicatorText
++ " was beaten by "
++ (fromMaybe "???" $ userName user)
++ ", "
++ " See " ++ submissionLink ++ "."
++ (T.replicate 10 " :champagne: ") ++ " :mleczko: "
msg chan message
case appNewBestResultSlackHook $ appSettings app of
Just "" -> return ()
Just hook -> liftIO $ runSlackHook hook message
Nothing -> return ()
else
return ()
where indicatorText = prettyIndicatorEntry indicator
getScoreForOut mainTestId out = do
mEvaluation <- runDB $ selectFirst [EvaluationChecksum ==. (outChecksum out),
EvaluationTest ==. mainTestId]