s464900/gonito
1
0
Fork 0
forked from filipg/gonito
Code Issues Pull Requests Projects Releases Wiki Activity

WIP

Browse Source
This commit is contained in:
Filip Gralinski 2020-09-05 23:26:53 +02:00
parent db8c1d6917
commit b3c259a478
8 changed files with 340 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
Data/Diff.hs Normal file
View File

@ -0,0 +1,113 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
module Data.Diff where
import Import
import Text.Blaze
import Text.Blaze.Html4.Strict hiding (map)
import Text.Blaze.Html4.Strict.Attributes hiding (map)
import Data.Foldable
import qualified Data.Map.Lazy as LM
data Diff a = OneThing a | TwoThings a a
presentDiff :: (Eq a, IsString m, Monoid m) => (a -> m) -> (m -> m) -> (m -> m) -> (Diff a -> m)
presentDiff presentAtom _ _ (OneThing u) = presentAtom u
presentDiff presentAtom presentOld presentNew (TwoThings old new)
| old == new = presentAtom new
| otherwise = presentOld (presentAtom old) <> presentNew (presentAtom new)
instance (Eq a, Show a) => Show (Diff a) where
show d = presentDiff show
(\x -> "[-" ++ x ++ "-]")
(\x -> "{+" ++ x ++ "+}")
d
instance (Eq a, ToMarkup a) => ToMarkup (Diff a) where
toMarkup d = presentDiff toMarkup
(Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:red;text-decoration: line-through;"))
(Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:green;text-decoration: underline;"))
d
-- toMarkup (OneThing u) = toMarkup u
-- toMarkup (TwoThings old new) = ((Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:green;")) (toMarkup new)) <> " (" <> ((Text.Blaze.Html4.Strict.span ! (Text.Blaze.Html4.Strict.Attributes.style "color:red;")) (toMarkup old)) <> ")"
instance Functor Diff where
fmap fun (OneThing u) = OneThing (fun u)
fmap fun (TwoThings old new) = TwoThings (fun old) (fun new)
instance Foldable Diff where
foldMap f (OneThing u) = f u
foldMap f (TwoThings old new) = f old `mappend` f new
instance Traversable Diff where
traverse f (OneThing u) = OneThing <$> f u
traverse f (TwoThings old new) = TwoThings <$> f old <*> f new
current :: Diff a -> a
current (OneThing u) = u
current (TwoThings _ new) = new
class Diffable t where
type DiffSettings t
type DiffResult t
diff :: DiffSettings t -> t -> t -> DiffResult t
single :: t -> DiffResult t
runDiff :: DiffSettings t -> Diff t -> DiffResult t
runDiff _ (OneThing u) = single u
runDiff s (TwoThings old new) = diff s old new
instance Diffable Int where
type DiffSettings Int = ()
type DiffResult Int = Diff Int
single u = OneThing u
diff _ old new
| old == new = OneThing new
| otherwise = TwoThings old new
instance Diffable Text where
type DiffSettings Text = ()
type DiffResult Text = Diff Text
single u = OneThing u
diff _ old new
| old == new = OneThing new
| otherwise = TwoThings old new
instance Diffable t => Diffable (Maybe t) where
type DiffSettings (Maybe t) = (t, DiffSettings t)
type DiffResult (Maybe t) = Maybe (DiffResult t)
single Nothing = Nothing
single (Just u) = Just $ single u
diff (_, sub) (Just old) (Just new) = Just $ diff sub old new
diff (defaultValue, sub) (Just old) Nothing = Just $ diff sub old defaultValue
diff (defaultValue, sub) Nothing (Just new) = Just $ diff sub defaultValue new
diff (_, _) Nothing Nothing = Nothing
instance (Eq v) => Diffable ([v]) where
type DiffSettings ([v]) = ()
type DiffResult ([v]) = [(v, Diff Bool)]
single t = map (\e -> (e, OneThing True)) t
diff () old new = [(oe, TwoThings True False) | oe <- old, not (oe `Import.elem` new) ]
++ map (\ne -> (ne, if ne `Import.elem` old then OneThing True else TwoThings False True)) new
instance (Eq k, Ord k, Diffable v) => Diffable (LM.Map k v) where
type DiffSettings (LM.Map k v) = (v, DiffSettings v)
type DiffResult (LM.Map k v) = LM.Map k (DiffResult v)
single m = LM.map single m
diff (defaultValue, sub) old new = LM.mergeWithKey (\_ a b -> Just $ diff sub a b)
(LM.map (\x -> diff sub x defaultValue))
(LM.map (\x -> diff sub defaultValue x))
old
new

262
Handler/Query.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Handler.Query where
import Import
@ -7,6 +9,8 @@ import Handler.Shared
import Handler.TagUtils
import PersistSHA1
import Data.Diff
import Handler.Tables
import Text.Blaze
@ -18,6 +22,8 @@ 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, (!!))
@ -28,10 +34,11 @@ import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Data.Conduit.SmartSource (lookForCompressedFiles)
import GEval.Core (GEvalSpecification(..), ResultOrdering(..))
import GEval.LineByLine (runLineByLineGeneralized, LineRecord(..))
import GEval.Common (FormattingOptions(..))
import GEval.LineByLine (runLineByLineGeneralized, runDiffGeneralized, LineRecord(..))
import GEval.Common (FormattingOptions(..), MetricValue)
import qualified Data.Conduit.List as CL
import System.FilePath (takeFileName)
import System.FilePath (takeFileName, makeRelative)
import System.Directory (makeAbsolute)
import Data.SplitIntoCrossTabs
@ -186,16 +193,28 @@ processQuery query = do
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)]
}
fetchViewVariantData :: VariantId -> Handler ViewVariantData
fetchViewVariantData variantId = do
mauthId <- maybeAuth
variant <- runDB $ get404 variantId
let theSubmissionId = variantSubmission variant
theSubmission <- runDB $ get404 theSubmissionId
testSelected <- runDB $ get404 testId
let testSelectedEnt = Entity testId testSelected
([entry], tests') <- runDB $ getChallengeSubmissionInfos priorityLimitForViewVariant
(\e -> entityKey e == theSubmissionId)
(\e -> entityKey e == variantId)
@ -222,13 +241,52 @@ getViewVariantTestR variantId testId = do
$ nub
$ map (\(out, test) -> (outChecksum $ entityVal out, testName $ entityVal test)) testOutputs
defaultLayout $ do
setTitle "Variant"
$(widgetFile "view-variant")
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
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'
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
@ -249,49 +307,94 @@ linkedWithAnchor h propFunc routeFunc anchorFunc =
Table.widget h (
\v -> [whamlet|<a href=@{routeFunc v}\\##{anchorFunc v}>#{propFunc v}|])
crossTableDefinition :: VariantId -> TableWithValues (Entity Test, Text) -> Table.Table App (Text, [(Entity Test, Text)])
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 (\(ix, h) -> linkedWithAnchor h
(snd . (!! ix) . snd)
((\(e, _) -> ViewVariantTestR variantId (entityKey e)) . (!! ix) . snd)
((\(e, _) -> getVariantTestLink variantId (entityKey e)) . (!! ix) . snd)
(("worst-items-" <>) . testName . entityVal . fst . (!! ix) . snd))
$ zip [0..] headerR)
crossTableDefinition _ _ = error $ "cross-tab of an unexpected size"
crossTableBody :: TableWithValues (Entity Test, Text) -> [(Text, [(Entity Test, Text)])]
crossTableBody :: TableWithValues (Entity Test, Diff Text) -> [(Text, [(Entity Test, Diff Text)])]
crossTableBody (TableWithValues _ rows) = rows
paramsTable :: Table.Table App Parameter
paramsTable :: Table.Table App (Text, Diff Text)
paramsTable = mempty
++ Table.text "Parameter" parameterName
++ Table.text "Value" parameterValue
++ Table.text "Parameter" fst
++ Table.widget "Value" ((\t -> [whamlet|#{t}|]) . snd)
viewOutput :: TableEntry -> [Entity Test] -> (SHA1, Text) -> WidgetFor App ()
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 (outputHash, testSet)
viewOutputWithNonDefaultTestSelected entry tests mainTest (OneThing outputHash, testSet)
maximumNumberOfItemsToBeShown :: Int
maximumNumberOfItemsToBeShown = 40
viewOutputWithNonDefaultTestSelected :: TableEntry -> [Entity Test] -> Entity Test -> (SHA1, Text) -> WidgetFor App ()
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 exp out lineNo val) = DiffLineRecord inp exp (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
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 $ outputHash
let outputSha1AsText = fromSHA1ToText $ current outputHash
let variant = variantName $ entityVal $ tableEntryVariant entry
let variantId = entityKey $ tableEntryVariant entry
let variantId = entityKey <$> tableEntryVariant <$> entry
let theStamp = submissionStamp $ entityVal $ tableEntrySubmission entry
isViewable <- handlerToWidget $ runDB $ checkWhetherVisible (entityVal $ tableEntrySubmission entry) mauthId
challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission entry
let theStamp = submissionStamp $ entityVal $ tableEntrySubmission $ current entry
challenge <- handlerToWidget $ runDB $ get404 $ submissionChallenge $ entityVal $ tableEntrySubmission $ current entry
let isNonSensitive = challengeSensitive challenge == Just False
let shouldBeShown = not ("test-" `isInfixOf` testSet) && isViewable && isNonSensitive
let shouldBeShown = not ("test-" `isInfixOf` testSet) && isNonSensitive
let mainMetric = testMetric $ entityVal mainTest
@ -299,56 +402,70 @@ viewOutputWithNonDefaultTestSelected entry tests mainTest (outputHash, testSet)
let mapping = LM.fromList $ map (\test -> (formatTestEvaluationScheme $ entityVal test,
(test,
(formatTruncatedScore (getTestFormattingOpts $ entityVal test)
$ extractScore (getTestReference test) entry)))) tests'
<$> extractScore (getTestReference test) <$> entry)))) tests'
let crossTables = splitIntoTablesWithValues "Metric" "Score" mapping testLabels
mResult <-
if shouldBeShown
then
do
mRepoDir <- handlerToWidget $ justGetSubmissionRepoDir (entityKey $ tableEntrySubmission entry)
case mRepoDir of
Just repoDir -> do
outFile' <- liftIO $ lookForCompressedFiles (repoDir </> (T.unpack variant) <.> "tsv")
let outFile = takeFileName outFile'
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 spec = GEvalSpecification {
gesOutDirectory = repoDir,
gesExpectedDirectory = Nothing,
gesTestName = (T.unpack testSet),
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 = Nothing,
gesOutHeader = Nothing,
gesShowPreprocessed = True }
let testName = T.unpack testSet
result <- liftIO $ runLineByLineGeneralized FirstTheWorst spec (\_ -> CL.take maximumNumberOfItemsToBeShown)
return $ Just $ zip [1..] result
Nothing -> return Nothing
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 = Nothing,
gesOutHeader = Nothing,
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
else
return Nothing
$(widgetFile "view-output")
lineByLineTable :: Entity Test -> UTCTime -> Table.Table App (Int, LineRecord)
lineByLineTable :: Entity Test -> UTCTime -> Table.Table App (Int, DiffLineRecord)
lineByLineTable (Entity testId test) theStamp = mempty
++ Table.int "#" fst
++ theLimitedTextCell "input" (((\(LineRecord inp _ _ _ _) -> inp) . snd))
++ theLimitedTextCell "expected output" ((\(LineRecord _ expected _ _ _) -> expected) . snd)
++ theLimitedTextCell "actual output" ((\(LineRecord _ _ out _ _) -> out) . snd)
++ resultCell test (fakeEvaluation . (\(LineRecord _ _ _ _ score) -> score) . snd)
++ 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,
@ -420,15 +537,22 @@ getHttpLink repo = case guessGitServer bareUrl of
branch = repoBranch repo
convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
submissionHeader :: FullSubmissionInfo -> Maybe Text -> WidgetFor App ()
submissionHeader submission mVariantName =
submissionHeader :: Diff (FullSubmissionInfo, Maybe Text) -> WidgetFor App ()
submissionHeader param =
$(widgetFile "submission-header")
where commitSha1AsText = fromSHA1ToText $ submissionCommit $ fsiSubmission submission
submitter = formatSubmitter $ fsiUser submission
publicSubmissionBranch = getPublicSubmissionBranch $ fsiSubmissionId submission
publicSubmissionRepo = getReadOnlySubmissionUrl (fsiScheme submission) (fsiChallengeRepo submission) $ challengeName $ fsiChallenge submission
browsableUrl = browsableGitRepoBranch (fsiScheme submission) (fsiChallengeRepo submission) (challengeName $ fsiChallenge submission) publicSubmissionBranch
stamp = T.pack $ show $ submissionStamp $ fsiSubmission submission
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')
queryResult :: FullSubmissionInfo -> WidgetFor App ()
queryResult submission = do

19
Handler/Tables.hs
View File

@ -8,6 +8,8 @@ import Handler.Evaluate
import Handler.SubmissionView
import Handler.TagUtils
import Data.Diff
import qualified Yesod.Table as Table
import Yesod.Table (Table)
@ -185,15 +187,24 @@ textLimited limit t
| otherwise = (Data.Text.take limit t) <> "…"
where l = length t
textCellSoftLimit = 140
textCellHardLimit = 5 * textCellSoftLimit
limitedWidget softLimit hardLimit v =
[whamlet|<span title="#{textLimited hardLimit v}"><tt>#{textLimited softLimit v}</tt>|]
limitedTextCell :: Text -> Int -> Int -> (a -> Text) -> Table site a
limitedTextCell h softLimit hardLimit textFun = Table.widget h (
\v -> [whamlet|<span title="#{textLimited hardLimit $ textFun v}"><tt>#{textLimited softLimit $ textFun v}</tt>|])
\v -> limitedWidget softLimit hardLimit (textFun v))
theLimitedTextCell :: Text -> (a -> Text) -> Table site a
theLimitedTextCell h textFun = limitedTextCell h softLimit hardLimit textFun
where softLimit = 140
hardLimit = 5 * softLimit
theLimitedTextCell h textFun = limitedTextCell h textCellSoftLimit textCellHardLimit textFun
theLimitedDiffTextCell :: Text -> (a -> Diff Text) -> Table site a
theLimitedDiffTextCell h textFun = Table.widget h (
\v -> case textFun v of
OneThing u -> limitedWidget textCellSoftLimit textCellHardLimit u
d@(TwoThings _ _) -> [whamlet|#{d}|])
statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, Maybe UserId) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do

1
config/routes
View File

@ -42,6 +42,7 @@
/view-variant/#VariantId ViewVariantR GET
/view-variant-test/#VariantId/#TestId ViewVariantTestR GET
/view-variant-diff/#VariantId/#VariantId/#TestId ViewVariantDiffR GET
/api/txt/score/#Text ApiTxtScoreR GET

1
gonito.cabal
View File

@ -58,6 +58,7 @@ library
Handler.Evaluate
Data.SubmissionConditions
Gonito.ExtractMetadata
Data.Diff
if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT

2
templates/query-result.hamlet
View File

@ -3,7 +3,7 @@
<p class="media-object">
<span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
<div class="media-body">
^{submissionHeader submission Nothing}
^{submissionHeader (OneThing (submission, Nothing))}
^{resultTable (Entity (fsiSubmissionId submission) (fsiSubmission submission))}
$if not (null (fsiSuperSubmissions submission))

22
templates/submission-header.hamlet
View File

@ -1,36 +1,36 @@
<div class="media-heading">
<div .subm-commit>#{commitSha1AsText}
<div .subm-description>^{fragmentWithTags (submissionDescription $ fsiSubmission submission) (map fst $ fsiTags submission)}
<div .subm-description>^{fragmentWithTags (submissionDescription $ fsiSubmission $ current submission) (map fst $ fsiTags $ current submission)}
<p>&nbsp;</p>
<dl class="dl-horizontal">
<dt>challenge
<dd><a href="@{ShowChallengeR $ challengeName $ fsiChallenge submission}">#{challengeTitle $ fsiChallenge submission}</a>
<dd><a href="@{ShowChallengeR $ challengeName $ fsiChallenge $ current submission}">#{challengeTitle $ fsiChallenge $ current submission}</a>
<dt>submitter
<dd>#{submitter}
<dt>submitted
<dd>#{stamp}
<dt>original repo
<dd>
$maybe (url, branchPart) <- getHttpLink (fsiRepo submission)
<code><a href="#{url}">#{repoUrl $ fsiRepo submission}</code></a> / branch <a href="#{url <> branchPart}"><code>#{repoBranch $ fsiRepo submission}</code></a>
$maybe (url, branchPart) <- getHttpLink (fsiRepo $ current submission)
<code><a href="#{url}">#{repoUrl $ fsiRepo $ current submission}</code></a> / branch <a href="#{url <> branchPart}"><code>#{repoBranch $ fsiRepo $ current submission}</code></a>
$nothing
<code>#{repoUrl $ fsiRepo submission}</code> / branch <code>#{repoBranch $ fsiRepo submission}</code>
$if submissionIsPublic $ fsiSubmission submission
<code>#{repoUrl $ fsiRepo $ current submission}</code> / branch <code>#{repoBranch $ fsiRepo $ current submission}</code>
$if submissionIsPublic $ fsiSubmission $ current submission
<dt>publicly available at
<dd><code>#{publicSubmissionRepo}</code> / branch <code>#{publicSubmissionBranch}</code>
<dt>browsable at
<dd><a href="#{browsableUrl}">#{browsableUrl}</a>
<dd><a href="#{current browsableUrl}">#{current browsableUrl}</a>
<dt>clone by
<dd><code>git clone --single-branch #{publicSubmissionRepo} -b #{publicSubmissionBranch}</code>
$if not (null (fsiExternalLinks submission))
<dd><code>git clone --single-branch #{current publicSubmissionRepo} -b #{current publicSubmissionBranch}</code>
$if not (null (fsiExternalLinks $ current submission))
<dt>see also
<dd>
$forall (Entity _ externalLink) <- fsiExternalLinks submission
$forall (Entity _ externalLink) <- fsiExternalLinks $ current submission
<a href="#{externalLinkUrl externalLink}">
#{fromMaybe (externalLinkUrl externalLink) (externalLinkTitle externalLink)}
<br>
$maybe variant <- mVariantName
$maybe variant <- runDiff variantSettings mVariantName
<dt>file basename
<dd><tt>#{variant}</tt>
$nothing

9
templates/view-variant.hamlet
View File

@ -3,12 +3,13 @@
<p class="media-object">
<span class="glyphicon glyphicon-asterisk" aria-hidden="hidden">
<div class="media-body">
^{submissionHeader fullSubmissionInfo (Just $ variantName variant)}
^{submissionHeader fullSubmissionInfo}
$case tableEntryParams entry
$of []
$case tableEntryParams <$> entry
$of OneThing []
$of TwoThings [] []
$of _
^{Table.buildBootstrap paramsTable (map entityVal $ tableEntryParams entry)}
^{Table.buildBootstrap paramsTable (mergeEntryParams $ map entityVal <$> (tableEntryParams <$> entry))}
$forall output <- outputs
^{viewOutputWithNonDefaultTestSelected entry tests testSelectedEnt output}