gitlab-haskell 1.2.1.0 → 1.3.0.0

raw patch · 14 files changed

+116/−94 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +3/−3
• gitlab-haskell.cabal +1/−1
• src/GitLab.hs +11/−10
• src/GitLab/API/Boards.hs +5/−8
• src/GitLab/API/Events.hs +3/−10
• src/GitLab/API/Groups.hs +7/−13
• src/GitLab/API/Issues.hs +7/−11
• src/GitLab/API/MergeRequests.hs +46/−4
• src/GitLab/API/Projects.hs +3/−4
• src/GitLab/API/Todos.hs +3/−4
• src/GitLab/API/Users.hs +3/−4
• src/GitLab/SystemHooks/Rules.hs +2/−1
• src/GitLab/Types.hs +5/−11
• src/GitLab/WebRequests/GitLabWebCalls.hs +17/−10

@@ -67,10 +67,10 @@      myProjects <- fromRight <$>       runGitLab-        (defaultGitLabServer+        (def            { url = "https://gitlab.example.com"-           , token = AuthMethodToken "my_token"} )-        (searchUser "joe" >>=  \usr -> userProjects (fromJust usr) defaultProjectSearchAttrs)+           , authMethod = AuthMethodToken "my_token"} )+        (searchUser "joe" >>=  \usr -> userProjects (fromJust usr) def)  ## Library use 

@@ -1,7 +1,7 @@ cabal-version: 3.0 name:           gitlab-haskell category:       Git-version:        1.2.1.0+version:        1.3.0.0 synopsis:       A Haskell library for the GitLab web API description:             This library lifts the GitLab REST API into Haskell: <https://docs.gitlab.com/ee/api/>

@@ -36,6 +36,7 @@     module GitLab.SystemHooks.GitLabSystemHooks,     module GitLab.SystemHooks.Types,     module GitLab.SystemHooks.Rules,+    module Data.Default,   ) where @@ -46,9 +47,9 @@ import qualified Data.Text as T import GitLab.API.Boards import GitLab.API.Branches-import GitLab.API.Events import GitLab.API.Commits import GitLab.API.Discussions+import GitLab.API.Events import GitLab.API.Groups import GitLab.API.Issues import GitLab.API.JobArtifacts@@ -82,11 +83,11 @@ -- -- > projectsWithIssuesEnabled :: IO [Project] -- > projectsWithIssuesEnabled =--- >   runGitLabyConfig $ filter (issueEnabled . issues_enabled) <$> allProjects+-- >   runGitLab myConfig $ filter (issueEnabled . issues_enabled) <$> allProjects -- >   where--- >     myConfig = defaultGitLabServer+-- >     myConfig = def -- >         { url = "https://gitlab.example.com"--- >         , token = AuthMethodToken "my_access_token" }+-- >         , authMethod = AuthMethodToken "my_access_token" } -- >     issueEnabled Nothing = False -- >     issueEnabled (Just b) = b runGitLab :: GitLabServerConfig -> GitLab a -> IO (Either GitLabError a)@@ -99,11 +100,11 @@ -- | The same as 'runGitLab', except that it prompts for a GitLab -- access token before running the GitLab action. ----- In this case you can just use 'defaultGitLabServer' with no+-- In this case you can just use 'def' with no -- modification of the record field values, because these values will -- be asked for at runtime: ----- > runGitLabPassPrompt defaultGitLabServer myGitLabProgram+-- > runGitLabPassPrompt def myGitLabProgram runGitLabPassPrompt :: GitLabServerConfig -> GitLab a -> IO (Either GitLabError a) runGitLabPassPrompt cfg action = do   liftIO $ hSetBuffering stdout NoBuffering@@ -111,7 +112,7 @@   hostUrl <- getLine   liftIO (putStr "Enter GitLab access token\n> ")   pass <- getLine-  runGitLab (cfg {url = T.pack hostUrl, token = AuthMethodToken (T.pack pass)}) action+  runGitLab (cfg {url = T.pack hostUrl, authMethod = AuthMethodToken (T.pack pass)}) action  -- | The same as 'runGitLab', except that it also takes a connection -- manager as an argument.@@ -130,9 +131,9 @@           Right (Right _versionInfo) -> func       goAhead = runExceptT (runReaderT action (GitLabState cfg manager))   -- No version check without authentication because /version is not public.-  case token cfg of+  case authMethod cfg of     AuthMethodNone -> goAhead-    _ -> withVersionCheck  goAhead+    _ -> withVersionCheck goAhead  -- | Only useful for testing GitLab actions that lift IO actions with -- liftIO. Cannot speak to a GitLab server. Only useful for the@@ -141,5 +142,5 @@ runGitLabDbg (GitLabT action) = do   liftIO $ hSetBuffering stdout LineBuffering   manager <- liftIO $ newManager (mkManagerSettings def Nothing)-  let cfg = GitLabServerConfig {url = "", token = AuthMethodToken "", retries = 1, debugSystemHooks = Nothing}+  let cfg = GitLabServerConfig {url = "", authMethod = AuthMethodToken "", retries = 1, debugSystemHooks = Nothing}   runExceptT (runReaderT action (GitLabState cfg manager))

@@ -41,13 +41,12 @@      -- * Board attributes     UpdateBoardAttrs (..),-    defaultUpdateBoardAttrs,     CreateBoardAttrs (..),-    defaultCreateBoardAttrs,   ) where  import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Either import Data.Maybe import Data.Text (Text)@@ -345,9 +344,8 @@   }  -- | default attributes for board update.-defaultUpdateBoardAttrs :: UpdateBoardAttrs-defaultUpdateBoardAttrs =-  UpdateBoardAttrs Nothing Nothing Nothing Nothing Nothing+instance Default UpdateBoardAttrs where+  def = UpdateBoardAttrs Nothing Nothing Nothing Nothing Nothing  updateBoardAttrs :: UpdateBoardAttrs -> [GitLabParam] updateBoardAttrs attrs =@@ -367,9 +365,8 @@   }  -- | default attributes for board creation.-defaultCreateBoardAttrs :: CreateBoardAttrs-defaultCreateBoardAttrs =-  CreateBoardAttrs Nothing Nothing Nothing+instance Default CreateBoardAttrs where+  def = CreateBoardAttrs Nothing Nothing Nothing  createBoardAttrs :: CreateBoardAttrs -> [GitLabParam] createBoardAttrs attrs =

@@ -29,13 +29,13 @@      -- * Filter attributes     EventFilterAttrs (..),-    defaultEventFilters,   ) where  import Control.Monad.Except import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -63,15 +63,8 @@   }  -- | Default event filters: no filtering applied.-defaultEventFilters :: EventFilterAttrs-defaultEventFilters =-  EventFilterAttrs-    { eventFilter_action = Nothing,-      eventFilter_target_type = Nothing,-      eventFilter_before = Nothing,-      eventFilter_after = Nothing,-      eventFilter_sort = Nothing-    }+instance Default EventFilterAttrs where+  def = EventFilterAttrs Nothing Nothing Nothing Nothing Nothing  -- | Get events for the currently authenticated user. --

@@ -50,14 +50,12 @@     GroupProjectOrderBy (..),     GroupAttrs (..),     BranchProtection (..),-    defaultGroupFilters,-    defaultListGroupsFilters,-    defaultGroupProjectFilters,   ) where  import Control.Monad.Except import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -243,9 +241,8 @@   }  -- | No group filters applied, thereby returning all groups.-defaultGroupProjectFilters :: GroupProjectAttrs-defaultGroupProjectFilters =-  GroupProjectAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+instance Default GroupProjectAttrs where+  def = GroupProjectAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing  -- | The order of group projects in search results. data GroupProjectOrderBy@@ -336,9 +333,8 @@     showBool False = "false"  -- | No group filters applied, thereby returning all groups.-defaultListGroupsFilters :: ListGroupsAttrs-defaultListGroupsFilters =-  ListGroupsAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+instance Default ListGroupsAttrs where+  def = ListGroupsAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing  -- | Attributes related to a group data GroupAttrs = GroupAttrs@@ -431,7 +427,5 @@     showBool False = "false"  -- | No group filters applied.-defaultGroupFilters ::-  GroupAttrs-defaultGroupFilters =-  GroupAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+instance Default GroupAttrs where+  def = GroupAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

@@ -77,9 +77,8 @@     issueStatisticsProject,      -- * Issues attributes-    defaultIssueFilters,-    defaultIssueAttrs,     IssueAttrs (..),+    defaultIssueAttrs,     IssueFilterAttrs (..),     DueDate (..),     IssueState (..),@@ -89,6 +88,7 @@ import Control.Monad.Except import Data.Aeson.TH import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -661,8 +661,8 @@       (\b -> Just ("with_labels_details", textToBS (showBool b))) =<< issueFilter_with_labels_details filters     ]     <> case issueFilter_iids filters of-         Nothing   -> []-         Just iids -> map (\i -> ("iids[]", textToBS (T.pack (show i)))) iids+      Nothing -> []+      Just iids -> map (\i -> ("iids[]", textToBS (T.pack (show i)))) iids   where     textToBS = Just . T.encodeUtf8     showBool :: Bool -> Text@@ -696,15 +696,11 @@   show IssueClosed = "closed"  -- | No issue filters, thereby returning all issues. Default scope is "all".-defaultIssueFilters :: IssueFilterAttrs-defaultIssueFilters =-  IssueFilterAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just All) Nothing Nothing Nothing Nothing Nothing Nothing+instance Default IssueFilterAttrs where+  def = IssueFilterAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just All) Nothing Nothing Nothing Nothing Nothing Nothing  -- | issue attributes when creating or editing issues.-defaultIssueAttrs ::-  -- | project ID-  Int ->-  IssueAttrs+defaultIssueAttrs :: ProjectId -> IssueAttrs defaultIssueAttrs prjId =   IssueAttrs prjId Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing 

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -31,7 +32,6 @@      -- * Get issues that would be closed by merging an MR     mergeRequestClosesIssues,-     --     -- * Get single MR changes      --     -- * List MR pipelines@@ -44,6 +44,7 @@      -- * Accept MR     acceptMergeRequest,+    AcceptMergeRequestAttrs (..),      -- * Delete a merge request     deleteMergeRequest,@@ -59,12 +60,14 @@ import Control.Monad.Except import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time.Clock import Data.Time.Format.ISO8601+import GHC.Generics import GitLab.Types import GitLab.WebRequests.GitLabWebCalls import Network.HTTP.Client@@ -273,6 +276,8 @@   Project ->   -- | merge request IID   Int ->+  -- | accept merge request attributes+  AcceptMergeRequestAttrs ->   GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest)) acceptMergeRequest project =   acceptMergeRequest' (project_id project)@@ -283,8 +288,11 @@   Int ->   -- | merge request IID   Int ->+  -- | accept merge request attributes+  AcceptMergeRequestAttrs ->   GitLab (Either (Response BSL.ByteString) (Maybe MergeRequest))-acceptMergeRequest' projectId mergeRequestIid = gitlabPost addr params+acceptMergeRequest' projectId mergeRequestIid attrs =+  gitlabPut addr (acceptMRAttrsParams attrs <> params)   where     params :: [GitLabParam]     params =@@ -490,8 +498,8 @@       (\t -> Just ("deployed_after", showTime t)) =<< mr_attr_deployed_after attrs     ]     <> case mr_attr_iids attrs of-         Nothing   -> []-         Just iids -> map (\i -> ("iids[]", showAttr i)) iids+      Nothing -> []+      Just iids -> map (\i -> ("iids[]", showAttr i)) iids   where     showAttr :: (Show a) => a -> Maybe BS.ByteString     showAttr = Just . T.encodeUtf8 . T.pack . show@@ -501,3 +509,37 @@     showBool False = Just (T.encodeUtf8 (T.pack "false"))     showTime :: UTCTime -> Maybe BS.ByteString     showTime = Just . T.encodeUtf8 . T.pack . iso8601Show++-- | Attributes for updating when editing a project with the+-- 'editProject' functions.+data AcceptMergeRequestAttrs = AcceptMergeRequestAttrs+  { -- | Set whether or not merge requests can be merged with skipped jobs.+    accept_mr_attr_auto_merge :: Maybe Bool,+    accept_mr_attr_merge_commit_message :: Maybe Text,+    accept_mr_attr_merge_when_pipeline_succeeds :: Maybe Bool,+    accept_mr_attr_sha :: Maybe Text,+    accept_mr_attr_should_remove_source_branch :: Maybe Bool,+    accept_mr_attr_squash_commit_message :: Maybe Text,+    accept_mr_attr_squash :: Maybe Bool+  }+  deriving (Generic, Show, Eq)++instance Default AcceptMergeRequestAttrs where+  def = AcceptMergeRequestAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing++acceptMRAttrsParams :: AcceptMergeRequestAttrs -> [GitLabParam]+acceptMRAttrsParams attrs =+  catMaybes+    [ (\b -> Just ("auto_merge", showBool b)) =<< accept_mr_attr_auto_merge attrs,+      (\t -> Just ("merge_commit_message", showAttrT t)) =<< accept_mr_attr_merge_commit_message attrs,+      (\b -> Just ("merge_when_pipeline_succeeds", showBool b)) =<< accept_mr_attr_merge_when_pipeline_succeeds attrs,+      (\t -> Just ("sha", showAttrT t)) =<< accept_mr_attr_sha attrs,+      (\b -> Just ("should_remove_source_branch", showBool b)) =<< accept_mr_attr_should_remove_source_branch attrs,+      (\t -> Just ("squash_commit_message", showAttrT t)) =<< accept_mr_attr_squash_commit_message attrs,+      (\b -> Just ("squash", showBool b)) =<< accept_mr_attr_squash attrs+    ]+  where+    showAttrT = Just . T.encodeUtf8+    showBool :: Bool -> Maybe BS.ByteString+    showBool True = Just (T.encodeUtf8 (T.pack "true"))+    showBool False = Just (T.encodeUtf8 (T.pack "false"))

@@ -89,7 +89,6 @@     -- transferProject,     -- transferProject',     defaultProjectAttrs,-    defaultProjectSearchAttrs,     ProjectAttrs (..),     ProjectSearchAttrs (..),     EnabledDisabled (..),@@ -103,6 +102,7 @@  import Control.Monad.Except import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.List import Data.Maybe import Data.Text (Text)@@ -937,9 +937,8 @@  -- | A default set of project searc filters where no project filters -- are applied, thereby returning all projects.-defaultProjectSearchAttrs :: ProjectSearchAttrs-defaultProjectSearchAttrs =-  ProjectSearchAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+instance Default ProjectSearchAttrs where+  def = ProjectSearchAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing  -- | Attributes related to a project data ProjectSearchAttrs = ProjectSearchAttrs

@@ -19,12 +19,12 @@     todosDone,      -- * TODO's filters-    defaultTodoFilters,     TodoAttrs (..),   ) where  import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -69,9 +69,8 @@     textToBS = Just . T.encodeUtf8  -- | No todo filters applied.-defaultTodoFilters :: TodoAttrs-defaultTodoFilters =-  TodoAttrs Nothing Nothing Nothing Nothing Nothing Nothing+instance Default TodoAttrs where+  def = TodoAttrs Nothing Nothing Nothing Nothing Nothing Nothing  -- | Marks a single pending to-do item given by its ID for the current -- user as done.

@@ -90,13 +90,13 @@     rejectUser,      -- * Users attributes-    defaultUserFilters,     UserAttrs (..),   ) where  import Control.Monad.Except import qualified Data.ByteString.Lazy as BSL+import Data.Default import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -544,9 +544,8 @@ rejectUser = userAction "/reject" "rejectUser"  -- | No group filters applied, thereby returning all groups.-defaultUserFilters :: UserAttrs-defaultUserFilters =-  UserAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+instance Default UserAttrs where+  def = UserAttrs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing  -- | Attributes related to a group data UserAttrs = UserAttrs

@@ -8,6 +8,7 @@ module GitLab.SystemHooks.Rules (ruleAddMembers, ruleAddNewUserToGroups) where  import Control.Monad+import Data.Default import Data.Text (Text) import GitLab.API.Groups import GitLab.API.Members@@ -35,7 +36,7 @@     ( \event@UserCreate {} -> do         mapM_           ( \groupName -> do-              grps <- groups (defaultListGroupsFilters {listGroupsFilter_search = Just groupName})+              grps <- groups (def {listGroupsFilter_search = Just groupName})                case grps of                 [] -> return ()

@@ -20,7 +20,6 @@     GitLabServerConfig (..),     GitLabError (..),     AuthMethod (..),-    defaultGitLabServer,     ArchiveFormat (..),     AccessLevel (..),     SearchIn (..),@@ -119,6 +118,7 @@ import Data.Aeson hiding (Key) import Data.Aeson.TH import Data.Aeson.Types hiding (Key)+import Data.Default import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock@@ -152,7 +152,7 @@ -- | configuration data specific to a GitLab server. data GitLabServerConfig = GitLabServerConfig   { url :: Text,-    token :: AuthMethod,+    authMethod :: AuthMethod,     -- | how many times to retry a HTTP request before giving up and returning an error.     retries :: Int,     -- | write system hook events to files in the system temporary directory.@@ -168,15 +168,9 @@     AllJSON   deriving (Eq) --- | default settings, the 'url' and 'authMethod' values may need to be overwritten.-defaultGitLabServer :: GitLabServerConfig-defaultGitLabServer =-  GitLabServerConfig-    { url = "https://gitlab.com",-      token = AuthMethodNone,-      retries = 5,-      debugSystemHooks = Nothing-    }+-- | default settings are https://gitlab.com with 'AuthMethodNone', the 'url' and 'authMethod' values may need to be overwritten.+instance Default GitLabServerConfig where+  def = GitLabServerConfig {url = "https://gitlab.com", authMethod = AuthMethodNone, retries = 5, debugSystemHooks = Nothing}  -- | personal access token, see <https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html> data AuthMethod

@@ -183,7 +183,7 @@   cfg <- MR.asks serverCfg   manager <- MR.asks httpManager   let url' = url cfg <> "/api/v4" <> urlPath <> T.decodeUtf8 (renderQuery True urlParams)-  let authHeaders = case token cfg of+  let authHeaders = case authMethod cfg of         AuthMethodNone -> []         AuthMethodToken t -> [("PRIVATE-TOKEN", T.encodeUtf8 t)]         AuthMethodOAuth t -> [("Authorization", "Bearer " <> T.encodeUtf8 t)]@@ -191,9 +191,10 @@       request =         request'           { method = httpMethod,-            requestHeaders = authHeaders <>-              [ ("content-type", contentType)-              ],+            requestHeaders =+              authHeaders+                <> [ ("content-type", contentType)+                   ],             requestBody = RequestBodyBS (renderQuery False contentParams)           }   liftIO $ tryGitLab 0 request (retries cfg) manager Nothing@@ -254,12 +255,18 @@         then do           case eitherDecode (responseBody response) of             Left decodeErr -> do-              liftIO $ hPutStrLn stderr $-                "[gitlab-haskell] JSON decode error for " <> T.unpack urlPath-                  <> " (page " <> show pageNum <> "): " <> decodeErr-              liftIO $ hPutStrLn stderr $-                "[gitlab-haskell] Raw response body: "-                  <> show (BSL.take 2000 (responseBody response))+              liftIO $+                hPutStrLn stderr $+                  "[gitlab-haskell] JSON decode error for "+                    <> T.unpack urlPath+                    <> " (page "+                    <> show pageNum+                    <> "): "+                    <> decodeErr+              liftIO $+                hPutStrLn stderr $+                  "[gitlab-haskell] Raw response body: "+                    <> show (BSL.take 2000 (responseBody response))               return (Right accum)             Right moreResults -> do               let accum' = accum <> moreResults