feat: support for codeberg host

Close #100

Author: guibou

app/Main.hs

@@ -42,6 +42,17 @@ githubKeyToParse =
           )
     )
 
+codebergKeyToParse :: Opt.Parser (Maybe CodebergKey)
+codebergKeyToParse =
+  optional
+    ( CodebergKey
+        <$> Opt.strOption
+          ( Opt.long "issuetracker-codebergkey"
+              <> Opt.metavar "PERSONAL_CODEBERG_KEY"
+              <> Opt.help "A codeberg developer key to allow for more API calls or access to private codeberg repo for the IssueTracker checker"
+          )
+    )
+
 parseGitlabKey :: Opt.ReadM (GitlabHost, GitlabKey)
 parseGitlabKey = Opt.eitherReader $ \(Text.pack -> s) -> case scan [re|^([^=]+)=(.+)$|] s of
   [(_, [x, y])] -> Right (GitlabHost x, GitlabKey y)
@@ -80,6 +91,7 @@ optionsParser =
     <*> ( KrankConfig
             <$> githubKeyToParse
             <*> gitlabKeyToParse
+            <*> codebergKeyToParse
             <*> Opt.switch
               ( Opt.long "dry-run"
                   <> Opt.help "Perform a dry run. Parse file, but do not execute HTTP requests"

src/Krank/Checkers/IssueTracker.hs

@@ -34,7 +34,7 @@ import qualified Text.Regex.PCRE.Heavy as RE
 import Utils.Github (showGithubException)
 import Utils.Gitlab (showGitlabException)
 
-data GitServer = Github | Gitlab GitlabHost
+data GitServer = Github | Gitlab GitlabHost | Codeberg
   deriving (Eq, Show)
 
 data IssueStatus = Open | Closed deriving (Eq, Show)
@@ -58,6 +58,7 @@ serverDomain ::
   GitServer ->
   Text
 serverDomain Github = "github.com"
+serverDomain Codeberg = "codeberg.org"
 serverDomain (Gitlab (GitlabHost h)) = h
 
 -- | This regex represents a github/gitlab issue URL
@@ -75,6 +76,7 @@ extractIssuesOnALine lineContent = map f (RE.scan gitRepoRe lineContent)
         colNo = 1 + ByteString.length (fst $ ByteString.breakSubstring match lineContent)
         provider
           | domain == "github.com" = Github
+          | domain == "codeberg.org" = Codeberg
           -- TODO: We suppose that all other cases are gitlab
           -- The only thing we risk here is a query with the wrong
           -- API to an irrelevant host.
@@ -109,6 +111,7 @@ issueUrl ::
   Req.Url 'Req.Https
 issueUrl issue = case server issue of
   Github -> Req.https "api.github.com" Req./: "repos" Req./: owner issue Req./: repo issue Req./: "issues" Req./~ issueNum issue
+  Codeberg -> Req.https "codeberg.org" Req./: "api" Req./: "v1" Req./: "repos" Req./: owner issue Req./: repo issue Req./: "issues" Req./~ issueNum issue
   Gitlab (GitlabHost host) -> Req.https host Req./: "api" Req./: "v4" Req./: "projects" Req./: [fmt|{owner issue}/{repo issue}|] Req./: "issues" Req./~ issueNum issue
 
 -- try Issue can fail, on non-2xx HTTP response
@@ -129,10 +132,14 @@ headersFor ::
 headersFor issue = do
   mGithubKey <- krankAsks githubKey
   mGitlabKeys <- krankAsks gitlabKeys
+  mCodebergKey <- krankAsks codebergKey
   case server issue of
     Github -> case mGithubKey of
       Just (GithubKey token) -> pure $ Req.oAuth2Token (Text.Encoding.encodeUtf8 token)
       Nothing -> pure mempty
+    Codeberg -> case mCodebergKey of
+      Just (CodebergKey token) -> pure $ Req.oAuth2Token (Text.Encoding.encodeUtf8 token)
+      Nothing -> pure mempty
     Gitlab host -> case Map.lookup host mGitlabKeys of
       Just (GitlabKey token) -> pure $ Req.header "PRIVATE-TOKEN" (Text.Encoding.encodeUtf8 token)
       Nothing -> pure mempty
@@ -150,6 +157,7 @@ showGitServerException ::
   Req.HttpException ->
   Text
 showGitServerException Github exc = showGithubException exc
+showGitServerException Codeberg exc = showGithubException exc
 showGitServerException (Gitlab _) exc = showGitlabException exc
 
 restIssue ::

src/Krank/Types.hs

@@ -2,6 +2,7 @@
 
 module Krank.Types
   ( GithubKey (..),
+    CodebergKey(..),
     GitlabHost (..),
     GitlabKey (..),
     Violation (..),
@@ -22,6 +23,8 @@ import qualified Network.HTTP.Req as Req
 
 newtype GithubKey = GithubKey Text deriving (Show)
 
+newtype CodebergKey = CodebergKey Text deriving (Show)
+
 newtype GitlabKey = GitlabKey Text deriving (Show)
 
 newtype GitlabHost = GitlabHost Text deriving (Show, Ord, Eq)
@@ -61,6 +64,8 @@ data KrankConfig = KrankConfig
     githubKey :: Maybe GithubKey,
     -- | The gitlab oAuth token
     gitlabKeys :: Map GitlabHost GitlabKey,
+    -- | The codeberg host token
+    codebergKey :: Maybe CodebergKey,
     -- | If 'True', all IO operations, such as HTTP requests, are ignored
     dryRun :: Bool,
     -- | Use color for formatting