gonito/Handler/Evaluate.hs

263 lines
11 KiB
Haskell

{-# LANGUAGE ScopedTypeVariables #-}
module Handler.Evaluate where
import Import
import Handler.Common
import Handler.Runner
import Handler.Shared
import Gonito.ExtractMetadata (ExtractionOptions(..),
extractMetadataFromRepoDir,
GonitoMetadata(..))
import qualified Data.Text as T
import qualified Data.Map.Strict as M
import GEval.Core
import GEval.EvaluationScheme
import GEval.OptionsParser
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
import GEval.Common (GEvalException, MetricResult(..), MetricValue)
import GEval.Formatting (formatTheResult)
import Options.Applicative
import Data.Conduit.SmartSource
import Data.Conduit.Bootstrap (defaultConfidenceLevel, getConfidenceBounds)
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
Just (Entity userId _) -> do
isOwner <- checkWhetherGivenUserRepo userId submissionId
let isSuperuser = checkIfAdmin maybeUser
submission <- get404 submissionId
let submissionVersionHash = submissionVersion submission
challenge <- get404 $ submissionChallenge submission
let challengeVersionHash = challengeVersion challenge
if (submissionVersionHash == challengeVersionHash)
then return False
else
do
(Entity _ submissionVer) <- getBy404 $ UniqueVersionByCommit submissionVersionHash
(Entity _ chalengeVer) <- getBy404 $ UniqueVersionByCommit challengeVersionHash
return ((isOwner || isSuperuser)
&&
((versionMajor submissionVer) == (versionMajor chalengeVer)
|| (versionMinor submissionVer) == (versionMinor chalengeVer)
|| (versionPatch submissionVer) < (versionPatch chalengeVer)))
Nothing -> return False
getReevaluateSubmissionR :: SubmissionId -> Handler TypedContent
getReevaluateSubmissionR submissionId =
runViewProgress $ doReevaluateSubmission submissionId
doReevaluateSubmission :: SubmissionId -> Channel -> Handler ()
doReevaluateSubmission submissionId chan = do
status <- runDB $ canBeReevaluated submissionId
if status
then
do
mRepoDir <- getSubmissionRepoDir submissionId chan
case mRepoDir of
Just repoDir -> do
-- 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 (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 ", (T.pack $ formatTheResult Nothing result) ]
time <- liftIO getCurrentTime
_ <- runDB $ insert $ let (pointResult, errorBound) = extractResult result
in Evaluation {
evaluationTest=outTest out,
evaluationChecksum=outChecksum out,
evaluationScore=Just pointResult,
evaluationErrorBound=errorBound,
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)
extractResult :: MetricResult -> (MetricValue, Maybe MetricValue)
extractResult (SimpleRun r) = (r, Nothing)
extractResult (BootstrapResampling vals) = ((upperBound + lowerBound) / 2.0, Just ((upperBound - lowerBound) / 2.0))
where (lowerBound, upperBound) = getConfidenceBounds defaultConfidenceLevel vals
rawEval :: FilePath
-> EvaluationScheme
-> FilePath
-> Text
-> FilePath
-> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe [(SourceSpec, [MetricResult])])))
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)])