forked from filipg/gonito
showing submissions correctly in "branches" mode
This commit is contained in:
parent
115df0521d
commit
a9de751d87
@ -40,6 +40,11 @@ getPresentation4RealR = do
|
||||
sampleLeaderboard <- getSampleLeaderboard sampleChallengeName
|
||||
sampleLeaderboard' <- getSampleLeaderboard sampleChallengeName'
|
||||
|
||||
app <- getYesod
|
||||
let scheme = appRepoScheme $ appSettings app
|
||||
|
||||
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
||||
|
||||
presentationLayout $(widgetFile "presentation-4real")
|
||||
|
||||
getPresentationDATeCH2017R = do
|
||||
@ -56,7 +61,12 @@ getSampleLeaderboard name = do
|
||||
(test, leaderboard) <- getLeaderboardEntries challengeId
|
||||
let leaderboardWithRanks = zip [1..] (take 10 leaderboard)
|
||||
|
||||
return $ Table.buildBootstrap (leaderboardTable Nothing (challengeName challenge) test) leaderboardWithRanks
|
||||
app <- getYesod
|
||||
let scheme = appRepoScheme $ appSettings app
|
||||
|
||||
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
||||
|
||||
return $ Table.buildBootstrap (leaderboardTable Nothing (challengeName challenge) scheme challengeRepo test) leaderboardWithRanks
|
||||
|
||||
presentationLayout widget = do
|
||||
master <- getYesod
|
||||
|
||||
@ -66,11 +66,15 @@ getPublicSubmissionUrl :: RepoScheme -> Maybe Repo -> Text -> Text
|
||||
getPublicSubmissionUrl SelfHosted _ bareRepoName = gitServer ++ bareRepoName
|
||||
getPublicSubmissionUrl Branches (Just repo) _ = repoUrl repo
|
||||
|
||||
getReadOnlySubmissionUrl :: Text -> Text
|
||||
getReadOnlySubmissionUrl bareRepoName = gitReadOnlyServer ++ bareRepoName
|
||||
getReadOnlySubmissionUrl :: RepoScheme -> Repo -> Text -> Text
|
||||
getReadOnlySubmissionUrl SelfHosted _ bareRepoName = gitReadOnlyServer ++ bareRepoName
|
||||
getReadOnlySubmissionUrl Branches repo _ = repoUrl repo
|
||||
|
||||
browsableGitRepoBranch :: Text -> Text -> Text
|
||||
browsableGitRepoBranch bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
|
||||
browsableGitRepoBranch :: RepoScheme -> Repo -> Text -> Text -> Text
|
||||
browsableGitRepoBranch SelfHosted _ bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
|
||||
browsableGitRepoBranch Branches repo _ branch = sshToHttps (repoUrl repo) branch
|
||||
|
||||
sshToHttps url branch = "https://" ++ (T.replace ".git" "" $ T.replace ":" "/" $ T.replace "ssh://git@" "" url) ++ "/tree/" ++ branch
|
||||
|
||||
browsableGitRepo :: Text -> Text
|
||||
browsableGitRepo bareRepoName
|
||||
|
||||
@ -42,7 +42,13 @@ getShowChallengeR name = do
|
||||
(mainTest, leaderboard) <- getLeaderboardEntries challengeId
|
||||
mauth <- maybeAuth
|
||||
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
||||
challengeLayout True challenge (showChallengeWidget muserId challenge mainTest repo leaderboard)
|
||||
|
||||
app <- getYesod
|
||||
let scheme = appRepoScheme $ appSettings app
|
||||
|
||||
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
||||
|
||||
challengeLayout True challenge (showChallengeWidget muserId challenge scheme challengeRepo mainTest repo leaderboard)
|
||||
|
||||
getChallengeReadmeR :: Text -> Handler Html
|
||||
getChallengeReadmeR name = do
|
||||
@ -58,7 +64,7 @@ challengeReadme name = do
|
||||
contents <- liftIO $ System.IO.readFile readmeFilePath
|
||||
return $ markdown def $ TL.pack contents
|
||||
|
||||
showChallengeWidget muserId challenge test repo leaderboard = $(widgetFile "show-challenge")
|
||||
showChallengeWidget muserId challenge scheme challengeRepo test repo leaderboard = $(widgetFile "show-challenge")
|
||||
where leaderboardWithRanks = zip [1..] leaderboard
|
||||
maybeRepoLink = getRepoLink repo
|
||||
|
||||
@ -409,9 +415,15 @@ getChallengeSubmissions condition name = do
|
||||
(evaluationMaps, tests) <- getChallengeSubmissionInfos condition challengeId
|
||||
mauth <- maybeAuth
|
||||
let muserId = (\(Entity uid _) -> uid) <$> mauth
|
||||
challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge evaluationMaps tests)
|
||||
|
||||
challengeAllSubmissionsWidget muserId challenge submissions tests = $(widgetFile "challenge-all-submissions")
|
||||
app <- getYesod
|
||||
let scheme = appRepoScheme $ appSettings app
|
||||
|
||||
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
||||
|
||||
challengeLayout True challenge (challengeAllSubmissionsWidget muserId challenge scheme challengeRepo evaluationMaps tests)
|
||||
|
||||
challengeAllSubmissionsWidget muserId challenge scheme challengeRepo submissions tests = $(widgetFile "challenge-all-submissions")
|
||||
|
||||
challengeLayout withHeader challenge widget = do
|
||||
tagsAvailableAsJSON <- runDB $ getAvailableTagsAsJSON
|
||||
|
||||
@ -11,27 +11,37 @@ data FullSubmissionInfo = FullSubmissionInfo {
|
||||
fsiSubmission :: Submission,
|
||||
fsiUser :: User,
|
||||
fsiRepo :: Repo,
|
||||
fsiChallenge :: Challenge }
|
||||
fsiChallenge :: Challenge,
|
||||
fsiChallengeRepo :: Repo,
|
||||
fsiScheme :: RepoScheme}
|
||||
|
||||
getFullInfo :: Entity Submission -> Handler FullSubmissionInfo
|
||||
getFullInfo (Entity submissionId submission) = do
|
||||
repo <- runDB $ get404 $ submissionRepo submission
|
||||
user <- runDB $ get404 $ submissionSubmitter submission
|
||||
challenge <- runDB $ get404 $ submissionChallenge submission
|
||||
challengeRepo <- runDB $ get404 $ challengePublicRepo challenge
|
||||
|
||||
app <- getYesod
|
||||
let scheme = appRepoScheme $ appSettings app
|
||||
|
||||
return $ FullSubmissionInfo {
|
||||
fsiSubmissionId = submissionId,
|
||||
fsiSubmission = submission,
|
||||
fsiUser = user,
|
||||
fsiRepo = repo,
|
||||
fsiChallenge = challenge }
|
||||
fsiChallenge = challenge,
|
||||
fsiChallengeRepo = challengeRepo,
|
||||
fsiScheme = scheme}
|
||||
|
||||
|
||||
queryResult submission = do
|
||||
$(widgetFile "query-result")
|
||||
where commitSha1AsText = fromSHA1ToText $ submissionCommit $ fsiSubmission submission
|
||||
submitter = formatSubmitter $ fsiUser submission
|
||||
publicSubmissionBranch = getPublicSubmissionBranch $ fsiSubmissionId submission
|
||||
publicSubmissionRepo = getReadOnlySubmissionUrl $ challengeName $ fsiChallenge submission
|
||||
browsableUrl = browsableGitRepoBranch (challengeName $ fsiChallenge submission) publicSubmissionBranch
|
||||
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
|
||||
|
||||
getTags submissionId = do
|
||||
|
||||
@ -32,13 +32,13 @@ data LeaderboardEntry = LeaderboardEntry {
|
||||
leaderboardTags :: [(Entity Tag, Entity SubmissionTag)]
|
||||
}
|
||||
|
||||
submissionsTable :: Maybe UserId -> Text -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])
|
||||
submissionsTable mauthId challengeName tests = mempty
|
||||
submissionsTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])
|
||||
submissionsTable mauthId challengeName repoScheme challengeRepo tests = mempty
|
||||
++ Table.text "submitter" (formatSubmitter . (\(_, Entity _ submitter, _, _) -> submitter))
|
||||
++ timestampCell "when" (submissionStamp . (\(Entity _ s, _, _, _) -> s))
|
||||
++ descriptionCell
|
||||
++ mconcat (map (\(Entity k t) -> resultCell t (extractScore k)) tests)
|
||||
++ statusCell challengeName (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
|
||||
++ statusCell challengeName repoScheme challengeRepo (\(Entity submissionId submission, Entity userId _, _, _) -> (submissionId, submission, userId, mauthId))
|
||||
|
||||
descriptionCell = Table.widget "description" (
|
||||
\(Entity _ s, _, _ ,tagEnts) -> fragmentWithSubmissionTags (submissionDescription s) tagEnts)
|
||||
@ -46,15 +46,15 @@ descriptionCell = Table.widget "description" (
|
||||
extractScore :: Key Test -> (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)]) -> Maybe Evaluation
|
||||
extractScore k (_, _, m, _) = lookup k m
|
||||
|
||||
leaderboardTable :: Maybe UserId -> Text -> Test -> Table App (Int, LeaderboardEntry)
|
||||
leaderboardTable mauthId challengeName test = mempty
|
||||
leaderboardTable :: Maybe UserId -> Text -> RepoScheme -> Repo -> Test -> Table App (Int, LeaderboardEntry)
|
||||
leaderboardTable mauthId challengeName repoScheme challengeRepo test = mempty
|
||||
++ Table.int "#" fst
|
||||
++ Table.text "submitter" (formatSubmitter . leaderboardUser . snd)
|
||||
++ timestampCell "when" (submissionStamp . leaderboardBestSubmission . snd)
|
||||
++ leaderboardDescriptionCell
|
||||
++ resultCell test ((\e -> Just e) . leaderboardEvaluation . snd)
|
||||
++ Table.int "×" (leaderboardNumberOfSubmissions . snd)
|
||||
++ statusCell challengeName (\(_, e) -> (leaderboardBestSubmissionId e,
|
||||
++ statusCell challengeName repoScheme challengeRepo (\(_, e) -> (leaderboardBestSubmissionId e,
|
||||
leaderboardBestSubmission e,
|
||||
leaderboardUserId e,
|
||||
mauthId))
|
||||
@ -72,13 +72,13 @@ timestampCell :: Text -> (a -> UTCTime) -> Table site a
|
||||
timestampCell h timestampFun = hoverTextCell h (Data.Text.pack . shorterFormat . timestampFun) (Data.Text.pack . show . timestampFun)
|
||||
where shorterFormat = formatTime defaultTimeLocale "%Y-%m-%d %H:%M"
|
||||
|
||||
statusCell :: Text -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a
|
||||
statusCell challengeName fun = Table.widget "" (statusCellWidget challengeName . fun)
|
||||
statusCell :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a
|
||||
statusCell challengeName repoScheme challengeRepo fun = Table.widget "" (statusCellWidget challengeName repoScheme challengeRepo . fun)
|
||||
|
||||
resultCell :: Test -> (a -> Maybe Evaluation) -> Table App a
|
||||
resultCell test fun = hoverTextCell ((testName test) ++ "/" ++ (Data.Text.pack $ show $ testMetric test)) (formatTruncatedScore (testPrecision test) . fun) (formatFullScore . fun)
|
||||
|
||||
statusCellWidget challengeName (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
|
||||
statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, userId, mauthId) = $(widgetFile "submission-status")
|
||||
where commitHash = fromSHA1ToText $ submissionCommit submission
|
||||
isPublic = submissionIsPublic submission
|
||||
isOwner = (mauthId == Just userId)
|
||||
@ -86,7 +86,7 @@ statusCellWidget challengeName (submissionId, submission, userId, mauthId) = $(w
|
||||
publicSubmissionBranch = getPublicSubmissionBranch submissionId
|
||||
maybeBrowsableUrl = if isPublic
|
||||
then
|
||||
Just $ browsableGitRepoBranch challengeName publicSubmissionBranch
|
||||
Just $ browsableGitRepoBranch repoScheme challengeRepo challengeName publicSubmissionBranch
|
||||
else
|
||||
Nothing
|
||||
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
<div class="alert alert-info" role="alert">
|
||||
<p>This is a long list of all submissions, if you want to see only the best, click <a href="@{ShowChallengeR (challengeName challenge)}">leaderboard</a>.
|
||||
|
||||
^{Table.buildBootstrap (submissionsTable muserId (challengeName challenge) tests) submissions}
|
||||
^{Table.buildBootstrap (submissionsTable muserId (challengeName challenge) scheme challengeRepo tests) submissions}
|
||||
|
||||
<div id="graph-container">
|
||||
|
||||
|
||||
@ -131,7 +131,7 @@
|
||||
<h2>… and see your results
|
||||
|
||||
<div style="font-size: 50%">
|
||||
^{Table.buildBootstrap (submissionsTable Nothing (challengeName challenge) tests) evaluationMaps}
|
||||
^{Table.buildBootstrap (submissionsTable Nothing (challengeName challenge) scheme challengeRepo tests) evaluationMaps}
|
||||
|
||||
<div class="step slide" data-x="2000" data-y="5000">
|
||||
<h2>Be open!</h2>
|
||||
|
||||
@ -5,7 +5,7 @@ $nothing
|
||||
|
||||
<h2>Leaderboard
|
||||
|
||||
^{Table.buildBootstrap (leaderboardTable muserId (challengeName challenge) test) leaderboardWithRanks}
|
||||
^{Table.buildBootstrap (leaderboardTable muserId (challengeName challenge) scheme challengeRepo test) leaderboardWithRanks}
|
||||
|
||||
<div id="graph-container">
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user