gonito/Handler/Query.hs

730 lines
31 KiB
Haskell
Raw Normal View History

2020-09-05 23:26:53 +02:00
{-# LANGUAGE ScopedTypeVariables #-}
2016-02-12 13:00:33 +01:00
module Handler.Query where
2021-02-15 12:51:24 +01:00
import Import hiding (fromList, Proxy)
2016-02-12 13:00:33 +01:00
2017-02-25 19:13:55 +01:00
import Handler.SubmissionView
2018-01-25 16:34:05 +01:00
import Handler.Shared
2018-11-10 11:20:17 +01:00
import Handler.TagUtils
2018-11-12 14:12:51 +01:00
import PersistSHA1
2020-09-05 23:26:53 +02:00
import Data.Diff
2018-11-12 14:12:51 +01:00
import Handler.Tables
import Text.Blaze
2018-11-12 14:12:51 +01:00
import qualified Yesod.Table as Table
2016-02-12 13:00:33 +01:00
import Database.Persist.Sql
2018-01-25 16:34:05 +01:00
import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.))
2016-02-12 13:00:33 +01:00
2020-09-05 23:26:53 +02:00
import Data.Maybe (fromJust)
2018-11-12 14:12:51 +01:00
import qualified Data.Text as T
2020-01-04 22:34:03 +01:00
import Data.List (nub, (!!))
import Data.List.Extra (groupOn)
2020-01-04 22:34:03 +01:00
import qualified Data.Map.Lazy as LM
2018-11-12 14:12:51 +01:00
2018-01-25 16:34:05 +01:00
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
2019-12-14 18:21:47 +01:00
import Data.Conduit.SmartSource (lookForCompressedFiles)
import GEval.Core (GEvalSpecification(..), GEvalOptions(..), ResultOrdering(..))
2020-09-05 23:26:53 +02:00
import GEval.LineByLine (runLineByLineGeneralized, runDiffGeneralized, LineRecord(..))
import GEval.Common (FormattingOptions(..), MetricValue)
import GEval.OptionsParser (readOptsFromConfigFile)
2019-12-14 18:21:47 +01:00
import qualified Data.Conduit.List as CL
import System.FilePath (takeFileName)
2020-09-05 23:26:53 +02:00
import System.Directory (makeAbsolute)
2019-12-14 18:21:47 +01:00
2020-01-04 22:34:03 +01:00
import Data.SplitIntoCrossTabs
2021-02-15 12:51:24 +01:00
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 Handler.ShowChallenge
data VariantView = VariantView {
variantViewId :: Int64,
variantViewName :: Text,
2021-02-15 21:39:06 +01:00
variantViewRank :: Int,
2021-02-15 12:51:24 +01:00
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)
2021-02-15 13:48:58 +01:00
return $ NamedSchema (Just "Parameter") $ mempty
2021-02-15 12:51:24 +01:00
& type_ .~ SwaggerObject
& properties .~
fromList [ ("name", stringSchema),
("value", stringSchema)
]
& required .~ [ "name", "value" ]
instance ToJSON VariantView where
toJSON entry = object
[ "id" .= variantViewId entry,
"name" .= variantViewName entry,
2021-02-15 21:39:06 +01:00
"rank" .= variantViewRank entry,
2021-02-15 12:51:24 +01:00
"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])
2021-02-15 13:48:58 +01:00
return $ NamedSchema (Just "Variant") $ mempty
2021-02-15 12:51:24 +01:00
& type_ .~ SwaggerObject
& properties .~
fromList [ ("id", intSchema),
("name", stringSchema),
2021-02-15 21:39:06 +01:00
("rank", intSchema),
2021-02-15 12:51:24 +01:00
("evaluations", evaluationsSchema),
("params", paramsSchema)
]
& required .~ [ "evaluations" ]
data QueryResultView = QueryResultView {
queryResultViewSubmissionInfo :: FullSubmissionInfo,
queryResultViewVariants :: [VariantView]
}
instance ToJSON QueryResultView where
toJSON entry = object
[ "submissionInfo" .= queryResultViewSubmissionInfo entry,
"variants" .= queryResultViewVariants entry
]
instance ToSchema QueryResultView where
declareNamedSchema _ = do
submissionInfoSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy FullSubmissionInfo)
variantViewsSchema <- declareSchemaRef (DPR.Proxy :: DPR.Proxy [VariantView])
2021-02-15 13:48:58 +01:00
return $ NamedSchema (Just "QueryResult") $ mempty
2021-02-15 12:51:24 +01:00
& type_ .~ SwaggerObject
& properties .~
fromList [ ("submissionInfo", submissionInfoSchema),
("variants", variantViewsSchema)
]
& required .~ [ "submissionInfo", "variants" ]
2018-01-25 16:34:05 +01:00
rawCommitQuery :: (MonadIO m, RawSql a) => Text -> ReaderT SqlBackend m [a]
2018-11-17 13:49:44 +01:00
rawCommitQuery sha1Prefix =
rawSql "SELECT ?? FROM submission WHERE cast(commit as text) like ?" [PersistText $ "\\\\x" ++ sha1Prefix ++ "%"]
2016-02-12 13:00:33 +01:00
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])]
2016-02-12 13:00:33 +01:00
findSubmissions sha1Prefix = do
2016-02-16 21:10:10 +01:00
mauthId <- maybeAuth
allSubmissions <- runDB $ rawCommitQuery sha1Prefix
submissions <- filterM (\sub -> runDB $ checkWhetherVisible (entityVal sub) (entityKey <$> mauthId)) allSubmissions
justSubmissions' <- mapM getFullInfo submissions
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)
2016-02-12 13:00:33 +01:00
2019-11-30 20:47:19 +01:00
getApiTxtScoreR :: Text -> Handler Text
getApiTxtScoreR query =
if T.null post
then getApiTxtScore Nothing pre
else getApiTxtScore (Just $ T.tail post) pre
where (pre, post) = T.breakOn "-" query
getApiTxtScore :: Maybe Text -> Text -> Handler Text
getApiTxtScore mMetricName sha1Prefix = do
submissions <- findSubmissions sha1Prefix
2018-01-25 16:34:05 +01:00
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"
2018-01-25 16:34:05 +01:00
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
2018-01-25 16:34:05 +01:00
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) -> 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.orderBy []
return (evaluation)
case evals of
2020-09-05 16:45:09 +02:00
[eval] -> return $ formatTruncatedScore (getTestFormattingOpts $ entityVal testEnt) (Just $ entityVal eval)
_ -> return "NONE"
Nothing -> return "NONE"
2018-01-25 16:34:05 +01:00
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
2019-12-14 14:10:50 +01:00
$ 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
2019-12-14 14:10:50 +01:00
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
[] -> 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"
2020-09-05 16:45:09 +02:00
Just (eval, testEnt) -> return $ formatTruncatedScore (getTestFormattingOpts $ entityVal testEnt)
(Just $ entityVal eval)
2016-02-12 13:00:33 +01:00
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
2018-11-10 11:20:17 +01:00
isFullQuery :: Text -> Bool
isFullQuery query = length query == 40
2016-02-12 13:00:33 +01:00
processQuery :: Text -> Handler Html
processQuery query = do
submissions' <- findSubmissions query
let submissions = map fst submissions'
2016-02-12 13:00:33 +01:00
defaultLayout $ do
setTitle "query results"
$(widgetFile "query-results")
2021-02-15 12:51:24 +01:00
toQueryResultView :: FullSubmissionInfo -> Handler QueryResultView
toQueryResultView fsi = do
let submissionId = fsiSubmissionId fsi
let submission = fsiSubmission fsi
(tableEntries, tests) <- runDB
$ getChallengeSubmissionInfos 2
(\s -> entityKey s == submissionId)
(const True)
id
(submissionChallenge submission)
let evaluations = map (\entry ->
VariantView {
variantViewId = fromSqlKey $ entityKey $ tableEntryVariant entry,
variantViewName = variantName $ entityVal $ tableEntryVariant entry,
2021-02-15 21:39:06 +01:00
variantViewRank = tableEntryRank entry,
2021-02-15 12:51:24 +01:00
variantViewEvaluations = catMaybes $ Import.map (convertEvaluationToView $ tableEntryMapping entry) tests,
variantViewParams = Import.map entityVal $ tableEntryParams entry
}) tableEntries
return $ QueryResultView {
queryResultViewSubmissionInfo = fsi,
queryResultViewVariants = evaluations }
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
2021-02-15 13:48:58 +01:00
(defs, spec) = runDeclare declareQuerySwagger mempty
2021-02-15 12:51:24 +01:00
priorityLimitForViewVariant :: Int
priorityLimitForViewVariant = 4
2020-09-05 23:26:53 +02:00
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
2020-09-05 23:26:53 +02:00
doViewVariantTestR (OneThing variantId) testId
data ViewVariantData = ViewVariantData {
viewVariantDataFullSubmissionInfo :: (FullSubmissionInfo, Maybe Text),
viewVariantDataTableEntry :: TableEntry,
viewVariantDataTests :: [Entity Test],
viewVariantDataOuts :: [(SHA1, Text)]
}
fetchViewVariantData :: VariantId -> Handler ViewVariantData
fetchViewVariantData variantId = do
2019-11-30 08:36:21 +01:00
mauthId <- maybeAuth
variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
([entry], tests') <- runDB $ getChallengeSubmissionInfos priorityLimitForViewVariant
2019-12-14 22:24:22 +01:00
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
let tests = sortBy (flip testComparator) tests'
isViewable <- runDB $ checkWhetherVisible theSubmission (entityKey <$> mauthId)
if isViewable
2019-11-30 08:36:21 +01:00
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
2020-09-05 23:26:53 +02:00
return $ ViewVariantData (fullSubmissionInfo, Just $ variantName variant) entry tests outputs
2019-11-30 08:36:21 +01:00
else
error "Cannot access this submission variant"
2020-09-05 23:26:53 +02:00
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
2020-09-05 23:26:53 +02:00
nullSHA1 :: SHA1
nullSHA1 = fromTextToSHA1 "da39a3ee5e6b4b0d3255bfef95601890afd80709"
doViewVariantTestR :: Diff VariantId -> TestId -> Handler Html
doViewVariantTestR variantId testId = do
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
2020-09-05 23:26:53 +02:00
defaultLayout $ do
setTitle "Variant"
$(widgetFile "view-variant")
mergeEntryParams :: Diff [Parameter] -> [(Text, Diff Text)]
mergeEntryParams (OneThing u) = map (\(Parameter _ name val) -> (name, OneThing val)) u
mergeEntryParams (TwoThings old new) = LM.toList $ diff ("", ()) oldMap newMap
where oldMap = mapify old
newMap = mapify new
mapify l = LM.fromList $ map (\(Parameter _ name val) -> (name, val)) l
getViewVariantR :: VariantId -> Handler Html
getViewVariantR variantId = do
variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
(_, tests') <- runDB $ getChallengeSubmissionInfos priorityLimitForViewVariant
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
id
(submissionChallenge theSubmission)
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}|])
2020-09-05 23:26:53 +02:00
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
2020-01-04 22:34:03 +01:00
++ Table.text headerH fst
++ mconcat (map (\(ix, h) -> linkedWithAnchor h
(snd . (!! ix) . snd)
2020-09-05 23:26:53 +02:00
((\(e, _) -> getVariantTestLink variantId (entityKey e)) . (!! ix) . snd)
2020-08-14 21:07:19 +02:00
(("worst-items-" <>) . testName . entityVal . fst . (!! ix) . snd))
$ zip [0..] headerR)
crossTableDefinition _ _ = error $ "cross-tab of an unexpected size"
2020-09-05 23:26:53 +02:00
crossTableBody :: TableWithValues (Entity Test, Diff Text) -> [(Text, [(Entity Test, Diff Text)])]
2020-01-04 22:34:03 +01:00
crossTableBody (TableWithValues _ rows) = rows
2020-09-05 23:26:53 +02:00
paramsTable :: Table.Table App (Text, Diff Text)
paramsTable = mempty
2020-09-05 23:26:53 +02:00
++ Table.text "Parameter" fst
++ Table.widget "Value" ((\t -> [whamlet|#{t}|]) . snd)
2020-09-05 23:26:53 +02:00
viewOutput :: Diff TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
2019-12-14 18:21:47 +01:00
viewOutput entry tests (outputHash, testSet) = do
let (mainTest:_) = filter (\e -> (testName $ entityVal e) == testSet) tests
2020-09-05 23:26:53 +02:00
viewOutputWithNonDefaultTestSelected entry tests mainTest (OneThing outputHash, testSet)
2020-09-05 16:56:59 +02:00
maximumNumberOfItemsToBeShown :: Int
maximumNumberOfItemsToBeShown = 40
2020-09-05 23:26:53 +02:00
getOut :: Maybe UserId -> TableEntry -> WidgetFor App (Maybe (FilePath, FilePath))
getOut mauthId entry = do
let variant = variantName $ entityVal $ tableEntryVariant entry
isViewable <- handlerToWidget $ runDB $ checkWhetherVisible (entityVal $ tableEntrySubmission entry) mauthId
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
2020-09-05 23:26:53 +02:00
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
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
2020-09-05 23:26:53 +02:00
let outputSha1AsText = fromSHA1ToText $ current outputHash
2019-12-14 18:21:47 +01:00
2020-09-05 23:26:53 +02:00
let variantId = entityKey <$> tableEntryVariant <$> entry
2019-12-14 18:21:47 +01:00
2020-09-05 23:26:53 +02:00
let theStamp = submissionStamp $ entityVal $ tableEntrySubmission $ current entry
challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission $ current entry
2019-12-14 18:21:47 +01:00
let isNonSensitive = challengeSensitive challenge == Just False
2020-09-05 23:26:53 +02:00
let shouldBeShown = not ("test-" `isInfixOf` testSet) && isNonSensitive
2019-12-14 18:21:47 +01:00
let mainMetric = testMetric $ entityVal mainTest
2020-01-04 22:34:03 +01:00
let testLabels = map (formatTestEvaluationScheme . entityVal) tests'
let mapping = LM.fromList $ map (\test -> (formatTestEvaluationScheme $ entityVal test,
(test,
2020-09-05 16:45:09 +02:00
(formatTruncatedScore (getTestFormattingOpts $ entityVal test)
2020-09-05 23:26:53 +02:00
<$> extractScore (getTestReference test) <$> entry)))) tests'
2020-01-04 22:34:03 +01:00
let crossTables = splitIntoTablesWithValues "Metric" "Score" mapping testLabels
2019-12-14 18:21:47 +01:00
mResult <-
if shouldBeShown
then
2020-01-04 22:34:03 +01:00
do
2020-09-05 23:26:53 +02:00
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
Right opts <- liftIO $ readOptsFromConfigFile [] (current repoDir </> "config.txt")
2020-09-05 23:26:53 +02:00
let spec = GEvalSpecification {
gesOutDirectory = current repoDir,
gesExpectedDirectory = Nothing,
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,
2020-09-05 23:26:53 +02:00
gesShowPreprocessed = True }
case outPaths of
OneThing _ -> do
result <- liftIO $ runLineByLineGeneralized FirstTheWorst
spec
(\_ -> CL.take maximumNumberOfItemsToBeShown)
return $ Just $ 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 $ zip [1..] $ map getBiLineRecord result
Nothing -> return Nothing
2019-12-14 18:21:47 +01:00
else
return Nothing
2019-11-30 08:36:21 +01:00
$(widgetFile "view-output")
2020-09-05 23:26:53 +02:00
lineByLineTable :: Entity Test -> UTCTime -> Table.Table App (Int, DiffLineRecord)
2019-12-14 18:21:47 +01:00
lineByLineTable (Entity testId test) theStamp = mempty
++ Table.int "#" fst
2020-09-05 23:26:53 +02:00
++ 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)
2019-12-14 18:21:47 +01:00
where fakeEvaluation score = Just $ Evaluation {
evaluationTest = testId,
evaluationChecksum = testChecksum test,
evaluationScore = Just score,
2020-01-28 23:14:46 +01:00
evaluationErrorBound = Nothing,
2019-12-14 18:21:47 +01:00
evaluationErrorMessage = Nothing,
evaluationStamp = theStamp,
evaluationVersion = Nothing }
2018-11-12 14:12:51 +01:00
resultTable :: Entity Submission -> WidgetFor App ()
resultTable (Entity submissionId submission) = do
(tableEntries, tests') <- handlerToWidget
$ runDB
2019-12-14 22:24:22 +01:00
$ getChallengeSubmissionInfos 2
(\s -> entityKey s == submissionId)
(const True)
id
(submissionChallenge submission)
2018-11-12 14:12:51 +01:00
let paramNames =
nub
$ map (parameterName . entityVal)
$ concat
$ map tableEntryParams tableEntries
let maximumNumberOfColumns = 10
let tests = adjustNumberOfColumnsShown (maximumNumberOfColumns - length paramNames) tests'
2018-11-12 14:12:51 +01:00
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
2019-11-29 22:10:48 +01:00
2020-05-31 21:26:29 +02:00
data GitServer = Gogs | GitLab
deriving (Eq, Show)
guessGitServer :: Text -> Maybe GitServer
guessGitServer bareUrl
| "git.wmi.amu.edu.pl" `isPrefixOf` bareUrl = Just Gogs
| "gitlab." `isPrefixOf` bareUrl = Just GitLab
| "git." `isPrefixOf` bareUrl = Just GitLab
| otherwise = Nothing
getHttpLink :: Repo -> Maybe (Text, Text)
getHttpLink repo = case guessGitServer bareUrl of
Just Gogs -> Just (convertToHttpLink bareUrl, "/src/" <> branch)
Just GitLab -> Just (convertToHttpLink bareUrl, "/-/tree/" <> branch)
Nothing -> Nothing
where bareUrl = T.replace "git@" "" url
url = repoUrl repo
branch = repoBranch repo
convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
2020-09-05 23:26:53 +02:00
submissionHeader :: Diff (FullSubmissionInfo, Maybe Text) -> WidgetFor App ()
submissionHeader param =
2019-11-29 22:10:48 +01:00
$(widgetFile "submission-header")
2020-09-05 23:26:53 +02:00
where variantSettings = ("out", ())
submission = fst <$> param
mVariantName = snd <$> param
commitSha1AsText = fromSHA1ToText <$> submissionCommit <$> fsiSubmission <$> submission
submitter = formatSubmitter <$> fsiUser <$> submission
publicSubmissionBranch = getPublicSubmissionBranch <$> fsiSubmissionId <$> submission
publicSubmissionRepo = submissionToSubmissionUrl <$> submission
browsableUrl = submissionToBrowsableUrl <$> submission
stamp = T.pack <$> show <$> submissionStamp <$> fsiSubmission <$> submission
submissionToSubmissionUrl submission' = getReadOnlySubmissionUrl (fsiScheme submission') (fsiChallengeRepo submission') $ challengeName $ fsiChallenge submission'
submissionToBrowsableUrl submission' = browsableGitRepoBranch (fsiScheme submission') (fsiChallengeRepo submission') (challengeName $ fsiChallenge submission') (getPublicSubmissionBranch $ fsiSubmissionId submission')
2018-11-12 14:12:51 +01:00
2019-11-29 22:10:48 +01:00
queryResult :: FullSubmissionInfo -> WidgetFor App ()
queryResult submission = do
$(widgetFile "query-result")
2016-02-12 13:00:33 +01:00
queryForm :: Form Text
queryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgGitCommitSha1) Nothing
outQueryForm :: Form Text
outQueryForm = renderBootstrap3 BootstrapBasicForm $ areq textField (fieldSettingsLabel MsgOutSha1) Nothing