gonito/Handler/Query.hs

837 lines
37 KiB
Haskell

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Handler.Query where
import Import hiding (fromList, Proxy)
import Handler.SubmissionView
import Handler.Shared
import Handler.TagUtils
import PersistSHA1
import Data.Diff
import Handler.Tables
import Text.Blaze
import qualified Yesod.Table as Table
import Database.Persist.Sql
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.List (nub, (!!))
import Data.List.Extra (groupOn)
import qualified Data.Map.Lazy as LM
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Data.Conduit.SmartSource (lookForCompressedFiles)
import GEval.Core (GEvalSpecification(..), GEvalOptions(..), ResultOrdering(..))
import GEval.LineByLine (runLineByLineGeneralized, runDiffGeneralized, LineRecord(..))
import GEval.Common (FormattingOptions(..), MetricValue)
import GEval.OptionsParser (readOptsFromConfigFile)
import qualified Data.Conduit.List as CL
import System.FilePath (takeFileName)
import System.Directory (makeAbsolute)
import Data.SplitIntoCrossTabs
import Data.Swagger hiding (get)
import qualified Data.Swagger as DS
import Data.Swagger.Declare
import Control.Lens hiding ((.=), (^.), (<.>))
import Data.Proxy as DPR
import Data.HashMap.Strict.InsOrd (fromList)
import qualified System.Directory as D
import Handler.ShowChallenge
data VariantView = VariantView {
variantViewId :: Int64,
variantViewName :: Text,
variantViewRank :: Int,
variantViewEvaluations :: [EvaluationView],
variantViewParams :: [Parameter]
}
instance ToJSON Parameter where
toJSON entry = object
[ "name" .= parameterName entry,
"value" .= parameterValue entry
]
instance ToSchema Parameter where
declareNamedSchema _ = do
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy String)
return $ NamedSchema (Just "Parameter") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("name", stringSchema),
("value", stringSchema)
]
& required .~ [ "name", "value" ]
instance ToJSON VariantView where
toJSON entry = object
[ "id" .= variantViewId entry,
"name" .= variantViewName entry,
"rank" .= variantViewRank entry,
"evaluations" .= variantViewEvaluations entry,
"params" .= variantViewParams entry
]
instance ToSchema VariantView where
declareNamedSchema _ = do
intSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Int64])
stringSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [String])
evaluationsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [EvaluationView])
paramsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [Parameter])
return $ NamedSchema (Just "Variant") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("id", intSchema),
("name", stringSchema),
("rank", intSchema),
("evaluations", evaluationsSchema),
("params", paramsSchema)
]
& required .~ [ "evaluations" ]
data QueryResultView = QueryResultView {
queryResultViewSubmissionInfo :: FullSubmissionInfo,
queryResultViewVariants :: [VariantView],
queryResultSharedParams :: [Parameter]
}
instance ToJSON QueryResultView where
toJSON entry = object
[ "submissionInfo" .= queryResultViewSubmissionInfo entry,
"variants" .= queryResultViewVariants entry,
"sharedParams" .= queryResultSharedParams entry
]
instance ToSchema QueryResultView where
declareNamedSchema _ = do
submissionInfoSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy FullSubmissionInfo)
return $ NamedSchema (Just "QueryResult") $ mempty
& type_ .~ SwaggerObject
& properties .~
fromList [ ("submissionInfo", submissionInfoSchema),
("variants", Inline $ toSchema (DPR.Proxy :: DPR.Proxy [VariantView])
& description .~ Just "A list of outputs (variants) associated with the given submission, usually one, but could be more"),
("sharedParams", Inline $ toSchema (DPR.Proxy :: DPR.Proxy [Parameter])
& description .~ Just "Parameters shared by all variants; if there is only one variant, all parameters will be given here")
]
& required .~ [ "submissionInfo", "variants" ]
rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
rawCommitQuery sha1Prefix =
rawSql "SELECT ?? FROM submission WHERE cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
rawOutQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
rawOutQuery sha1Prefix =
rawSql "SELECT ?? FROM out WHERE cast(checksum as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
groupBySecond :: Eq b => [(FullSubmissionInfo, b)] -> [(FullSubmissionInfo, [b])]
groupBySecond lst = map putOut $ groupOn (fsiSubmissionId . fst) lst
where putOut ((ha, hb):t) = (ha, hb:nub (map snd t))
putOut [] = error "should not be here"
findSubmissions :: Text -> Handler [(FullSubmissionInfo, [SHA1])]
findSubmissions sha1Prefix = do
allSubmissions <- runDB $ rawCommitQuery sha1Prefix
justSubmissions' <- mapM getFullInfo allSubmissions
let justSubmissions = map (\s -> (s, [])) justSubmissions'
outs <- runDB $ rawOutQuery sha1Prefix
submissionsByOuts <- mapM fetchSubmissionByOut outs
return (justSubmissions ++ groupBySecond submissionsByOuts)
fetchSubmissionByOut :: Entity Out -> HandlerFor App (FullSubmissionInfo, SHA1)
fetchSubmissionByOut (Entity _ out) = do
variant <- runDB $ get404 $ outVariant out
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
let theSubmissionEnt = Entity theSubmissionId theSubmission
fsi <- getFullInfo theSubmissionEnt
return (fsi, outChecksum out)
getApiTxtScoreR :: Text -> Handler Text
getApiTxtScoreR query =
if T.null postT
then getApiTxtScore Nothing preT
else getApiTxtScore (Just $ T.tail postT) preT
where (preT, postT) = T.breakOn "-" query
getApiTxtScore :: Maybe Text -> Text -> Handler Text
getApiTxtScore mMetricName sha1Prefix = do
submissions <- findSubmissions sha1Prefix
case submissions of
[] -> return noneMessage
((fsi, _):_) -> case submissions of
[(_, [])] -> doGetScore mMetricName (Entity (fsiSubmissionId fsi)
(fsiSubmission fsi))
_ -> do
let hashes = nub $ concat $ map snd submissions
case hashes of
[h] -> doGetScoreForOut mMetricName
(Entity (fsiSubmissionId fsi)
(fsiSubmission fsi))
h
[] -> return noneMessage
_ -> return ambiguousArgumentMessage
where ambiguousArgumentMessage = "AMBIGUOUS ARGUMENT"
noneMessage = "NONE"
doGetScore :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Maybe Text -> Entity Submission -> HandlerFor site Text
doGetScore mMetricName submission = do
let challengeId = submissionChallenge $ entityVal submission
mTestEnt <- runDB $ fetchTestByName mMetricName challengeId
case mTestEnt of
Just testEnt -> do
let theTestId = entityKey testEnt
let submissionId = entityKey submission
evals <- runDB $ E.select
$ E.from $ \(out, evaluation, variant, ver) -> do
E.where_ (variant ^. VariantSubmission E.==. E.val submissionId
E.&&. out ^. OutVariant E.==. variant ^. VariantId
E.&&. out ^. OutTest E.==. E.val theTestId
E.&&. evaluation ^. EvaluationTest E.==. E.val theTestId
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
E.&&. evaluation ^. EvaluationVersion E.==. ver ^. VersionCommit)
E.orderBy [E.desc (ver ^. VersionStamp)]
return (evaluation, ver)
case onlyWithHeadVersions evals of
[eval] -> return $ formatTruncatedScore (getTestFormattingOpts $ entityVal testEnt) (Just $ entityVal eval)
_ -> return "NONE"
Nothing -> return "NONE"
where onlyWithHeadVersions [] = []
onlyWithHeadVersions ((he,hv):t) = he:(onlyWithHeadVersions' hv t)
onlyWithHeadVersions' _ [] = []
onlyWithHeadVersions' v ((he,hv):t)
| entityKey hv == entityKey v = (he:(onlyWithHeadVersions' v t))
| otherwise = []
doGetScoreForOut :: (BaseBackend (YesodPersistBackend site) ~ SqlBackend, PersistUniqueRead (YesodPersistBackend site), BackendCompatible SqlBackend (YesodPersistBackend site), YesodPersist site, PersistQueryRead (YesodPersistBackend site)) => Maybe Text -> Entity Submission -> SHA1 -> HandlerFor site Text
doGetScoreForOut mMetricName submission sha1code = do
let submissionId = entityKey submission
evals <- runDB $ E.select
$ E.from $ \(out, evaluation, variant, test, theVersion) -> 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.&&. (evaluation ^. EvaluationVersion E.==. theVersion ^. VersionCommit))
E.orderBy [E.asc (test ^. TestPriority),
E.desc (theVersion ^. VersionMajor),
E.desc (theVersion ^. VersionMinor),
E.desc (theVersion ^. VersionPatch)]
return (evaluation, test)
let evalSelected = case evals of
[] -> Nothing
((eval, test):_) -> case mMetricName of
Nothing -> Just (eval, test)
Just mn -> find (\(_, t) -> formatTestEvaluationScheme (entityVal t) == mn) evals
case evalSelected of
Nothing -> return "None"
Just (eval, testEnt) -> return $ formatTruncatedScore (getTestFormattingOpts $ entityVal testEnt)
(Just $ entityVal eval)
getQueryFormR :: Handler Html
getQueryFormR = do
(formWidget, formEnctype) <- generateFormPost queryForm
defaultLayout $ do
setTitle "Searching for submissions"
$(widgetFile "query-form")
postQueryFormR :: Handler Html
postQueryFormR = do
((result, formWidget), formEnctype) <- runFormPost queryForm
case result of
FormSuccess query -> processQuery query
_ -> defaultLayout $ do
setTitle "Searching for submissions"
$(widgetFile "query-form")
getQueryResultsR :: Text -> Handler Html
getQueryResultsR = processQuery
isFullQuery :: Text -> Bool
isFullQuery query = length query == 40
detectSingleVariantSubmissionQuery :: (PersistQueryRead backend, MonadIO m, BaseBackend backend ~ SqlBackend) => [FullSubmissionInfo] -> ReaderT backend m (Maybe (Key Variant))
detectSingleVariantSubmissionQuery [submissionInfo] = do
if (null $ fsiSuperSubmissions submissionInfo)
then
do
variants <- selectList [VariantSubmission ==. fsiSubmissionId submissionInfo] []
case variants of
[Entity variantId _] -> return $ Just variantId
_ -> return Nothing
else
return Nothing
detectSingleVariantSubmissionQuery _ = return Nothing
processQuery :: Text -> Handler Html
processQuery query = do
mUserId <- maybeAuthId
submissions' <- findSubmissions query
let submissions = map fst submissions'
mSingleVariant <- runDB $ detectSingleVariantSubmissionQuery submissions
case mSingleVariant of
Just singleVariantId -> redirect $ ViewVariantR singleVariantId
Nothing -> do
defaultLayout $ do
setTitle "query results"
$(widgetFile "query-results")
toQueryResultView :: FullSubmissionInfo -> Handler QueryResultView
toQueryResultView fsi = do
let submissionId = fsiSubmissionId fsi
let submission = fsiSubmission fsi
theVersion <- realSubmissionVersion $ Entity submissionId submission
(tableEntries, tests) <- runDB
$ getChallengeSubmissionInfosForVersion 2
(\s -> entityKey s == submissionId)
(const True)
id
(submissionChallenge submission)
theVersion
let (commonParams, strippedTableEntries) = extractCommonParams tableEntries
let evaluations = map (\entry ->
VariantView {
variantViewId = fromSqlKey $ entityKey $ tableEntryVariant entry,
variantViewName = variantName $ entityVal $ tableEntryVariant entry,
variantViewRank = tableEntryRank entry,
variantViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
variantViewParams = Import.map entityVal $ tableEntryParams entry
}) strippedTableEntries
return $ QueryResultView {
queryResultViewSubmissionInfo = fsi,
queryResultViewVariants = evaluations,
queryResultSharedParams = map entityVal commonParams }
getQueryJsonR :: Text -> Handler Value
getQueryJsonR query = do
submissions' <- findSubmissions query
let submissions = map fst submissions'
qrvs <- mapM toQueryResultView submissions
return $ array qrvs
declareQuerySwagger :: Declare (Definitions Schema) Swagger
declareQuerySwagger = do
-- param schemas
let querySchema = toParamSchema (Proxy :: Proxy String)
queryResponse <- declareResponse (Proxy :: Proxy [QueryResultView])
return $ mempty
& paths .~
fromList [ ("/api/query/{query}",
mempty & DS.get ?~ (mempty
& parameters .~ [ Inline $ mempty
& name .~ "query"
& required ?~ True
& schema .~ ParamOther (mempty
& in_ .~ ParamPath
& paramSchema .~ querySchema) ]
& produces ?~ MimeList ["application/json"]
& description ?~ "For a SHA1 hash prefix returns all the submissions matching"
& at 200 ?~ Inline queryResponse))
]
queryApi :: Swagger
queryApi = spec & definitions .~ defs
where
(defs, spec) = runDeclare declareQuerySwagger mempty
priorityLimitForViewVariant :: Int
priorityLimitForViewVariant = 4
getViewVariantDiffR :: VariantId -> VariantId -> TestId -> Handler Html
getViewVariantDiffR oldVariantId newVariantId testId = do
doViewVariantTestR (TwoThings oldVariantId newVariantId) testId
getViewVariantTestR :: VariantId -> TestId -> Handler Html
getViewVariantTestR variantId testId = do
doViewVariantTestR (OneThing variantId) testId
data ViewVariantData = ViewVariantData {
viewVariantDataFullSubmissionInfo :: (FullSubmissionInfo, Maybe Text),
viewVariantDataTableEntry :: TableEntry,
viewVariantDataTests :: [Entity Test],
viewVariantDataOuts :: [(SHA1, Text)]
}
-- Return the submission version for which the tests are available.
-- It should be simply submissionVersion but the problem is that
-- we change the update the change version when updating a challenge
-- (if the test did not change), and we are left sometimes with dangling
-- versions for which no tests are available.
realSubmissionVersion :: Entity Submission -> Handler SHA1
realSubmissionVersion (Entity submissionId _) = do
testOutputs <- runDB $ E.select
$ E.from $ \(variant, out, test, evaluation, ver) -> do
E.where_ (variant ^. VariantSubmission E.==. E.val submissionId
E.&&. out ^. OutVariant E.==. variant ^. VariantId
E.&&. out ^. OutTest E.==. test ^. TestId
E.&&. out ^. OutChecksum E.==. evaluation ^. EvaluationChecksum
E.&&. evaluation ^. EvaluationVersion E.==. ver ^. VersionCommit)
E.orderBy [E.desc (ver ^. VersionStamp)]
return test
let (t:_) = testOutputs
return $ testCommit $ entityVal t
fetchViewVariantData :: VariantId -> Handler ViewVariantData
fetchViewVariantData variantId = do
variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
theVersion <- realSubmissionVersion $ Entity theSubmissionId theSubmission
([entry], tests') <- runDB $ getChallengeSubmissionInfosForVersion priorityLimitForViewVariant
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
theVersion
let tests = sortBy (flip testComparator) tests'
let isViewable = True
if isViewable
then
do
fullSubmissionInfo <- getFullInfo (Entity theSubmissionId theSubmission)
testOutputs <- runDB $ E.select
$ E.from $ \(out, test) -> do
E.where_ (out ^. OutTest E.==. test ^. TestId
E.&&. out ^. OutVariant E.==. E.val variantId)
E.orderBy []
return (out, test)
let outputs =
sortBy (\a b -> ((snd b) `compare` (snd a)))
$ nub
$ map (\(out, test) -> (outChecksum $ entityVal out, testName $ entityVal test)) testOutputs
return $ ViewVariantData (fullSubmissionInfo, Just $ variantName variant) entry tests outputs
else
error "Cannot access this submission variant"
instance Diffable SHA1 where
type DiffSettings SHA1 = ()
type DiffResult SHA1 = Diff SHA1
single u = OneThing u
diff _ old new
| old == new = OneThing new
| otherwise = TwoThings old new
postCompareFormR :: VariantId -> TestId -> Handler Html
postCompareFormR variantId testId = do
((result, _), _) <- runFormPost outQueryForm
case result of
FormSuccess outQuery -> do
(out:_) <- runDB $ rawOutQuery outQuery
let otherVariantId = outVariant $ entityVal out
doViewVariantTestR (TwoThings otherVariantId variantId) testId
nullSHA1 :: SHA1
nullSHA1 = fromTextToSHA1 "da39a3ee5e6b4b0d3255bfef95601890afd80709"
doViewVariantTestR :: Diff VariantId -> TestId -> Handler Html
doViewVariantTestR variantId testId = do
mUserId <- maybeAuthId
testSelected <- runDB $ get404 testId
let testSelectedEnt = Entity testId testSelected
variantInfos <- mapM (fetchViewVariantData) variantId
let fullSubmissionInfo = viewVariantDataFullSubmissionInfo <$> variantInfos
let entry = viewVariantDataTableEntry <$> variantInfos
let tests' = viewVariantDataTests <$> variantInfos
let outputs' = viewVariantDataOuts <$> variantInfos
let testIds = map fst $ runDiff () $ fmap (map entityKey) tests'
testEnts <- mapM (runDB . get404) testIds
let tests = map (\(i,e) -> Entity i e) $ zip testIds testEnts
let outputs :: [(Diff SHA1, Text)] =
sortBy (\a b -> ((snd b) `compare` (snd a)))
$ map swap $ LM.toList $ runDiff (nullSHA1, ()) $ fmap (LM.fromList . map swap) outputs'
(formWidget, formEnctype) <- generateFormPost outQueryForm
defaultLayout $ do
setTitle "Variant"
$(widgetFile "view-variant")
mergeEntryParams :: Diff [Parameter] -> [(Text, Diff Text)]
mergeEntryParams (OneThing u) = map (\(Parameter _ pname pval) -> (pname, OneThing pval)) u
mergeEntryParams (TwoThings old new) = LM.toList $ diff ("", ()) oldMap newMap
where oldMap = mapify old
newMap = mapify new
mapify l = LM.fromList $ map (\(Parameter _ pname pval) -> (pname, pval)) l
getViewVariantR :: VariantId -> Handler Html
getViewVariantR variantId = do
variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
theVersion <- realSubmissionVersion $ Entity theSubmissionId theSubmission
(_, tests') <- runDB $ getChallengeSubmissionInfosForVersion priorityLimitForViewVariant
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
theVersion
let (mainTest:_) = sortBy (flip testComparator) tests'
getViewVariantTestR variantId (entityKey mainTest)
linkedWithAnchor :: (Text.Blaze.ToMarkup a1, Text.Blaze.ToMarkup a2)
=> Text -> (t -> a2) -> (t -> Route site) -> (t -> a1) -> Table.Table site t
linkedWithAnchor h propFunc routeFunc anchorFunc =
Table.widget h (
\v -> [whamlet|<a href=@{routeFunc v}\\##{anchorFunc v}>#{propFunc v}|])
getVariantTestLink :: Diff VariantId -> TestId -> Route App
getVariantTestLink (OneThing u) testId = ViewVariantTestR u testId
getVariantTestLink (TwoThings old new) testId = ViewVariantDiffR old new testId
crossTableDefinition :: Diff VariantId -> TableWithValues (Entity Test, Diff Text) -> Table.Table App (Text, [(Entity Test, Diff Text)])
crossTableDefinition variantId (TableWithValues (headerH : headerR) _) = mempty
++ Table.text headerH fst
++ mconcat (map (\(i, h) -> linkedWithAnchor h
(snd . (!! i) . snd)
((\(e, _) -> getVariantTestLink variantId (entityKey e)) . (!! i) . snd)
(("worst-items-" <>) . testName . entityVal . fst . (!! i) . snd))
$ zip [0..] headerR)
crossTableDefinition _ _ = error $ "cross-tab of an unexpected size"
crossTableBody :: TableWithValues (Entity Test, Diff Text) -> [(Text, [(Entity Test, Diff Text)])]
crossTableBody (TableWithValues _ rows) = rows
paramsTable :: Table.Table App (Text, Diff Text)
paramsTable = mempty
++ Table.text "Parameter" fst
++ Table.widget "Value" ((\t -> [whamlet|#{t}|]) . snd)
viewOutput :: Diff TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
viewOutput entry tests (outputHash, testSet) = do
let (mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests
viewOutputWithNonDefaultTestSelected entry tests mainTest (OneThing outputHash, testSet)
maximumNumberOfItemsToBeShown :: Int
maximumNumberOfItemsToBeShown = 40
getOut :: Maybe UserId -> TableEntry -> WidgetFor App (Maybe (FilePath, FilePath))
getOut _ entry = do
let variant = variantName $ entityVal $ tableEntryVariant entry
let isViewable = True
if isViewable
then
do
mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir $ entityKey $ tableEntrySubmission entry
case mRepoDir of
Just repoDir -> do
outFilePath <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv")
return $ Just (repoDir, outFilePath)
Nothing -> return Nothing
else
do
return Nothing
data DiffLineRecord = DiffLineRecord Text Text (Diff (Text, MetricValue)) Word32
deriving (Show)
getUniLineRecord :: LineRecord -> DiffLineRecord
getUniLineRecord (LineRecord inp expect out lineNo val) = DiffLineRecord inp expect (OneThing (out, val)) lineNo
getBiLineRecord :: (LineRecord, LineRecord) -> DiffLineRecord
getBiLineRecord ((LineRecord oldInp oldExp oldOut oldLineNo oldVal), (LineRecord newInp newExp newOut newLineNo newVal))
| oldInp == newInp && oldExp == newExp && oldLineNo == newLineNo = DiffLineRecord newInp
newExp
(TwoThings (oldOut, oldVal)
(newOut, newVal))
newLineNo
| otherwise = error "inconsistent line records when diffing"
getScoreFromDiff :: DiffLineRecord -> MetricValue
getScoreFromDiff (DiffLineRecord _ _ (OneThing (_, s)) _) = s
getScoreFromDiff (DiffLineRecord _ _ (TwoThings (_, oldS) (_, newS)) _) = newS - oldS
data SourceOfExpected = NoExpectedFound | ExpectedFromSubmission | ExpectedFromChallenge
deriving (Eq, Show)
checkForExpected :: FilePath -> FilePath -> IO Bool
checkForExpected repoDir testName = do
expFile <- lookForCompressedFiles (repoDir </> testName </> "expected.tsv")
expFileExists <- D.doesFileExist expFile
return expFileExists
viewOutputWithNonDefaultTestSelected :: Diff TableEntry
-> [Entity Test]
-> Entity Test
-> (Diff SHA1, Text)
-> WidgetFor App ()
viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet) = do
let tests' = filter (\e -> (testName $ entityVal e) == testSet) tests
mauthId <- maybeAuthId
let outputSha1AsText = fromSHA1ToText $ current outputHash
let variantId = entityKey <$> tableEntryVariant <$> entry
let theStamp = submissionStamp $ entityVal $ tableEntrySubmission $ current entry
let theVersion = submissionVersion $ entityVal $ tableEntrySubmission $ current entry
challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission $ current entry
let isNonSensitive = challengeSensitive challenge == Just False
let shouldBeShown = testSet /= (testName $ entityVal mainTest) && isNonSensitive
let mainMetric = testMetric $ entityVal mainTest
let testLabels = map (formatTestEvaluationScheme . entityVal) tests'
let theMapping = LM.fromList $ map (\test -> (formatTestEvaluationScheme $ entityVal test,
(test,
(formatTruncatedScore (getTestFormattingOpts $ entityVal test)
<$> extractScore (getTestReference test) <$> entry)))) tests'
let crossTables = splitIntoTablesWithValues "Metric" "Score" theMapping testLabels
mResult <-
if shouldBeShown
then
do
outPaths <- mapM (getOut mauthId) entry
case current outPaths of
Just _ -> do
let repoDir = fst <$> fromJust <$> outPaths
let outFilePath = snd <$> fromJust <$> outPaths
let outFile = takeFileName $ current outFilePath
let testName = T.unpack testSet
challengeRepoDir <- handlerToWidget $ getRepoDir (challengePublicRepo challenge)
expFileExistsInChallengeRepo <- liftIO $ checkForExpected challengeRepoDir testName
expFileExists <- liftIO $ checkForExpected (current repoDir) testName
let expFileStatus = if expFileExists
then ExpectedFromSubmission
else
if expFileExistsInChallengeRepo
then ExpectedFromChallenge
else NoExpectedFound
if expFileStatus /= NoExpectedFound
then do
let theRepoDir = case expFileStatus of
ExpectedFromSubmission -> (current repoDir)
ExpectedFromChallenge -> challengeRepoDir
NoExpectedFound -> error "Should not be here"
Right opts <- liftIO $ readOptsFromConfigFile [] (theRepoDir </> "config.txt")
let spec = GEvalSpecification {
gesOutDirectory = current repoDir,
gesExpectedDirectory = Just theRepoDir,
gesTestName = testName,
gesSelector = Nothing,
gesOutFile = outFile,
gesAltOutFiles = Nothing,
gesExpectedFile = "expected.tsv",
gesInputFile = "in.tsv",
gesMetrics = [mainMetric],
gesFormatting = FormattingOptions {
decimalPlaces = Nothing,
asPercentage = False },
gesTokenizer = Nothing,
gesGonitoHost = Nothing,
gesToken = Nothing,
gesGonitoGitAnnexRemote = Nothing,
gesReferences = Nothing,
gesBootstrapResampling = Nothing,
gesInHeader = gesInHeader $ geoSpec opts,
gesOutHeader = gesOutHeader $ geoSpec opts,
gesShowPreprocessed = True }
case outPaths of
OneThing _ -> do
result <- liftIO $ runLineByLineGeneralized FirstTheWorst
spec
(\_ -> CL.take maximumNumberOfItemsToBeShown)
return $ Just (expFileStatus, zip [1..] $ map getUniLineRecord result)
TwoThings (Just (oldRepoDir, oldOutFilePath)) _ -> do
absOldOutFilePath <- liftIO $ makeAbsolute (oldRepoDir </> testName </> (takeFileName oldOutFilePath))
result <- liftIO $ runDiffGeneralized FirstTheWorst
absOldOutFilePath
spec
(\_ -> CL.take maximumNumberOfItemsToBeShown)
return $ Just (expFileStatus, zip [1..] $ map getBiLineRecord result)
else
do
return Nothing
Nothing -> return Nothing
else
return Nothing
$(widgetFile "view-output")
lineByLineTable :: Entity Test -> SHA1 -> UTCTime -> Table.Table App (Int, DiffLineRecord)
lineByLineTable (Entity testId test) theVersion theStamp = mempty
++ Table.int "#" fst
++ theLimitedTextCell "input" (((\(DiffLineRecord inp _ _ _) -> inp) . snd))
++ theLimitedTextCell "expected output" ((\(DiffLineRecord _ expected _ _) -> expected) . snd)
++ theLimitedDiffTextCell "actual output" (fmap fst . (\(DiffLineRecord _ _ out _) -> out) . snd)
++ resultCell test (fakeEvaluation . getScoreFromDiff . snd)
where fakeEvaluation score = Just $ Evaluation {
evaluationTest = testId,
evaluationChecksum = testChecksum test,
evaluationScore = Just score,
evaluationErrorBound = Nothing,
evaluationErrorMessage = Nothing,
evaluationStamp = theStamp,
evaluationVersion = theVersion }
resultTable :: Entity Submission -> WidgetFor App ()
resultTable entSubmission@(Entity submissionId submission) = do
theVersion <- handlerToWidget $ realSubmissionVersion entSubmission
(tableEntries, tests') <- handlerToWidget
$ runDB
$ getChallengeSubmissionInfosForVersion 2
(\s -> entityKey s == submissionId)
(const True)
id
(submissionChallenge submission)
theVersion
let (commonParams', strippedTableEntries) = extractCommonParams tableEntries
let commonParams = map (\(Entity _ p) -> (parameterName p, OneThing $ parameterValue p)) commonParams'
let paramNames =
nub
$ map (parameterName . entityVal)
$ concat
$ map tableEntryParams strippedTableEntries
let maximumNumberOfColumns = 10
let tests = adjustNumberOfColumnsShown (maximumNumberOfColumns - length paramNames) tests'
let resultId = show $ fromSqlKey submissionId
let jsSelector = String $ T.pack ("#t" ++ resultId ++ " > table")
let delta = Number $ fromIntegral ((length paramNames) + 1)
let higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
$(widgetFile "result-table")
adjustNumberOfColumnsShown :: Int -> [Entity Test] -> [Entity Test]
adjustNumberOfColumnsShown maximumNumberOfColumns tests = adjustNumberOfColumnsShown' (max maximumNumberOfColumns minimumNumberOfTests) tests
where adjustNumberOfColumnsShown' maximumNumberOfColumns' tests'
| length tests <= maximumNumberOfColumns' = tests'
| otherwise = let filteredTests = filter (\t -> not ("dev" `isInfixOf` (testName $ entityVal t))) tests'
in if null filteredTests
then tests'
else
if length filteredTests <= maximumNumberOfColumns'
then filteredTests
else take maximumNumberOfColumns' filteredTests
minimumNumberOfTests = 2
canFullInfoBeShown :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryRead backend, PersistUniqueRead backend) => Diff (FullSubmissionInfo, b) -> Maybe (Key User) -> ReaderT backend m Bool
canFullInfoBeShown (OneThing (fsi, _)) mUserId = checkWhetherVisible (fsiSubmission fsi) mUserId
canFullInfoBeShown (TwoThings (fsiA, _) (fsiB, _)) mUserId = do
checkA <- checkWhetherVisible (fsiSubmission fsiA) mUserId
checkB <- checkWhetherVisible (fsiSubmission fsiB) mUserId
return (checkA && checkB)
submissionHeader :: Maybe UserId -> Diff (FullSubmissionInfo, Maybe Text) -> WidgetFor App ()
submissionHeader mUserId param = do
showFullInfo <- handlerToWidget $ runDB $ canFullInfoBeShown param mUserId
app <- getYesod
let repoHost = appRepoHost $ appSettings app
let submissionToSubmissionUrl submission'
= getReadOnlySubmissionUrl (fsiScheme submission')
repoHost
(fsiChallengeRepo submission')
(challengeName $ fsiChallenge submission')
let publicSubmissionRepo = submissionToSubmissionUrl <$> submission
let submissionToBrowsableUrl submission'
= browsableGitRepoBranch (fsiScheme submission')
repoHost
(fsiChallengeRepo submission')
(challengeName $ fsiChallenge submission')
(getPublicSubmissionBranch $ fsiSubmissionId submission')
let browsableUrl = submissionToBrowsableUrl <$> submission
$(widgetFile "submission-header")
where variantSettings = ("out", ())
submission = fst <$> param
mVariantName = snd <$> param
commitSha1AsText = fromSHA1ToText <$> submissionCommit <$> fsiSubmission <$> submission
submitter = formatSubmitter <$> fsiUser <$> submission
publicSubmissionBranch = getPublicSubmissionBranch <$> fsiSubmissionId <$> submission
stamp = T.pack <$> show <$> submissionStamp <$> fsiSubmission <$> submission
queryResult :: Maybe UserId -> FullSubmissionInfo -> WidgetFor App ()
queryResult mUserId submission = do
$(widgetFile "query-result")
queryForm :: Form Text
queryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgGitCommitSha1) Nothing
outQueryForm :: Form Text
outQueryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgOutSha1) Nothing