Fix links to public submissions

Handler/Query.hs

@@ -756,6 +756,25 @@ submissionHeader :: Maybe UserId -> Diff (FullSubmissionInfo, Maybe Text) -> Wid
 submissionHeader mUserId param = do
   showFullInfo <- handlerToWidget $ runDB $ canFullInfoBeShown param mUserId
 
+  app <- getYesod
+  let repoHost = appRepoHost $ appSettings app
+  let submissionToSubmissionUrl submission'
+        = getReadOnlySubmissionUrl (fsiScheme submission')
+                                   repoHost
+                                   (fsiChallengeRepo submission')
+                                   (challengeName $ fsiChallenge submission')
+  let publicSubmissionRepo = submissionToSubmissionUrl <$> submission
+
+  let submissionToBrowsableUrl submission'
+        = browsableGitRepoBranch (fsiScheme submission')
+                                 repoHost
+                                 (fsiChallengeRepo submission')
+                                 (challengeName $ fsiChallenge submission')
+                                 (getPublicSubmissionBranch $ fsiSubmissionId submission')
+
+  let browsableUrl = submissionToBrowsableUrl <$> submission
+
+
   $(widgetFile "submission-header")
     where variantSettings = ("out", ())
           submission = fst <$> param
@@ -763,12 +782,8 @@ submissionHeader mUserId param = do
           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 :: Maybe UserId -> FullSubmissionInfo -> WidgetFor App ()
 queryResult mUserId submission = do

Handler/Shared.hs

@@ -80,15 +80,22 @@ getPublicSubmissionUrl SelfHosted repoHost _ bareRepoName = repoHost ++ bareRepo
 getPublicSubmissionUrl Branches _ (Just repo) _ = repoUrl repo
 getPublicSubmissionUrl NoInternalGitServer repoHost _ bareRepoName = repoHost ++ bareRepoName
 
-getReadOnlySubmissionUrl :: RepoScheme -> Repo -> Text -> Text
-getReadOnlySubmissionUrl SelfHosted _ bareRepoName = gitReadOnlyServer ++ bareRepoName
-getReadOnlySubmissionUrl Branches repo _ = repoUrl repo
-getReadOnlySubmissionUrl NoInternalGitServer repo _ = repoUrl repo
+-- convert a git URL to a publicly available URL
+publicRepoUrl :: Text -> Text
+publicRepoUrl = T.replace "git@github.com:" "https://github.com/"
+                . T.replace "git@gitlab.com:" "https://gitlab.com/"
 
-browsableGitRepoBranch :: RepoScheme -> Repo -> Text -> Text -> Text
-browsableGitRepoBranch SelfHosted _ bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
-browsableGitRepoBranch Branches repo _ branch = sshToHttps (repoUrl repo) branch
-browsableGitRepoBranch NoInternalGitServer repo _ branch = sshToHttps (repoUrl repo) branch
+getReadOnlySubmissionUrl :: RepoScheme -> Text -> Repo -> Text -> Text
+getReadOnlySubmissionUrl SelfHosted _ _ bareRepoName = gitReadOnlyServer ++ bareRepoName
+getReadOnlySubmissionUrl Branches _ repo _ = repoUrl repo
+getReadOnlySubmissionUrl NoInternalGitServer repoHost _ bareRepoName = publicRepoUrl (repoHost ++ bareRepoName)
+
+browsableGitRepoBranch :: RepoScheme -> Text -> Repo -> Text -> Text -> Text
+browsableGitRepoBranch SelfHosted _ _ bareRepoName branch = (browsableGitRepo bareRepoName) ++ "/" ++ branch ++ "/"
+browsableGitRepoBranch Branches _ repo _ branch = sshToHttps (repoUrl repo) branch
+browsableGitRepoBranch NoInternalGitServer repoHost repo _ branch
+  = sshToHttps (getPublicSubmissionUrl NoInternalGitServer repoHost (Just repo) branch)
+               branch
 
 sshToHttps :: Text -> Text -> Text
 sshToHttps url branch = "https://" ++ (T.replace ".git" "" $ T.replace ":" "/" $ T.replace "ssh://" "" $ T.replace "git@" "" url) ++ "/tree/" ++ branch

Handler/Tables.hs

@@ -287,16 +287,21 @@ statusCellWidget :: Text -> RepoScheme -> Repo -> (SubmissionId, Submission, Var
 statusCellWidget challengeName repoScheme challengeRepo (submissionId, submission, variantId, _, mauthId) = do
   isReevaluable <- handlerToWidget $ runDB $ canBeReevaluated submissionId
   let isVisible = True
+
+  app <- getYesod
+  let repoHost = appRepoHost $ appSettings app
+
+  let maybeBrowsableUrl = if isPublic
+                                then
+                                  Just $ browsableGitRepoBranch repoScheme repoHost challengeRepo challengeName publicSubmissionBranch
+                                else
+                                  Nothing
+
   $(widgetFile "submission-status")
     where commitHash = fromSHA1ToText $ submissionCommit submission
           isPublic = submissionIsPublic submission
           isOwner = (mauthId == Just (submissionSubmitter submission))
           publicSubmissionBranch = getPublicSubmissionBranch submissionId
-          maybeBrowsableUrl = if isPublic
-                                then
-                                  Just $ browsableGitRepoBranch repoScheme challengeRepo challengeName publicSubmissionBranch
-                                else
-                                  Nothing
 
 getInfoLink :: Submission -> Maybe UserId -> Maybe (Route App)
 getInfoLink submission _ = Just $ QueryResultsR commitHash