diff --git a/Handler/Evaluate.hs b/Handler/Evaluate.hs index c214879..1331e33 100644 --- a/Handler/Evaluate.hs +++ b/Handler/Evaluate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Handler.Evaluate where import Import @@ -6,9 +8,33 @@ import Handler.Common import Handler.Runner import Handler.Shared -import qualified Data.Text as T +import Gonito.ExtractMetadata (ExtractionOptions(..), + extractMetadataFromRepoDir, + GonitoMetadata(..)) -canBeReevaluated :: (YesodAuthPersist (HandlerSite m), MonadHandler m, PersistUniqueRead backend, AuthEntity (HandlerSite m) ~ User, AuthId (HandlerSite m) ~ Key User, BaseBackend backend ~ SqlBackend) => Key Submission -> ReaderT backend m Bool +import qualified Data.Text as T +import qualified Data.Map.Strict as M + +import GEval.Core +import GEval.EvaluationScheme +import GEval.Common (MetricValue) +import GEval.OptionsParser +import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..)) + +import Options.Applicative +import Data.Conduit.SmartSource + +import System.FilePath (takeFileName, dropExtensions, (-<.>)) + +import PersistSHA1 + +canBeReevaluated :: (YesodAuthPersist (HandlerSite m), + MonadHandler m, + PersistUniqueRead backend, + AuthEntity (HandlerSite m) ~ User, + AuthId (HandlerSite m) ~ Key User, + BaseBackend backend ~ SqlBackend) + => Key Submission -> ReaderT backend m Bool canBeReevaluated submissionId = do maybeUser <- maybeAuth case maybeUser of @@ -51,8 +77,177 @@ doReevaluateSubmission submissionId chan = do mRepoDir <- getSubmissionRepoDir submissionId chan case mRepoDir of Just repoDir -> do - msg chan ("Will evaluate in " ++ (T.pack repoDir)) + -- not exactly right, as the parameters might have been changed manuall + gonitoMetadata <- liftIO + $ extractMetadataFromRepoDir repoDir (ExtractionOptions { + extractionOptionsDescription = Nothing, + extractionOptionsTags = Nothing, + extractionOptionsGeneralParams = Nothing, + extractionOptionsUnwantedParams = Nothing, + extractionOptionsParamFiles = Nothing, + extractionOptionsMLRunPath = Nothing, + extractionOptionsExternalLinks = Nothing, + extractionOptionsDependencies = Nothing }) + + submission <- runDB $ get404 submissionId + let previousVersion = submissionVersion submission + challenge <- runDB $ get404 $ submissionChallenge submission + let currentChallengeVersion = challengeVersion challenge + + runDB $ update submissionId [SubmissionVersion =. currentChallengeVersion] + + catch (getOuts chan submissionId (gonitoMetadataGeneralParams gonitoMetadata) >> return ()) $ \(_::SomeException) -> do + err chan "SOMETHING WENT WRONG!!! REVERTING TO THE PREVIOUS VERSION" + runDB $ update submissionId [SubmissionVersion =. previousVersion] + + return () + Nothing -> do err chan "Something went wrong, won't evaluate" else msg chan "Won't re-evaluate!" + +-- | Does the evaluation for a submission. Inserts Out, Variant and Evaluation records. +getOuts :: Channel -> Key Submission -> M.Map Text Text -> Handler ([Out]) +getOuts chan submissionId generalParams = do + submission <- runDB $ get404 submissionId + let challengeId = submissionChallenge submission + let version = submissionVersion submission + repoDir <- getRepoDir $ submissionRepo submission + activeTests <- runDB $ selectList [TestChallenge ==. challengeId, + TestActive ==. True, + TestCommit ==. submissionVersion submission] [] + + outs' <- mapM (outsForTest repoDir submissionId generalParams) activeTests + let outs = concat outs' + + mapM_ checkOrInsertOut outs + mapM_ (checkOrInsertEvaluation repoDir chan version) outs + return outs + +outFileName :: FilePath +outFileName = "out.tsv" + +getOutFilePath :: FilePath -> Test -> FilePath +getOutFilePath repoDir test = repoDir (T.unpack $ testName test) outFileName + +findOutFile :: FilePath -> Test -> IO (Maybe FilePath) +findOutFile repoDir test = do + let baseOut = getOutFilePath repoDir test + ofs <- mapM (\ext -> findFilePossiblyCompressed (baseOut -<.> ext)) extensionsHandled + return $ listToMaybe $ catMaybes ofs + +doesOutExist :: FilePath -> Entity Test -> IO Bool +doesOutExist repoDir (Entity _ test) = do + result <- findOutFile repoDir test + return $ isJust result + +-- | Returns an Out object (won't insert into a database!) +outForTest :: MonadIO m => FilePath -> FilePath -> Key Variant -> Entity Test -> m Out +outForTest repoDir outF variantId (Entity testId test) = do + let outPath = repoDir (T.unpack $ testName test) outF + checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [outPath] + return Out { + outVariant=variantId, + outTest=testId, + outChecksum=SHA1 checksum } + +-- | Returns all possible outs for a given test. +-- Won't insert Out objects to the database, though it might add new variant objects. +outsForTest :: FilePath -> SubmissionId -> M.Map Text Text -> Entity Test -> HandlerFor App [Out] +outsForTest repoDir submissionId generalParams testEnt@(Entity _ test) = do + outFiles <- liftIO $ outFilesForTest repoDir test + + forM outFiles $ \outFile -> do + theVariant <- getVariant submissionId generalParams outFile + outForTest repoDir outFile theVariant testEnt + +-- | Returns the filenames (not file paths) of all output files for a given test. +outFilesForTest :: FilePath -> Test -> IO [FilePath] +outFilesForTest repoDir test = do + mMultipleOuts <- checkMultipleOutsCore repoDir (T.unpack $ testName test) "out.tsv" + case mMultipleOuts of + Just outFiles -> return $ map takeFileName outFiles + Nothing -> do + mOutFile <- findOutFile repoDir test + case mOutFile of + Just outF -> return [takeFileName outF] + Nothing -> return [] + +getVariant :: SubmissionId -> M.Map Text Text -> FilePath -> Handler VariantId +getVariant submissionId generalParams outFilePath = runDB $ do + let outFile = takeFileName outFilePath + let name = T.pack $ dropExtensions outFile + maybeVariant <- getBy $ UniqueVariantSubmissionName submissionId name + case maybeVariant of + Just (Entity vid _) -> return vid + Nothing -> do + vid <- insert $ Variant submissionId name + let (OutputFileParsed _ paramMap) = parseParamsFromFilePath outFile + + forM_ (M.toList (paramMap `M.union` generalParams)) $ \(param, val) -> do + _ <- insert $ Parameter vid param val + return () + + return vid + +checkOrInsertOut :: Out -> Handler () +checkOrInsertOut out = do + maybeOut <- runDB $ getBy $ UniqueOutVariantTestChecksum (outVariant out) (outTest out) (outChecksum out) + case maybeOut of + Just _ -> return () + Nothing -> (runDB $ insert out) >> return () + +checkOrInsertEvaluation :: FilePath -> Channel -> SHA1 -> Out -> Handler () +checkOrInsertEvaluation repoDir chan version out = do + test <- runDB $ get404 $ outTest out + challenge <- runDB $ get404 $ testChallenge test + maybeEvaluation' <- runDB $ fetchTheEvaluation out version + + let maybeEvaluation = case maybeEvaluation' of + Just (Entity _ evaluation) -> case evaluationVersion evaluation of + Just _ -> maybeEvaluation' + Nothing -> Nothing + Nothing -> Nothing + + case maybeEvaluation of + Just (Entity _ evaluation) -> do + msg chan $ concat ["Already evaluated with score ", (fromMaybe "???" $ formatNonScientifically <$> evaluationScore evaluation)] + Nothing -> do + msg chan $ "Start evaluation..." + challengeDir <- getRepoDir $ challengePrivateRepo challenge + variant <- runDB $ get404 $ outVariant out + resultOrException <- liftIO $ rawEval challengeDir (evaluationSchemeMetric $ testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv") + case resultOrException of + Right (Left _) -> do + err chan "Cannot parse options, check the challenge repo" + Right (Right (_, Just [(_, [result])])) -> do + msg chan $ concat [ "Evaluated! Score ", (formatNonScientifically result) ] + time <- liftIO getCurrentTime + _ <- runDB $ insert $ Evaluation { + evaluationTest=outTest out, + evaluationChecksum=outChecksum out, + evaluationScore=Just result, + evaluationErrorMessage=Nothing, + evaluationStamp=time, + evaluationVersion=Just version } + msg chan "Evaluation done" + Right (Right (_, Just _)) -> do + err chan "Unexpected multiple results (???)" + Right (Right (_, Nothing)) -> do + err chan "Error during the evaluation" + Left exception -> do + err chan $ "Evaluation failed: " ++ (T.pack $ show exception) + +rawEval :: FilePath + -> Metric + -> FilePath + -> Text + -> FilePath + -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe [(SourceSpec, [MetricValue])]))) +rawEval challengeDir metric repoDir name outF = Import.try (runGEvalGetOptions [ + "--alt-metric", (show metric), + "--expected-directory", challengeDir, + "--out-directory", repoDir, + "--out-file", outF, + "--test-name", (T.unpack name)]) diff --git a/Handler/Query.hs b/Handler/Query.hs index 2c72202..3c930b7 100644 --- a/Handler/Query.hs +++ b/Handler/Query.hs @@ -117,14 +117,18 @@ doGetScoreForOut mMetricName submission sha1code = do let submissionId = entityKey submission evals <- runDB $ E.select - $ E.from $ \(out, evaluation, variant, test) -> do + $ E.from $ \(out, evaluation, variant, test, version) -> do E.where_ (variant ^. VariantSubmission E.==. E.val submissionId E.&&. out ^. OutVariant E.==. variant ^. VariantId E.&&. out ^. OutTest E.==. test ^. TestId E.&&. evaluation ^. EvaluationTest E.==. test ^. TestId E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum - E.&&. out ^. OutChecksum E.==. E.val sha1code) - E.orderBy [E.asc (test ^. TestPriority)] + E.&&. out ^. OutChecksum E.==. E.val sha1code + E.&&. (evaluation ^. EvaluationVersion E.==. E.just (version ^. VersionCommit))) + E.orderBy [E.asc (test ^. TestPriority), + E.desc (version ^. VersionMajor), + E.desc (version ^. VersionMinor), + E.desc (version ^. VersionPatch)] return (evaluation, test) let evalSelected = case evals of diff --git a/Handler/Shared.hs b/Handler/Shared.hs index f5944cc..b2ecaca 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -530,6 +530,23 @@ checkWhetherGivenUserRepo userId submissionId = do submission <- get404 submissionId return $ userId == submissionSubmitter submission -fetchTheEvaluation :: (MonadIO m, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) +fetchTheEvaluation :: (PersistQueryRead backend, MonadIO m, BaseBackend backend ~ SqlBackend) => Out -> SHA1 -> ReaderT backend m (Maybe (Entity Evaluation)) -fetchTheEvaluation out _ = getBy $ UniqueEvaluationTestChecksum (outTest out) (outChecksum out) +fetchTheEvaluation out version = do + -- It's complicated due to legacy issues - should be + -- done by simply running UniqueEvaluationTestChecksumVersion + + evals <- selectList [EvaluationTest ==. outTest out, + EvaluationChecksum ==. outChecksum out, + EvaluationVersion ==. Just version] [] + case evals of + [eval] -> return $ Just eval + [] -> do + evals' <- selectList [EvaluationTest ==. outTest out, + EvaluationChecksum ==. outChecksum out, + EvaluationVersion ==. Nothing] [] + case evals' of + [eval] -> return $ Just eval + [] -> return Nothing + _ -> error "More than evaluation for the same test and version!" + _ -> error "More than evaluation for the same test, checksum and version!" diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index c19ae18..e6f539d 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -19,6 +19,7 @@ import Handler.TagUtils import Handler.MakePublic import Handler.Dashboard import Handler.Common +import Handler.Evaluate import Text.Blaze @@ -316,6 +317,8 @@ doCreateSubmission' _ userId challengeId mDescription mTags repoSpec chan = do E.&&. test ^. TestName E.==. E.val (testName mainTest) E.&&. test ^. TestMetric E.==. E.val (testMetric mainTest) E.&&. test ^. TestActive + E.&&. (evaluation ^. EvaluationVersion E.==. E.just (version ^. VersionCommit) + E.||. E.isNothing (evaluation ^. EvaluationVersion)) E.&&. version ^. VersionCommit E.==. test ^. TestCommit E.&&. version ^. VersionMajor E.>=. E.val submittedMajorVersion) E.orderBy [orderDirection (evaluation ^. EvaluationScore)] @@ -490,137 +493,6 @@ getSubmission userId repoId commit challengeId description chan = do submissionIsHidden=False, submissionVersion=challengeVersion challenge} --- | Does the evaluation for a submission. Inserts Out, Variant and Evaluation records. -getOuts :: Channel -> Key Submission -> M.Map Text Text -> Handler ([Out]) -getOuts chan submissionId generalParams = do - submission <- runDB $ get404 submissionId - let challengeId = submissionChallenge submission - repoDir <- getRepoDir $ submissionRepo submission - activeTests <- runDB $ selectList [TestChallenge ==. challengeId, - TestActive ==. True, - TestCommit ==. submissionVersion submission] [] - - outs' <- mapM (outsForTest repoDir submissionId generalParams) activeTests - let outs = concat outs' - - mapM_ checkOrInsertOut outs - mapM_ (checkOrInsertEvaluation repoDir chan) outs - return outs - -outFileName :: FilePath -outFileName = "out.tsv" - -getOutFilePath :: FilePath -> Test -> FilePath -getOutFilePath repoDir test = repoDir (T.unpack $ testName test) outFileName - -findOutFile :: FilePath -> Test -> IO (Maybe FilePath) -findOutFile repoDir test = do - let baseOut = getOutFilePath repoDir test - ofs <- mapM (\ext -> findFilePossiblyCompressed (baseOut -<.> ext)) extensionsHandled - return $ listToMaybe $ catMaybes ofs - -doesOutExist :: FilePath -> Entity Test -> IO Bool -doesOutExist repoDir (Entity _ test) = do - result <- findOutFile repoDir test - return $ isJust result - --- | Returns an Out object (won't insert into a database!) -outForTest :: MonadIO m => FilePath -> FilePath -> Key Variant -> Entity Test -> m Out -outForTest repoDir outF variantId (Entity testId test) = do - let outPath = repoDir (T.unpack $ testName test) outF - checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [outPath] - return Out { - outVariant=variantId, - outTest=testId, - outChecksum=SHA1 checksum } - --- | Returns all possible outs for a given test. --- Won't insert Out objects to the database, though it might add new variant objects. -outsForTest :: FilePath -> SubmissionId -> M.Map Text Text -> Entity Test -> HandlerFor App [Out] -outsForTest repoDir submissionId generalParams testEnt@(Entity _ test) = do - outFiles <- liftIO $ outFilesForTest repoDir test - - forM outFiles $ \outFile -> do - theVariant <- getVariant submissionId generalParams outFile - outForTest repoDir outFile theVariant testEnt - --- | Returns the filenames (not file paths) of all output files for a given test. -outFilesForTest :: FilePath -> Test -> IO [FilePath] -outFilesForTest repoDir test = do - mMultipleOuts <- checkMultipleOutsCore repoDir (Data.Text.unpack $ testName test) "out.tsv" - case mMultipleOuts of - Just outFiles -> return $ map takeFileName outFiles - Nothing -> do - mOutFile <- findOutFile repoDir test - case mOutFile of - Just outF -> return [takeFileName outF] - Nothing -> return [] - -getVariant :: SubmissionId -> M.Map Text Text -> FilePath -> Handler VariantId -getVariant submissionId generalParams outFilePath = runDB $ do - let outFile = takeFileName outFilePath - let name = Data.Text.pack $ dropExtensions outFile - maybeVariant <- getBy $ UniqueVariantSubmissionName submissionId name - case maybeVariant of - Just (Entity vid _) -> return vid - Nothing -> do - vid <- insert $ Variant submissionId name - let (OutputFileParsed _ paramMap) = parseParamsFromFilePath outFile - - forM_ (M.toList (paramMap `M.union` generalParams)) $ \(param, val) -> do - _ <- insert $ Parameter vid param val - return () - - return vid - -checkOrInsertOut :: Out -> Handler () -checkOrInsertOut out = do - maybeOut <- runDB $ getBy $ UniqueOutVariantTestChecksum (outVariant out) (outTest out) (outChecksum out) - case maybeOut of - Just _ -> return () - Nothing -> (runDB $ insert out) >> return () - -checkOrInsertEvaluation :: FilePath -> Channel -> Out -> Handler () -checkOrInsertEvaluation repoDir chan out = do - test <- runDB $ get404 $ outTest out - challenge <- runDB $ get404 $ testChallenge test - maybeEvaluation <- runDB $ fetchTheEvaluation out undefined - case maybeEvaluation of - Just (Entity _ evaluation) -> do - msg chan $ concat ["Already evaluated with score ", (fromMaybe "???" $ formatNonScientifically <$> evaluationScore evaluation)] - Nothing -> do - msg chan $ "Start evaluation..." - challengeDir <- getRepoDir $ challengePrivateRepo challenge - variant <- runDB $ get404 $ outVariant out - resultOrException <- liftIO $ rawEval challengeDir (evaluationSchemeMetric $ testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv") - case resultOrException of - Right (Left _) -> do - err chan "Cannot parse options, check the challenge repo" - Right (Right (_, Just [(_, [result])])) -> do - msg chan $ concat [ "Evaluated! Score ", (formatNonScientifically result) ] - time <- liftIO getCurrentTime - _ <- runDB $ insert $ Evaluation { - evaluationTest=outTest out, - evaluationChecksum=outChecksum out, - evaluationScore=Just result, - evaluationErrorMessage=Nothing, - evaluationStamp=time } - msg chan "Evaluation done" - Right (Right (_, Just _)) -> do - err chan "Unexpected multiple results (???)" - Right (Right (_, Nothing)) -> do - err chan "Error during the evaluation" - Left exception -> do - err chan $ "Evaluation failed: " ++ (T.pack $ show exception) - -rawEval :: FilePath -> Metric -> FilePath -> Text -> FilePath -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe [(SourceSpec, [MetricValue])]))) -rawEval challengeDir metric repoDir name outF = Import.try (runGEvalGetOptions [ - "--alt-metric", (show metric), - "--expected-directory", challengeDir, - "--out-directory", repoDir, - "--out-file", outF, - "--test-name", (T.unpack name)]) - getSubmissionRepo :: UserId -> Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo)) getSubmissionRepo userId challengeId repoSpec chan = getPossiblyExistingRepo checkRepoAvailibility userId challengeId repoSpec chan diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 7cb244b..2305978 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -326,13 +326,24 @@ getChallengeSubmissionInfos condition variantCondition challengeId = do let evaluationMaps = filter (variantCondition . tableEntryVariant) evaluationMaps' return (evaluationMaps, tests) -getScore :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Key Test -> Key Variant -> ReaderT backend m (Maybe Double) +getScore :: (MonadIO m, BackendCompatible SqlBackend backend, + PersistQueryRead backend, PersistUniqueRead backend, BaseBackend backend ~ SqlBackend) + => Key Test -> Key Variant -> ReaderT backend m (Maybe Double) getScore testId variantId = do + variant <- get404 variantId + submission <- get404 $ variantSubmission variant + let version = submissionVersion submission + evaluations <- E.select $ E.from $ \(out, evaluation) -> do E.where_ (out ^. OutVariant E.==. E.val variantId E.&&. out ^. OutTest E.==. E.val testId E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum + -- all this complication here and with orderBy due + -- to the legacy issue with evaluation version sometimes missing + E.&&. (evaluation ^. EvaluationVersion E.==. E.val (Just version) + E.||. E.isNothing (evaluation ^. EvaluationVersion)) E.&&. evaluation ^. EvaluationTest E.==. E.val testId) + E.orderBy [E.desc (E.isNothing (evaluation ^. EvaluationVersion))] return evaluation return $ case evaluations of (e:_) -> evaluationScore $ entityVal e @@ -343,7 +354,8 @@ getEvaluationMap :: (MonadIO m, PersistQueryRead backend, PersistUniqueRead back getEvaluationMap (rank, (s@(Entity submissionId submission), v@(Entity variantId _))) = do outs <- selectList [OutVariant ==. variantId] [] user <- get404 $ submissionSubmitter submission - maybeEvaluations <- mapM (\(Entity _ o) -> fetchTheEvaluation o undefined) outs + let versionHash = submissionVersion submission + maybeEvaluations <- mapM (\(Entity _ o) -> fetchTheEvaluation o versionHash) outs let evaluations = catMaybes maybeEvaluations let pairs = map (\(Entity _ e) -> (evaluationTest e, e)) evaluations pairs' <- mapM (\(testId, e) -> do @@ -355,7 +367,7 @@ getEvaluationMap (rank, (s@(Entity submissionId submission), v@(Entity variantId parameters <- selectList [ParameterVariant ==. variantId] [Asc ParameterName] - (Entity _ version) <- getBy404 $ UniqueVersionByCommit $ submissionVersion submission + (Entity _ version) <- getBy404 $ UniqueVersionByCommit versionHash let major = versionMajor version let minor = versionMinor version let patch = versionPatch version diff --git a/config/models b/config/models index 9157b5f..6e1c623 100644 --- a/config/models +++ b/config/models @@ -123,7 +123,8 @@ Evaluation score Double Maybe errorMessage Text Maybe stamp UTCTime default=now() - UniqueEvaluationTestChecksum test checksum + -- Should be just SHA1 (without Maybe) - Maybe is just a legacy + version SHA1 Maybe Comment challenge ChallengeId author UserId