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

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

View File

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

View File

@ -8,6 +8,8 @@ import Handler.Evaluate
import Handler.SubmissionView import Handler.SubmissionView
import Handler.TagUtils import Handler.TagUtils
import Data.Diff
import qualified Yesod.Table as Table import qualified Yesod.Table as Table
import Yesod.Table (Table) import Yesod.Table (Table)
@ -185,15 +187,24 @@ textLimited limit t
| otherwise = (Data.Text.take limit t) <> "" | otherwise = (Data.Text.take limit t) <> ""
where l = length 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 :: Text -> Int -> Int -> (a -> Text) -> Table site a
limitedTextCell h softLimit hardLimit textFun = Table.widget h ( 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 :: Text -> (a -> Text) -> Table site a
theLimitedTextCell h textFun = limitedTextCell h softLimit hardLimit textFun theLimitedTextCell h textFun = limitedTextCell h textCellSoftLimit textCellHardLimit textFun
where softLimit = 140
hardLimit = 5 * softLimit
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 :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, VariantId, Variant, Maybe UserId) -> WidgetFor App ()
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do

View File

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

View File

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

View File

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

View File

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

View File

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