gitlab-haskell 0.1.4 → 0.1.5

raw patch · 8 files changed

+230/−41 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +26/−3
• gitlab-haskell.cabal +25/−5
• src/GitLab/API/MergeRequests.hs +65/−0
• src/GitLab/API/Projects.hs +4/−1
• src/GitLab/API/Repositories.hs +32/−0
• src/GitLab/API/Todos.hs +8/−0
• src/GitLab/Types.hs +53/−4
• src/GitLab/WebRequests/GitLabWebCalls.hs +17/−28

@@ -19,7 +19,30 @@ The library parses JSON results into Haskell data types in the `GitLab.Types` module. -## Applications using this library+## Example -* `gitlab-tools`: a command line tool for bulk transactions against a-  GitLab server. [link](https://gitlab.com/robstewart57/gitlab-tools)+Run all GitLab actions with `runGitLab`: ++    runGitLab ::+      (MonadUnliftIO m, MonadIO m)+       => GitLabServerConfig+       -> GitLab m a+       -> m a++For example:++    myTodos <- runGitLab+                 (defaultGitLabServer+                   { url = "https://gitlab.example.com"+                   , token="my_token"} )+                 todos++Which uses the `todos` function:++    todos :: MonadIO m => GitLab m [Todo] ++This returns all GitLab TODO items, as Haskell values of type `Todo`+for the user identified with the access token`my_token`.++The `gitlab-tools` command line tool for bulk GitLab transactions uses+this library [link](https://gitlab.com/robstewart57/gitlab-tools).

@@ -1,12 +1,31 @@ cabal-version: 2.4 name:           gitlab-haskell category:       Git-version:        0.1.4+version:        0.1.5 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: <https://docs.gitlab.com/ee/api/>-  .-  Unsurprisingly, GitLab hosts this Haskell library: <https://gitlab.com/robstewart57/gitlab-haskell>+            This Haskell library queries and updates the database of a GitLab instance using the GitLab web API: <https://docs.gitlab.com/ee/api/>+            .+            Run all GitLab actions with `runGitLab`:+            .+            > runGitLab :: (MonadUnliftIO m, MonadIO m)+            >  => GitLabServerConfig -- ^ the GitLab server details+            >  -> GitLab m a         -- ^ the GitLab action+            >  -> m a+            .+            For example:+            .+            > myTodos <- runGitLab+            >      (defaultGitLabServer+            >          { url = "https://gitlab.example.com"+            >          , token="my_token"} )+            >      todos+            .+            Which uses the `todos` function:+            .+            > todos :: MonadIO m => GitLab m [Todo] +            .+            Unsurprisingly, this library is maintained on GitLab: <https://gitlab.com/robstewart57/gitlab-haskell>   homepage:       https://gitlab.com/robstewart57/gitlab-haskell@@ -41,7 +60,8 @@                 , GitLab.API.MergeRequests                 , GitLab.API.RepositoryFiles                 , GitLab.API.Todos-                , GitLab.WebRequests.GitLabWebCalls+  other-modules:+                  GitLab.WebRequests.GitLabWebCalls   hs-source-dirs:                  src   build-depends:

@@ -11,7 +11,9 @@ module GitLab.API.MergeRequests where  import Control.Monad.IO.Unlift+import Data.Text (Text) import qualified Data.Text as T+import Network.HTTP.Types.Status  import GitLab.Types import GitLab.WebRequests.GitLabWebCalls@@ -33,3 +35,66 @@       "/projects/"       <> 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 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' 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+    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 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' projectId mergeRequestIid = gitlabPost addr dataBody+  where+    dataBody :: Text+    dataBody = T.pack $+      "id=" <> show projectId <> "&merge_request_iid=" <> show mergeRequestIid+    addr =+      T.pack $+      "/projects/" <> show projectId <> "/merge_requests/" <>+      show mergeRequestIid <>+      "/merge"

@@ -106,7 +106,7 @@   (commits :: [Commit]) <- projectCommits' projectId   return (map author_email commits) --- | gets all projects for a user's username.+-- | gets all projects for a user given their username. -- -- > userProjects "harry" userProjects' ::@@ -119,6 +119,9 @@   where     urlPath userId = "/users/" <> T.pack (show userId) <> "/projects" +-- | gets all projects for a user.+--+-- > userProjects myUser userProjects ::      (MonadUnliftIO m, MonadIO m) => User -> GitLab m (Maybe [Project]) userProjects theUser = userProjects' (user_username theUser)

@@ -11,6 +11,7 @@ module GitLab.API.Repositories where  import Control.Monad.IO.Unlift+import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T  import GitLab.Types@@ -35,3 +36,34 @@       <> 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 project = getFileArchive' (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' projectId format path = do+  archiveData <- gitlabReqByteString addr+  liftIO $ BSL.writeFile path archiveData+  where+    addr =+      "/projects/"+      <> T.pack (show projectId)+      <> "/repository"+      <> "/archive"+      <> T.pack (show format)+  

@@ -1,5 +1,13 @@ {-# 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 GitLab.API.Todos where  import Control.Monad.IO.Class

@@ -17,6 +17,7 @@   , GitLabState(..)   , GitLabServerConfig(..)   , defaultGitLabServer+  , ArchiveFormat(..)   , Member(..)   , Namespace(..)   , Links(..)@@ -85,6 +86,32 @@   , 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@@ -189,6 +216,7 @@   , project_stats :: Maybe ProjectStats   } deriving (Generic, Show) +-- | project statistics. data ProjectStats =   ProjectStats   { commit_count :: Int@@ -211,7 +239,7 @@   , user_web_url :: Maybe Text   } deriving (Generic, Show) --- | milestones.+-- | milestone state. data MilestoneState = MSActive                     | MSClosed                     deriving (Show)@@ -220,6 +248,7 @@   parseJSON (String "closed") = return MSClosed   parseJSON x = unexpected x +-- | milestones. data Milestone =   Milestone   { milestone_project_id :: Maybe Int@@ -322,6 +351,7 @@   , total :: Int   } deriving (Generic, Show) +-- | diff between two commits. data Diff =   Diff   { diff :: Text@@ -468,15 +498,21 @@   , 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 :: Bool-  -- , merge_request_allow_maintainer_to_push :: 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@@ -495,13 +531,16 @@   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)@@ -521,6 +560,7 @@ instance FromJSON TodoProject where   parseJSON = genericParseJSON (defaultOptions { fieldLabelModifier = drop 3 }) +-- | TODOs. data Todo = Todo { todo_id :: Int                  , todo_project :: TodoProject                  , todo_author :: User@@ -658,6 +698,15 @@ 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" 

@@ -10,6 +10,7 @@   , gitlabWithAttrsOne   , gitlabPost   , gitlabReqText+  , gitlabReqByteString   ) where  import Network.HTTP.Conduit@@ -78,8 +79,8 @@     Left s -> error s     Right xs -> xs -gitlabReq :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a]-gitlabReq urlPath attrs =+gitlabReqJsonMany :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a]+gitlabReqJsonMany urlPath attrs =   go 1 []   where     go i accum = do@@ -106,8 +107,8 @@       then return accum'       else go (i+1) accum' -gitlabReqOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a)-gitlabReqOne urlPath attrs = go+gitlabReqOne :: (MonadIO m) => (BSL.ByteString -> output) -> Text -> Text -> GitLab m output+gitlabReqOne parser urlPath attrs = go   where     go = do       cfg <- serverCfg <$> ask@@ -126,40 +127,28 @@             , responseTimeout = responseTimeoutMicro (timeout cfg)             }       res <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing-      return (parseBSOne (responseBody res))+      return (parser (responseBody res)) +gitlabReqJsonOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a)+gitlabReqJsonOne = gitlabReqOne parseBSOne+ gitlabReqText :: (MonadIO m) => Text -> GitLab m String-gitlabReqText urlPath = go-  where-    go = do-      cfg <- serverCfg <$> ask-      manager <- httpManager <$> ask-      let url' =-               url cfg-            <> "/api/v4"-            <> urlPath-            <> "?per_page=100"-            <> "&page=1"-      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 (C.unpack (responseBody res))+gitlabReqText urlPath = gitlabReqOne C.unpack urlPath "" +gitlabReqByteString :: (MonadIO m) => Text -> GitLab m BSL.ByteString+gitlabReqByteString urlPath = gitlabReqOne Prelude.id urlPath ""+ gitlab :: (MonadIO m, FromJSON a) => Text -> GitLab m [a]-gitlab addr = gitlabReq addr ""+gitlab addr = gitlabReqJsonMany addr ""  gitlabOne :: (MonadIO m, FromJSON a) => Text -> GitLab m (Maybe a)-gitlabOne addr = gitlabReqOne addr ""+gitlabOne addr = gitlabReqJsonOne addr ""  gitlabWithAttrs :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a]-gitlabWithAttrs  = gitlabReq+gitlabWithAttrs  = gitlabReqJsonMany  gitlabWithAttrsOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Maybe a)-gitlabWithAttrsOne  = gitlabReqOne+gitlabWithAttrsOne  = gitlabReqJsonOne  totalPages :: Response a -> Int totalPages resp =