forked from filipg/gonito
Implement re-evaluation
This commit is contained in:
parent
770c167753
commit
c5e43fcbea
@ -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)])
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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!"
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user