multiple outs can be accepted now

This commit is contained in:
Filip Gralinski 2018-07-14 15:27:49 +02:00
parent bb77049918
commit f3960c371d
2 changed files with 49 additions and 15 deletions

View File

@ -9,6 +9,7 @@ import qualified Data.Text.Lazy as TL
import Text.Markdown import Text.Markdown
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Map.Strict as M
import qualified Yesod.Table as Table import qualified Yesod.Table as Table
@ -20,7 +21,7 @@ import Handler.TagUtils
import GEval.Core import GEval.Core
import GEval.OptionsParser import GEval.OptionsParser
import GEval.ParseParams (parseParamsFromFilePath, OutputFileParsed(..))
import PersistSHA1 import PersistSHA1
@ -28,6 +29,8 @@ import Options.Applicative
import System.IO (readFile) import System.IO (readFile)
import System.FilePath (takeFileName, dropExtensions)
import Data.Attoparsec.Text import Data.Attoparsec.Text
import Data.Text (pack, unpack) import Data.Text (pack, unpack)
@ -282,9 +285,10 @@ getOuts chan submissionId = do
let challengeId = submissionChallenge submission let challengeId = submissionChallenge submission
repoDir <- getRepoDir $ submissionRepo submission repoDir <- getRepoDir $ submissionRepo submission
activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] [] activeTests <- runDB $ selectList [TestChallenge ==. challengeId, TestActive ==. True] []
testsDone <- filterM (liftIO . doesOutExist repoDir) activeTests
theVariant <- getVariant submissionId "out" outs' <- mapM (outsForTest repoDir submissionId) activeTests
outs <- mapM (outForTest repoDir theVariant) testsDone let outs = concat outs'
mapM_ checkOrInsertOut outs mapM_ checkOrInsertOut outs
mapM_ (checkOrInsertEvaluation repoDir chan) outs mapM_ (checkOrInsertEvaluation repoDir chan) outs
return outs return outs
@ -305,21 +309,49 @@ doesOutExist repoDir (Entity _ test) = do
result <- findOutFile repoDir test result <- findOutFile repoDir test
return $ isJust result return $ isJust result
outForTest :: MonadIO m => FilePath -> Key Variant -> Entity Test -> m Out outForTest :: MonadIO m => FilePath -> FilePath -> Key Variant -> Entity Test -> m Out
outForTest repoDir variantId (Entity testId test) = do outForTest repoDir outF variantId (Entity testId test) = do
(Just outF) <- liftIO $ findOutFile repoDir test let outPath = repoDir </> (T.unpack $ testName test) </> outF
checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [outF] checksum <- liftIO $ gatherSHA1ForCollectionOfFiles [outPath]
return Out { return Out {
outVariant=variantId, outVariant=variantId,
outTest=testId, outTest=testId,
outChecksum=SHA1 checksum } outChecksum=SHA1 checksum }
getVariant :: SubmissionId -> Text -> Handler VariantId outsForTest :: FilePath -> SubmissionId -> Entity Test -> HandlerFor App [Out]
getVariant submissionId name = runDB $ do outsForTest repoDir submissionId testEnt@(Entity _ test) = do
outFiles <- liftIO $ outFilesForTest repoDir test
forM outFiles $ \outFile -> do
theVariant <- getVariant submissionId outFile
outForTest repoDir outFile theVariant testEnt
-- returns the filename (not file path)
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 -> FilePath -> Handler VariantId
getVariant submissionId outFilePath = runDB $ do
let outFile = takeFileName outFilePath
let name = Data.Text.pack $ dropExtensions outFile
maybeVariant <- getBy $ UniqueVariantSubmissionName submissionId name maybeVariant <- getBy $ UniqueVariantSubmissionName submissionId name
case maybeVariant of case maybeVariant of
Just (Entity vid _) -> return vid Just (Entity vid _) -> return vid
Nothing -> insert $ Variant submissionId name Nothing -> do
vid <- insert $ Variant submissionId name
let (OutputFileParsed _ paramMap) = parseParamsFromFilePath outFile
forM_ (M.toList paramMap) $ \(param, val) -> do
_ <- insert $ Parameter vid param val
return ()
return vid
checkOrInsertOut :: Out -> Handler () checkOrInsertOut :: Out -> Handler ()
checkOrInsertOut out = do checkOrInsertOut out = do
@ -339,7 +371,8 @@ checkOrInsertEvaluation repoDir chan out = do
Nothing -> do Nothing -> do
msg chan $ "Start evaluation..." msg chan $ "Start evaluation..."
challengeDir <- getRepoDir $ challengePrivateRepo challenge challengeDir <- getRepoDir $ challengePrivateRepo challenge
resultOrException <- liftIO $ rawEval challengeDir (testMetric test) repoDir (testName test) variant <- runDB $ get404 $ outVariant out
resultOrException <- liftIO $ rawEval challengeDir (testMetric test) repoDir (testName test) ((T.unpack $ variantName variant) <.> "tsv")
case resultOrException of case resultOrException of
Right (Left _) -> do Right (Left _) -> do
err chan "Cannot parse options, check the challenge repo" err chan "Cannot parse options, check the challenge repo"
@ -360,11 +393,12 @@ checkOrInsertEvaluation repoDir chan out = do
Left exception -> do Left exception -> do
err chan $ "Evaluation failed: " ++ (T.pack $ show exception) err chan $ "Evaluation failed: " ++ (T.pack $ show exception)
rawEval :: FilePath -> Metric -> FilePath -> Text -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe [(SourceSpec, [MetricValue])]))) rawEval :: FilePath -> Metric -> FilePath -> Text -> FilePath -> IO (Either GEvalException (Either (ParserResult GEvalOptions) (GEvalOptions, Maybe [(SourceSpec, [MetricValue])])))
rawEval challengeDir metric repoDir name = Import.try (runGEvalGetOptions [ rawEval challengeDir metric repoDir name outF = Import.try (runGEvalGetOptions [
"--alt-metric", (show metric), "--alt-metric", (show metric),
"--expected-directory", challengeDir, "--expected-directory", challengeDir,
"--out-directory", repoDir, "--out-directory", repoDir,
"--out-file", outF,
"--test-name", (T.unpack name)]) "--test-name", (T.unpack name)])
getSubmissionRepo :: Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo)) getSubmissionRepo :: Key Challenge -> RepoSpec -> Channel -> Handler (Maybe (Key Repo))

View File

@ -122,7 +122,7 @@ library
, filemanip , filemanip
, cryptohash , cryptohash
, markdown , markdown
, geval >= 1.1.0.0 && < 1.2 , geval >= 1.1.2.0 && < 1.2
, filepath , filepath
, yesod-table , yesod-table
, regex-tdfa , regex-tdfa