{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GitLab.API.Projects where
import Data.Either
import Data.List
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
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
import Network.HTTP.Types.Status
import Network.HTTP.Types.URI
import UnliftIO.Async
allProjects :: GitLab [Project]
allProjects =
gitlabWithAttrsUnsafe "/projects" "&statistics=true"
projectForks ::
Text ->
GitLab (Either Status [Project])
projectForks projectName = do
let urlPath =
"/projects/"
<> T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName))
<> "/forks"
gitlab urlPath
searchProjectId ::
Int ->
GitLab (Either Status (Maybe Project))
searchProjectId projectId = do
let urlPath = T.pack ("/projects/" <> show projectId)
gitlabWithAttrsOne urlPath "&statistics=true"
projectsWithName ::
Text ->
GitLab [Project]
projectsWithName projectName =
filter (\project -> projectName == project_path project)
<$> gitlabWithAttrsUnsafe "/projects" ("&search=" <> projectName)
projectsWithNameAndUser :: Text -> Text -> GitLab (Either Status (Maybe Project))
projectsWithNameAndUser username projectName =
gitlabWithAttrsOne
( "/projects/"
<> T.decodeUtf8
(urlEncode False (T.encodeUtf8 (username <> "/" <> projectName)))
)
"&statistics=true"
multipleCommitters :: Project -> GitLab Bool
multipleCommitters project = do
emailAddresses <- commitsEmailAddresses project
return (length (nub emailAddresses) > 1)
commitsEmailAddresses :: Project -> GitLab [Text]
commitsEmailAddresses project = do
result <- commitsEmailAddresses' (project_id project)
return (fromRight (error "commitsEmailAddresses error") result)
commitsEmailAddresses' :: Int -> GitLab (Either Status [Text])
commitsEmailAddresses' projectId = do
attempt <- projectCommits' projectId
case attempt of
Left httpStatus -> return (Left httpStatus)
Right (commits :: [Commit]) ->
return (Right (map author_email commits))
userProjects' :: Text -> GitLab (Maybe [Project])
userProjects' username = do
userMaybe <- searchUser username
case userMaybe of
Nothing -> return Nothing
Just usr -> Just <$> gitlabUnsafe (urlPath (user_id usr))
where
urlPath userId = "/users/" <> T.pack (show userId) <> "/projects"
userProjects :: User -> GitLab (Maybe [Project])
userProjects theUser =
userProjects' (user_username theUser)
projectOfIssue :: Issue -> GitLab Project
projectOfIssue issue = do
result <- searchProjectId (issue_project_id issue)
case fromRight (error "projectOfIssue error") result of
Nothing -> error "projectOfIssue error"
Just proj -> return proj
issuesCreatedByUser :: Text -> GitLab (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 ::
Text ->
GitLab [(Project, [Issue], [User])]
issuesOnForks projectName = do
projects <- projectsWithName projectName
mapM processProject projects
where
processProject ::
Project ->
GitLab (Project, [Issue], [User])
processProject proj = do
(openIssues :: [Issue]) <- projectOpenedIssues proj
let authors = map issue_author openIssues
return (proj, openIssues, authors)
projectMemebersCount :: Project -> GitLab (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]) <- gitlabUnsafe addr
return (map (\x -> (member_username x, member_name x)) res)
projectCISuccess ::
Project ->
GitLab Bool
projectCISuccess project = do
pipes <- pipelines project
case pipes of
[] -> return False
(x : _) -> return (pipeline_status x == "success")
namespacePathToUserId ::
Text ->
GitLab (Maybe Int)
namespacePathToUserId namespacePath = do
user_maybe <- searchUser namespacePath
case user_maybe of
Nothing -> return Nothing
Just usr -> return (Just (user_id usr))
projectDiffs :: Project -> Text -> GitLab (Either Status [Diff])
projectDiffs proj =
projectDiffs' (project_id proj)
projectDiffs' :: Int -> Text -> GitLab (Either Status [Diff])
projectDiffs' projId commitSha =
gitlab
( "/projects/"
<> T.pack (show projId)
<> "/repository/commits/"
<> commitSha
<> "/diff/"
)
shareProjectWithGroup ::
Int ->
Int ->
AccessLevel ->
GitLab (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"