gitlab-haskell 1.0.1.0 → 1.0.2.0

raw patch · 8 files changed

+76/−25 lines, 8 filesdep +unix-compatdep −unixPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: unix-compat

Dependencies removed: unix

API changes (from Hackage documentation)

Files

• README.md +2/−2
• data/system-hooks/project-created-diacritics.json +12/−0
• gitlab-haskell.cabal +2/−2
• src/GitLab.hs +1/−1
• src/GitLab/SystemHooks/GitLabSystemHooks.hs +14/−6
• src/GitLab/Types.hs +16/−5
• src/GitLab/WebRequests/GitLabWebCalls.hs +9/−9
• tests/SystemHookTests.hs +20/−0

@@ -29,8 +29,8 @@ GitLab data with data types and functions that the library provides. E.g. -    searchUser     :: Text -> GitLab (Maybe User)-    userProjects   :: User -> GitLab (Maybe [Project])+    searchUser   :: Text -> GitLab (Maybe User)+    userProjects :: User -> ProjectSearchAttrs -> GitLab (Maybe [Project])  ## Server-side GitLab file hooks 

@@ -0,0 +1,12 @@+{+          "created_at": "2012-07-21T07:30:54Z",+          "updated_at": "2012-07-21T07:38:22Z",+          "event_name": "project_create",+                "name": "StoreCloud",+         "owner_email": "eloisesmith@gmail.com",+          "owner_name": "Smith, Eloïse",+                "path": "storecloud",+ "path_with_namespace": "eloisesmith/storecloud",+          "project_id": 74,+    "project_visibility": "private"+}

@@ -1,7 +1,7 @@ cabal-version: 2.4 name:           gitlab-haskell category:       Git-version:        1.0.1.0+version:        1.0.2.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/>@@ -207,7 +207,7 @@               , transformers               , time >= 1.9               , temporary-              , unix+              , unix-compat               , mtl               , data-default-class   default-language: Haskell2010

@@ -131,5 +131,5 @@ runGitLabDbg (GitLabT action) = do   liftIO $ hSetBuffering stdout LineBuffering   manager <- liftIO $ newManager (mkManagerSettings def Nothing)-  let cfg = GitLabServerConfig {url = "", token = AuthMethodToken "", retries = 1, debugSystemHooks = False}+  let cfg = GitLabServerConfig {url = "", token = AuthMethodToken "", retries = 1, debugSystemHooks = NoHookDebugging}   runReaderT action (GitLabState cfg manager)

@@ -28,7 +28,7 @@ import GitLab.SystemHooks.Types import GitLab.Types import System.IO.Temp-import System.Posix.Files+import System.PosixCompat.Files  -- | Attempts to fire each rule in sequence. Reads the JSON data -- received from the GitLab server from standard input.@@ -42,14 +42,19 @@ receiveString :: Text -> [Rule] -> GitLab () receiveString eventContent rules = do   traceSystemHook eventContent-  mapM_ (fire eventContent) rules+  didFire <- mapM (fire eventContent) rules+  when (not (or didFire)) $ do+    cfg <- MR.asks serverCfg+    when (debugSystemHooks cfg == UnprocessedEvents || debugSystemHooks cfg == AllEvents) $ liftIO $ do+      fpath <- writeSystemTempFile "gitlab-system-hook-unprocessed-" (T.unpack eventContent)+      void $ setFileMode fpath otherReadMode  traceSystemHook :: Text -> GitLab () traceSystemHook eventContent = do   cfg <- MR.asks serverCfg   liftIO $     E.catch-      ( when (debugSystemHooks cfg) $ do+      ( when (debugSystemHooks cfg == AllJSON || debugSystemHooks cfg == AllEvents) $ do           fpath <- writeSystemTempFile "gitlab-system-hook-" (T.unpack eventContent)           void $ setFileMode fpath otherReadMode       )@@ -63,11 +68,14 @@     then return True     else g -fire :: Text -> Rule -> GitLab ()+fire :: Text -> Rule -> GitLab Bool fire contents rule = do   result <- tryFire contents rule-  when result $-    liftIO (putStrLn ("fired: " <> labelOf rule))+  case result of+    True -> do+      liftIO (putStrLn ("fired: " <> labelOf rule))+      return True+    False -> return False   where     labelOf :: Rule -> String     labelOf (Match lbl _) = lbl

@@ -105,6 +105,7 @@     EventActionName (..),     EventTargetType (..),     PushData (..),+    DebugSystemHooks (..),   ) where @@ -130,7 +131,7 @@ instance MT.MonadTrans GitLabT where   lift = GitLabT . MT.lift -instance MIO.MonadIO m => MIO.MonadIO (GitLabT m) where+instance (MIO.MonadIO m) => MIO.MonadIO (GitLabT m) where   liftIO = GitLabT . MIO.liftIO  -- | Utility type which uses 'IO' as underlying monad@@ -148,11 +149,21 @@     token :: 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.-    debugSystemHooks :: Bool+    -- | write system hook events to files in the system temporary directory.+    debugSystemHooks :: DebugSystemHooks   } +data DebugSystemHooks+  = -- | Report all JSON objects received and unprocessed events+    AllEvents+  | -- | Report unprocessed events+    UnprocessedEvents+  | -- | Report all JSON objects received+    AllJSON+  | -- | No debugging+    NoHookDebugging+  deriving (Eq)+ -- | default settings, the 'url' and 'token' values will need to be overwritten. defaultGitLabServer :: GitLabServerConfig defaultGitLabServer =@@ -160,7 +171,7 @@     { url = "https://gitlab.com",       token = AuthMethodToken "",       retries = 5,-      debugSystemHooks = False+      debugSystemHooks = NoHookDebugging     }  -- | personal access token, see <https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html>

@@ -18,7 +18,7 @@ import Control.Monad.IO.Class import qualified Control.Monad.Reader as MR import Data.Aeson-import Data.ByteString+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import Data.Maybe (isJust) import Data.Text (Text)@@ -35,7 +35,7 @@  instance Exception.Exception GitLabException -type GitLabParam = (ByteString, Maybe ByteString)+type GitLabParam = (BS.ByteString, Maybe BS.ByteString)  gitlabGetOne ::   (FromJSON a) =>@@ -158,9 +158,9 @@  gitlabHTTP ::   -- | HTTP method (PUT, POST, DELETE, GET)-  ByteString ->+  BS.ByteString ->   -- | Content type (content-type)-  ByteString ->+  BS.ByteString ->   -- | the URL   Text ->   -- | the URL parameters for GET calls@@ -190,9 +190,9 @@ gitlabHTTPOne ::   FromJSON a =>   -- | HTTP method (PUT, POST, DELETE, GET)-  ByteString ->+  BS.ByteString ->   -- | Content type (content-type)-  ByteString ->+  BS.ByteString ->   -- | the URL   Text ->   -- | the URL query data for GET calls@@ -216,9 +216,9 @@ gitlabHTTPMany ::   (FromJSON a) =>   -- | HTTP method (PUT, POST, DELETE, GET)-  ByteString ->+  BS.ByteString ->   -- | Content type (content-type)-  ByteString ->+  BS.ByteString ->   -- | the URL   Text ->   -- | the URL query data for GET calls@@ -258,7 +258,7 @@     findPages [] = False     findPages (("X-Next-Page", bs) : _) = isJust $ readNP bs     findPages (_ : xs) = findPages xs-    readNP :: ByteString -> Maybe Int+    readNP :: BS.ByteString -> Maybe Int     readNP bs = readMaybe (T.unpack (T.decodeUtf8 bs))  successStatus :: Status -> Bool

@@ -23,6 +23,11 @@             >>= \eventJson -> parseEvent eventJson @?= Just projectCreatedHaskell         ),       testCase+        "project-create-diacritics-event"+        ( TIO.readFile "data/system-hooks/project-created-diacritics.json"+            >>= \eventJson -> parseEvent eventJson @?= Just projectCreatedDiatricsHaskell+        ),+      testCase         "project-destroy-event"         ( TIO.readFile "data/system-hooks/project-destroyed.json"             >>= \eventJson -> parseEvent eventJson @?= Just projectDestroyedHaskell@@ -1143,6 +1148,21 @@       projectCreate_owner_name = "John Smith",       projectCreate_path = "storecloud",       projectCreate_path_with_namespace = "jsmith/storecloud",+      projectCreate_project_id = 74,+      projectCreate_project_visibility = Private+    }++projectCreatedDiatricsHaskell :: ProjectCreate+projectCreatedDiatricsHaskell =+  ProjectCreate+    { projectCreate_created_at = "2012-07-21T07:30:54Z",+      projectCreate_updated_at = "2012-07-21T07:38:22Z",+      projectCreate_action = "project_create",+      projectCreate_name = "StoreCloud",+      projectCreate_owner_email = "eloisesmith@gmail.com",+      projectCreate_owner_name = "Smith, Eloïse",+      projectCreate_path = "storecloud",+      projectCreate_path_with_namespace = "eloisesmith/storecloud",       projectCreate_project_id = 74,       projectCreate_project_visibility = Private     }