From ae933093dc2426ae8342185bbfcfa971e569d2d1 Mon Sep 17 00:00:00 2001
From: Filip Gralinski <filipg@amu.edu.pl>
Date: Wed, 16 Jun 2021 08:06:28 +0200
Subject: [PATCH] Improve generating browsable links

---
 Handler/Query.hs                | 19 ---------------
 Handler/ShowChallenge.hs        | 42 ++++++++++++++++++++++++++++++---
 templates/show-challenge.hamlet |  2 +-
 3 files changed, 40 insertions(+), 23 deletions(-)

diff --git a/Handler/Query.hs b/Handler/Query.hs
index 75c2785..7f94703 100644
--- a/Handler/Query.hs
+++ b/Handler/Query.hs
@@ -683,25 +683,6 @@ adjustNumberOfColumnsShown maximumNumberOfColumns tests = adjustNumberOfColumnsS
 
         minimumNumberOfTests = 2
 
-data GitServer = Gogs | GitLab
-  deriving (Eq, Show)
-
-guessGitServer :: Text -> Maybe GitServer
-guessGitServer bareUrl
-  | "git.wmi.amu.edu.pl" `isPrefixOf` bareUrl = Just Gogs
-  | "gitlab." `isPrefixOf` bareUrl = Just GitLab
-  | "git." `isPrefixOf` bareUrl = Just GitLab
-  | otherwise = Nothing
-
-getHttpLink :: Repo -> Maybe (Text, Text)
-getHttpLink repo = case guessGitServer bareUrl of
-  Just Gogs -> Just (convertToHttpLink bareUrl, "/src/" <> branch)
-  Just GitLab -> Just (convertToHttpLink bareUrl, "/-/tree/" <> branch)
-  Nothing -> Nothing
-  where bareUrl = T.replace "git@" "" url
-        url = repoUrl repo
-        branch = repoBranch repo
-        convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
 
 submissionHeader :: Diff (FullSubmissionInfo, Maybe Text) -> WidgetFor App ()
 submissionHeader param =
diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs
index c205788..680db8a 100644
--- a/Handler/ShowChallenge.hs
+++ b/Handler/ShowChallenge.hs
@@ -376,10 +376,46 @@ showChallengeWidget mUserEnt
         higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
         mUserId = entityKey <$> mUserEnt
 
-getRepoLink :: Repo -> Maybe Text
-getRepoLink repo
-  | sitePrefix `isPrefixOf` theUrl = Just $ (browsableGitRepo bareRepoName) ++ "/" ++ (repoBranch repo)
+data GitServer = Gogs | GitLab | GitHub | Gonito
+  deriving (Eq, Show)
+
+guessGitServer :: Text -> Maybe GitServer
+guessGitServer bareUrl
+  | "git.wmi.amu.edu.pl" `isPrefixOf` bareUrl = Just Gogs
+  | "gitlab." `isPrefixOf` bareUrl = Just GitLab
+  | "git." `isPrefixOf` bareUrl = Just GitLab
+  | "github." `isPrefixOf` bareUrl = Just GitHub
+  | "gonito.net" `isPrefixOf` bareUrl = Just Gonito
   | otherwise = Nothing
+
+getHttpLink :: Repo -> Maybe (Text, Text)
+getHttpLink repo = case guessGitServer bareUrl of
+  Just Gogs -> Just (convertToHttpLink bareUrl, "/src/" <> branch)
+  Just GitLab -> Just (convertToHttpLink bareUrl, "/-/tree/" <> branch)
+  Just GitHub -> Just (convertToHttpLink bareUrl, "/tree/" <> branch)
+  Just Gonito -> Just (fixGonito $ convertToHttpLink bareUrl, "/" <> branch)
+  Nothing -> Nothing
+  where bareUrl = removeProtocol $ removeLogin rurl
+        removeLogin t = r
+          where (_, r) = T.breakOnEnd "@" t
+        rurl = repoUrl repo
+        branch = repoBranch repo
+        convertToHttpLink = ("https://" <>) . (T.replace ":" "/") . (T.replace ".git" "")
+        removeProtocol = stripPrefixes ["https://", "http://", "git://", "ssh://",
+                                        "ssh." -- when a domain with ssh. prefix is used
+                                       ]
+        stripPrefixes prefixes t = foldr stripPrefixFrom t prefixes
+        stripPrefixFrom pref t = if pref `isPrefixOf` t
+                                   then drop (length pref) t
+                                   else t
+        fixGonito t = T.replace "https://gonito.net" "https://gonito.net/gitlist" t
+
+getRepoLink :: Repo -> Maybe Text
+getRepoLink repo = case getHttpLink repo of
+  Just (hostname, linkRest) -> Just $ hostname <> linkRest
+  Nothing -> if sitePrefix `isPrefixOf` theUrl
+            then Just $ (browsableGitRepo bareRepoName) ++ "/" ++ (repoBranch repo)
+            else Nothing
   where sitePrefix = "git://gonito.net/" :: Text
         sitePrefixLen = length sitePrefix
         theUrl = repoUrl repo
diff --git a/templates/show-challenge.hamlet b/templates/show-challenge.hamlet
index 18a7ed6..a35cdc6 100644
--- a/templates/show-challenge.hamlet
+++ b/templates/show-challenge.hamlet
@@ -1,6 +1,6 @@
 <p> Git repo URL: <tt>#{repoUrl repo}</tt> / Branch: <tt> #{repoBranch repo}</tt>
 $maybe repoLink  <- maybeRepoLink
-  (Browse at <tt><a href="#{repoLink}">#{repoLink}</a></tt>)
+  Browse at <tt><a href="#{repoLink}">#{repoLink}</a></tt>
 $nothing
 
 $if (challengeArchived challenge == Just True)