diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -31,15 +31,17 @@ For example: - myTodos <- runGitLab - (defaultGitLabServer - { url = "https://gitlab.example.com" - , token="my_token"} ) - todos + myProjects <- + runGitLab + (defaultGitLabServer + { url = "https://gitlab.example.com" + , token="my_token"} ) + (searchUser "joe" >>= userProjects . fromJust) -Which uses the `todos` function: +Which uses the` function: - todos :: MonadIO m => GitLab m [Todo] + searchUser :: Text -> GitLab m (Maybe User) + userProjects :: User -> GitLab m (Maybe [Project]) This returns all GitLab TODO items, as Haskell values of type `Todo` for the user identified with the access token`my_token`. diff --git a/gitlab-haskell.cabal b/gitlab-haskell.cabal --- a/gitlab-haskell.cabal +++ b/gitlab-haskell.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: gitlab-haskell category: Git -version: 0.1.5 +version: 0.1.6 synopsis: A Haskell library for the GitLab web API description: This Haskell library queries and updates the database of a GitLab instance using the GitLab web API: @@ -19,11 +19,12 @@ > (defaultGitLabServer > { url = "https://gitlab.example.com" > , token="my_token"} ) - > todos + > (searchUser "joe" >>= userProjects . fromJust) . Which uses the `todos` function: . - > todos :: MonadIO m => GitLab m [Todo] + > searchUser :: Text -> GitLab m (Maybe User) + > userProjects :: User -> GitLab m (Maybe [Project]) . Unsurprisingly, this library is maintained on GitLab: @@ -60,6 +61,7 @@ , GitLab.API.MergeRequests , GitLab.API.RepositoryFiles , GitLab.API.Todos + , GitLab.API.Version other-modules: GitLab.WebRequests.GitLabWebCalls hs-source-dirs: diff --git a/src/GitLab.hs b/src/GitLab.hs --- a/src/GitLab.hs +++ b/src/GitLab.hs @@ -1,37 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} -{-| -Module : GitLab -Description : Contains the 'runGitLab' function to run GitLab actions -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : GitLab +-- Description : Contains the 'runGitLab' function to run GitLab actions +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab - ( runGitLab - , module GitLab.Types - , module GitLab.API.Pipelines - , module GitLab.API.Groups - , module GitLab.API.Members - , module GitLab.API.Commits - , module GitLab.API.Projects - , module GitLab.API.Users - , module GitLab.API.Issues - , module GitLab.API.Branches - , module GitLab.API.Jobs - , module GitLab.API.MergeRequests - , module GitLab.API.Repositories - , module GitLab.API.RepositoryFiles - , module GitLab.API.Todos - ) where + ( runGitLab, + runGitLabWithManager, + module GitLab.Types, + module GitLab.API.Pipelines, + module GitLab.API.Groups, + module GitLab.API.Members, + module GitLab.API.Commits, + module GitLab.API.Projects, + module GitLab.API.Users, + module GitLab.API.Issues, + module GitLab.API.Branches, + module GitLab.API.Jobs, + module GitLab.API.MergeRequests, + module GitLab.API.Repositories, + module GitLab.API.RepositoryFiles, + module GitLab.API.Todos, + module GitLab.API.Version, + ) +where import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Trans.Reader -import Network.Connection (TLSSettings (..)) -import Network.HTTP.Conduit -import System.IO - import GitLab.API.Branches import GitLab.API.Commits import GitLab.API.Groups @@ -45,7 +44,12 @@ import GitLab.API.RepositoryFiles import GitLab.API.Todos import GitLab.API.Users +import GitLab.API.Version import GitLab.Types +import Network.Connection (TLSSettings (..)) +import Network.HTTP.Conduit +import Network.HTTP.Types.Status +import System.IO -- | runs a GitLab action. -- @@ -70,4 +74,18 @@ liftIO $ hSetBuffering stdout LineBuffering let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing manager <- liftIO $ newManager settings - runReaderT action (GitLabState cfg manager) + runGitLabWithManager manager cfg action + +-- | The same as 'runGitLab', except that it also takes a connection +-- manager as an argument. +runGitLabWithManager :: + (MonadUnliftIO m, MonadIO m) => Manager -> GitLabServerConfig -> GitLab m a -> m a +runGitLabWithManager manager cfg action = do + -- test the token access + tokenTest <- runReaderT gitlabVersion (GitLabState cfg manager) + case tokenTest of + Left (Status 401 "Unauthorized") -> error "access token not accepted." + Left st -> error ("unexpected HTTP status: " <> show st) + Right _versionInfo -> + -- it worked, run the user code. + runReaderT action (GitLabState cfg manager) diff --git a/src/GitLab/API/Branches.hs b/src/GitLab/API/Branches.hs --- a/src/GitLab/API/Branches.hs +++ b/src/GitLab/API/Branches.hs @@ -1,35 +1,36 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : Branches -Description : Queries about repository branches -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Branches +-- Description : Queries about repository branches +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Branches where +import Control.Monad.IO.Unlift +import Data.Either import qualified Data.Text as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls -import Control.Monad.IO.Unlift - +import Network.HTTP.Types.Status -- | Get a list of repository branches from a project, sorted by name -- alphabetically. branches :: (MonadIO m) => Project -> GitLab m [Branch] -branches project = branches' (project_id project) +branches project = do + result <- branches' (project_id project) + return (fromRight (error "branches error") result) -- | Get a list of repository branches from a project given its -- project ID, sorted by name alphabetically. -branches' :: (MonadIO m) => Int -> GitLab m [Branch] +branches' :: (MonadIO m) => Int -> GitLab m (Either Status [Branch]) branches' projectId = gitlab addr where addr = "/projects/" - <> T.pack (show projectId) - <> "/repository" - <> "/branches" - + <> T.pack (show projectId) + <> "/repository" + <> "/branches" diff --git a/src/GitLab/API/Commits.hs b/src/GitLab/API/Commits.hs --- a/src/GitLab/API/Commits.hs +++ b/src/GitLab/API/Commits.hs @@ -1,32 +1,38 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : Commits -Description : Queries about commits in repositories -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Commits +-- Description : Queries about commits in repositories +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Commits where import Control.Monad.IO.Unlift +import Data.Either import Data.Text (Text) import qualified Data.Text as T - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status -- | returns all commits for a project. -projectCommits :: (MonadIO m) - => Project -- ^ the project - -> GitLab m [Commit] -projectCommits project = projectCommits' (project_id project) +projectCommits :: + (MonadIO m) => + -- | the project + Project -> + GitLab m [Commit] +projectCommits project = do + result <- projectCommits' (project_id project) + return (fromRight (error "projectCommits error") result) -- | returns all commits for a project given its project ID. -projectCommits' :: (MonadIO m) - => Int -- ^ project ID - -> GitLab m [Commit] +projectCommits' :: + (MonadIO m) => + -- | project ID + Int -> + GitLab m (Either Status [Commit]) projectCommits' projectId = gitlabWithAttrs (commitsAddr projectId) "&with_stats=true" where @@ -36,25 +42,34 @@ -- | returns a commit for the given project and commit hash, if such -- a commit exists. -commitDetails :: (MonadIO m) - => Project -- ^ the project - -> Text -- ^ the commit hash - -> GitLab m (Maybe Commit) -commitDetails project = commitDetails' (project_id project) +commitDetails :: + (MonadIO m) => + -- | the project + Project -> + -- | the commit hash + Text -> + GitLab m (Maybe Commit) +commitDetails project theHash = do + result <- commitDetails' (project_id project) theHash + return (fromRight (error "commitDetails error") result) -- | returns a commit for the given project ID and commit hash, if -- such a commit exists. -commitDetails' :: (MonadIO m) - => Int -- ^ project ID - -> Text -- ^ the commit hash - -> GitLab m (Maybe Commit) +commitDetails' :: + (MonadIO m) => + -- | project ID + Int -> + -- | the commit hash + Text -> + GitLab m (Either Status (Maybe Commit)) commitDetails' projectId hash = gitlabOne (commitsAddr projectId) where commitsAddr :: Int -> Text commitsAddr projId = "/projects/" - <> T.pack (show projId) - <> "/repository" - <> "/commits" - <> "/" <> hash + <> T.pack (show projId) + <> "/repository" + <> "/commits" + <> "/" + <> hash diff --git a/src/GitLab/API/Groups.hs b/src/GitLab/API/Groups.hs --- a/src/GitLab/API/Groups.hs +++ b/src/GitLab/API/Groups.hs @@ -1,50 +1,60 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -{-| -Module : Groups -Description : Queries about and updates to groups -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Groups +-- Description : Queries about and updates to groups +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Groups where import Control.Monad.IO.Class import Control.Monad.IO.Unlift +import qualified Data.ByteString.Char8 as C import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Network.HTTP.Types.Status -import Network.HTTP.Types.URI -import qualified Data.ByteString.Char8 as C - import GitLab.API.Members import GitLab.API.Users import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI -- | gets groups with the given group name or path. -- -- > projectsWithNameOrPath "group1" -groupsWithNameOrPath :: (MonadUnliftIO m, MonadIO m) - => Text -- ^ group name being searched for. - -> GitLab m [Group] -groupsWithNameOrPath groupName = - filter (\group -> - groupName == group_name group - || groupName == group_path group - ) <$> - gitlabWithAttrs "/groups" ("&search=" <> groupName) +groupsWithNameOrPath :: + (MonadUnliftIO m, MonadIO m) => + -- | group name being searched for. + Text -> + GitLab m (Either Status [Group]) +groupsWithNameOrPath groupName = do + result <- gitlabWithAttrs "/groups" ("&search=" <> groupName) + case result of + Left {} -> return result + Right groups -> + return + ( Right + $filter + ( \group -> + groupName == group_name group + || groupName == group_path group + ) + groups + ) -- | adds all registered users to a group. addAllUsersToGroup :: - (MonadIO m, MonadUnliftIO m) - => Text -- ^ group name - -> AccessLevel -- ^ level of access granted - -> GitLab m [Either Status Member] + (MonadIO m, MonadUnliftIO m) => + -- | group name + Text -> + -- | level of access granted + AccessLevel -> + GitLab m [Either Status Member] addAllUsersToGroup groupName access = do allRegisteredUsers <- allUsers let allUserIds = map user_username allRegisteredUsers @@ -52,55 +62,69 @@ -- | adds a user to a group. addUserToGroup :: - (MonadIO m, MonadUnliftIO m) - => Text -- ^ group name - -> AccessLevel -- ^ level of access granted - -> User -- ^ the user - -> GitLab m (Either Status Member) + (MonadIO m, MonadUnliftIO m) => + -- | group name + Text -> + -- | level of access granted + AccessLevel -> + -- | the user + User -> + GitLab m (Either Status Member) addUserToGroup groupName access usr = addUserToGroup' groupName access (user_id usr) -- | adds a user with a given user ID to a group. addUserToGroup' :: - (MonadIO m, MonadUnliftIO m) - => Text -- ^ group name - -> AccessLevel -- ^ level of access granted - -> Int -- ^ user ID - -> GitLab m (Either Status Member) + (MonadIO m, MonadUnliftIO m) => + -- | group name + Text -> + -- | level of access granted + AccessLevel -> + -- | user ID + Int -> + GitLab m (Either Status Member) addUserToGroup' groupName access userId = do - groups <- groupsWithNameOrPath groupName - case groups of - [] -> return (Left (mkStatus 404 (C.pack "cannot find group"))) - [grp] -> + attempt <- groupsWithNameOrPath groupName + case attempt of + Left httpStatus -> return (Left httpStatus) + Right [] -> return (Left (mkStatus 404 (C.pack "cannot find group"))) + Right [grp] -> do gitlabPost addr dataBody where dataBody :: Text dataBody = - "user_id=" <> T.pack (show userId) <> "&access_level=" <> - T.pack (show access) - addr = "/groups/" - <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp))))) - <> "/members" - (_:_) -> + "user_id=" <> T.pack (show userId) <> "&access_level=" + <> T.pack (show access) + addr = + "/groups/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp))))) + <> "/members" + Right (_ : _) -> return (Left (mkStatus 404 (C.pack "too many groups found"))) -- | adds a list of users to a group. addUsersToGroup :: - (MonadIO m, MonadUnliftIO m) - => Text -- ^ group name - -> AccessLevel -- ^ level of access granted - -> [User] -- ^ list of usernames to be added to the group - -> GitLab m [Either Status Member] + (MonadIO m, MonadUnliftIO m) => + -- | group name + Text -> + -- | level of access granted + AccessLevel -> + -- | list of usernames to be added to the group + [User] -> + GitLab m [Either Status Member] addUsersToGroup groupName access = mapM (addUserToGroup groupName access) -- | adds a list of users to a group. addUsersToGroup' :: - (MonadIO m, MonadUnliftIO m) - => Text -- ^ group name - -> AccessLevel -- ^ level of access granted - -> [Text] -- ^ list of usernames to be added to the group - -> GitLab m [Either Status Member] + (MonadIO m, MonadUnliftIO m) => + -- | group name + Text -> + -- | level of access granted + AccessLevel -> + -- | list of usernames to be added to the group + [Text] -> + GitLab m [Either Status Member] addUsersToGroup' groupName access usernames = do users <- catMaybes <$> mapM searchUser usernames mapM (addUserToGroup' groupName access . user_id) users diff --git a/src/GitLab/API/Issues.hs b/src/GitLab/API/Issues.hs --- a/src/GitLab/API/Issues.hs +++ b/src/GitLab/API/Issues.hs @@ -1,50 +1,57 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -{-| -Module : Issues -Description : Queries about issues created against projects -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Issues +-- Description : Queries about issues created against projects +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Issues where import Control.Monad.IO.Class import Control.Monad.IO.Unlift +import Data.Either import qualified Data.Text as T - -import GitLab.WebRequests.GitLabWebCalls import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status -- | returns all issues against a project. projectOpenedIssues :: - (MonadIO m, MonadUnliftIO m) - => Project -- ^ the project - -> GitLab m [Issue] -projectOpenedIssues = projectOpenedIssues' . project_id + (MonadIO m, MonadUnliftIO m) => + -- | the project + Project -> + GitLab m [Issue] +projectOpenedIssues p = do + result <- projectOpenedIssues' (project_id p) + return (fromRight (error "projectOpenedIssues error") result) -- | returns all issues against a project given its project ID. projectOpenedIssues' :: - (MonadIO m, MonadUnliftIO m) - => Int -- ^ the project ID - -> GitLab m [Issue] + (MonadIO m, MonadUnliftIO m) => + -- | the project ID + Int -> + GitLab m (Either Status [Issue]) projectOpenedIssues' projectId = do - let path = "/projects/" <> T.pack (show projectId) <> "/issues" - gitlab path - -- gitlabReq path "&state=opened" + let path = "/projects/" <> T.pack (show projectId) <> "/issues" + gitlab path +-- gitlabReq path "&state=opened" + -- | gets all issues create by a user. userIssues :: - (MonadIO m) - => User -- ^ the user - -> GitLab m [Issue] + (MonadIO m) => + -- | the user + User -> + GitLab m [Issue] userIssues usr = - gitlabWithAttrs addr attrs + gitlabWithAttrsUnsafe addr attrs where addr = "/issues" - attrs = T.pack $ - "&author_id=" - <> show (user_id usr) - <> "&scope=all" + attrs = + T.pack $ + "&author_id=" + <> show (user_id usr) + <> "&scope=all" diff --git a/src/GitLab/API/Jobs.hs b/src/GitLab/API/Jobs.hs --- a/src/GitLab/API/Jobs.hs +++ b/src/GitLab/API/Jobs.hs @@ -1,37 +1,41 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : Jobs -Description : Queries about jobs ran on projects -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Jobs +-- Description : Queries about jobs ran on projects +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Jobs where import Control.Monad.IO.Unlift +import Data.Either import qualified Data.Text as T - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status -- | returns all jobs ran on a project. jobs :: - (MonadIO m) - => Project -- ^ the project - -> GitLab m [Job] -jobs project = jobs' (project_id project) + (MonadIO m) => + -- | the project + Project -> + GitLab m [Job] +jobs project = do + result <- jobs' (project_id project) + return (fromRight (error "jobs error") result) -- | returns all jobs ran on a project given its project ID. jobs' :: - (MonadIO m) - => Int -- ^ the project ID - -> GitLab m [Job] + (MonadIO m) => + -- | the project ID + Int -> + GitLab m (Either Status [Job]) jobs' projectId = gitlab addr where addr = "/projects/" - <> T.pack (show projectId) - <> "/jobs" + <> T.pack (show projectId) + <> "/jobs" diff --git a/src/GitLab/API/Members.hs b/src/GitLab/API/Members.hs --- a/src/GitLab/API/Members.hs +++ b/src/GitLab/API/Members.hs @@ -1,27 +1,26 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -{-| -Module : Members -Description : Queries about and updates to members of projects -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Members +-- Description : Queries about and updates to members of projects +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Members where import Control.Monad.IO.Class +import Data.Either import Data.Text (Text) import qualified Data.Text as T -import Network.HTTP.Types.Status - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status -- | the access levels for project members. See -data AccessLevel = - Guest +data AccessLevel + = Guest | Reporter | Developer | Maintainer @@ -36,10 +35,12 @@ -- | the members of a project. membersOfProject :: (MonadIO m) => Project -> GitLab m [Member] -membersOfProject = membersOfProject' . project_id +membersOfProject p = do + result <- membersOfProject' (project_id p) + return (fromRight (error "membersOfProject error") result) -- | the members of a project given its ID. -membersOfProject' :: (MonadIO m) => Int -> GitLab m [Member] +membersOfProject' :: (MonadIO m) => Int -> GitLab m (Either Status [Member]) membersOfProject' projectId = gitlab addr where @@ -50,11 +51,14 @@ -- 'Right Member' for each successful action, otherwise it returns -- 'Left Status'. addMemberToProject :: - (MonadIO m) - => Project -- ^ the project - -> AccessLevel -- ^ level of access - -> User -- ^ the user - -> GitLab m (Either Status Member) + (MonadIO m) => + -- | the project + Project -> + -- | level of access + AccessLevel -> + -- | the user + User -> + GitLab m (Either Status Member) addMemberToProject project access usr = addMemberToProject' (project_id project) access (user_id usr) @@ -62,30 +66,35 @@ -- project's ID and the user's ID. Returns @Right Member@ for each -- successful action, otherwise it returns @Left Status@. addMemberToProject' :: - (MonadIO m) - => Int -- ^ project ID - -> AccessLevel -- ^ level of access - -> Int -- ^ user ID - -> GitLab m (Either Status Member) + (MonadIO m) => + -- | project ID + Int -> + -- | level of access + AccessLevel -> + -- | user ID + Int -> + GitLab m (Either Status Member) addMemberToProject' projectId access userId = gitlabPost addr dataBody where dataBody :: Text dataBody = - "user_id=" <> T.pack (show userId) <> "&access_level=" <> T.pack (show access) + "user_id=" <> T.pack (show userId) <> "&access_level=" <> T.pack (show access) addr = "/projects/" <> T.pack (show projectId) <> "/members" - -- | adds a list of users to a project with the given access -- level. Returns 'Right Member' for each successful action, otherwise -- it returns 'Left Status'. addMembersToProject :: - (MonadIO m) - => Project -- ^ the project - -> AccessLevel -- ^ level of access - -> [User] -- ^ users to add to the project - -> GitLab m [Either Status Member] + (MonadIO m) => + -- | the project + Project -> + -- | level of access + AccessLevel -> + -- | users to add to the project + [User] -> + GitLab m [Either Status Member] addMembersToProject project access = mapM (addMemberToProject project access) @@ -93,11 +102,13 @@ -- given the project's ID and the user IDs. Returns @Right Member@ for -- each successful action, otherwise it returns @Left Status@. addMembersToProject' :: - (MonadIO m) - => Int -- ^ project ID - -> AccessLevel -- ^ level of acces - -> [Int] -- ^ IDs of users to add to the project - -> GitLab m [Either Status Member] + (MonadIO m) => + -- | project ID + Int -> + -- | level of acces + AccessLevel -> + -- | IDs of users to add to the project + [Int] -> + GitLab m [Either Status Member] addMembersToProject' projectId access = mapM (addMemberToProject' projectId access) - diff --git a/src/GitLab/API/MergeRequests.hs b/src/GitLab/API/MergeRequests.hs --- a/src/GitLab/API/MergeRequests.hs +++ b/src/GitLab/API/MergeRequests.hs @@ -1,100 +1,122 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : MergeRequests -Description : Queries about merge requests against projects -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : MergeRequests +-- Description : Queries about merge requests against projects +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.MergeRequests where import Control.Monad.IO.Unlift +import Data.Either import Data.Text (Text) import qualified Data.Text as T -import Network.HTTP.Types.Status - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status -- | returns the merge requests for a project. -mergeRequests :: (MonadIO m) - => Project -- ^ the project - -> GitLab m [MergeRequest] -mergeRequests = mergeRequests' . project_id +mergeRequests :: + (MonadIO m) => + -- | the project + Project -> + GitLab m [MergeRequest] +mergeRequests p = do + result <- mergeRequests' (project_id p) + return (fromRight (error "mergeRequests error") result) -- | returns the merge requests for a project given its project ID. -mergeRequests' :: (MonadIO m) - => Int -- ^ project ID - -> GitLab m [MergeRequest] +mergeRequests' :: + (MonadIO m) => + -- | project ID + Int -> + GitLab m (Either Status [MergeRequest]) mergeRequests' projectId = gitlabWithAttrs addr "&scope=all" where addr = "/projects/" - <> T.pack (show projectId) - <> "/merge_requests" + <> T.pack (show projectId) + <> "/merge_requests" -- | Creates a merge request. -createMergeRequest - :: (MonadIO m) - => Project -- ^ project - -> Text -- ^ source branch - -> Text -- ^ target branch - -> Int -- ^ target project ID - -> Text -- ^ merge request title - -> Text -- ^ merge request description - -> GitLab m (Either Status MergeRequest) +createMergeRequest :: + (MonadIO m) => + -- | project + Project -> + -- | source branch + Text -> + -- | target branch + Text -> + -- | target project ID + Int -> + -- | merge request title + Text -> + -- | merge request description + Text -> + GitLab m (Either Status MergeRequest) createMergeRequest project = createMergeRequest' (project_id project) - + -- | Creates a merge request. -createMergeRequest' - :: (MonadIO m) - => Int -- ^ project ID - -> Text -- ^ source branch - -> Text -- ^ target branch - -> Int -- ^ target project ID - -> Text -- ^ merge request title - -> Text -- ^ merge request description - -> GitLab m (Either Status MergeRequest) +createMergeRequest' :: + (MonadIO m) => + -- | project ID + Int -> + -- | source branch + Text -> + -- | target branch + Text -> + -- | target project ID + Int -> + -- | merge request title + Text -> + -- | merge request description + Text -> + GitLab m (Either Status MergeRequest) createMergeRequest' projectId sourceBranch targetBranch targetProjectId mrTitle mrDescription = gitlabPost addr dataBody where dataBody :: Text dataBody = - "source_branch=" <> sourceBranch <> "&target_branch=" <> targetBranch <> - "&target_project_id=" <> - T.pack (show targetProjectId) <> - "&title=" <> - mrTitle <> - "&description=" <> - mrDescription + "source_branch=" <> sourceBranch <> "&target_branch=" <> targetBranch + <> "&target_project_id=" + <> T.pack (show targetProjectId) + <> "&title=" + <> mrTitle + <> "&description=" + <> mrDescription addr = T.pack $ "/projects/" <> show projectId <> "/merge_requests" -- | Accepts a merge request. -acceptMergeRequest - :: (MonadIO m) - => Project -- ^ project - -> Int -- ^ merge request IID - -> GitLab m (Either Status MergeRequest) +acceptMergeRequest :: + (MonadIO m) => + -- | project + Project -> + -- | merge request IID + Int -> + GitLab m (Either Status MergeRequest) acceptMergeRequest project = acceptMergeRequest' (project_id project) -- | Accepts a merge request. -acceptMergeRequest' - :: (MonadIO m) - => Int -- ^ project ID - -> Int -- ^ merge request IID - -> GitLab m (Either Status MergeRequest) +acceptMergeRequest' :: + (MonadIO m) => + -- | project ID + Int -> + -- | merge request IID + Int -> + GitLab m (Either Status MergeRequest) acceptMergeRequest' projectId mergeRequestIid = gitlabPost addr dataBody where dataBody :: Text - dataBody = T.pack $ - "id=" <> show projectId <> "&merge_request_iid=" <> show mergeRequestIid + dataBody = + T.pack $ + "id=" <> show projectId <> "&merge_request_iid=" <> show mergeRequestIid addr = T.pack $ - "/projects/" <> show projectId <> "/merge_requests/" <> - show mergeRequestIid <> - "/merge" + "/projects/" <> show projectId <> "/merge_requests/" + <> show mergeRequestIid + <> "/merge" diff --git a/src/GitLab/API/Pipelines.hs b/src/GitLab/API/Pipelines.hs --- a/src/GitLab/API/Pipelines.hs +++ b/src/GitLab/API/Pipelines.hs @@ -1,37 +1,43 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : Pipelines -Description : Queries about project pipelines -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Pipelines +-- Description : Queries about project pipelines +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Pipelines where import Control.Monad.IO.Unlift +import Data.Either import qualified Data.Text as T - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status -- | returns the pipelines for a project. -pipelines :: (MonadIO m) - => Project -- ^ the project - -> GitLab m [Pipeline] -pipelines = pipelines' . project_id +pipelines :: + (MonadIO m) => + -- | the project + Project -> + GitLab m [Pipeline] +pipelines p = do + result <- pipelines' (project_id p) + return (fromRight (error "pipelines error") result) -- | returns the pipelines for a project given its project ID. -pipelines' :: (MonadIO m) - => Int -- ^ the project ID - -> GitLab m [Pipeline] +pipelines' :: + (MonadIO m) => + -- | the project ID + Int -> + GitLab m (Either Status [Pipeline]) pipelines' projectId = gitlabWithAttrs - addr - "&sort=desc" -- most recent first + addr + "&sort=desc" -- most recent first where addr = "/projects/" - <> T.pack (show projectId) - <> "/pipelines" + <> T.pack (show projectId) + <> "/pipelines" diff --git a/src/GitLab/API/Projects.hs b/src/GitLab/API/Projects.hs --- a/src/GitLab/API/Projects.hs +++ b/src/GitLab/API/Projects.hs @@ -1,27 +1,23 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -{-| -Module : Projects -Description : Queries about projects -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Projects +-- Description : Queries about projects +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Projects where import Control.Monad.IO.Class import Control.Monad.IO.Unlift +import Data.Either 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 @@ -29,62 +25,68 @@ import GitLab.API.Users import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI +import UnliftIO.Async -- | gets all projects. allProjects :: (MonadIO m) => GitLab m [Project] allProjects = - gitlabWithAttrs "/projects" "&statistics=true" + gitlabWithAttrsUnsafe "/projects" "&statistics=true" -- | gets all forks of a project. Supports use of namespaces. -- -- > projectForks "project1" -- > projectForks "group1/project1" -projectForks :: (MonadUnliftIO m, MonadIO m) - => Text -- ^ name or namespace of the project - -> GitLab m [Project] +projectForks :: + (MonadUnliftIO m, MonadIO m) => + -- | name or namespace of the project + Text -> + GitLab m (Either Status [Project]) projectForks projectName = do let urlPath = - "/projects/" <> - T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName)) <> - "/forks" + "/projects/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName)) + <> "/forks" gitlab urlPath -- | searches for a 'Project' with the given project ID, returns -- 'Nothing' if a project with the given ID is not found. -searchProjectId :: (MonadIO m) - => Int -- ^ project ID - -> GitLab m (Maybe Project) +searchProjectId :: + (MonadIO m) => + -- | project ID + Int -> + GitLab m (Either Status (Maybe Project)) searchProjectId projectId = do let urlPath = T.pack ("/projects/" <> show projectId) - gitlabWithAttrsOne urlPath "&statistics=true" + gitlabWithAttrsOne urlPath "&statistics=true" -- | gets all projects with the given project name. -- -- > projectsWithName "project1" -projectsWithName :: (MonadUnliftIO m, MonadIO m) - => Text -- ^ project name being searched for. - -> GitLab m [Project] +projectsWithName :: + (MonadUnliftIO m, MonadIO m) => + -- | project name being searched for. + Text -> + GitLab m [Project] projectsWithName projectName = - filter (\project -> projectName == project_path project) <$> - gitlabWithAttrs "/projects" ("&search=" <> projectName) + filter (\project -> projectName == project_path project) + <$> gitlabWithAttrsUnsafe "/projects" ("&search=" <> projectName) --- | gets a project with the given name for the given username. E.g. +-- | gets a project with the given name for the given username. E.g. -- -- > projectsNamespaceName "user1" "project1" -- -- looks for "user1/project1" projectsWithNameAndUser :: - (MonadUnliftIO m, MonadIO m) => Text -> Text -> GitLab m (Maybe Project) + (MonadUnliftIO m, MonadIO m) => Text -> Text -> GitLab m (Either Status (Maybe Project)) projectsWithNameAndUser username projectName = - -- gitlabOne - -- ("/projects/" <> - -- T.decodeUtf8 - -- (urlEncode False (T.encodeUtf8 (username <> "/" <> projectName)))) gitlabWithAttrsOne - ("/projects/" <> - T.decodeUtf8 - (urlEncode False (T.encodeUtf8 (username <> "/" <> projectName)))) - "&statistics=true" + ( "/projects/" + <> T.decodeUtf8 + (urlEncode False (T.encodeUtf8 (username <> "/" <> projectName))) + ) + "&statistics=true" -- | returns 'True' if a project has multiple committers, according to -- the email addresses of the commits. @@ -94,28 +96,34 @@ return (length (nub emailAddresses) > 1) -- | gets the email addresses in the author information in all commit --- for a project. +-- for a project. commitsEmailAddresses :: - (MonadUnliftIO m, MonadIO m) => Project -> GitLab m [Text] -commitsEmailAddresses = commitsEmailAddresses' . project_id + (MonadUnliftIO m, MonadIO m) => Project -> GitLab m [Text] +commitsEmailAddresses project = do + result <- commitsEmailAddresses' (project_id project) + return (fromRight (error "commitsEmailAddresses error") result) -- | gets the email addresses in the author information in all commit --- for a project defined by the project's ID. -commitsEmailAddresses' :: (MonadUnliftIO m, MonadIO m) => Int -> GitLab m [Text] +-- for a project defined by the project's ID. +commitsEmailAddresses' :: (MonadUnliftIO m, MonadIO m) => Int -> GitLab m (Either Status [Text]) commitsEmailAddresses' projectId = do - (commits :: [Commit]) <- projectCommits' projectId - return (map author_email commits) + -- (commits :: [Commit]) <- projectCommits' projectId + attempt <- projectCommits' projectId + case attempt of + Left httpStatus -> return (Left httpStatus) + Right (commits :: [Commit]) -> + return (Right (map author_email commits)) -- | gets all projects for a user given their username. -- -- > userProjects "harry" userProjects' :: - (MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe [Project]) + (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)) + Just usr -> Just <$> gitlabUnsafe (urlPath (user_id usr)) where urlPath userId = "/users/" <> T.pack (show userId) <> "/projects" @@ -123,14 +131,16 @@ -- -- > userProjects myUser userProjects :: - (MonadUnliftIO m, MonadIO m) => User -> GitLab m (Maybe [Project]) -userProjects theUser = userProjects' (user_username theUser) + (MonadUnliftIO m, MonadIO m) => User -> GitLab m (Maybe [Project]) +userProjects theUser = + userProjects' (user_username theUser) -- | gets the 'GitLab.Types.Project' against which the given 'Issue' -- was created. projectOfIssue :: (MonadIO m) => Issue -> GitLab m Project -projectOfIssue issue = - fromJust <$> searchProjectId (issue_project_id issue) +projectOfIssue issue = do + result <- searchProjectId (issue_project_id issue) + return (fromJust (fromRight (error "projectOfIssue error") result)) -- | finds all issues created by a user. -- @@ -139,7 +149,7 @@ -- returns a (user,projects) tuple, where 'user' is the 'User' found -- for the given searched username, and a list of 'Project's that the -- user has created issues for. -issuesCreatedByUser :: (MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe (User,[Project])) +issuesCreatedByUser :: (MonadUnliftIO m, MonadIO m) => Text -> GitLab m (Maybe (User, [Project])) issuesCreatedByUser username = do user_maybe <- searchUser username case user_maybe of @@ -153,17 +163,18 @@ -- of triples of: 1) the found project, 2) the list of issues for the -- found projects, and 3) a list of users who've created issues. issuesOnForks :: - (MonadUnliftIO m, MonadIO m) - => Text -- ^ name or namespace of the project - -> GitLab m [(Project, [Issue], [User])] + (MonadUnliftIO m, MonadIO m) => + -- | name or namespace of the project + 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]) + (MonadUnliftIO m, MonadIO m) => + Project -> + GitLab m (Project, [Issue], [User]) processProject proj = do (openIssues :: [Issue]) <- projectOpenedIssues proj let authors = map issue_author openIssues @@ -173,7 +184,7 @@ -- where namespace is the namespace of the project -- e.g. "user1/project1", and members is a list of (username,name) -- tuples about all members of the project. -projectMemebersCount :: (MonadIO m) => Project -> GitLab m (Text,[(Text,Text)]) +projectMemebersCount :: (MonadIO m) => Project -> GitLab m (Text, [(Text, Text)]) projectMemebersCount project = do friends <- count return (namespace_name (namespace project), friends) @@ -181,26 +192,29 @@ count = do let addr = "/projects/" <> T.pack (show (project_id project)) <> "/members/all" - (res :: [Member]) <- gitlab addr + (res :: [Member]) <- gitlabUnsafe addr return (map (\x -> (member_username x, member_name x)) res) -- | returns 'True' is the last commit for a project passes all -- continuous integration tests. projectCISuccess :: - (MonadIO m) - => Project -- ^ the name or namespace of the project - -> GitLab m Bool + (MonadIO m) => + -- | the name or namespace of the project + Project -> + GitLab m Bool projectCISuccess project = do pipes <- pipelines project case pipes of [] -> return False - (x:_) -> return (pipeline_status x == "success") + (x : _) -> return (pipeline_status x == "success") -- | searches for a username, and returns a user ID for that user, or --- 'Nothing' if a user cannot be found. -namespacePathToUserId :: (MonadIO m) - => Text -- ^ name or namespace of project - -> GitLab m (Maybe Int) +-- 'Nothing' if a user cannot be found. +namespacePathToUserId :: + (MonadIO m) => + -- | name or namespace of project + Text -> + GitLab m (Maybe Int) namespacePathToUserId namespacePath = do user_maybe <- searchUser namespacePath case user_maybe of @@ -208,37 +222,42 @@ Just usr -> return (Just (user_id usr)) -- | gets all diffs in a project for a given commit SHA. -projectDiffs :: (MonadIO m) => Project -> Text -> GitLab m [Diff] +projectDiffs :: (MonadIO m) => Project -> Text -> GitLab m (Either Status [Diff]) projectDiffs proj = projectDiffs' (project_id proj) -- | gets all diffs in a project for a given project ID, for a given -- commit SHA. -projectDiffs' :: (MonadIO m) => Int -> Text -> GitLab m [Diff] +projectDiffs' :: (MonadIO m) => Int -> Text -> GitLab m (Either Status [Diff]) projectDiffs' projId commitSha = gitlab - ("/projects/" - <> T.pack (show projId) - <> "/repository/commits/" - <> commitSha - <> "/diff/") + ( "/projects/" + <> T.pack (show projId) + <> "/repository/commits/" + <> commitSha + <> "/diff/" + ) -- | share a project with a group. shareProjectWithGroup :: - (MonadIO m) - => Int -- ^ group ID - -> Int -- ^ project ID - -> AccessLevel -- ^ level of access granted - -> GitLab m (Either Status GroupShare) + (MonadIO m) => + -- | group ID + Int -> + -- | project ID + Int -> + -- | level of access granted + 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" + <> T.pack (show groupId) + <> "&group_access=" + <> T.pack (show access) + addr = + "/projects/" + <> T.pack (show projectId) + <> "/share" diff --git a/src/GitLab/API/Repositories.hs b/src/GitLab/API/Repositories.hs --- a/src/GitLab/API/Repositories.hs +++ b/src/GitLab/API/Repositories.hs @@ -1,69 +1,111 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : Repositories -Description : Queries about project repositories -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Repositories +-- Description : Queries about project repositories +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Repositories where import Control.Monad.IO.Unlift import qualified Data.ByteString.Lazy as BSL +import Data.Either import qualified Data.Text as T - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status -- | returns a list of repository files and directories in a project. -repositories :: (MonadIO m) - => Project -- ^ the project - -> GitLab m [Repository] -repositories project = repositories' (project_id project) +repositories :: + (MonadIO m) => + -- | the project + Project -> + GitLab m [Repository] +repositories project = + fromRight (error "repositories error") <$> repositories' (project_id project) -- | returns a list of repository files and directories in a project -- given its project ID. -repositories' :: (MonadIO m) - => Int -- ^ the project ID - -> GitLab m [Repository] +repositories' :: + (MonadIO m) => + -- | the project ID + Int -> + GitLab m (Either Status [Repository]) repositories' projectId = gitlab addr where addr = "/projects/" - <> T.pack (show projectId) - <> "/repository" - <> "/tree" + <> T.pack (show projectId) + <> "/repository" + <> "/tree" -- | get a file archive of the repository files. For example: -- -- > getFileArchive myProject TarGz "/tmp/myProject.tar.gz" -getFileArchive :: (MonadIO m) - => Project -- ^ project - -> ArchiveFormat -- ^ file format - -> FilePath -- ^ file path to store the archive - -> GitLab m () +getFileArchive :: + (MonadIO m) => + -- | project + Project -> + -- | file format + ArchiveFormat -> + -- | file path to store the archive + FilePath -> + GitLab m () getFileArchive project = getFileArchive' (project_id project) +-- | get a file archive of the repository files as a +-- 'BSL.ByteString'. For example: +-- +-- > getFileArchiveBS myProject TarGz "/tmp/myProject.tar.gz" +getFileArchiveBS :: + (MonadIO m) => + -- | project + Project -> + -- | file format + ArchiveFormat -> + GitLab m (Either Status BSL.ByteString) +getFileArchiveBS project = getFileArchiveBS' (project_id project) + -- | get a file archive of the repository files using the project's -- ID. For example: -- -- > getFileArchive' 3453 Zip "/tmp/myProject.zip" -getFileArchive' :: (MonadIO m) - => Int -- ^ project ID - -> ArchiveFormat -- ^ file format - -> FilePath -- ^ file path to store the archive - -> GitLab m () +getFileArchive' :: + (MonadIO m) => + -- | project ID + Int -> + -- | file format + ArchiveFormat -> + -- | file path to store the archive + FilePath -> + GitLab m () getFileArchive' projectId format path = do - archiveData <- gitlabReqByteString addr - liftIO $ BSL.writeFile path archiveData + attempt <- getFileArchiveBS' projectId format + case attempt of + Left _status -> return () + Right archiveData -> + liftIO $ BSL.writeFile path archiveData + +-- | get a file archive of the repository files as a 'BSL.ByteString' +-- using the project's ID. For example: +-- +-- > getFileArchiveBS' 3453 Zip "/tmp/myProject.zip" +getFileArchiveBS' :: + (MonadIO m) => + -- | project ID + Int -> + -- | file format + ArchiveFormat -> + GitLab m (Either Status BSL.ByteString) +getFileArchiveBS' projectId format = do + gitlabReqByteString addr where addr = "/projects/" - <> T.pack (show projectId) - <> "/repository" - <> "/archive" - <> T.pack (show format) - + <> T.pack (show projectId) + <> "/repository" + <> "/archive" + <> T.pack (show format) diff --git a/src/GitLab/API/RepositoryFiles.hs b/src/GitLab/API/RepositoryFiles.hs --- a/src/GitLab/API/RepositoryFiles.hs +++ b/src/GitLab/API/RepositoryFiles.hs @@ -1,63 +1,72 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : RepositoryFiles -Description : Queries about project repository files -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : RepositoryFiles +-- Description : Queries about project repository files +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.RepositoryFiles where import Control.Monad.IO.Unlift import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Network.HTTP.Types.URI - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI -- | Get a list of repository files and directories in a project. -repositoryFiles :: (MonadIO m) - => Project -- ^ the project - -> Text -- ^ the file path - -> Text -- ^ name of the branch, tag or commit - -> GitLab m (Maybe RepositoryFile) +repositoryFiles :: + (MonadIO m) => + -- | the project + Project -> + -- | the file path + Text -> + -- | name of the branch, tag or commit + Text -> + GitLab m (Either Status (Maybe RepositoryFile)) repositoryFiles project = repositoryFiles' (project_id project) -- | Get a list of repository files and directories in a project given -- the project's ID. -repositoryFiles' :: (MonadIO m) - => Int -- ^ project ID - -> Text -- ^ the file path - -> Text -- ^ name of the branch, tag or commit - -> GitLab m (Maybe RepositoryFile) +repositoryFiles' :: + (MonadIO m) => + -- | project ID + Int -> + -- | the file path + Text -> + -- | name of the branch, tag or commit + Text -> + GitLab m (Either Status (Maybe RepositoryFile)) repositoryFiles' projectId filePath reference = gitlabWithAttrsOne addr ("&ref=" <> reference) where addr = "/projects/" - <> T.pack (show projectId) - <> "/repository" - <> "/files" - <> "/" - <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) - -- <> filePath + <> T.pack (show projectId) + <> "/repository" + <> "/files" + <> "/" + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 filePath)) -- | Get raw data for a given file blob hash. -repositoryFileBlob :: (MonadIO m) - => Int -- ^ project ID - -> Text -- ^ blob SHA - -> GitLab m String +repositoryFileBlob :: + (MonadIO m) => + -- | project ID + Int -> + -- | blob SHA + Text -> + GitLab m (Either Status String) repositoryFileBlob projectId blobSha = gitlabReqText addr where addr = "/projects/" - <> T.pack (show projectId) - <> "/repository" - <> "/blobs/" - <> blobSha - <> "/raw" + <> T.pack (show projectId) + <> "/repository" + <> "/blobs/" + <> blobSha + <> "/raw" diff --git a/src/GitLab/API/Todos.hs b/src/GitLab/API/Todos.hs --- a/src/GitLab/API/Todos.hs +++ b/src/GitLab/API/Todos.hs @@ -1,13 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -{-| -Module : Todos -Description : Queries about todos for users. -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Todos +-- Description : Queries about todos for users. +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Todos where import Control.Monad.IO.Class @@ -16,4 +15,4 @@ -- | returns all pending todos for the user, as defined by the access token. todos :: (MonadIO m) => GitLab m [Todo] -todos = gitlab "/todos" +todos = gitlabUnsafe "/todos" diff --git a/src/GitLab/API/Users.hs b/src/GitLab/API/Users.hs --- a/src/GitLab/API/Users.hs +++ b/src/GitLab/API/Users.hs @@ -1,48 +1,50 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -{-| -Module : Users -Description : Queries about registered users -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} +-- | +-- Module : Users +-- Description : Queries about registered users +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable module GitLab.API.Users where import Control.Monad.IO.Class import Data.List import Data.Maybe import Data.Text (Text) - import GitLab.Types import GitLab.WebRequests.GitLabWebCalls -- | all registered users. allUsers :: (MonadIO m) => GitLab m [User] allUsers = do - let path = "/users" - gitlab path + let path = "/users" + gitlabUnsafe path -- | searches for a user given a username. Returns @Just User@ if the -- user is found, otherwise @Nothing@. -searchUser :: (MonadIO m) - => Text -- ^ username to search for - -> GitLab m (Maybe User) +searchUser :: + (MonadIO m) => + -- | username to search for + Text -> + GitLab m (Maybe User) searchUser username = do let path = "/users" attrs = "&username=" <> username - res <- gitlabWithAttrs path attrs + res <- gitlabWithAttrsUnsafe path attrs if null res - then return Nothing - else return (Just (head res)) + then return Nothing + else return (Just (head res)) -- | searches for users given a list of usernames, returns them in -- alphabetical order of their usernames. -orderedUsers :: (MonadIO m) - => [Text] -- ^ usernames to search for - -> GitLab m [User] +orderedUsers :: + (MonadIO m) => + -- | usernames to search for + [Text] -> + GitLab m [User] orderedUsers usernames = do users <- catMaybes <$> mapM searchUser usernames return (orderUsersByName users) diff --git a/src/GitLab/API/Version.hs b/src/GitLab/API/Version.hs new file mode 100644 --- /dev/null +++ b/src/GitLab/API/Version.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Version +-- Description : Queries about GitLab instance version +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2020 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable +module GitLab.API.Version where + +import Control.Monad.IO.Class +import GitLab.Types +import GitLab.WebRequests.GitLabWebCalls +import Network.HTTP.Types.Status + +gitlabVersion :: (MonadIO m) => GitLab m (Either Status (Maybe Version)) +gitlabVersion = do + let path = "/version" + gitlabOne path diff --git a/src/GitLab/Types.hs b/src/GitLab/Types.hs --- a/src/GitLab/Types.hs +++ b/src/GitLab/Types.hs @@ -1,848 +1,974 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-| -Module : GitLab.Types -Description : Haskell records corresponding to JSON data from GitLab API calls -Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 -License : BSD3 -Maintainer : robstewart57@gmail.com -Stability : stable --} -module GitLab.Types - ( - GitLab - , GitLabState(..) - , GitLabServerConfig(..) - , defaultGitLabServer - , ArchiveFormat(..) - , Member(..) - , Namespace(..) - , Links(..) - , Owner(..) - , Permissions(..) - , Project(..) - , ProjectStats(..) - , User(..) - , Milestone(..) - , TimeStats(..) - , Issue(..) - , Pipeline(..) - , Commit(..) - , CommitTodo(..) - , CommitStats(..) - , Diff(..) - , Repository(..) - , Job(..) - , Artifact(..) - , Group(..) - , GroupShare(..) - , Branch(..) - , RepositoryFile(..) - , MergeRequest(..) - , Todo(..) - , TodoAction(..) - , TodoTarget(..) - , TodoState(..) - , URL - ) where - -import Control.Monad.Trans.Reader -import Data.Aeson -import Data.Aeson.Types -import Data.Text (Text) -import Data.Time.Clock -import GHC.Generics -import Network.HTTP.Conduit - --- | type synonym for all GitLab actions. -type GitLab m a = ReaderT GitLabState m a - --- | state used by GitLab actions, used internally. -data GitLabState = - GitLabState - { serverCfg :: GitLabServerConfig - , httpManager :: Manager - } - --- | configuration data specific to a GitLab server. -data GitLabServerConfig = - GitLabServerConfig - { url :: Text - , token :: Text -- ^ personal access token, see - , timeout :: Int -- ^ milliseconds - , retries :: Int -- ^ how many times to retry a HTTP request before giving up and returning an error. - } - --- | default settings, the 'url' and 'token' values will need to be overwritten. -defaultGitLabServer :: GitLabServerConfig -defaultGitLabServer = - GitLabServerConfig - { url = "https://gitlab.com" - , token = "" - , timeout = 15000000 -- 15 seconds - , retries = 5 - } - --- https://docs.gitlab.com/ee/api/repositories.html#get-file-archive --- tar.gz, tar.bz2, tbz, tbz2, tb2, bz2, tar, and zip - --- | archive format for file archives of repositories. --- See 'GitLab.API.Repositories.getFileArchive' in 'GitLab.API.Repositories'. -data ArchiveFormat - = TarGz -- ^ ".tar.gz" - | TarBz2 -- ^ ".tar.bz2" - | Tbz -- ^ ".tbz" - | Tbz2 -- ^ ".tbz2" - | Tb2 -- ^ ".tb2" - | Bz2 -- ^ ".bz2" - | Tar -- ^ ".tar" - | Zip -- ^ ".zip" - -instance Show ArchiveFormat where - show TarGz = ".tar.gz" - show TarBz2 = ".tar.bz2" - show Tbz = ".tbz" - show Tbz2 = ".tbz2" - show Tb2 = ".tb2" - show Bz2 = ".bz2" - show Tar = ".tar" - show Zip = ".zip" - - --- | member of a project. -data Member = - Member - { member_id :: Int - , member_name :: Text - , member_username :: Text - , member_state :: Text - , member_avatar_uri :: Maybe Text - , member_web_url :: Maybe Text - , access_level :: Int - , expires_at :: Maybe Text - } deriving (Generic, Show) - --- | namespaces. -data Namespace = - Namespace - { namespace_id :: Int - , namespace_name :: Text - , namespace_path :: Text - , kind :: Text - , full_path :: Text - , parent_id :: Maybe Text - } deriving (Generic, Show) - --- | links. -data Links = - Links - { self :: Text - , issues :: Text - , merge_requests :: Text - , repo_branches :: Text - , link_labels :: Text - , link_events :: Text - , members :: Text - } deriving (Generic, Show) - --- | owners. -data Owner = - Ownwer - { owner_id :: Int - , owner_name :: Text - , owner_username :: Text - , state :: Text - , owner_avatar_url :: Maybe Text - , owner_web_url :: Text - } deriving (Generic, Show) - --- | permissions. -data Permissions = - Permissions - { project_access :: Maybe Object - , group_access :: Maybe Object - } deriving (Generic, Show) - --- | projects. -data Project = - Project - { project_id :: Int - , description :: Maybe Text - , project_name :: Text - , name_with_namespace :: Text - , project_path :: Text - , path_with_namespace :: Text - , project_created_at :: Text - , default_branch :: Maybe Text - , tag_list:: [Text] -- check - , ssh_url_to_repo:: Text - , http_url_to_repo:: Text - , project_web_url:: Text - , readme_url :: Maybe Text -- check - , project_avatar_url:: Maybe Text -- check - , star_count:: Int - , forks_count:: Int - , last_activity_at:: Text - , namespace :: Namespace - , _links :: Maybe Links - , archived :: Maybe Bool - , visibility :: Maybe Text - , owner :: Maybe Owner - , resolve_outdated_diff_discussions :: Maybe Bool - , container_registry_enabled :: Maybe Bool - , issues_enabled :: Maybe Bool - , merge_requests_enabled:: Maybe Bool - , wiki_enabled :: Maybe Bool - , jobs_enabled :: Maybe Bool - , snippets_enabled :: Maybe Bool - , shared_runners_enabled :: Maybe Bool - , lfs_enabled :: Maybe Bool - , creator_id :: Maybe Int - , forked_from_project :: Maybe Project - , import_status :: Maybe String - , open_issues_count :: Maybe Int - , public_jobs :: Maybe Bool - , ci_config_path :: Maybe Text -- check null - , shared_with_groups :: Maybe [Object] - , only_allow_merge_if_pipeline_succeeds :: Maybe Bool - , request_access_enabled :: Maybe Bool - , only_allow_merge_if_all_discussions_are_resolved :: Maybe Bool - , printing_merge_request_link_enabled :: Maybe Bool - , merge_method:: Maybe Text - , permissions :: Maybe Permissions - , project_stats :: Maybe ProjectStats - } deriving (Generic, Show) - --- | project statistics. -data ProjectStats = - ProjectStats - { commit_count :: Int - , storage_size :: Int - , repository_size :: Int - , wiki_size :: Maybe Int - , lfs_objects_size :: Maybe Int - , job_artifacts_size :: Maybe Int - , packages_size :: Maybe Int - } deriving (Generic, Show) - --- | registered users. -data User = - User - { user_id :: Int - , user_username :: Text - , user_name :: Text - , user_state :: Text - , user_avatar_uri :: Maybe Text - , user_web_url :: Maybe Text - } deriving (Generic, Show) - --- | milestone state. -data MilestoneState = MSActive - | MSClosed - deriving (Show) -instance FromJSON MilestoneState where - parseJSON (String "active") = return MSActive - parseJSON (String "closed") = return MSClosed - parseJSON x = unexpected x - --- | milestones. -data Milestone = - Milestone - { milestone_project_id :: Maybe Int - , milestone_group_id :: Maybe Int - , milestone_description :: Text - , milestone_state :: MilestoneState - , milestone_due_date :: Maybe UTCTime - , milestone_iid :: Int - , milestone_created_at :: Maybe UTCTime - , milestone_title :: Text - , milestone_id :: Int - , milestone_updated_at :: UTCTime - , milestone_web_url :: URL - } deriving (Generic, Show) -instance FromJSON Milestone where - parseJSON = genericParseJSON (defaultOptions { fieldLabelModifier = drop 10 }) - --- | time stats. -data TimeStats = - TimeStats - { time_estimate :: Int - , total_time_spent :: Int - , humane_time_estimate :: Maybe Int - , human_total_time_spent :: Maybe Int - } deriving (Generic, Show) - --- | project issues. -data Issue = - Issue - { issue_state :: Text - , issue_description :: Text - , issue_author :: User - , milestone :: Maybe Milestone - , issue_project_id :: Int - , assignees :: Maybe [User] - , assignee :: Maybe User - , updated_at :: Text - , closed_at :: Maybe Text - , closed_by :: Maybe User - , issue_id :: Int - , issue_title :: Text - , issue_created_at :: Text - , iid :: Int - , issue_labels :: [Text] - , upvotes :: Int - , downvotes :: Int - , user_notes_count :: Int - , issue_due_date :: Maybe Text - , issue_web_url :: Text - , confidential :: Bool - , weight :: Maybe Text -- Int? - , discussion_locked :: Maybe Bool - , time_stats :: TimeStats - } deriving (Generic, Show) - --- | project pipelines -data Pipeline = - Pipeline - { pipeline_id :: Int - , sha :: Text - , pipeline_ref :: Text - , pipeline_status :: Text - , pipeline_web_url :: Maybe Text - } deriving (Generic, Show) - --- | code commits. -data Commit = - Commit - { commit_id :: Text - , short_id :: Text - , title :: Text - , author_name :: Text - , author_email :: Text - , authored_date :: Text - , committer_name :: Text - , committer_email :: Text - , committed_date :: Text - , commit_created_at :: Text - , message :: Text - , parent_ids :: Maybe [Text] - , last_pipeline :: Maybe Pipeline - , commit_stats :: Maybe CommitStats - , commit_status :: Maybe Text - } deriving (Generic, Show) - --- | summary of a code commit for TODOs. -data CommitTodo = - CommitTodo - { todo_commit_id :: Text - , todo_commit_short_id :: Text - , todo_commit_created_at :: Text - , todo_parent_ids :: Maybe [Text] - } deriving (Generic, Show) - --- | commit stats. -data CommitStats = - Stats - { additions :: Int - , deletions :: Int - , total :: Int - } deriving (Generic, Show) - --- | diff between two commits. -data Diff = - Diff - { diff :: Text - , new_path :: Text - , old_path :: Text - , a_mode :: Maybe Text - , b_mode :: Maybe Text - , new_file :: Bool - , renamed_file :: Bool - , deleted_file :: Bool - } deriving (Generic, Show) - --- | repositories. -data Repository = - Repository - { repository_id :: Text - , repository_name :: Text - , repository_type :: Text - , repository_path :: Text - , mode :: Text - } deriving (Generic, Show) - --- | jobs. -data Job = - Job - { - commit :: Commit - , coverage :: Maybe Text -- ? - , created_at :: Text - , started_at :: Text - , finished_at :: Text - , duration :: Double - , artifacts_expire_at :: Maybe Text - , id :: Int - , name :: Text - , pipeline :: Pipeline - , job_ref :: Text - , artifacts :: [Artifact] - -- , runner :: Maybe Text - , stage :: Text - , status :: Text - , tag :: Bool - , job_web_url :: Text - , user :: User - } deriving (Generic, Show) - --- | artifacts. -data Artifact = - Artifact - { file_type :: Text - , size :: Int - , filename :: Text - , file_format :: Maybe Text - } deriving (Generic, Show) - --- | groups. -data Group = - Group - { - group_id :: Int - , group_name :: Text - , group_path :: Text - , group_description :: Text - , group_visibility :: Text - , group_lfs_enabled :: Bool - , group_avatar_url :: Maybe Text - , group_web_url :: Text - , group_request_access_enabled :: Bool - , group_full_name :: Text - , group_full_path :: Text - , group_file_template_project_id :: Maybe Int - , group_parent_id :: Maybe Int - } deriving (Generic, Show) - --- | response to sharing a project with a group. -data GroupShare = - GroupShare - { share_id :: Int - , share_project_id :: Int - , share_group_id :: Int - , share_group_access :: Int - , share_expires_at :: Maybe Text - } deriving (Generic, Show) - --- | code branches. -data Branch = - Branch - { branch_name :: Text - , merged :: Bool - , protected :: Bool - , branch_default :: Bool - , developers_can_push :: Bool - , developers_can_merge :: Bool - , can_push :: Bool - , branch_commit :: Commit - } deriving (Generic, Show) - --- | files in a repository. -data RepositoryFile = - RepositoryFile - { repository_file_file_name :: Text - , repository_file_file_path :: Text - , repository_file_size :: Int - , encoding :: Text - , content :: Text - , content_sha256 :: Text - , ref :: Text - , blob_id :: Text - , repository_file_commit_id :: Text - , last_commit_id :: Text - } deriving (Generic, Show) - --- | project merge requests. -data MergeRequest = - MergeRequest - { merge_request_id :: Int - , merge_request_iid :: Int - , merge_request_project_id :: Int - , merge_request_title :: Text - , merge_request_description :: Text - , merge_request_state :: Text - , merge_request_merged_by :: Maybe User - , merge_request_merged_at :: Maybe Text - , merge_request_closed_by :: Maybe User - , merge_request_closed_at :: Maybe Text - , merge_request_created_at :: Text - , merge_request_updated_at :: Text - , merge_request_target_branch :: Text - , merge_request_source_branch :: Text - , merge_request_upvotes :: Int - , merge_request_downvotes :: Int - , merge_request_author :: User - , merge_request_assignee :: Maybe User - , merge_request_source_project_id :: Int - , merge_request_target_project_id :: Int - , merge_request_labels :: [Text] - , merge_request_work_in_progress :: Bool - , merge_request_milestone :: Maybe Milestone - , merge_request_merge_when_pipeline_succeeds :: Bool - , merge_request_merge_status :: Text - , merge_request_sha :: Text - , merge_request_merge_commit_sha :: Maybe Text - , merge_request_user_notes_count ::Int - , merge_request_discussion_locked :: Maybe Bool - , merge_request_should_remove_source_branch :: Maybe Bool - , merge_request_force_remove_source_branch :: Maybe Bool - , merge_request_allow_collaboration :: Maybe Bool - , merge_request_allow_maintainer_to_push :: Maybe Bool - , merge_request_web_url :: Text - , merge_request_time_stats :: TimeStats - , merge_request_squash :: Bool - , merge_request_changes_count :: Maybe Int - , merge_request_pipeline :: Maybe Pipeline - , merge_request_diverged_commits_count :: Maybe Int - , merge_request_rebase_in_progress :: Maybe Bool - , merge_request_has_conflicts :: Bool - , merge_request_blocking_discussions_resolved :: Maybe Bool - , merge_request_approvals_before_merge :: Maybe Bool -- ? - } deriving (Generic, Show) - --- | TODO actions. -data TodoAction = TAAssigned - | TAMentioned - | TABuildFailed - | TAMarked - | TAApprovalRequired - | TAUnmergeable - | TADirectlyAddressed - deriving (Show) -instance FromJSON TodoAction where - parseJSON (String "assigned") = return TAAssigned - parseJSON (String "mentioned") = return TAMentioned - parseJSON (String "build_failed") = return TABuildFailed - parseJSON (String "marked") = return TAMarked - parseJSON (String "approval_required") = return TAApprovalRequired - parseJSON (String "unmergeable") = return TAUnmergeable - parseJSON (String "directly_addressed") = return TADirectlyAddressed - parseJSON x = unexpected x - --- | TODO targets. -data TodoTarget = TTIssue Issue - | TTMergeRequest MergeRequest - | TTCommit CommitTodo - deriving (Show) - --- | URL is a synonym for 'Text'. -type URL = Text - --- | TODO states. -data TodoState = TSPending - | TSDone - deriving (Show) -instance FromJSON TodoState where - parseJSON (String "pending") = return TSPending - parseJSON (String "done") = return TSDone - parseJSON x = unexpected x - -data TodoProject = TP { tp_id :: Int - , tp_description :: Text - , tp_name :: Text - , tp_name_with_namespace :: Text - , tp_path :: Text - , tp_path_with_namespace :: Text - , tp_created_at :: UTCTime } - deriving (Generic, Show) -instance FromJSON TodoProject where - parseJSON = genericParseJSON (defaultOptions { fieldLabelModifier = drop 3 }) - --- | TODOs. -data Todo = Todo { todo_id :: Int - , todo_project :: TodoProject - , todo_author :: User - , todo_action_name :: TodoAction - , todo_target :: TodoTarget - , todo_target_url :: URL - , todo_body :: Text - , todo_state :: TodoState - , todo_created_at :: UTCTime } - deriving (Show) -instance FromJSON Todo where - parseJSON = withObject "Todo" $ \v -> Todo - <$> v .: "id" - <*> v .: "project" - <*> v .: "author" - <*> v .: "action_name" - <*> (v .: "target_type" >>= \case - "MergeRequest" -> TTMergeRequest <$> v .: "target" - "Issue" -> TTIssue <$> v .: "target" - "Commit" -> TTCommit <$> v .: "target" - (_ :: Text) -> fail "" ) - <*> v .: "target_url" - <*> v .: "body" - <*> v .: "state" - <*> v .: "created_at" - ------------------------------ --- JSON GitLab parsers below ------------------------------ - -bodyNoPrefix :: String -> String -bodyNoPrefix "commit_created_at" = "created_at" -bodyNoPrefix "commit_id" = "id" -bodyNoPrefix "commit_status" = "status" -bodyNoPrefix "todo_commit_id" = "id" -bodyNoPrefix "todo_commit_short_id" = "short_id" -bodyNoPrefix "todo_commit_created_at" = "created_at" -bodyNoPrefix "todo_parent_ids" = "parent_ids" -bodyNoPrefix "issue_author" = "author" -bodyNoPrefix "issue_created_at" = "created_at" -bodyNoPrefix "issue_description" = "description" -bodyNoPrefix "issue_due_date" = "due_date" -bodyNoPrefix "issue_id" = "id" -bodyNoPrefix "issue_labels" = "labels" -bodyNoPrefix "issue_project_id" = "project_id" -bodyNoPrefix "issue_state" = "state" -bodyNoPrefix "issue_title" = "title" -bodyNoPrefix "issue_web_url" = "web_url" -bodyNoPrefix "job_web_url" = "web_url" -bodyNoPrefix "link_events" = "events" -bodyNoPrefix "link_labels" = "labels" -bodyNoPrefix "member_avatar_url" = "avatar_url" -bodyNoPrefix "member_id" = "id" -bodyNoPrefix "member_name" = "name" -bodyNoPrefix "member_state" = "state" -bodyNoPrefix "member_username" = "username" -bodyNoPrefix "member_web_url" = "we_url" -bodyNoPrefix "namespace_id" = "id" -bodyNoPrefix "namespace_name" = "name" -bodyNoPrefix "namespace_path" = "path" -bodyNoPrefix "owner_avatar_url" = "avatar_url" -bodyNoPrefix "owner_id" = "id" -bodyNoPrefix "owner_name" = "name" -bodyNoPrefix "owner_username" = "username" -bodyNoPrefix "owner_web_url" = "web_url" -bodyNoPrefix "pipeline_id" = "id" -bodyNoPrefix "pipeline_status" = "status" -bodyNoPrefix "pipeline_web_url" = "web_url" -bodyNoPrefix "project_avatar_url" = "avatar_url" -bodyNoPrefix "project_created_at" = "created_at" -bodyNoPrefix "project_id" = "id" -bodyNoPrefix "project_name" = "name" -bodyNoPrefix "project_path" = "path" -bodyNoPrefix "project_web_url" = "web_url" -bodyNoPrefix "repository_id" = "id" -bodyNoPrefix "repository_name" = "name" -bodyNoPrefix "repository_path" = "path" -bodyNoPrefix "repository_type" = "type" -bodyNoPrefix "user_avatar_url" = "avatar_url" -bodyNoPrefix "user_id" = "id" -bodyNoPrefix "user_name" = "name" -bodyNoPrefix "user_state" = "state" -bodyNoPrefix "user_username" = "username" -bodyNoPrefix "user_web_url" = "we_url" - -bodyNoPrefix "event_title" = "title" -bodyNoPrefix "event_project_id" = "project_id" - -bodyNoPrefix "job_ref" = "ref" -bodyNoPrefix "pipeline_ref" = "ref" - -bodyNoPrefix "branch_name" = "name" -bodyNoPrefix "branch_default" = "default" -bodyNoPrefix "branch_commit" = "commit" - -bodyNoPrefix "repository_file_file_name" = "file_name" -bodyNoPrefix "repository_file_file_path" = "file_path" -bodyNoPrefix "repository_file_size" = "size" -bodyNoPrefix "repository_file_commit_id" = "commit_id" - -bodyNoPrefix "merge_request_id" = "id" -bodyNoPrefix "merge_request_iid" = "iid" -bodyNoPrefix "merge_request_project_id" = "project_id" -bodyNoPrefix "merge_request_title" = "title" -bodyNoPrefix "merge_request_description" = "description" -bodyNoPrefix "merge_request_state" = "state" -bodyNoPrefix "merge_request_merged_by" = "merged_by" -bodyNoPrefix "merge_request_merged_at" = "merged_at" -bodyNoPrefix "merge_request_closed_by" = "closed_by" -bodyNoPrefix "merge_request_closed_at" = "closed_at" -bodyNoPrefix "merge_request_created_at" = "created_at" -bodyNoPrefix "merge_request_updated_at" = "updated_at" -bodyNoPrefix "merge_request_target_branch" = "target_branch" -bodyNoPrefix "merge_request_source_branch" = "source_branch" -bodyNoPrefix "merge_request_upvotes" = "upvotes" -bodyNoPrefix "merge_request_downvotes" = "downvotes" -bodyNoPrefix "merge_request_author" = "author" -bodyNoPrefix "merge_request_assignee" = "assignee" -bodyNoPrefix "merge_request_source_project_id" = "source_project_id" -bodyNoPrefix "merge_request_target_project_id" = "target_project_id" -bodyNoPrefix "merge_request_labels" = "labels" -bodyNoPrefix "merge_request_work_in_progress" = "work_in_progress" -bodyNoPrefix "merge_request_milestone" = "milestone" -bodyNoPrefix "merge_request_merge_when_pipeline_succeeds" = "merge_when_pipeline_succeeds" -bodyNoPrefix "merge_request_merge_status" = "merge_status" -bodyNoPrefix "merge_request_sha" = "sha" -bodyNoPrefix "merge_request_merge_commit_sha" = "merge_commit_sha" -bodyNoPrefix "merge_request_user_notes_count" = "user_notes_count" -bodyNoPrefix "merge_request_discussion_locked" = "discussion_locked" -bodyNoPrefix "merge_request_should_remove_source_branch" = "should_remove_source_branch" -bodyNoPrefix "merge_request_force_remove_source_branch" = "force_remove_source_branch" -bodyNoPrefix "merge_request_allow_collaboration" = "allow_collaboration" -bodyNoPrefix "merge_request_allow_maintainer_to_push" = "allow_maintainer_to_push" -bodyNoPrefix "merge_request_web_url" = "web_url" -bodyNoPrefix "merge_request_time_stats" = "time_stats" -bodyNoPrefix "merge_request_squash" = "squash" -bodyNoPrefix "merge_request_approvals_before_merge" = "approvals_before_merge" -bodyNoPrefix "merge_request_allow_contribution" = "allow_contribution" -bodyNoPrefix "merge_request_changes_count" = "changes_count" -bodyNoPrefix "merge_request_pipeline" = "pipeline" -bodyNoPrefix "merge_request_diverged_commits_count" = "diverged_commits_count" -bodyNoPrefix "merge_request_rebase_in_progress" = "rebase_in_progress" -bodyNoPrefix "merge_request_has_conflicts" = "has_conflicts" -bodyNoPrefix "merge_request_blocking_discussions_resolved" = "blocking_discussions_resolved" - - -bodyNoPrefix "project_stats" = "statistics" -bodyNoPrefix "commit_stats" = "stats" - -bodyNoPrefix "share_id" = "id" -bodyNoPrefix "share_project_id" = "project_id" -bodyNoPrefix "share_group_id" = "group_id" -bodyNoPrefix "share_group_access" = "group_access" -bodyNoPrefix "share_expires_at" = "expires_at" - -bodyNoPrefix "group_id" = "id" -bodyNoPrefix "group_name" = "name" -bodyNoPrefix "group_path" = "path" -bodyNoPrefix "group_description" = "description" -bodyNoPrefix "group_visibility" = "visibility" -bodyNoPrefix "group_lfs_enabled" = "lfs_enabled" -bodyNoPrefix "group_avatar_url" = "avatar_url" -bodyNoPrefix "group_web_url" = "web_url" -bodyNoPrefix "group_request_access_enabled" = "request_access_enabled" -bodyNoPrefix "group_full_name" = "full_name" -bodyNoPrefix "group_full_path" = "full_path" -bodyNoPrefix "group_file_template_project_id" = "file_template_project_id" -bodyNoPrefix "group_parent_id" = "parent_id" --- TODO field names for Issues data type -bodyNoPrefix s = s - -instance FromJSON TimeStats where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Issue where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON User where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Commit where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON CommitTodo where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON CommitStats where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Pipeline where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Member where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Permissions where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Owner where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Links where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Namespace where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Project where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON ProjectStats where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Repository where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Job where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Artifact where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Group where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON GroupShare where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Branch where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON RepositoryFile where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON MergeRequest where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) - -instance FromJSON Diff where - parseJSON = genericParseJSON - (defaultOptions - { fieldLabelModifier = bodyNoPrefix }) +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : GitLab.Types +-- Description : Haskell records corresponding to JSON data from GitLab API calls +-- Copyright : (c) Rob Stewart, Heriot-Watt University, 2019 +-- License : BSD3 +-- Maintainer : robstewart57@gmail.com +-- Stability : stable +module GitLab.Types + ( GitLab, + GitLabState (..), + GitLabServerConfig (..), + defaultGitLabServer, + ArchiveFormat (..), + Member (..), + Namespace (..), + Links (..), + Owner (..), + Permissions (..), + Project (..), + ProjectStats (..), + User (..), + Milestone (..), + TimeStats (..), + Issue (..), + Pipeline (..), + Commit (..), + CommitTodo (..), + CommitStats (..), + Diff (..), + Repository (..), + Job (..), + Artifact (..), + Group (..), + GroupShare (..), + Branch (..), + RepositoryFile (..), + MergeRequest (..), + Todo (..), + TodoAction (..), + TodoTarget (..), + TodoState (..), + Version (..), + URL, + ) +where + +import Control.Monad.Trans.Reader +import Data.Aeson +import Data.Aeson.Types +import Data.Text (Text) +import Data.Time.Clock +import GHC.Generics +import Network.HTTP.Conduit + +-- | type synonym for all GitLab actions. +type GitLab m a = ReaderT GitLabState m a + +-- | state used by GitLab actions, used internally. +data GitLabState + = GitLabState + { serverCfg :: GitLabServerConfig, + httpManager :: Manager + } + +-- | configuration data specific to a GitLab server. +data GitLabServerConfig + = GitLabServerConfig + { url :: Text, + -- | personal access token, see + token :: Text, + -- | milliseconds + timeout :: Int, + -- | how many times to retry a HTTP request before giving up and returning an error. + retries :: Int + } + +-- | default settings, the 'url' and 'token' values will need to be overwritten. +defaultGitLabServer :: GitLabServerConfig +defaultGitLabServer = + GitLabServerConfig + { url = "https://gitlab.com", + token = "", + timeout = 15000000, -- 15 seconds + retries = 5 + } + +-- https://docs.gitlab.com/ee/api/repositories.html#get-file-archive +-- tar.gz, tar.bz2, tbz, tbz2, tb2, bz2, tar, and zip + +-- | archive format for file archives of repositories. +-- See 'GitLab.API.Repositories.getFileArchive' in 'GitLab.API.Repositories'. +data ArchiveFormat + = -- | ".tar.gz" + TarGz + | -- | ".tar.bz2" + TarBz2 + | -- | ".tbz" + Tbz + | -- | ".tbz2" + Tbz2 + | -- | ".tb2" + Tb2 + | -- | ".bz2" + Bz2 + | -- | ".tar" + Tar + | -- | ".zip" + Zip + +instance Show ArchiveFormat where + show TarGz = ".tar.gz" + show TarBz2 = ".tar.bz2" + show Tbz = ".tbz" + show Tbz2 = ".tbz2" + show Tb2 = ".tb2" + show Bz2 = ".bz2" + show Tar = ".tar" + show Zip = ".zip" + +-- | member of a project. +data Member + = Member + { member_id :: Int, + member_name :: Text, + member_username :: Text, + member_state :: Text, + member_avatar_uri :: Maybe Text, + member_web_url :: Maybe Text, + access_level :: Int, + expires_at :: Maybe Text + } + deriving (Generic, Show) + +-- | namespaces. +data Namespace + = Namespace + { namespace_id :: Int, + namespace_name :: Text, + namespace_path :: Text, + kind :: Text, + full_path :: Text, + parent_id :: Maybe Text + } + deriving (Generic, Show) + +-- | links. +data Links + = Links + { self :: Text, + issues :: Text, + merge_requests :: Text, + repo_branches :: Text, + link_labels :: Text, + link_events :: Text, + members :: Text + } + deriving (Generic, Show) + +-- | owners. +data Owner + = Ownwer + { owner_id :: Int, + owner_name :: Text, + owner_username :: Text, + state :: Text, + owner_avatar_url :: Maybe Text, + owner_web_url :: Text + } + deriving (Generic, Show) + +-- | permissions. +data Permissions + = Permissions + { project_access :: Maybe Object, + group_access :: Maybe Object + } + deriving (Generic, Show) + +-- | projects. +data Project + = Project + { project_id :: Int, + description :: Maybe Text, + project_name :: Text, + name_with_namespace :: Text, + project_path :: Text, + path_with_namespace :: Text, + project_created_at :: Text, + default_branch :: Maybe Text, + tag_list :: [Text], -- check + ssh_url_to_repo :: Text, + http_url_to_repo :: Text, + project_web_url :: Text, + readme_url :: Maybe Text, -- check + project_avatar_url :: Maybe Text, -- check + star_count :: Int, + forks_count :: Int, + last_activity_at :: Text, + namespace :: Namespace, + _links :: Maybe Links, + archived :: Maybe Bool, + visibility :: Maybe Text, + owner :: Maybe Owner, + resolve_outdated_diff_discussions :: Maybe Bool, + container_registry_enabled :: Maybe Bool, + issues_enabled :: Maybe Bool, + merge_requests_enabled :: Maybe Bool, + wiki_enabled :: Maybe Bool, + jobs_enabled :: Maybe Bool, + snippets_enabled :: Maybe Bool, + shared_runners_enabled :: Maybe Bool, + lfs_enabled :: Maybe Bool, + creator_id :: Maybe Int, + forked_from_project :: Maybe Project, + import_status :: Maybe String, + open_issues_count :: Maybe Int, + public_jobs :: Maybe Bool, + ci_config_path :: Maybe Text, -- check null + shared_with_groups :: Maybe [Object], + only_allow_merge_if_pipeline_succeeds :: Maybe Bool, + request_access_enabled :: Maybe Bool, + only_allow_merge_if_all_discussions_are_resolved :: Maybe Bool, + printing_merge_request_link_enabled :: Maybe Bool, + merge_method :: Maybe Text, + permissions :: Maybe Permissions, + project_stats :: Maybe ProjectStats + } + deriving (Generic, Show) + +-- | project statistics. +data ProjectStats + = ProjectStats + { commit_count :: Int, + storage_size :: Int, + repository_size :: Int, + wiki_size :: Maybe Int, + lfs_objects_size :: Maybe Int, + job_artifacts_size :: Maybe Int, + packages_size :: Maybe Int + } + deriving (Generic, Show) + +-- | registered users. +data User + = User + { user_id :: Int, + user_username :: Text, + user_name :: Text, + user_state :: Text, + user_avatar_uri :: Maybe Text, + user_web_url :: Maybe Text + } + deriving (Generic, Show) + +-- | milestone state. +data MilestoneState + = MSActive + | MSClosed + deriving (Show) + +instance FromJSON MilestoneState where + parseJSON (String "active") = return MSActive + parseJSON (String "closed") = return MSClosed + parseJSON x = unexpected x + +-- | milestones. +data Milestone + = Milestone + { milestone_project_id :: Maybe Int, + milestone_group_id :: Maybe Int, + milestone_description :: Text, + milestone_state :: MilestoneState, + milestone_due_date :: Maybe UTCTime, + milestone_iid :: Int, + milestone_created_at :: Maybe UTCTime, + milestone_title :: Text, + milestone_id :: Int, + milestone_updated_at :: UTCTime, + milestone_web_url :: URL + } + deriving (Generic, Show) + +instance FromJSON Milestone where + parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 10}) + +-- | time stats. +data TimeStats + = TimeStats + { time_estimate :: Int, + total_time_spent :: Int, + humane_time_estimate :: Maybe Int, + human_total_time_spent :: Maybe Int + } + deriving (Generic, Show) + +-- | project issues. +data Issue + = Issue + { issue_state :: Text, + issue_description :: Text, + issue_author :: User, + milestone :: Maybe Milestone, + issue_project_id :: Int, + assignees :: Maybe [User], + assignee :: Maybe User, + updated_at :: Text, + closed_at :: Maybe Text, + closed_by :: Maybe User, + issue_id :: Int, + issue_title :: Text, + issue_created_at :: Text, + iid :: Int, + issue_labels :: [Text], + upvotes :: Int, + downvotes :: Int, + user_notes_count :: Int, + issue_due_date :: Maybe Text, + issue_web_url :: Text, + confidential :: Bool, + weight :: Maybe Text, -- Int? + discussion_locked :: Maybe Bool, + time_stats :: TimeStats + } + deriving (Generic, Show) + +-- | project pipelines +data Pipeline + = Pipeline + { pipeline_id :: Int, + sha :: Text, + pipeline_ref :: Text, + pipeline_status :: Text, + pipeline_web_url :: Maybe Text + } + deriving (Generic, Show) + +-- | code commits. +data Commit + = Commit + { commit_id :: Text, + short_id :: Text, + title :: Text, + author_name :: Text, + author_email :: Text, + authored_date :: Text, + committer_name :: Text, + committer_email :: Text, + committed_date :: Text, + commit_created_at :: Text, + message :: Text, + parent_ids :: Maybe [Text], + last_pipeline :: Maybe Pipeline, + commit_stats :: Maybe CommitStats, + commit_status :: Maybe Text + } + deriving (Generic, Show) + +-- | summary of a code commit for TODOs. +data CommitTodo + = CommitTodo + { todo_commit_id :: Text, + todo_commit_short_id :: Text, + todo_commit_created_at :: Text, + todo_parent_ids :: Maybe [Text] + } + deriving (Generic, Show) + +-- | commit stats. +data CommitStats + = Stats + { additions :: Int, + deletions :: Int, + total :: Int + } + deriving (Generic, Show) + +-- | diff between two commits. +data Diff + = Diff + { diff :: Text, + new_path :: Text, + old_path :: Text, + a_mode :: Maybe Text, + b_mode :: Maybe Text, + new_file :: Bool, + renamed_file :: Bool, + deleted_file :: Bool + } + deriving (Generic, Show) + +-- | repositories. +data Repository + = Repository + { repository_id :: Text, + repository_name :: Text, + repository_type :: Text, + repository_path :: Text, + mode :: Text + } + deriving (Generic, Show) + +-- | jobs. +data Job + = Job + { commit :: Commit, + coverage :: Maybe Text, -- ? + created_at :: Text, + started_at :: Text, + finished_at :: Text, + duration :: Double, + artifacts_expire_at :: Maybe Text, + id :: Int, + name :: Text, + pipeline :: Pipeline, + job_ref :: Text, + artifacts :: [Artifact], + -- , runner :: Maybe Text + stage :: Text, + status :: Text, + tag :: Bool, + job_web_url :: Text, + user :: User + } + deriving (Generic, Show) + +-- | artifacts. +data Artifact + = Artifact + { file_type :: Text, + size :: Int, + filename :: Text, + file_format :: Maybe Text + } + deriving (Generic, Show) + +-- | groups. +data Group + = Group + { group_id :: Int, + group_name :: Text, + group_path :: Text, + group_description :: Text, + group_visibility :: Text, + group_lfs_enabled :: Bool, + group_avatar_url :: Maybe Text, + group_web_url :: Text, + group_request_access_enabled :: Bool, + group_full_name :: Text, + group_full_path :: Text, + group_file_template_project_id :: Maybe Int, + group_parent_id :: Maybe Int + } + deriving (Generic, Show) + +-- | response to sharing a project with a group. +data GroupShare + = GroupShare + { share_id :: Int, + share_project_id :: Int, + share_group_id :: Int, + share_group_access :: Int, + share_expires_at :: Maybe Text + } + deriving (Generic, Show) + +-- | code branches. +data Branch + = Branch + { branch_name :: Text, + merged :: Bool, + protected :: Bool, + branch_default :: Bool, + developers_can_push :: Bool, + developers_can_merge :: Bool, + can_push :: Bool, + branch_commit :: Commit + } + deriving (Generic, Show) + +-- | files in a repository. +data RepositoryFile + = RepositoryFile + { repository_file_file_name :: Text, + repository_file_file_path :: Text, + repository_file_size :: Int, + encoding :: Text, + content :: Text, + content_sha256 :: Text, + ref :: Text, + blob_id :: Text, + repository_file_commit_id :: Text, + last_commit_id :: Text + } + deriving (Generic, Show) + +-- | project merge requests. +data MergeRequest + = MergeRequest + { merge_request_id :: Int, + merge_request_iid :: Int, + merge_request_project_id :: Int, + merge_request_title :: Text, + merge_request_description :: Text, + merge_request_state :: Text, + merge_request_merged_by :: Maybe User, + merge_request_merged_at :: Maybe Text, + merge_request_closed_by :: Maybe User, + merge_request_closed_at :: Maybe Text, + merge_request_created_at :: Text, + merge_request_updated_at :: Text, + merge_request_target_branch :: Text, + merge_request_source_branch :: Text, + merge_request_upvotes :: Int, + merge_request_downvotes :: Int, + merge_request_author :: User, + merge_request_assignee :: Maybe User, + merge_request_source_project_id :: Int, + merge_request_target_project_id :: Int, + merge_request_labels :: [Text], + merge_request_work_in_progress :: Bool, + merge_request_milestone :: Maybe Milestone, + merge_request_merge_when_pipeline_succeeds :: Bool, + merge_request_merge_status :: Text, + merge_request_sha :: Text, + merge_request_merge_commit_sha :: Maybe Text, + merge_request_user_notes_count :: Int, + merge_request_discussion_locked :: Maybe Bool, + merge_request_should_remove_source_branch :: Maybe Bool, + merge_request_force_remove_source_branch :: Maybe Bool, + merge_request_allow_collaboration :: Maybe Bool, + merge_request_allow_maintainer_to_push :: Maybe Bool, + merge_request_web_url :: Text, + merge_request_time_stats :: TimeStats, + merge_request_squash :: Bool, + merge_request_changes_count :: Maybe Int, + merge_request_pipeline :: Maybe Pipeline, + merge_request_diverged_commits_count :: Maybe Int, + merge_request_rebase_in_progress :: Maybe Bool, + merge_request_has_conflicts :: Bool, + merge_request_blocking_discussions_resolved :: Maybe Bool, + merge_request_approvals_before_merge :: Maybe Bool -- ? + } + deriving (Generic, Show) + +-- | TODO actions. +data TodoAction + = TAAssigned + | TAMentioned + | TABuildFailed + | TAMarked + | TAApprovalRequired + | TAUnmergeable + | TADirectlyAddressed + deriving (Show) + +instance FromJSON TodoAction where + parseJSON (String "assigned") = return TAAssigned + parseJSON (String "mentioned") = return TAMentioned + parseJSON (String "build_failed") = return TABuildFailed + parseJSON (String "marked") = return TAMarked + parseJSON (String "approval_required") = return TAApprovalRequired + parseJSON (String "unmergeable") = return TAUnmergeable + parseJSON (String "directly_addressed") = return TADirectlyAddressed + parseJSON x = unexpected x + +-- | TODO targets. +data TodoTarget + = TTIssue Issue + | TTMergeRequest MergeRequest + | TTCommit CommitTodo + deriving (Show) + +-- | URL is a synonym for 'Text'. +type URL = Text + +-- | TODO states. +data TodoState + = TSPending + | TSDone + deriving (Show) + +instance FromJSON TodoState where + parseJSON (String "pending") = return TSPending + parseJSON (String "done") = return TSDone + parseJSON x = unexpected x + +data TodoProject + = TP + { tp_id :: Int, + tp_description :: Text, + tp_name :: Text, + tp_name_with_namespace :: Text, + tp_path :: Text, + tp_path_with_namespace :: Text, + tp_created_at :: UTCTime + } + deriving (Generic, Show) + +instance FromJSON TodoProject where + parseJSON = genericParseJSON (defaultOptions {fieldLabelModifier = drop 3}) + +-- | TODOs. +data Todo + = Todo + { todo_id :: Int, + todo_project :: TodoProject, + todo_author :: User, + todo_action_name :: TodoAction, + todo_target :: TodoTarget, + todo_target_url :: URL, + todo_body :: Text, + todo_state :: TodoState, + todo_created_at :: UTCTime + } + deriving (Show) + +instance FromJSON Todo where + parseJSON = withObject "Todo" $ \v -> + Todo + <$> v .: "id" + <*> v .: "project" + <*> v .: "author" + <*> v .: "action_name" + <*> ( v .: "target_type" >>= \case + "MergeRequest" -> TTMergeRequest <$> v .: "target" + "Issue" -> TTIssue <$> v .: "target" + "Commit" -> TTCommit <$> v .: "target" + (_ :: Text) -> fail "" + ) + <*> v .: "target_url" + <*> v .: "body" + <*> v .: "state" + <*> v .: "created_at" + +-- | version of the GitLab instance. +data Version + = Version + { version :: Text, + revision :: Text + } + deriving (Generic, Show) + +----------------------------- +-- JSON GitLab parsers below +----------------------------- + +bodyNoPrefix :: String -> String +bodyNoPrefix "commit_created_at" = "created_at" +bodyNoPrefix "commit_id" = "id" +bodyNoPrefix "commit_status" = "status" +bodyNoPrefix "todo_commit_id" = "id" +bodyNoPrefix "todo_commit_short_id" = "short_id" +bodyNoPrefix "todo_commit_created_at" = "created_at" +bodyNoPrefix "todo_parent_ids" = "parent_ids" +bodyNoPrefix "issue_author" = "author" +bodyNoPrefix "issue_created_at" = "created_at" +bodyNoPrefix "issue_description" = "description" +bodyNoPrefix "issue_due_date" = "due_date" +bodyNoPrefix "issue_id" = "id" +bodyNoPrefix "issue_labels" = "labels" +bodyNoPrefix "issue_project_id" = "project_id" +bodyNoPrefix "issue_state" = "state" +bodyNoPrefix "issue_title" = "title" +bodyNoPrefix "issue_web_url" = "web_url" +bodyNoPrefix "job_web_url" = "web_url" +bodyNoPrefix "link_events" = "events" +bodyNoPrefix "link_labels" = "labels" +bodyNoPrefix "member_avatar_url" = "avatar_url" +bodyNoPrefix "member_id" = "id" +bodyNoPrefix "member_name" = "name" +bodyNoPrefix "member_state" = "state" +bodyNoPrefix "member_username" = "username" +bodyNoPrefix "member_web_url" = "we_url" +bodyNoPrefix "namespace_id" = "id" +bodyNoPrefix "namespace_name" = "name" +bodyNoPrefix "namespace_path" = "path" +bodyNoPrefix "owner_avatar_url" = "avatar_url" +bodyNoPrefix "owner_id" = "id" +bodyNoPrefix "owner_name" = "name" +bodyNoPrefix "owner_username" = "username" +bodyNoPrefix "owner_web_url" = "web_url" +bodyNoPrefix "pipeline_id" = "id" +bodyNoPrefix "pipeline_status" = "status" +bodyNoPrefix "pipeline_web_url" = "web_url" +bodyNoPrefix "project_avatar_url" = "avatar_url" +bodyNoPrefix "project_created_at" = "created_at" +bodyNoPrefix "project_id" = "id" +bodyNoPrefix "project_name" = "name" +bodyNoPrefix "project_path" = "path" +bodyNoPrefix "project_web_url" = "web_url" +bodyNoPrefix "repository_id" = "id" +bodyNoPrefix "repository_name" = "name" +bodyNoPrefix "repository_path" = "path" +bodyNoPrefix "repository_type" = "type" +bodyNoPrefix "user_avatar_url" = "avatar_url" +bodyNoPrefix "user_id" = "id" +bodyNoPrefix "user_name" = "name" +bodyNoPrefix "user_state" = "state" +bodyNoPrefix "user_username" = "username" +bodyNoPrefix "user_web_url" = "we_url" +bodyNoPrefix "event_title" = "title" +bodyNoPrefix "event_project_id" = "project_id" +bodyNoPrefix "job_ref" = "ref" +bodyNoPrefix "pipeline_ref" = "ref" +bodyNoPrefix "branch_name" = "name" +bodyNoPrefix "branch_default" = "default" +bodyNoPrefix "branch_commit" = "commit" +bodyNoPrefix "repository_file_file_name" = "file_name" +bodyNoPrefix "repository_file_file_path" = "file_path" +bodyNoPrefix "repository_file_size" = "size" +bodyNoPrefix "repository_file_commit_id" = "commit_id" +bodyNoPrefix "merge_request_id" = "id" +bodyNoPrefix "merge_request_iid" = "iid" +bodyNoPrefix "merge_request_project_id" = "project_id" +bodyNoPrefix "merge_request_title" = "title" +bodyNoPrefix "merge_request_description" = "description" +bodyNoPrefix "merge_request_state" = "state" +bodyNoPrefix "merge_request_merged_by" = "merged_by" +bodyNoPrefix "merge_request_merged_at" = "merged_at" +bodyNoPrefix "merge_request_closed_by" = "closed_by" +bodyNoPrefix "merge_request_closed_at" = "closed_at" +bodyNoPrefix "merge_request_created_at" = "created_at" +bodyNoPrefix "merge_request_updated_at" = "updated_at" +bodyNoPrefix "merge_request_target_branch" = "target_branch" +bodyNoPrefix "merge_request_source_branch" = "source_branch" +bodyNoPrefix "merge_request_upvotes" = "upvotes" +bodyNoPrefix "merge_request_downvotes" = "downvotes" +bodyNoPrefix "merge_request_author" = "author" +bodyNoPrefix "merge_request_assignee" = "assignee" +bodyNoPrefix "merge_request_source_project_id" = "source_project_id" +bodyNoPrefix "merge_request_target_project_id" = "target_project_id" +bodyNoPrefix "merge_request_labels" = "labels" +bodyNoPrefix "merge_request_work_in_progress" = "work_in_progress" +bodyNoPrefix "merge_request_milestone" = "milestone" +bodyNoPrefix "merge_request_merge_when_pipeline_succeeds" = "merge_when_pipeline_succeeds" +bodyNoPrefix "merge_request_merge_status" = "merge_status" +bodyNoPrefix "merge_request_sha" = "sha" +bodyNoPrefix "merge_request_merge_commit_sha" = "merge_commit_sha" +bodyNoPrefix "merge_request_user_notes_count" = "user_notes_count" +bodyNoPrefix "merge_request_discussion_locked" = "discussion_locked" +bodyNoPrefix "merge_request_should_remove_source_branch" = "should_remove_source_branch" +bodyNoPrefix "merge_request_force_remove_source_branch" = "force_remove_source_branch" +bodyNoPrefix "merge_request_allow_collaboration" = "allow_collaboration" +bodyNoPrefix "merge_request_allow_maintainer_to_push" = "allow_maintainer_to_push" +bodyNoPrefix "merge_request_web_url" = "web_url" +bodyNoPrefix "merge_request_time_stats" = "time_stats" +bodyNoPrefix "merge_request_squash" = "squash" +bodyNoPrefix "merge_request_approvals_before_merge" = "approvals_before_merge" +bodyNoPrefix "merge_request_allow_contribution" = "allow_contribution" +bodyNoPrefix "merge_request_changes_count" = "changes_count" +bodyNoPrefix "merge_request_pipeline" = "pipeline" +bodyNoPrefix "merge_request_diverged_commits_count" = "diverged_commits_count" +bodyNoPrefix "merge_request_rebase_in_progress" = "rebase_in_progress" +bodyNoPrefix "merge_request_has_conflicts" = "has_conflicts" +bodyNoPrefix "merge_request_blocking_discussions_resolved" = "blocking_discussions_resolved" +bodyNoPrefix "project_stats" = "statistics" +bodyNoPrefix "commit_stats" = "stats" +bodyNoPrefix "share_id" = "id" +bodyNoPrefix "share_project_id" = "project_id" +bodyNoPrefix "share_group_id" = "group_id" +bodyNoPrefix "share_group_access" = "group_access" +bodyNoPrefix "share_expires_at" = "expires_at" +bodyNoPrefix "group_id" = "id" +bodyNoPrefix "group_name" = "name" +bodyNoPrefix "group_path" = "path" +bodyNoPrefix "group_description" = "description" +bodyNoPrefix "group_visibility" = "visibility" +bodyNoPrefix "group_lfs_enabled" = "lfs_enabled" +bodyNoPrefix "group_avatar_url" = "avatar_url" +bodyNoPrefix "group_web_url" = "web_url" +bodyNoPrefix "group_request_access_enabled" = "request_access_enabled" +bodyNoPrefix "group_full_name" = "full_name" +bodyNoPrefix "group_full_path" = "full_path" +bodyNoPrefix "group_file_template_project_id" = "file_template_project_id" +bodyNoPrefix "group_parent_id" = "parent_id" +-- TODO field names for Issues data type +bodyNoPrefix s = s + +instance FromJSON TimeStats where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Issue where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON User where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Commit where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON CommitTodo where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON CommitStats where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Pipeline where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Member where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Permissions where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Owner where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Links where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Namespace where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Project where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON ProjectStats where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Repository where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Job where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Artifact where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Group where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON GroupShare where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Branch where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON RepositoryFile where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON MergeRequest where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Diff where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) + +instance FromJSON Version where + parseJSON = + genericParseJSON + ( defaultOptions + { fieldLabelModifier = bodyNoPrefix + } + ) diff --git a/src/GitLab/WebRequests/GitLabWebCalls.hs b/src/GitLab/WebRequests/GitLabWebCalls.hs --- a/src/GitLab/WebRequests/GitLabWebCalls.hs +++ b/src/GitLab/WebRequests/GitLabWebCalls.hs @@ -1,85 +1,107 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | internal module to support modules in GitLab.API module GitLab.WebRequests.GitLabWebCalls - ( - gitlab - , gitlabWithAttrs - , gitlabOne - , gitlabWithAttrsOne - , gitlabPost - , gitlabReqText - , gitlabReqByteString - ) where + ( gitlab, + gitlabUnsafe, + gitlabWithAttrs, + gitlabWithAttrsUnsafe, + gitlabOne, + gitlabWithAttrsOne, + gitlabWithAttrsOneUnsafe, + gitlabPost, + gitlabReqText, + gitlabReqByteString, + ) +where -import Network.HTTP.Conduit +import qualified Control.Exception as Exception +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.Aeson import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Lazy.Char8 as C +import Data.Either import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Aeson -import qualified Control.Exception as E -import Network.HTTP.Types.Status import GitLab.Types -import Control.Monad.Trans.Reader -import Control.Monad.IO.Class -import Data.ByteString.Lazy.Char8 as C +import Network.HTTP.Conduit +import Network.HTTP.Types.Status import Network.HTTP.Types.URI +newtype GitLabException = GitLabException String + deriving (Eq, Show) + +instance Exception.Exception GitLabException + +-- In this module, "unsafe" functions are those that discard HTTP +-- error code responses, e.g. 404, 409. + gitlabPost :: (MonadIO m, FromJSON b) => - Text -- ^ the URL to post to - -> Text -- ^ the data to post - -> GitLab m (Either Status b) + -- | the URL to post to + Text -> + -- | the data to post + Text -> + GitLab m (Either Status b) gitlabPost urlPath dataBody = do cfg <- serverCfg <$> ask manager <- httpManager <$> ask let url' = url cfg <> "/api/v4" <> urlPath let request' = parseRequest_ (T.unpack url') - request = request' - { method = "POST" - , requestHeaders = - [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))] - , requestBody = RequestBodyBS (T.encodeUtf8 dataBody) } - res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing - case responseStatus res of - resp@(Status 404 _msg) -> return (Left resp) - resp@(Status 409 _msg) -> return (Left resp) - _ -> return (case parseBSOne (responseBody res) of - Just x -> Right x - Nothing -> Left $ - mkStatus 409 "unable to parse POST response") + request = + request' + { method = "POST", + requestHeaders = + [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))], + requestBody = RequestBodyBS (T.encodeUtf8 dataBody) + } + resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + if successStatus (responseStatus resp) + then + return + ( case parseBSOne (responseBody resp) of + Just x -> Right x + Nothing -> + Left $ + mkStatus 409 "unable to parse POST response" + ) + else return (Left (responseStatus resp)) tryGitLab :: - Int -- ^ the current retry count - -> Request -- ^ the GitLab request - -> Int -- ^ maximum number of retries permitted - -> Manager -- ^ HTTP manager - -> Maybe HttpException -- ^ the exception to report if maximum retries met - -> IO (Response BSL.ByteString) + -- | the current retry count + Int -> + -- | the GitLab request + Request -> + -- | maximum number of retries permitted + Int -> + -- | HTTP manager + Manager -> + -- | the exception to report if maximum retries met + Maybe HttpException -> + IO (Response BSL.ByteString) tryGitLab i request maxRetries manager lastException | i == maxRetries = error (show lastException) | otherwise = - httpLbs request manager - `E.catch` - \ex -> tryGitLab (i+1) request maxRetries manager (Just ex) + httpLbs request manager + `Exception.catch` \ex -> tryGitLab (i + 1) request maxRetries manager (Just ex) parseBSOne :: FromJSON a => BSL.ByteString -> Maybe a parseBSOne bs = case eitherDecode bs of Left _err -> Nothing - -- useful when debugging - -- error (show _err) + -- useful when debugging Right xs -> Just xs -parseBSMany :: FromJSON a => BSL.ByteString -> [a] +parseBSMany :: FromJSON a => BSL.ByteString -> IO [a] parseBSMany bs = case eitherDecode bs of - Left s -> error s - Right xs -> xs + Left s -> Exception.throwIO $ GitLabException s + Right xs -> return xs -gitlabReqJsonMany :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a] +gitlabReqJsonMany :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status [a]) gitlabReqJsonMany urlPath attrs = go 1 [] where @@ -87,74 +109,100 @@ cfg <- serverCfg <$> ask manager <- httpManager <$> ask let url' = - url cfg - <> "/api/v4" - <> urlPath - <> "?per_page=100" - <> "&page=" - <> T.pack (show i) - <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 attrs)) + url cfg + <> "/api/v4" + <> urlPath + <> "?per_page=100" + <> "&page=" + <> T.pack (show i) + <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 attrs)) let request' = parseRequest_ (T.unpack url') - request = request' - { requestHeaders = - [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))] - , responseTimeout = responseTimeoutMicro (timeout cfg) - } - res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing - let numPages = totalPages res - accum' = accum ++ parseBSMany (responseBody res) - if numPages == i - then return accum' - else go (i+1) accum' + request = + request' + { requestHeaders = + [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))], + responseTimeout = responseTimeoutMicro (timeout cfg) + } + resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + if successStatus (responseStatus resp) + then do + moreResults <- liftIO $ parseBSMany (responseBody resp) + let numPages = totalPages resp + accum' = accum ++ moreResults + if numPages == i + then return (Right accum') + else go (i + 1) accum' + else return (Left (responseStatus resp)) -gitlabReqOne :: (MonadIO m) => (BSL.ByteString -> output) -> Text -> Text -> GitLab m output +gitlabReqOne :: (MonadIO m) => (BSL.ByteString -> output) -> Text -> Text -> GitLab m (Either Status output) gitlabReqOne parser urlPath attrs = go where go = do cfg <- serverCfg <$> ask manager <- httpManager <$> ask let url' = - url cfg - <> "/api/v4" - <> urlPath - <> "?per_page=100" - <> "&page=1" - <> attrs + url cfg + <> "/api/v4" + <> urlPath + <> "?per_page=100" + <> "&page=1" + <> attrs let request' = parseRequest_ (T.unpack url') - request = request' - { requestHeaders = - [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))] - , responseTimeout = responseTimeoutMicro (timeout cfg) - } - res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing - return (parser (responseBody res)) + request = + request' + { requestHeaders = + [("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))], + responseTimeout = responseTimeoutMicro (timeout cfg) + } + resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + if successStatus (responseStatus resp) + then return (Right (parser (responseBody resp))) + else return (Left (responseStatus resp)) + where -gitlabReqJsonOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a) -gitlabReqJsonOne = gitlabReqOne parseBSOne +gitlabReqJsonOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status (Maybe a)) +gitlabReqJsonOne gitlabURL attr = do + gitlabReqOne parseBSOne gitlabURL attr -gitlabReqText :: (MonadIO m) => Text -> GitLab m String +gitlabReqText :: (MonadIO m) => Text -> GitLab m (Either Status String) gitlabReqText urlPath = gitlabReqOne C.unpack urlPath "" -gitlabReqByteString :: (MonadIO m) => Text -> GitLab m BSL.ByteString +gitlabReqByteString :: (MonadIO m) => Text -> GitLab m (Either Status BSL.ByteString) gitlabReqByteString urlPath = gitlabReqOne Prelude.id urlPath "" -gitlab :: (MonadIO m, FromJSON a) => Text -> GitLab m [a] +gitlab :: (MonadIO m, FromJSON a) => Text -> GitLab m (Either Status [a]) gitlab addr = gitlabReqJsonMany addr "" -gitlabOne :: (MonadIO m, FromJSON a) => Text -> GitLab m (Maybe a) +gitlabUnsafe :: (MonadIO m, FromJSON a) => Text -> GitLab m [a] +gitlabUnsafe addr = do + fromRight (error "gitlabUnsafe error") <$> gitlab addr + +gitlabOne :: (MonadIO m, FromJSON a) => Text -> GitLab m (Either Status (Maybe a)) gitlabOne addr = gitlabReqJsonOne addr "" -gitlabWithAttrs :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a] -gitlabWithAttrs = gitlabReqJsonMany +gitlabWithAttrs :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status [a]) +gitlabWithAttrs = gitlabReqJsonMany -gitlabWithAttrsOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a) -gitlabWithAttrsOne = gitlabReqJsonOne +gitlabWithAttrsUnsafe :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a] +gitlabWithAttrsUnsafe gitlabURL attrs = + fromRight (error "gitlabWithAttrsUnsafe error") <$> gitlabReqJsonMany gitlabURL attrs +gitlabWithAttrsOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status (Maybe a)) +gitlabWithAttrsOne = gitlabReqJsonOne + +gitlabWithAttrsOneUnsafe :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a) +gitlabWithAttrsOneUnsafe gitlabURL attrs = + fromRight (error "gitlabWithAttrsUnsafe error") <$> gitlabReqJsonOne gitlabURL attrs + totalPages :: Response a -> Int totalPages resp = let hdrs = responseHeaders resp - in findPages hdrs + in findPages hdrs where findPages [] = 1 -- error "cannot find X-Total-Pages in header" - findPages (("X-Total-Pages",bs):_) = read (T.unpack (T.decodeUtf8 bs)) - findPages (_:xs) = findPages xs + findPages (("X-Total-Pages", bs) : _) = read (T.unpack (T.decodeUtf8 bs)) + findPages (_ : xs) = findPages xs + +successStatus :: Status -> Bool +successStatus (Status n _msg) = + n >= 200 && n <= 226