{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
module GitLab.API.Projects where
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types.URI
import Network.HTTP.Types.Status
import UnliftIO.Async
import GitLab.API.Commits
import GitLab.API.Issues
import GitLab.API.Members
import GitLab.API.Pipelines
import GitLab.API.Users
import GitLab.Types
import GitLab.WebRequests.GitLabWebCalls
allProjects :: (MonadIO m) => GitLab m [Project]
allProjects =
gitlabWithAttrs "/projects" "&statistics=true"
projectForks :: (MonadUnliftIO m, MonadIO m)
=> Text
-> GitLab m [Project]
projectForks projectName = do
let urlPath =
"/projects/" <>
T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName)) <>
"/forks"
gitlab urlPath
searchProjectId :: (MonadIO m)
=> Int
-> GitLab m (Maybe Project)
searchProjectId projectId = do
let urlPath = T.pack ("/projects/" <> show projectId)
gitlabWithAttrsOne urlPath "&statistics=true"
projectsWithName :: (MonadUnliftIO m, MonadIO m)
=> Text
-> GitLab m [Project]
projectsWithName projectName =
filter (\project -> projectName == project_path project) <$>
gitlabWithAttrs "/projects" ("&search=" <> projectName)
projectsWithNameAndUser ::
(MonadUnliftIO m, MonadIO m) => Text -> Text -> GitLab m (Maybe Project)
projectsWithNameAndUser username projectName =
gitlabWithAttrsOne
("/projects/" <>
T.decodeUtf8
(urlEncode False (T.encodeUtf8 (username <> "/" <> projectName))))
"&statistics=true"
multipleCommitters :: (MonadUnliftIO m, MonadIO m) => Project -> GitLab m Bool
multipleCommitters project = do
emailAddresses <- commitsEmailAddresses project
return (length (nub emailAddresses) > 1)
commitsEmailAddresses ::
(MonadUnliftIO m, MonadIO m) => Project -> GitLab m [Text]
commitsEmailAddresses = commitsEmailAddresses' . project_id
commitsEmailAddresses' :: (MonadUnliftIO m, MonadIO m) => Int -> GitLab m [Text]
commitsEmailAddresses' projectId = do
(commits :: [Commit]) <- projectCommits' projectId
return (map author_email commits)
userProjects' ::
(MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe [Project])
userProjects' username = do
userMaybe <- searchUser username
case userMaybe of
Nothing -> return Nothing
Just usr -> Just <$> gitlab (urlPath (user_id usr))
where
urlPath userId = "/users/" <> T.pack (show userId) <> "/projects"
userProjects ::
(MonadUnliftIO m, MonadIO m) => User -> GitLab m (Maybe [Project])
userProjects theUser = userProjects' (user_username theUser)
projectOfIssue :: (MonadIO m) => Issue -> GitLab m Project
projectOfIssue issue =
fromJust <$> searchProjectId (issue_project_id issue)
issuesCreatedByUser :: (MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe (User,[Project]))
issuesCreatedByUser username = do
user_maybe <- searchUser username
case user_maybe of
Nothing -> return Nothing
Just usr -> do
usersIssues <- userIssues usr
projects <- mapConcurrently projectOfIssue usersIssues
return (Just (usr, projects))
issuesOnForks ::
(MonadUnliftIO m, MonadIO m)
=> Text
-> GitLab m [(Project, [Issue], [User])]
issuesOnForks projectName = do
projects <- projectsWithName projectName
mapM processProject projects
where
processProject ::
(MonadUnliftIO m, MonadIO m)
=> Project
-> GitLab m (Project, [Issue], [User])
processProject proj = do
(openIssues :: [Issue]) <- projectOpenedIssues proj
let authors = map issue_author openIssues
return (proj, openIssues, authors)
projectMemebersCount :: (MonadIO m) => Project -> GitLab m (Text,[(Text,Text)])
projectMemebersCount project = do
friends <- count
return (namespace_name (namespace project), friends)
where
count = do
let addr =
"/projects/" <> T.pack (show (project_id project)) <> "/members/all"
(res :: [Member]) <- gitlab addr
return (map (\x -> (member_username x, member_name x)) res)
projectCISuccess ::
(MonadIO m)
=> Project
-> GitLab m Bool
projectCISuccess project = do
pipes <- pipelines project
case pipes of
[] -> return False
(x:_) -> return (pipeline_status x == "success")
namespacePathToUserId :: (MonadIO m)
=> Text
-> GitLab m (Maybe Int)
namespacePathToUserId namespacePath = do
user_maybe <- searchUser namespacePath
case user_maybe of
Nothing -> return Nothing
Just usr -> return (Just (user_id usr))
projectDiffs :: (MonadIO m) => Project -> Text -> GitLab m [Diff]
projectDiffs proj commitSha =
projectDiffs' (project_id proj) commitSha
projectDiffs' :: (MonadIO m) => Int -> Text -> GitLab m [Diff]
projectDiffs' projId commitSha =
gitlab
("/projects/"
<> T.pack (show projId)
<> "/repository/commits/"
<> commitSha
<> "/diff/")
shareProjectWithGroup ::
(MonadIO m)
=> Int
-> Int
-> AccessLevel
-> GitLab m (Either Status GroupShare)
shareProjectWithGroup groupId projectId access =
gitlabPost addr dataBody
where
dataBody :: Text
dataBody =
"group_id="
<> T.pack (show groupId)
<> "&group_access="
<> T.pack (show access)
addr = "/projects/"
<> T.pack (show projectId)
<> "/share"