showing submissions correctly in "branches" mode

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

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 :: RepoScheme -> Repo -> Text -> Text
-getReadOnlySubmissionUrl bareRepoName = gitReadOnlyServer ++ bareRepoName
+getReadOnlySubmissionUrl SelfHosted _ bareRepoName = gitReadOnlyServer ++ bareRepoName
+getReadOnlySubmissionUrl Branches repo _ = repoUrl repo
 
-browsableGitRepoBranch :: Text -> Text -> Text
+browsableGitRepoBranch :: RepoScheme -> Repo -> Text -> Text -> Text
-browsableGitRepoBranch bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
+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

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

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
+          publicSubmissionRepo = getReadOnlySubmissionUrl (fsiScheme submission) (fsiChallengeRepo submission) $ challengeName $ fsiChallenge submission
-          browsableUrl = browsableGitRepoBranch (challengeName $ fsiChallenge submission) publicSubmissionBranch
+          browsableUrl = browsableGitRepoBranch (fsiScheme submission) (fsiChallengeRepo submission) (challengeName $ fsiChallenge submission) publicSubmissionBranch
           stamp = T.pack $ show $ submissionStamp $ fsiSubmission submission
 
 getTags submissionId = do

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 :: Maybe UserId -> Text -> RepoScheme -> Repo -> [Entity Test] -> Table App (Entity Submission, Entity User, Map (Key Test) Evaluation, [(Entity Tag, Entity SubmissionTag)])
-submissionsTable mauthId challengeName tests = mempty
+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 :: Maybe UserId -> Text -> RepoScheme -> Repo -> Test -> Table App (Int, LeaderboardEntry)
-leaderboardTable mauthId challengeName test = mempty
+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 :: Text -> RepoScheme -> Repo -> (a -> (SubmissionId, Submission, UserId, Maybe UserId)) -> Table App a
-statusCell challengeName fun = Table.widget "" (statusCellWidget challengeName . fun)
+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
 

templates/challenge-all-submissions.hamlet

@@ -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">
 

templates/presentation-4real.hamlet

@@ -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>

templates/show-challenge.hamlet

@@ -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">