diff --git a/Handler/Presentation.hs b/Handler/Presentation.hs index f406593..754cdae 100644 --- a/Handler/Presentation.hs +++ b/Handler/Presentation.hs @@ -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 diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 2d0a356..2a1085f 100644 --- a/Handler/Shared.hs +++ b/Handler/Shared.hs @@ -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 diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index 2cbd43e..73229f1 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -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 diff --git a/Handler/SubmissionView.hs b/Handler/SubmissionView.hs index 6942201..f352e35 100644 --- a/Handler/SubmissionView.hs +++ b/Handler/SubmissionView.hs @@ -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 diff --git a/Handler/Tables.hs b/Handler/Tables.hs index 8a7ef36..dc55828 100644 --- a/Handler/Tables.hs +++ b/Handler/Tables.hs @@ -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 diff --git a/templates/challenge-all-submissions.hamlet b/templates/challenge-all-submissions.hamlet index f446d8a..260b701 100644 --- a/templates/challenge-all-submissions.hamlet +++ b/templates/challenge-all-submissions.hamlet @@ -1,7 +1,7 @@