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.3.0.1 +version: 0.3.0.2 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: diff --git a/src/GitLab/API/Boards.hs b/src/GitLab/API/Boards.hs --- a/src/GitLab/API/Boards.hs +++ b/src/GitLab/API/Boards.hs @@ -14,6 +14,7 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client @@ -34,7 +35,7 @@ Int -> GitLab (Either (Response BSL.ByteString) [IssueBoard]) projectIssueBoards' projectId = - gitlab (boardsAddr projectId) + gitlabGetMany (boardsAddr projectId) [] where boardsAddr :: Int -> Text boardsAddr projId = @@ -58,7 +59,7 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe IssueBoard)) projectIssueBoard' projectId boardId = do - gitlabOne boardAddr + gitlabGetOne boardAddr [] where boardAddr :: Text boardAddr = @@ -83,11 +84,11 @@ Text -> GitLab (Either (Response BSL.ByteString) (Maybe IssueBoard)) createIssueBoard' projectId boardName = do - gitlabPost boardAddr T.empty + gitlabPost boardAddr [("name", Just (T.encodeUtf8 boardName))] where boardAddr :: Text boardAddr = - "/projects/" <> T.pack (show projectId) <> "/boards/?name=" <> boardName + "/projects/" <> T.pack (show projectId) <> "/boards" -- | Updates a project issue board. updateIssueBoard' :: @@ -97,9 +98,9 @@ Int -> -- | attributes for updating boards UpdateBoardAttrs -> - GitLab (Either (Response BSL.ByteString) IssueBoard) + GitLab (Either (Response BSL.ByteString) (Maybe IssueBoard)) updateIssueBoard' projectId boardId attrs = do - gitlabPut boardAddr T.empty + gitlabPut boardAddr (updateBoardAttrs attrs) where boardAddr :: Text boardAddr = @@ -107,7 +108,6 @@ <> T.pack (show projectId) <> "/boards/" <> T.pack (show boardId) - <> T.pack (updateBoardAttrs attrs) -- | Deletes a project issue board. deleteIssueBoard :: @@ -115,7 +115,7 @@ Project -> -- | the board IssueBoard -> - GitLab (Either (Response BSL.ByteString) ()) + GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteIssueBoard project board = do deleteIssueBoard' (project_id project) (board_id board) @@ -125,7 +125,7 @@ Int -> -- | the board ID Int -> - GitLab (Either (Response BSL.ByteString) ()) + GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteIssueBoard' projectId boardId = do gitlabDelete boardAddr where @@ -156,7 +156,7 @@ Int -> GitLab (Either (Response BSL.ByteString) [BoardIssue]) projectBoardLists' projectId boardId = - gitlab boardsAddr + gitlabGetMany boardsAddr [] where boardsAddr :: Text boardsAddr = @@ -186,7 +186,7 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe BoardIssue)) boardList' projectId boardId listId = - gitlabOne boardsAddr + gitlabGetOne boardsAddr [] where boardsAddr :: Text boardsAddr = @@ -216,7 +216,7 @@ CreateBoardAttrs -> GitLab (Either (Response BSL.ByteString) (Maybe BoardIssue)) createBoardList' projectId boardId attrs = - gitlabPost boardsAddr T.empty + gitlabPost boardsAddr (createBoardAttrs attrs) where boardsAddr :: Text boardsAddr = @@ -225,7 +225,6 @@ <> "/boards/" <> T.pack (show boardId) <> "/lists" - <> T.pack (createBoardAttrs attrs) -- | Updates an existing issue board list. This call is used to change list position. reorderBoardList :: @@ -253,7 +252,7 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe BoardIssue)) reorderBoardList' projectId boardId listId newPosition = - gitlabPut boardsAddr T.empty + gitlabPut boardsAddr [("position", Just (T.encodeUtf8 (T.pack (show newPosition))))] where boardsAddr :: Text boardsAddr = @@ -263,7 +262,6 @@ <> T.pack (show boardId) <> "/lists/" <> T.pack (show listId) - <> T.pack ("?position=" <> show newPosition) -- | Only for administrators and project owners. Deletes a board list. deleteBoardList :: @@ -273,7 +271,7 @@ IssueBoard -> -- | list ID Int -> - GitLab (Either (Response BSL.ByteString) ()) + GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteBoardList project board = deleteBoardList' (project_id project) (board_id board) @@ -285,7 +283,7 @@ Int -> -- | list ID Int -> - GitLab (Either (Response BSL.ByteString) ()) + GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteBoardList' projectId boardId listId = gitlabDelete boardsAddr where @@ -311,20 +309,15 @@ noUpdateBoardAttrs = UpdateBoardAttrs Nothing Nothing Nothing Nothing Nothing -updateBoardAttrs :: UpdateBoardAttrs -> String +updateBoardAttrs :: UpdateBoardAttrs -> [GitLabParam] updateBoardAttrs attrs = - case attrsUrl of - [] -> "" - (x : xs) -> "?" <> x <> concatMap ('&' :) xs - where - attrsUrl = - catMaybes - [ (\s -> Just ("name=" <> s)) =<< updateBoard_new_name attrs, - (\i -> Just ("assignee_id=" <> show i)) =<< updateBoard_assignee_id attrs, - (\i -> Just ("milestone_id=" <> show i)) =<< updateBoard_milestone_id attrs, - (\s -> Just ("labels=" <> s)) =<< updateBoard_labels attrs, - (\i -> Just ("weight=" <> show i)) =<< updateBoard_weight attrs - ] + catMaybes + [ (\s -> Just ("name", Just (T.encodeUtf8 (T.pack s)))) =<< updateBoard_new_name attrs, + (\i -> Just ("assignee_id", Just (T.encodeUtf8 (T.pack (show i))))) =<< updateBoard_assignee_id attrs, + (\i -> Just ("milestone_id", Just (T.encodeUtf8 (T.pack (show i))))) =<< updateBoard_milestone_id attrs, + (\s -> Just ("labels", Just (T.encodeUtf8 (T.pack s)))) =<< updateBoard_labels attrs, + (\i -> Just ("weight", Just (T.encodeUtf8 (T.pack (show i))))) =<< updateBoard_weight attrs + ] -- | exactly one parameter must be provided. data CreateBoardAttrs = CreateBoardAttrs @@ -338,15 +331,10 @@ noCreateBoardAttrs = CreateBoardAttrs Nothing Nothing Nothing -createBoardAttrs :: CreateBoardAttrs -> String +createBoardAttrs :: CreateBoardAttrs -> [GitLabParam] createBoardAttrs attrs = - case attrsUrl of - [] -> "" - (x : xs) -> "?" <> x <> concatMap ('&' :) xs - where - attrsUrl = - catMaybes - [ (\i -> Just ("label_id=" <> show i)) =<< createBoard_label_id attrs, - (\i -> Just ("assignee_id=" <> show i)) =<< createBoard_assignee_id attrs, - (\i -> Just ("milestone_id=" <> show i)) =<< createBoard_milestone_id attrs - ] + catMaybes + [ (\i -> Just ("label_id", Just (T.encodeUtf8 (T.pack (show i))))) =<< createBoard_label_id attrs, + (\i -> Just ("assignee_id", Just (T.encodeUtf8 (T.pack (show i))))) =<< createBoard_assignee_id attrs, + (\i -> Just ("milestone_id", Just (T.encodeUtf8 (T.pack (show i))))) =<< createBoard_milestone_id attrs + ] 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 @@ -27,7 +27,7 @@ -- project ID, sorted by name alphabetically. branches' :: Int -> GitLab (Either (Response BSL.ByteString) [Branch]) branches' projectId = - gitlab addr + gitlabGetMany addr [] where addr = "/projects/" 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 @@ -13,6 +13,7 @@ import Data.Either import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client @@ -33,7 +34,7 @@ Int -> GitLab (Either (Response BSL.ByteString) [Commit]) projectCommits' projectId = - gitlabWithAttrs (commitsAddr projectId) "&with_stats=true" + gitlabGetMany (commitsAddr projectId) [("with_stats", Just "true")] where commitsAddr :: Int -> Text commitsAddr projId = @@ -60,7 +61,7 @@ Text -> GitLab (Either (Response BSL.ByteString) [Commit]) branchCommits' projectId branchName = do - gitlabWithAttrs (commitsAddr projectId) ("&ref_name=" <> branchName) + gitlabGetMany (commitsAddr projectId) [("ref_name", Just (T.encodeUtf8 branchName))] where commitsAddr :: Int -> Text commitsAddr projId = @@ -87,7 +88,7 @@ Text -> GitLab (Either (Response BSL.ByteString) (Maybe Commit)) commitDetails' projectId hash = - gitlabOne (commitsAddr projectId) + gitlabGetOne (commitsAddr projectId) [] where commitsAddr :: Int -> Text commitsAddr projId = diff --git a/src/GitLab/API/Discussions.hs b/src/GitLab/API/Discussions.hs --- a/src/GitLab/API/Discussions.hs +++ b/src/GitLab/API/Discussions.hs @@ -42,4 +42,4 @@ <> "/commits/" <> T.unpack commitHash <> "/discussions" - gitlab urlPath + gitlabGetMany urlPath [] 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 @@ -30,7 +30,7 @@ Text -> GitLab (Either (Response BSL.ByteString) [Group]) groupsWithNameOrPath groupName = do - result <- gitlabWithAttrs "/groups" ("&search=" <> groupName) + result <- gitlabGetMany "/groups" [("search", Just (T.encodeUtf8 groupName))] case result of Left {} -> return result Right groups -> @@ -87,12 +87,13 @@ -- return (Left (mk (Response BSL.ByteString) 404 (T.encodeUtf8 (T.pack "cannot find group")))) -- return (Left (mk (Response (T.encodeUtf8 (T.pack "cannot find group")))) Right [grp] -> - gitlabPost addr dataBody + gitlabPost addr params where - dataBody :: Text - dataBody = - "user_id=" <> T.pack (show usrId) <> "&access_level=" - <> T.pack (show access) + params :: [GitLabParam] + params = + [ ("user_id", Just (T.encodeUtf8 (T.pack (show usrId)))), + ("access_level", Just (T.encodeUtf8 (T.pack (show access)))) + ] addr = "/groups/" <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (T.pack (show (group_id grp))))) @@ -146,4 +147,4 @@ "/groups/" <> show groupID <> "/projects" - gitlab urlPath + gitlabGetMany urlPath [] 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 @@ -31,14 +31,12 @@ ) where -import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as BSL import Data.Either import Data.Maybe import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Encoding +import qualified Data.Text.Encoding as T import Data.Time.Clock import Data.Time.Format.ISO8601 import GitLab.Types @@ -141,14 +139,13 @@ -- | the GitLab issues GitLab (Either (Response BSL.ByteString) [Issue]) projectIssues' projectId attrs = - gitlab urlPath + gitlabGetMany urlPath (issuesAttrs attrs) where urlPath = T.pack $ "/projects/" <> show projectId <> "/issues" - <> issuesAttrs attrs -- | Gets issues count statistics on all issues the authenticated user has access to. issueStatisticsUser :: @@ -157,12 +154,11 @@ -- | the issue statistics GitLab IssueStatistics issueStatisticsUser attrs = - gitlabOneUnsafe urlPath + gitlabUnsafe (gitlabGetOne urlPath (issuesAttrs attrs)) where urlPath = T.pack $ "/issues_statistics" - <> issuesAttrs attrs -- | Gets issues count statistics for a given group. issueStatisticsGroup :: @@ -188,14 +184,13 @@ -- | the issue statistics GitLab (Either (Response BSL.ByteString) (Maybe IssueStatistics)) issueStatisticsGroup' groupId attrs = - gitlabOne urlPath + gitlabGetOne urlPath (issuesAttrs attrs) where urlPath = T.pack $ "/groups/" <> show groupId <> "/issues_statistics" - <> issuesAttrs attrs -- | Gets issues count statistics for a given group. issueStatisticsProject :: @@ -221,14 +216,13 @@ -- | the issue statistics GitLab (Either (Response BSL.ByteString) (Maybe IssueStatistics)) issueStatisticsProject' projId attrs = - gitlabOne urlPath + gitlabGetOne urlPath (issuesAttrs attrs) where urlPath = T.pack $ "/projects/" <> show projId <> "/issues_statistics" - <> issuesAttrs attrs -- | gets all issues create by a user. userIssues :: @@ -236,14 +230,14 @@ User -> GitLab [Issue] userIssues usr = - gitlabWithAttrsUnsafe addr attrs + fromRight (error "userIssues error") <$> gitlabGetMany addr params where addr = "/issues" - attrs = - T.pack $ - "&author_id=" - <> show (user_id usr) - <> "&scope=all" + params :: [GitLabParam] + params = + [ ("author_id", Just (T.encodeUtf8 (T.pack (show (user_id usr))))), + ("scope", Just "all") + ] -- | create a new issue. newIssue :: @@ -269,12 +263,11 @@ newIssue' projectId issueTitle issueDescription = gitlabPost addr dataBody where - dataBody :: Text + dataBody :: [GitLabParam] dataBody = - "title=" - <> issueTitle - <> "&description=" - <> issueDescription + [ ("title", Just (T.encodeUtf8 issueTitle)), + ("description", Just (T.encodeUtf8 issueDescription)) + ] addr = "/projects/" <> T.pack (show projectId) @@ -291,13 +284,14 @@ "/projects/" <> T.pack (show projId) <> "/issues/" <> T.pack (show issueId) - gitlabPut - urlPath - ( Data.Text.Lazy.toStrict - ( Data.Text.Lazy.Encoding.decodeUtf8 - (J.encode editIssueReq) - ) - ) + result <- + gitlabPut + urlPath + (editIssuesAttrs editIssueReq) + case result of + Left resp -> return (Left resp) + Right Nothing -> error "editIssue error" + Right (Just issue) -> return (Right issue) ------------------------------- -- Internal functions and types @@ -329,42 +323,66 @@ issueFilter_with_labels_details :: Maybe Bool } -issuesAttrs :: IssueAttrs -> String +editIssuesAttrs :: EditIssueReq -> [GitLabParam] +editIssuesAttrs filters = + catMaybes + [ Just ("id", textToBS (T.pack (show (edit_issue_id filters)))), + Just ("issue_id", textToBS (T.pack (show (edit_issue_issue_iid filters)))), + -- (\i -> Just ("assignee_id", textToBS (T.pack (show i)))) =<< edit_issue_issue_id filters, + (\t -> Just ("title", textToBS t)) =<< edit_issue_title filters, + (\t -> Just ("description", textToBS t)) =<< edit_issue_description filters, + (\b -> Just ("confidential", textToBS (showBool b))) =<< edit_issue_confidential filters, + -- TODO + -- (\is -> Just ("assignee_ids", textToBS )) =<< edit_issue_assignee_ids filters, + (\i -> Just ("milestone_id", textToBS (T.pack (show i)))) =<< edit_issue_milestone_id filters, + -- TODO + -- (\ts -> Just ("labels", textToBS (T.pack (show i)))) =<< edit_issue_labels filters, + (\t -> Just ("state_event", textToBS t)) =<< edit_issue_state_event filters, + (\t -> Just ("updated_at", textToBS t)) =<< edit_issue_updated_at filters, + (\t -> Just ("due_date", textToBS t)) =<< edit_issue_due_date filters, + (\i -> Just ("weight", textToBS (T.pack (show i)))) =<< edit_issue_weight filters, + (\b -> Just ("discussion_locked", textToBS (showBool b))) =<< edit_issue_discussion_locked filters, + (\i -> Just ("epic_id", textToBS (T.pack (show i)))) =<< edit_issue_epic_id filters, + (\i -> Just ("epic_iid", textToBS (T.pack (show i)))) =<< edit_issue_epic_iid filters + ] + where + textToBS = Just . T.encodeUtf8 + showBool :: Bool -> Text + showBool True = "true" + showBool False = "false" + +issuesAttrs :: IssueAttrs -> [GitLabParam] issuesAttrs filters = - case attrsUrl of - [] -> "" - (x : xs) -> "?" <> x <> concatMap ('&' :) xs + catMaybes + [ (\i -> Just ("assignee_id", textToBS (T.pack (show i)))) =<< issueFilter_assignee_id filters, + (\t -> Just ("assignee_username", textToBS (T.pack t))) =<< issueFilter_assignee_username filters, + (\i -> Just ("author_id", textToBS (T.pack (show i)))) =<< issueFilter_author_id filters, + (\i -> Just ("author_username", textToBS ((T.pack (show i))))) =<< issueFilter_author_username filters, + (\b -> Just ("confidential", textToBS (showBool b))) =<< issueFilter_confidential filters, + (\t -> Just ("created_after", textToBS (showTime t))) =<< issueFilter_created_after filters, + (\t -> Just ("created_before", textToBS (showTime t))) =<< issueFilter_created_before filters, + (\due -> Just ("due_date", textToBS (T.pack (show due)))) =<< issueFilter_due_date filters, + (\iids -> Just ("iids[]", textToBS (T.pack (show iids)))) =<< issueFilter_iids filters, + (\issueIn -> Just ("assignee_id", textToBS (T.pack (show issueIn)))) =<< issueFilter_in filters, + (\i -> Just ("iteration_id", textToBS (T.pack (show i)))) =<< issueFilter_iteration_id filters, + (\s -> Just ("iteration_title", textToBS (T.pack s))) =<< issueFilter_iteration_title filters, + (\s -> Just ("milestone", textToBS (T.pack s))) =<< issueFilter_milestone filters, + (\s -> Just ("labels", textToBS (T.pack s))) =<< issueFilter_labels filters, + (\s -> Just ("my_reaction_emoji", textToBS (T.pack s))) =<< issueFilter_my_reaction_emoji filters, + (\b -> Just ("non_archived", textToBS (showBool b))) =<< issueFilter_non_archived filters, + (\x -> Just ("order_by", textToBS (T.pack (show x)))) =<< issueFilter_order_by filters, + (\x -> Just ("scope", textToBS (T.pack (show x)))) =<< issueFilter_scope filters, + (\s -> Just ("search", textToBS (T.pack s))) =<< issueFilter_search filters, + (\x -> Just ("sort", textToBS (T.pack (show x)))) =<< issueFilter_sort filters, + (\x -> Just ("state", textToBS (T.pack (show x)))) =<< issueFilter_state filters, + (\t -> Just ("updated_after", textToBS (showTime t))) =<< issueFilter_updated_after filters, + (\t -> Just ("updated_before", textToBS (showTime t))) =<< issueFilter_updated_before filters, + (\b -> Just ("with_labels_details", textToBS (showBool b))) =<< issueFilter_with_labels_details filters + ] where - attrsUrl = - catMaybes - [ (\i -> Just ("assignee_id=" <> show i)) =<< issueFilter_assignee_id filters, - (\t -> Just ("assignee_username=" <> t)) =<< issueFilter_assignee_username filters, - (\i -> Just ("author_id=" <> show i)) =<< issueFilter_author_id filters, - (\i -> Just ("author_username=" <> show i)) =<< issueFilter_author_username filters, - (\b -> Just ("confidential=" <> showBool b)) =<< issueFilter_confidential filters, - (\t -> Just ("created_after=" <> showTime t)) =<< issueFilter_created_after filters, - (\t -> Just ("created_before=" <> showTime t)) =<< issueFilter_created_before filters, - (\due -> Just ("due_date=" <> show due)) =<< issueFilter_due_date filters, - (\iids -> Just ("iids[]=" <> show iids)) =<< issueFilter_iids filters, - (\issueIn -> Just ("assignee_id=" <> show issueIn)) =<< issueFilter_in filters, - (\i -> Just ("iteration_id=" <> show i)) =<< issueFilter_iteration_id filters, - (\s -> Just ("iteration_title=" <> s)) =<< issueFilter_iteration_title filters, - (\s -> Just ("milestone=" <> s)) =<< issueFilter_milestone filters, - (\s -> Just ("labels=" <> s)) =<< issueFilter_labels filters, - (\s -> Just ("my_reaction_emoji=" <> s)) =<< issueFilter_my_reaction_emoji filters, - (\b -> Just ("non_archived=" <> showBool b)) =<< issueFilter_non_archived filters, - (\x -> Just ("order_by=" <> show x)) =<< issueFilter_order_by filters, - (\x -> Just ("scope=" <> show x)) =<< issueFilter_scope filters, - (\s -> Just ("search=" <> s)) =<< issueFilter_search filters, - (\x -> Just ("sort=" <> show x)) =<< issueFilter_sort filters, - (\x -> Just ("state=" <> show x)) =<< issueFilter_state filters, - (\t -> Just ("updated_after=" <> showTime t)) =<< issueFilter_updated_after filters, - (\t -> Just ("updated_before=" <> showTime t)) =<< issueFilter_updated_before filters, - (\b -> Just ("with_labels_details=" <> showBool b)) =<< issueFilter_with_labels_details filters - ] - where - showBool :: Bool -> String - showBool True = "true" - showBool False = "false" - showTime :: UTCTime -> String - showTime = iso8601Show + textToBS = Just . T.encodeUtf8 + showBool :: Bool -> Text + showBool True = "true" + showBool False = "false" + showTime :: UTCTime -> Text + showTime = T.pack . iso8601Show 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 @@ -31,7 +31,7 @@ Int -> GitLab (Either (Response BSL.ByteString) [Job]) jobs' projectId = - gitlab addr + gitlabGetMany addr [] where addr = "/projects/" 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 @@ -12,8 +12,8 @@ import qualified Data.ByteString.Lazy as BSL import Data.Either -import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client @@ -42,7 +42,7 @@ -- | the members of a project given its ID. membersOfProject' :: Int -> GitLab (Either (Response BSL.ByteString) [Member]) membersOfProject' projectId = - gitlab addr + gitlabGetMany addr [] where addr = "/projects/" <> T.pack (show projectId) <> "/members" @@ -73,11 +73,13 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe Member)) addMemberToProject' projectId access userId = - gitlabPost addr dataBody + gitlabPost addr params where - dataBody :: Text - dataBody = - "user_id=" <> T.pack (show userId) <> "&access_level=" <> T.pack (show access) + params :: [GitLabParam] + params = + [ ("user_id", Just (T.encodeUtf8 (T.pack (show userId)))), + ("access_level", Just (T.encodeUtf8 (T.pack (show access)))) + ] addr = "/projects/" <> T.pack (show projectId) <> "/members" 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 @@ -13,6 +13,7 @@ import Data.Either import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client @@ -37,7 +38,7 @@ Int -> GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest)) mergeRequest' projectId mergeRequestIID = - gitlabOne addr + gitlabGetOne addr [] where addr = "/projects/" @@ -60,7 +61,7 @@ Int -> GitLab (Either (Response BSL.ByteString) [MergeRequest]) mergeRequests' projectId = - gitlabWithAttrs addr "&scope=all" + gitlabGetMany addr [("scope", Just "all")] where addr = "/projects/" @@ -101,17 +102,16 @@ Text -> GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest)) createMergeRequest' projectId sourceBranch targetBranch targetProjectId mrTitle mrDescription = - gitlabPost addr dataBody + gitlabPost addr params where - dataBody :: Text - dataBody = - "source_branch=" <> sourceBranch <> "&target_branch=" <> targetBranch - <> "&target_project_id=" - <> T.pack (show targetProjectId) - <> "&title=" - <> mrTitle - <> "&description=" - <> mrDescription + params :: [GitLabParam] + params = + [ ("source_branch", Just (T.encodeUtf8 sourceBranch)), + ("target_branch", Just (T.encodeUtf8 targetBranch)), + ("target_project_id", Just (T.encodeUtf8 (T.pack (show targetProjectId)))), + ("title", Just (T.encodeUtf8 mrTitle)), + ("description", Just (T.encodeUtf8 mrDescription)) + ] addr = T.pack $ "/projects/" <> show projectId <> "/merge_requests" -- | Accepts a merge request. @@ -131,12 +131,13 @@ -- | merge request IID Int -> GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest)) -acceptMergeRequest' projectId mergeRequestIid = gitlabPost addr dataBody +acceptMergeRequest' projectId mergeRequestIid = gitlabPost addr params where - dataBody :: Text - dataBody = - T.pack $ - "id=" <> show projectId <> "&merge_request_iid=" <> show mergeRequestIid + params :: [GitLabParam] + params = + [ ("id", Just (T.encodeUtf8 (T.pack (show projectId)))), + ("merge_request_iid", Just (T.encodeUtf8 (T.pack (show mergeRequestIid)))) + ] addr = T.pack $ "/projects/" <> show projectId <> "/merge_requests/" @@ -149,7 +150,7 @@ Project -> -- | merge request IID Int -> - GitLab (Either (Response BSL.ByteString) ()) + GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteMergeRequest project = deleteMergeRequest' (project_id project) @@ -159,7 +160,7 @@ Int -> -- | merge request IID Int -> - GitLab (Either (Response BSL.ByteString) ()) + GitLab (Either (Response BSL.ByteString) (Maybe ())) deleteMergeRequest' projectId mergeRequestIid = gitlabDelete addr where addr = diff --git a/src/GitLab/API/Notes.hs b/src/GitLab/API/Notes.hs --- a/src/GitLab/API/Notes.hs +++ b/src/GitLab/API/Notes.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client @@ -36,17 +37,14 @@ Text -> GitLab (Either (Response BSL.ByteString) (Maybe ())) createMergeRequestNote' projectId mergeRequestIID comment = - gitlabPost addr dataBody + gitlabPost addr params where - dataBody :: Text - dataBody = - T.pack $ - "id=" - <> show projectId - <> "&merge_request_iid=" - <> show mergeRequestIID - <> "&body=" - <> T.unpack comment + params :: [GitLabParam] + params = + [ ("id", Just (T.encodeUtf8 (T.pack (show projectId)))), + ("merge_request_iid", Just (T.encodeUtf8 (T.pack (show mergeRequestIID)))), + ("body", Just (T.encodeUtf8 comment)) + ] addr = T.pack $ "/projects/" <> show projectId <> "/merge_requests/" 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 @@ -31,9 +31,9 @@ Int -> GitLab (Either (Response BSL.ByteString) [Pipeline]) pipelines' projectId = - gitlabWithAttrs + gitlabGetMany addr - "&sort=desc" -- most recent first + [("sort", Just "desc")] -- most recent first where addr = "/projects/" 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 @@ -30,7 +30,8 @@ -- | gets all projects. allProjects :: GitLab [Project] allProjects = - gitlabWithAttrsUnsafe "/projects" "&statistics=true" + fromRight (error "allProjects error") + <$> gitlabGetMany "/projects" [("statistics", Just "true")] -- | gets all forks of a project. Supports use of namespaces. -- @@ -45,7 +46,7 @@ "/projects/" <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 projectName)) <> "/forks" - gitlab urlPath + gitlabGetMany urlPath [] -- | searches for a 'Project' with the given project ID, returns -- 'Nothing' if a project with the given ID is not found. @@ -55,7 +56,7 @@ GitLab (Either (Response BSL.ByteString) (Maybe Project)) searchProjectId projectId = do let urlPath = T.pack ("/projects/" <> show projectId) - gitlabWithAttrsOne urlPath "&statistics=true" + gitlabGetOne urlPath [("statistics", Just "true")] -- | gets all projects with the given project name. -- @@ -64,9 +65,13 @@ -- | project name being searched for. Text -> GitLab [Project] -projectsWithName projectName = - filter (\project -> projectName == project_path project) - <$> gitlabWithAttrsUnsafe "/projects" ("&search=" <> projectName) +projectsWithName projectName = do + results <- gitlabGetMany "/projects" [("search", Just (T.encodeUtf8 projectName))] + case results of + Left _ -> error "projectsWithName error" + Right projects -> + return $ + filter (\project -> projectName == project_path project) projects -- | gets a project with the given name for the given username. E.g. -- @@ -75,12 +80,12 @@ -- looks for "user1/project1" projectsWithNameAndUser :: Text -> Text -> GitLab (Either (Response BSL.ByteString) (Maybe Project)) projectsWithNameAndUser username projectName = - gitlabWithAttrsOne + gitlabGetOne ( "/projects/" <> T.decodeUtf8 (urlEncode False (T.encodeUtf8 (username <> "/" <> projectName))) ) - "&statistics=true" + [("statistics", Just "true")] -- | returns 'True' if a project has multiple committers, according to -- the email addresses of the commits. @@ -115,7 +120,11 @@ userMaybe <- searchUser username case userMaybe of Nothing -> return Nothing - Just usr -> Just <$> gitlabUnsafe (urlPath (user_id usr)) + Just usr -> do + result <- gitlabGetMany (urlPath (user_id usr)) [] + case result of + Left _ -> error "userProjects' error" + Right projs -> return (Just projs) where urlPath usrId = "/users/" <> T.pack (show usrId) <> "/projects" @@ -183,7 +192,7 @@ count = do let addr = "/projects/" <> T.pack (show (project_id project)) <> "/members/all" - (res :: [Member]) <- gitlabUnsafe addr + (res :: [Member]) <- fromRight (error "projectMembersCount error") <$> gitlabGetMany addr [] return (map (\x -> (member_username x, member_name x)) res) -- | returns 'True' is the last commit for a project passes all @@ -219,13 +228,14 @@ -- commit SHA. projectDiffs' :: Int -> Text -> GitLab (Either (Response BSL.ByteString) [Diff]) projectDiffs' projId commitSha = - gitlab + gitlabGetMany ( "/projects/" <> T.pack (show projId) <> "/repository/commits/" <> commitSha <> "/diff/" ) + [] -- | add a group to a project. addGroupToProject :: @@ -237,14 +247,13 @@ AccessLevel -> GitLab (Either (Response BSL.ByteString) (Maybe GroupShare)) addGroupToProject groupId projectId access = - gitlabPost addr dataBody + gitlabPost addr params where - dataBody :: Text - dataBody = - "group_id=" - <> T.pack (show groupId) - <> "&group_access=" - <> T.pack (show access) + params :: [GitLabParam] + params = + [ ("group_id", Just (T.encodeUtf8 (T.pack (show groupId)))), + ("group_access", Just (T.encodeUtf8 (T.pack (show access)))) + ] addr = "/projects/" <> T.pack (show projectId) 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 @@ -32,7 +32,7 @@ Int -> GitLab (Either (Response BSL.ByteString) [Repository]) repositories' projectId = - gitlab addr + gitlabGetMany addr [] where addr = "/projects/" @@ -63,7 +63,12 @@ -- | file format ArchiveFormat -> GitLab (Either (Response BSL.ByteString) BSL.ByteString) -getFileArchiveBS project = getFileArchiveBS' (project_id project) +getFileArchiveBS project format = do + result <- getFileArchiveBS' (project_id project) format + case result of + Left resp -> return (Left resp) + Right Nothing -> error "could not download file" + Right (Just bs) -> return (Right bs) -- | get a file archive of the repository files using the project's -- ID. For example: @@ -81,7 +86,9 @@ attempt <- getFileArchiveBS' projectId format case attempt of Left st -> return (Left st) - Right archiveData -> + Right Nothing -> + Right <$> error "cannot download file" + Right (Just archiveData) -> Right <$> liftIO (BSL.writeFile fPath archiveData) -- | get a file archive of the repository files as a 'BSL.ByteString' @@ -93,9 +100,12 @@ Int -> -- | file format ArchiveFormat -> - GitLab (Either (Response BSL.ByteString) BSL.ByteString) -getFileArchiveBS' projectId format = - gitlabReqByteString addr + GitLab (Either (Response BSL.ByteString) (Maybe BSL.ByteString)) +getFileArchiveBS' projectId format = do + result <- gitlabGetOne addr [] :: GitLab (Either (Response BSL.ByteString) (Maybe Bool)) + case result of + Left response -> return (Right (Just (responseBody response))) + Right _b -> error "impossible" -- we're asking it to parse BS as a Bool, which shouldn't be possible. where addr = "/projects/" 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 @@ -40,7 +40,7 @@ Text -> GitLab (Either (Response BSL.ByteString) (Maybe RepositoryFile)) repositoryFiles' projectId filePath reference = - gitlabWithAttrsOne addr ("&ref=" <> reference) + gitlabGetOne addr [("ref", Just (T.encodeUtf8 reference))] where addr = "/projects/" @@ -56,9 +56,9 @@ Int -> -- | blob SHA Text -> - GitLab (Either (Response BSL.ByteString) String) + GitLab (Either (Response BSL.ByteString) (Maybe String)) repositoryFileBlob projectId blobSha = - gitlabReqText addr + gitlabGetOne addr [] where addr = "/projects/" diff --git a/src/GitLab/API/Tags.hs b/src/GitLab/API/Tags.hs --- a/src/GitLab/API/Tags.hs +++ b/src/GitLab/API/Tags.hs @@ -32,7 +32,7 @@ Int -> GitLab (Either (Response BSL.ByteString) [Tag]) tags' projectId = do - gitlabWithAttrs (commitsAddr projectId) "" + gitlabGetMany (commitsAddr projectId) [] where commitsAddr :: Int -> Text commitsAddr projId = 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 @@ -14,4 +14,4 @@ -- | returns all pending todos for the user, as defined by the access token. todos :: GitLab [Todo] -todos = gitlabUnsafe "/todos" +todos = gitlabUnsafe (gitlabGetOne "/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 @@ -10,10 +10,12 @@ -- Stability : stable module GitLab.API.Users where +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 GitLab.Types import GitLab.WebRequests.GitLabWebCalls @@ -21,7 +23,7 @@ allUsers :: GitLab [User] allUsers = do let path = "/users" - gitlabUnsafe path + fromRight (error "allUsers error") <$> gitlabGetMany path [] -- | searches for a user given a user ID. Returns @Just User@ if the -- user is found, otherwise @Nothing@. @@ -33,7 +35,7 @@ let path = "/users/" <> T.pack (show usrId) - res <- gitlabOne path + res <- gitlabGetOne path [] case res of Left _err -> return Nothing Right Nothing -> return Nothing @@ -47,11 +49,12 @@ GitLab (Maybe User) searchUser username = do let path = "/users" - attrs = "&username=" <> username - res <- gitlabWithAttrsUnsafe path attrs - case res of - [] -> return Nothing - (user : _) -> return (Just user) + params = [("username", Just (T.encodeUtf8 username))] + result <- gitlabGetMany path params + case result of + Left _err -> return Nothing + Right [] -> return Nothing + Right (x : _) -> return (Just x) -- | searches for users given a list of usernames, returns them in -- alphabetical order of their usernames. diff --git a/src/GitLab/API/Version.hs b/src/GitLab/API/Version.hs --- a/src/GitLab/API/Version.hs +++ b/src/GitLab/API/Version.hs @@ -18,4 +18,4 @@ gitlabVersion :: GitLab (Either (Response BSL.ByteString) (Maybe Version)) gitlabVersion = do let urlPath = "/version" - gitlabOne urlPath + gitlabGetOne urlPath [] 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 @@ -3,20 +3,13 @@ -- | internal module to support modules in GitLab.API module GitLab.WebRequests.GitLabWebCalls - ( gitlab, - gitlabUnsafe, - gitlabOneUnsafe, - gitlabWithAttrs, - gitlabWithAttrsUnsafe, - gitlabOne, - -- gitlabOneIO, - gitlabWithAttrsOne, - gitlabWithAttrsOneUnsafe, + ( GitLabParam, + gitlabGetOne, + gitlabGetMany, gitlabPost, gitlabPut, gitlabDelete, - gitlabReqText, - gitlabReqByteString, + gitlabUnsafe, ) where @@ -24,10 +17,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import Data.Aeson -import qualified Data.ByteString as BS +import Data.ByteString import qualified Data.ByteString.Lazy as BSL -import qualified 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 @@ -42,98 +33,217 @@ instance Exception.Exception GitLabException --- In this module, "unsafe" functions are those that discard HTTP --- error code responses, e.g. 404, 409. +type GitLabParam = (ByteString, Maybe ByteString) -gitlabPost :: - (FromJSON b) => +gitlabGetOne :: + (FromJSON a) => -- | the URL to post to Text -> -- | the data to post + [GitLabParam] -> + GitLab (Either (Response BSL.ByteString) (Maybe a)) +gitlabGetOne urlPath params = + request + where + request = + gitlabHTTPOne + "GET" + "application/x-www-form-urlencoded" + urlPath + params + [] + +gitlabGetMany :: + (FromJSON a) => + -- | the URL to post to Text -> - GitLab (Either (Response BSL.ByteString) (Maybe 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)), - ("content-type", "application/x-www-form-urlencoded") - ], - 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 (Just x) - Nothing -> Right Nothing - -- Nothing -> - -- Left $ - -- mkStatus 409 "unable to parse POST response" - ) - else return (Left resp) + -- | the data to post + [GitLabParam] -> + GitLab (Either (Response BSL.ByteString) [a]) +gitlabGetMany urlPath params = + gitlabHTTPMany + "GET" + "application/x-www-form-urlencoded" + urlPath + params + [] -gitlabPut :: - FromJSON b => +gitlabPost :: + (FromJSON a) => -- | the URL to post to Text -> -- | the data to post + [GitLabParam] -> + GitLab (Either (Response BSL.ByteString) (Maybe a)) +gitlabPost urlPath params = do + request + where + request = + gitlabHTTPOne + "POST" + "application/x-www-form-urlencoded" + urlPath + [] + params + +gitlabPut :: + FromJSON a => + -- | the URL to post to Text -> - GitLab (Either (Response BSL.ByteString) b) -gitlabPut 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 = "PUT", - requestHeaders = - [ ("PRIVATE-TOKEN", T.encodeUtf8 (token cfg)), - ("content-type", "application/x-www-form-urlencoded") - ], - 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 resp - ) - else return (Left resp) + -- | the data to post + [GitLabParam] -> + GitLab (Either (Response BSL.ByteString) (Maybe a)) +gitlabPut urlPath params = do + request + where + request = + gitlabHTTPOne + "PUT" + "application/x-www-form-urlencoded" + urlPath + [] + params gitlabDelete :: -- | the URL to post to Text -> - GitLab (Either (Response BSL.ByteString) ()) + GitLab (Either (Response BSL.ByteString) (Maybe ())) gitlabDelete urlPath = do + result <- request + case result of + Right (Just _) -> return (Right (Just ())) + x -> return x + where + request = + gitlabHTTPOne + "DELETE" + "application/x-www-form-urlencoded" + urlPath + [] + [] + +-- | Assumes that HTTP error code responses, e.g. 404, 409, won't be +-- returned as (Left response) value. +gitlabUnsafe :: GitLab (Either a (Maybe b)) -> GitLab b +gitlabUnsafe query = do + result <- query + case result of + Left _err -> error "gitlabUnsafe error" + Right Nothing -> error "gitlabUnsafe error" + Right (Just x) -> return x + +--------------------- +-- internal functions + +gitlabHTTP :: + -- | HTTP method (PUT, POST, DELETE, GET) + ByteString -> + -- | Content type (content-type) + ByteString -> + -- | the URL + Text -> + -- | the URL parameters for GET calls + [GitLabParam] -> + -- | the content paramters for POST, PUT and DELETE calls + [GitLabParam] -> + GitLab (Response BSL.ByteString) +gitlabHTTP httpMethod contentType urlPath urlParams contentParams = do cfg <- serverCfg <$> ask manager <- httpManager <$> ask - let url' = url cfg <> "/api/v4" <> urlPath + let url' = url cfg <> "/api/v4" <> urlPath <> T.decodeUtf8 (renderQuery True urlParams) let request' = parseRequest_ (T.unpack url') request = request' - { method = "DELETE", + { method = httpMethod, requestHeaders = [ ("PRIVATE-TOKEN", T.encodeUtf8 (token cfg)), - ("content-type", "application/x-www-form-urlencoded") + ("content-type", contentType) ], - requestBody = RequestBodyBS BS.empty + requestBody = RequestBodyBS (renderQuery False contentParams) } - resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing - if successStatus (responseStatus resp) - then return (Right ()) - else return (Left resp) + response <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing + return response +gitlabHTTPOne :: + FromJSON a => + -- | HTTP method (PUT, POST, DELETE, GET) + ByteString -> + -- | Content type (content-type) + ByteString -> + -- | the URL + Text -> + -- | the URL query data for GET calls + [GitLabParam] -> + -- | the content parameters for POST, PUT and DELETE calls + [GitLabParam] -> + GitLab + (Either (Response BSL.ByteString) (Maybe a)) +gitlabHTTPOne httpMethod contentType urlPath urlParams contentParams = do + response <- + gitlabHTTP + httpMethod + contentType + urlPath + urlParams + contentParams + if successStatus (responseStatus response) + then return (Right (parseOne (responseBody response))) + else return (Left response) + +gitlabHTTPMany :: + (FromJSON a) => + -- | HTTP method (PUT, POST, DELETE, GET) + ByteString -> + -- | Content type (content-type) + ByteString -> + -- | the URL + Text -> + -- | the URL query data for GET calls + [GitLabParam] -> + -- | the content parameters for POST, PUT and DELETE calls + [GitLabParam] -> + GitLab + (Either (Response BSL.ByteString) [a]) +gitlabHTTPMany httpMethod contentType urlPath urlParams contentParams = do + go 1 [] + where + go :: FromJSON a => Int -> [a] -> GitLab (Either (Response BSL.ByteString) [a]) + go pageNum accum = do + response <- + gitlabHTTP + httpMethod + contentType + urlPath + (urlParams <> [("per_page", Just "100"), ("page", Just (T.encodeUtf8 (T.pack (show pageNum))))]) + contentParams + if successStatus (responseStatus response) + then do + case parseMany (responseBody response) of + Nothing -> return (Right accum) + Just moreResults -> do + let numPages = totalPages response + accum' = accum <> moreResults + if pageNum == numPages + then return (Right accum') + else go (pageNum + 1) accum' + else return (Left response) + +totalPages :: Response a -> Int +totalPages resp = + let hdrs = responseHeaders resp + in findPages hdrs + where + findPages [] = 1 -- error "cannot find X-Total-Pages in header" + findPages (("X-Total-Pages", bs) : _) = + case readMaybe (T.unpack (T.decodeUtf8 bs)) of + Just s -> s + Nothing -> error "cannot find X-Total-Pages in header" + findPages (_ : xs) = findPages xs + +successStatus :: Status -> Bool +successStatus (Status n _msg) = + n >= 200 && n <= 226 + tryGitLab :: -- | the current retry count Int -> @@ -152,181 +262,14 @@ httpLbs request manager `Exception.catch` \ex -> tryGitLab (i + 1) request maxRetries manager (Just ex) -parseBSOne :: FromJSON a => BSL.ByteString -> Maybe a -parseBSOne bs = +parseOne :: FromJSON a => BSL.ByteString -> Maybe a +parseOne bs = case eitherDecode bs of Left _err -> Nothing - -- useful when debugging - Right xs -> Just xs + Right x -> Just x -parseBSMany :: FromJSON a => BSL.ByteString -> IO [a] -parseBSMany bs = +parseMany :: FromJSON a => BSL.ByteString -> Maybe [a] +parseMany bs = case eitherDecode bs of - Left s -> Exception.throwIO $ GitLabException s - Right xs -> return xs - -gitlabReqJsonMany :: (FromJSON a) => Text -> Text -> GitLab (Either (Response BSL.ByteString) [a]) -gitlabReqJsonMany urlPath attrs = - go 1 [] - where - go i accum = do - cfg <- serverCfg <$> ask - manager <- httpManager <$> ask - let url' = - url cfg - <> "/api/v4" - <> urlPath - <> ( if (hasQuestionMark urlPath) - then "&" - else "?" - ) - <> "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) - } - 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 resp) - --- not sure what this was planned for --- --- gitlabReqOneIO :: Manager -> GitLabServerConfig -> (BSL.ByteString -> output) -> Text -> Text -> IO (Either Status output) --- gitlabReqOneIO manager cfg parser urlPath attrs = go --- where --- go = do --- let url' = --- 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) --- } --- resp <- tryGitLab 0 request (retries cfg) manager Nothing --- if successStatus (responseStatus resp) --- then return (Right (parser (responseBody resp))) --- else return (Left (responseStatus resp)) - -gitlabReqOne :: (BSL.ByteString -> output) -> Text -> Text -> GitLab (Either (Response BSL.ByteString) output) -gitlabReqOne parser urlPath attrs = go - where - go = do - cfg <- serverCfg <$> ask - manager <- httpManager <$> ask - let url' = - url cfg - <> "/api/v4" - <> urlPath - <> ( if (hasQuestionMark urlPath) - then "&" - else "?" - ) - <> "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) - } - resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing - if successStatus (responseStatus resp) - then return (Right (parser (responseBody resp))) - else return (Left resp) - --- not sure what this was planned for --- --- gitlabReqJsonOneIO :: (FromJSON a) => Manager -> GitLabServerConfig -> Text -> Text -> IO (Either Status (Maybe a)) --- gitlabReqJsonOneIO mgr cfg urlPath attrs = --- gitlabReqOneIO mgr cfg parseBSOne urlPath attrs - -gitlabReqJsonOne :: (FromJSON a) => Text -> Text -> GitLab (Either (Response BSL.ByteString) (Maybe a)) -gitlabReqJsonOne = - gitlabReqOne parseBSOne - -gitlabReqText :: Text -> GitLab (Either (Response BSL.ByteString) String) -gitlabReqText urlPath = gitlabReqOne C.unpack urlPath "" - -gitlabReqByteString :: Text -> GitLab (Either (Response BSL.ByteString) BSL.ByteString) -gitlabReqByteString urlPath = gitlabReqOne Prelude.id urlPath "" - -gitlab :: FromJSON a => Text -> GitLab (Either (Response BSL.ByteString) [a]) -gitlab addr = gitlabReqJsonMany addr "" - -gitlabUnsafe :: (FromJSON a) => Text -> GitLab [a] -gitlabUnsafe addr = - fromRight (error "gitlabUnsafe error") <$> gitlab addr - --- not sure what this was planned for --- --- gitlabOneIO :: (FromJSON a) => Manager -> GitLabServerConfig -> Text -> IO (Either Status (Maybe a)) --- gitlabOneIO mgr cfg addr = gitlabReqJsonOneIO mgr cfg addr "" - -gitlabOne :: (FromJSON a) => Text -> GitLab (Either (Response BSL.ByteString) (Maybe a)) -gitlabOne addr = gitlabReqJsonOne addr "" - -gitlabOneUnsafe :: (FromJSON a) => Text -> GitLab a -gitlabOneUnsafe addr = do - result <- fromRight (error "gitlabOneUnsafe error") <$> gitlabOne addr - case result of - Nothing -> error "gitlabOneUnsafe error" - Just value -> return value - -gitlabWithAttrs :: (FromJSON a) => Text -> Text -> GitLab (Either (Response BSL.ByteString) [a]) -gitlabWithAttrs = gitlabReqJsonMany - -gitlabWithAttrsUnsafe :: (FromJSON a) => Text -> Text -> GitLab [a] -gitlabWithAttrsUnsafe gitlabURL attrs = - fromRight (error "gitlabWithAttrsUnsafe error") <$> gitlabReqJsonMany gitlabURL attrs - -gitlabWithAttrsOne :: (FromJSON a) => Text -> Text -> GitLab (Either (Response BSL.ByteString) (Maybe a)) -gitlabWithAttrsOne = gitlabReqJsonOne - -gitlabWithAttrsOneUnsafe :: (FromJSON a) => Text -> Text -> GitLab a -gitlabWithAttrsOneUnsafe gitlabURL attrs = do - result <- gitlabReqJsonOne gitlabURL attrs - case result of - Left s -> error ("gitlabWithAttrsOneUnsafe: " <> show s) - Right Nothing -> error ("gitlabWithAttrsOneUnsafe: could not parse JSON for " <> show attrs) - Right (Just x) -> return x - -totalPages :: Response a -> Int -totalPages resp = - let hdrs = responseHeaders resp - in findPages hdrs - where - findPages [] = 1 -- error "cannot find X-Total-Pages in header" - findPages (("X-Total-Pages", bs) : _) = - case readMaybe (T.unpack (T.decodeUtf8 bs)) of - Just s -> s - Nothing -> error "cannot find X-Total-Pages in header" - findPages (_ : xs) = findPages xs - -successStatus :: Status -> Bool -successStatus (Status n _msg) = - n >= 200 && n <= 226 - -hasQuestionMark :: Text -> Bool -hasQuestionMark = T.isInfixOf "?" + Left _err -> Nothing + Right xs -> Just xs