Improve generating browsable links

This commit is contained in:
Filip Gralinski 2021-06-16 08:06:28 +02:00
parent 8677a9249b
commit ae933093dc
3 changed files with 40 additions and 23 deletions

View File

@ -683,25 +683,6 @@ adjustNumberOfColumnsShown maximumNumberOfColumns tests = adjustNumberOfColumnsS
minimumNumberOfTests = 2 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 :: Diff (FullSubmissionInfo, Maybe Text) -> WidgetFor App ()
submissionHeader param = submissionHeader param =

View File

@ -376,10 +376,46 @@ showChallengeWidget mUserEnt
higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests higherTheBetterArray = getIsHigherTheBetterArray $ map entityVal tests
mUserId = entityKey <$> mUserEnt mUserId = entityKey <$> mUserEnt
getRepoLink :: Repo -> Maybe Text data GitServer = Gogs | GitLab | GitHub | Gonito
getRepoLink repo deriving (Eq, Show)
| sitePrefix `isPrefixOf` theUrl = Just $ (browsableGitRepo bareRepoName) ++ "/" ++ (repoBranch repo)
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 | 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 where sitePrefix = "git://gonito.net/" :: Text
sitePrefixLen = length sitePrefix sitePrefixLen = length sitePrefix
theUrl = repoUrl repo theUrl = repoUrl repo

View File

@ -1,6 +1,6 @@
<p> Git repo URL: <tt>#{repoUrl repo}</tt> / Branch: <tt> #{repoBranch repo}</tt> <p> Git repo URL: <tt>#{repoUrl repo}</tt> / Branch: <tt> #{repoBranch repo}</tt>
$maybe repoLink <- maybeRepoLink $maybe repoLink <- maybeRepoLink
(Browse at <tt><a href="#{repoLink}">#{repoLink}</a></tt>) Browse at <tt><a href="#{repoLink}">#{repoLink}</a></tt>
$nothing $nothing
$if (challengeArchived challenge == Just True) $if (challengeArchived challenge == Just True)