Implement re-evaluation

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)])

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.&&. out ^. OutChecksum E.==. E.val sha1code
-                  E.orderBy [E.asc (test ^. TestPriority)]
+                            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

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!"

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
 

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

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