libjenkins 0.4.3.0 → 0.5.0

raw patch · 12 files changed

+210/−170 lines, 12 filesdep +exceptionsdep +network-uridep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, network-uri

Dependency ranges changed: network

API changes (from Hackage documentation)

Files

• CHANGELOG.md +30/−7
• README.md +0/−1
• bench/Concurrency.hs +6/−7
• example/grep-jobs.hs +1/−1
• example/rename-jobs.hs +3/−3
• example/running-jobs-count.hs +1/−1
• libjenkins.cabal +7/−3
• src/Jenkins/Rest.hs +54/−72
• src/Jenkins/Rest/Internal.hs +77/−60
• src/Jenkins/Rest/Method.hs +1/−0
• test/Jenkins/Rest/InternalSpec.hs +24/−10
• test/Jenkins/RestSpec.hs +6/−5

@@ -1,3 +1,26 @@+0.5.0+=====++  * Replaced `concurrentlys` and `concurrentlys_` with `traverseC` and `traverseC_`+    respectively. Quick migration guide:++    + `concurrentlys`  -> `traverseC  id . toList`+    + `concurrentlys_` -> `traverseC_ id . toList`++  * Added `getS` for tighter control of Jenkins responses consumption++  * `post` variants do not read the response body at all anymore++  * Added `orElse`++  * Removed `runJenkinsThrowing` from the API++  * `runJenkins` only catches exceptions thrown by the execution of `Jenkins` queries++  * Switched to `network-uri`++  * Removed `io` from the API. Quick migration guide: `io` -> `liftIO`+ 0.4.3.0 ======= @@ -6,21 +29,21 @@ 0.4.2.0 ======= -  * Generalize `ConnectInfo`+  * Generalized `ConnectInfo`  0.4.1.0 ======= -  * Generalize `io`+  * Generalized `io` -  * Add `runJenkinsThrowing`+  * Added `runJenkinsThrowing`  0.4.0.0 ======= -  * Use `Text` for username and API token (password)+  * Switched to `Text` for username and API token (password) -  * Support `lens-4.0`+  * Supported `lens-4.0`  0.3.0.0 =======@@ -33,12 +56,12 @@    * More optics in `Network.HTTP.Conduit.Lens` -  * Add `overallLoad` and `computer` REST API methods shortcuts+  * Added `overallLoad` and `computer` REST API methods shortcuts  0.2.0.0 ======= -  * Move onto http-conduit 2.0 API.+  * Moved onto http-conduit 2.0 API.  0.1.0.0 =======

@@ -1,5 +1,4 @@ libjenkins ========== [![Hackage](https://budueba.com/hackage/libjenkins)](https://hackage.haskell.org/package/libjenkins)-[![Build Status](https://drone.io/github.com/supki/libjenkins/status.png)](https://drone.io/github.com/supki/libjenkins/latest) [![Build Status](https://secure.travis-ci.org/supki/libjenkins.png?branch=master)](https://travis-ci.org/supki/libjenkins)

@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | Concurrency benchmark -- -- The benchmark does the folllowing:@@ -16,9 +15,9 @@ module Main (main) where  import           Control.Lens                  -- lens-import           Control.Lens.Aeson            -- lens-aeson-import qualified Data.ByteString.Char8 as B    -- bytestring+import           Data.Aeson.Lens               -- lens-aeson import           Data.Text (Text)              -- text+import qualified Data.Text as Text             -- text import           Jenkins.Rest                  -- libjenkins import           System.Environment (getArgs)  -- base import           System.Exit (exitFailure)     -- base@@ -31,9 +30,9 @@ main = do   m:host:port:user:pass:_ <- getArgs   ds <- descriptions (aggregate m) $-    ConnectInfo host (read port) (B.pack user) (B.pack pass)+    ConnectInfo host (read port) (Text.pack user) (Text.pack pass)   case ds of-    Result ds  -> mapM_ print ds+    Result ds' -> mapM_ print ds'     Disconnect -> die "disconnect!"     Error e    -> die (show e)  where@@ -42,14 +41,14 @@     exitFailure    aggregate :: String -> Aggregate a b-  aggregate "concurrent" = (concurrentlys .) . map+  aggregate "concurrent" = traverseC   aggregate "sequential" = mapM   aggregate _ = error "Unknown mode"  descriptions   :: Aggregate Text (Maybe Text)   -> ConnectInfo-  -> IO (Result HttpException [Maybe Text])+  -> IO (Result JenkinsException [Maybe Text]) descriptions aggregate settings = runJenkins settings $ do   res <- get (json -?- "tree" -=- "jobs[name]")   aggregate describe (res ^.. key "jobs".values.key "name"._String)

@@ -6,7 +6,7 @@ import           Control.Lens                              -- lens import           Control.Exception.Lens                    -- lens import           Control.Monad                             -- base-import           Data.Aeson.Lens (key, values, _String)    -- lens+import           Data.Aeson.Lens (key, values, _String)    -- lens-aeson import           Data.String (fromString)                  -- base import           Data.Text (Text)                          -- text import qualified Data.Text as Text                         -- text

@@ -5,7 +5,7 @@  import           Control.Lens                  -- lens import           Control.Monad (when)          -- base-import           Data.Aeson.Lens               -- lens+import           Data.Aeson.Lens               -- lens-aeson import           Data.Foldable (for_)          -- base import           Data.Function (fix)           -- base import           Data.String (fromString)      -- base@@ -46,7 +46,7 @@     exitFailure  -- | Prompt to rename all jobs matching pattern-rename :: Options -> IO (Result HttpException ())+rename :: Options -> IO (Result JenkinsException ()) rename (Options { settings, old, new }) = runJenkins settings $ do   -- get jobs names from jenkins "root" API   res <- get (json -?- "tree" -=- "jobs[name]")@@ -63,7 +63,7 @@       post_ (job name -/- "doRename" -?- "newName" -=- name')    -- asks user until she enters 'y' or 'n'-  prompt message = io . fix $ \loop -> do+  prompt message = liftIO . fix $ \loop -> do     Text.putStrLn message     res <- Text.getLine     case Text.toUpper res of

@@ -8,7 +8,7 @@ module Main (main) where  import Control.Lens                      -- lens-import Data.Aeson.Lens                   -- lens+import Data.Aeson.Lens                   -- lens-aeson import Data.ByteString.Lazy (ByteString) -- bytestring import Data.String (fromString)          -- bytestring import Jenkins.Rest                      -- libjenkins

@@ -1,5 +1,5 @@ name:                libjenkins-version:             0.4.3.0+version:             0.5.0 synopsis:            Jenkins API interface description:         Jenkins API interface. It supports REST and Discovery APIs license:             BSD3@@ -26,7 +26,7 @@ source-repository this   type:     git   location: https://github.com/supki/libjenkins-  tag:      0.4.3.0+  tag:      0.5.0  library   default-language:  Haskell2010@@ -43,12 +43,14 @@     , bytestring    >= 0.9     , conduit       >= 1.0     , free          >= 4.1+    , exceptions    >= 0.6.1     , http-client   >= 0.2.0.2     , http-conduit  >= 2.0 && < 2.2     , http-types    >= 0.8     , lens          >= 4.0.1     , monad-control >= 0.3-    , network       >= 2.4+    , network       >= 2.6+    , network-uri   >= 2.6     , resourcet     >= 1.1     , text          >= 0.11     , transformers  >= 0.3@@ -74,6 +76,7 @@     , bytestring     , conduit     , free+    , exceptions     , hspec     , hspec-expectations-lens     , http-client@@ -82,6 +85,7 @@     , lens     , monad-control     , network+    , network-uri     , resourcet     , text     , transformers

@@ -10,21 +10,21 @@   , defaultConnectInfo   , Result(..)   , runJenkins-  , runJenkinsThrowing     -- ** Combinators   , get+  , getS   , post   , post_   , concurrently-  , io-  , disconnect+  , orElse+  , liftIO   , with     -- ** Method   , module Jenkins.Rest.Method     -- ** Convenience   , postXML-  , concurrentlys-  , concurrentlys_+  , traverseC+  , traverseC_   , reload   , restart   , forceRestart@@ -37,100 +37,83 @@   , _Error   , _Disconnect   , _Result+  , JenkinsException(..)     -- * Reexports   , Request   , HttpException   ) where -import Control.Applicative ((<$))-import Data.Foldable (Foldable, foldr)-import Control.Lens-import Control.Monad.IO.Class (MonadIO(..))-import Data.ByteString.Lazy (ByteString)-import Data.Monoid (mempty)-import Network.HTTP.Conduit (Request, HttpException)-import Prelude hiding (foldr)-import Text.XML (Document, renderLBS, def)+import           Control.Applicative ((<$))+import           Control.Lens+import           Control.Monad.Trans.Resource (ResourceT, runResourceT)+import           Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy+import           Data.Conduit (ResumableSource, ($$+-))+import qualified Data.Conduit.List as CL+import           Data.Monoid (mempty)+import           Network.HTTP.Conduit (Request, HttpException)+import           Text.XML (Document, renderLBS, def) -import Jenkins.Rest.Internal-import Jenkins.Rest.Method-import Network.HTTP.Conduit.Lens+import           Jenkins.Rest.Internal+import           Jenkins.Rest.Method+import           Network.HTTP.Conduit.Lens -{-# ANN module ("HLint: ignore Use const" :: String) #-} +-- | @GET@ query+--+-- While the return type is a lazy bytestring, the entire response+-- sits in memory anyway: lazy I/O is not used+get :: Method Complete f -> Jenkins Lazy.ByteString+get m = fmap Lazy.fromChunks . liftIO . runResourceT =<< liftJ (Get m ($$+- CL.consume))  -- | @GET@ query-get :: Method Complete f -> Jenkins ByteString-get m = liftJ $ Get m id-{-# INLINE get #-}+--+-- If you don't close the source eventually (either explicitly with+-- 'Data.Conduit.closeResumableSource' or implicitly by reading from it)+-- it will leak a socket.+getS :: Method Complete f -> Jenkins (ResumableSource (ResourceT IO) Strict.ByteString)+getS m = liftJ (Get m id)  -- | @POST@ query (with a payload)-post :: (forall f. Method Complete f) -> ByteString -> Jenkins ()-post m body = liftJ $ Post m body (\_ -> ())-{-# INLINE post #-}+post :: (forall f. Method Complete f) -> Lazy.ByteString -> Jenkins ()+post m body = liftJ (Post m body ())  -- | @POST@ query (without payload) post_ :: (forall f. Method Complete f) -> Jenkins () post_ m = post m mempty-{-# INLINE post_ #-}  -- | Do both queries 'concurrently' concurrently :: Jenkins a -> Jenkins b -> Jenkins (a, b)-concurrently ja jb = liftJ $ Conc ja jb (,)-{-# INLINE concurrently #-}---- | Lift an arbitrary 'IO' action to the 'Jenkins' monad------ @--- io :: 'IO' a -> 'Jenkins' a--- @-io :: MonadIO m => IO a -> m a-io = liftIO-{-# INLINE io #-}+concurrently ja jb = liftJ (Conc ja jb (,)) --- | Disconnect from Jenkins------ Any following queries won't be executed-disconnect :: Jenkins a-disconnect = liftJ Dcon-{-# INLINE disconnect #-}+-- | @orElse a b@ runs @a@ and only runs @b@ if @a@ has thrown a @JenkinsException@+orElse :: Jenkins a -> Jenkins a -> Jenkins a+orElse ja jb = liftJ (Or ja jb)  -- | Make local changes to the 'Request' with :: (Request -> Request) -> Jenkins a -> Jenkins a with f j = liftJ $ With f j id-{-# INLINE with #-} - -- | @POST@ job's @config.xml@ (or any other xml, really) in @xml-conduit@ format postXML :: (forall f. Method Complete f) -> Document -> Jenkins ()-postXML m =-  with (requestHeaders <>~ [("Content-Type", "text/xml")]) . post m . renderLBS def-{-# INLINE postXML #-}+postXML m = with (requestHeaders <>~ [("Content-Type", "text/xml")]) . post m . renderLBS def --- | Send a list of queries 'concurrently'-concurrentlys :: Foldable f => f (Jenkins a) -> Jenkins [a]-concurrentlys = foldr go (return [])+-- | Make a bunch of queries 'concurrently'+traverseC :: (a -> Jenkins b) -> [a] -> Jenkins [b]+traverseC f = foldr go (return [])  where-  go x xs = do-    (y, ys) <- concurrently x xs-    return (y : ys)-{-# INLINE concurrentlys #-}+  go x xs = do (y, ys) <- concurrently (f x) xs; return (y : ys) --- | Send a list of queries 'concurrently' ignoring their results------ /Note/: exceptions are still raised-concurrentlys_ :: Foldable f => f (Jenkins a) -> Jenkins ()-concurrentlys_ = foldr (\x xs -> () <$ concurrently x xs) (return ())-{-# INLINE concurrentlys_ #-}+-- | Make a bunch of queries 'concurrently' ignoring their results+traverseC_ :: (a -> Jenkins b) -> [a] -> Jenkins ()+traverseC_ f = foldr (\x xs -> () <$ concurrently (f x) xs) (return ())  -- | Reload jenkins configuration from disk -- -- Calls @/reload@ and disconnects reload :: Jenkins a-reload = do-  post_ "reload"-  disconnect-{-# INLINE reload #-}+reload = do post_ "reload"; disconnect  -- | Restart jenkins safely --@@ -138,16 +121,15 @@ -- -- @/safeRestart@ allows all running jobs to complete restart :: Jenkins a-restart = do-  post_ "safeRestart"-  disconnect-{-# INLINE restart #-}+restart = do post_ "safeRestart"; disconnect  -- | Force jenkins to restart without waiting for running jobs to finish -- -- Calls @/restart@ and disconnects forceRestart :: Jenkins a-forceRestart = do-  post_ "restart"-  disconnect-{-# INLINE forceRestart #-}+forceRestart = do post_ "restart"; disconnect++-- Disconnect from Jenkins. Any following queries won't be executed+disconnect :: Jenkins a+disconnect = liftJ Dcon+{-# INLINE disconnect #-}

@@ -12,9 +12,9 @@  import           Control.Applicative import           Control.Concurrent.Async (concurrently)-import           Control.Exception (Exception, try, toException) import           Control.Lens import           Control.Monad+import           Control.Monad.Catch (MonadCatch, Exception(..), try, catch, throwM) import           Control.Monad.Free.Church (F, iterM, liftF) import           Control.Monad.IO.Class (MonadIO(..)) import           Control.Monad.Trans.Class (lift)@@ -23,6 +23,9 @@ import           Control.Monad.Trans.Resource (ResourceT) import           Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT) import           Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString as Strict+import           Data.Conduit (ResumableSource)+import qualified Data.Conduit as C import           Data.Data (Data, Typeable) import           Data.Text (Text) import qualified Data.Text.Encoding as Text@@ -33,37 +36,39 @@ import           Jenkins.Rest.Method (Method, Type(..), render, slash) import qualified Network.HTTP.Conduit.Lens as Lens +{-# ANN module ("HLint: ignore Use const" :: String) #-}+{-# ANN module ("HLint: ignore Use join" :: String) #-} + -- | Jenkins REST API query sequence description newtype Jenkins a = Jenkins { unJenkins :: F JenkinsF a }   deriving (Functor, Applicative, Monad)  instance MonadIO Jenkins where   liftIO = liftJ . IO-  {-# INLINE liftIO #-}  -- | Jenkins REST API query data JenkinsF a where-  Get  :: Method Complete f -> (ByteString -> a) -> JenkinsF a-  Post :: (forall f. Method Complete f) -> ByteString -> (ByteString -> a) -> JenkinsF a+  Get  :: Method Complete f -> (ResumableSource (ResourceT IO) Strict.ByteString -> a) -> JenkinsF a+  Post :: (forall f. Method Complete f) -> ByteString -> a -> JenkinsF a   Conc :: Jenkins a -> Jenkins b -> (a -> b -> c) -> JenkinsF c+  Or   :: Jenkins a -> Jenkins a -> JenkinsF a   IO   :: IO a -> JenkinsF a   With :: (Request -> Request) -> Jenkins b -> (b -> a) -> JenkinsF a   Dcon :: JenkinsF a  instance Functor JenkinsF where   fmap f (Get  m g)      = Get  m      (f . g)-  fmap f (Post m body g) = Post m body (f . g)+  fmap f (Post m body a) = Post m body (f a)   fmap f (Conc m n g)    = Conc m n    (\a b -> f (g a b))+  fmap f (Or a b)        = Or (fmap f a) (fmap f b)   fmap f (IO a)          = IO (fmap f a)   fmap f (With h j g)    = With h j    (f . g)   fmap _ Dcon            = Dcon-  {-# INLINE fmap #-}  -- | Lift 'JenkinsF' to 'Jenkins' liftJ :: JenkinsF a -> Jenkins a liftJ = Jenkins . liftF-{-# INLINE liftJ #-}  -- | Jenkins connection settings --@@ -78,43 +83,34 @@  -- | The result of Jenkins REST API queries data Result e v =-    Error e    -- ^ Exception @e@ was thrown while querying+    Error e    -- ^ Exception @e@ was thrown while querying Jenkins   | Disconnect -- ^ The client was explicitly disconnected   | Result v   -- ^ Querying successfully finished the with value @v@     deriving (Show, Eq, Ord, Typeable, Data, Generic) +newtype JenkinsException+  = JenkinsHttpException HttpException+    deriving (Show, Typeable)++instance Exception JenkinsException+ -- | Query Jenkins API using 'Jenkins' description -- -- Successful result is either 'Disconnect' or @ 'Result' v @ -- -- If 'HttpException' was thrown by @http-conduit@, 'runJenkins' catches it -- and wraps in 'Error'. Other exceptions are /not/ catched-runJenkins :: HasConnectInfo t => t -> Jenkins a -> IO (Result HttpException a)+runJenkins :: HasConnectInfo t => t -> Jenkins a -> IO (Result JenkinsException a) runJenkins conn jenk = either Error (maybe Disconnect Result) <$> try (runJenkinsInternal conn jenk) --- | Query Jenkins API using 'Jenkins' description------ Successful result is either 'Disconnect' or @ 'Result' v @------ No exceptions are catched, i.e.------ @--- runJenkinsThrowing :: 'ConnectInfo' -> 'Jenkins' a -> 'IO' ('Result' 'Void' a)--- @------ is perfectly fine—'Result' won't ever be an 'Error'-runJenkinsThrowing :: HasConnectInfo t => t -> Jenkins a -> IO (Result e a)-runJenkinsThrowing conn jenk = maybe Disconnect Result <$> runJenkinsInternal conn jenk- runJenkinsInternal :: HasConnectInfo t => t -> Jenkins a -> IO (Maybe a)-runJenkinsInternal (view connectInfo -> ConnectInfo h p user token) jenk =-  withManager $ \manager -> do-    req <- liftIO $ parseUrl h-    let req' = req-          & Lens.port            .~ p-          & Lens.responseTimeout .~ Just (20 * 1000000)-          & applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token)-    runReaderT (runMaybeT (iterJenkinsIO manager jenk)) req'+runJenkinsInternal (view connectInfo -> ConnectInfo h p user token) jenk = do+  url <- parseUrl h+  withManager $ \m ->+    runReaderT (runMaybeT (iterJenkinsIO m jenk))+      . set Lens.port p+      . applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token)+      $ url   -- | A prism into Jenkins error@@ -146,54 +142,75 @@   -> Jenkins a   -> MaybeT (ReaderT Request (ResourceT IO)) a iterJenkinsIO manager = iterJenkins (interpreter manager)-{-# INLINE iterJenkinsIO #-}  -- | Tear down 'JenkinsF' AST with a 'JenkinsF'-algebra iterJenkins :: Monad m => (JenkinsF (m a) -> m a) -> Jenkins a -> m a iterJenkins go = iterM go . unJenkins-{-# INLINE iterJenkins #-}  -- | 'JenkinsF' AST interpreter interpreter   :: Manager   -> JenkinsF (MaybeT (ReaderT Request (ResourceT IO)) a)   -> MaybeT (ReaderT Request (ResourceT IO)) a-interpreter manager = go where+interpreter man = go where   go (Get m next) = do     req <- lift ask-    let req' = req-          & Lens.path   %~ (`slash` render m)-          & Lens.method .~ "GET"-    bs <- lift . lift $ httpLbs req' manager-    next (responseBody bs)+    res <- lift . lift $ http (prepareGet m req) man `withException` JenkinsHttpException+    next (responseBody res)   go (Post m body next) = do     req <- lift ask-    let req' = req-          & Lens.path          %~ (`slash` render m)-          & Lens.method        .~ "POST"-          & Lens.requestBody   .~ RequestBodyLBS body-          & Lens.redirectCount .~ 0-          & Lens.checkStatus   .~ \s@(Status st _) hs cookie_jar ->-            if 200 <= st && st < 400-                then Nothing-                else Just . toException $ StatusCodeException s hs cookie_jar-    res <- lift . lift $ httpLbs req' manager-    next (responseBody res)-  go (Conc jenka jenkb next) = do-    (a, b) <- liftWith $ \run' -> liftWith $ \run'' -> liftWith $ \run''' ->-      let-        run :: Jenkins t -> IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT t)))-        run = run''' . run'' . run' . iterJenkinsIO manager-      in-        concurrently (run jenka) (run jenkb)-    c <- restoreT . restoreT . restoreT $ return a-    d <- restoreT . restoreT . restoreT $ return b+    res <- lift . lift $ http (preparePost m body req) man `withException` JenkinsHttpException+    ()  <- lift . lift $ C.closeResumableSource (responseBody res)+    next+  go (Conc ja jb next) = do+    (a, b) <- intoIO man $ \run -> concurrently (run ja) (run jb)+    c      <- outoIO (return a)+    d      <- outoIO (return b)     next c d+  go (Or ja jb) = do+    res  <- intoIO man $ \run -> run ja `catch` \(JenkinsHttpException _) -> run jb+    next <- outoIO (return res)+    next   go (IO action) = join (liftIO action)   go (With f jenk next) = do-    res <- mapMaybeT (local f) (iterJenkinsIO manager jenk)+    res <- mapMaybeT (local f) (iterJenkinsIO man jenk)     next res   go Dcon = mzero++intoIO+  :: Monad m+  => Manager+  -> ((forall b. Jenkins b -> IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT b)))) -> m a)+  -> MaybeT (ReaderT Request (ResourceT m)) a+intoIO m f =+  liftWith $ \run' -> liftWith $ \run'' -> liftWith $ \run''' ->+    let+      run :: Jenkins t -> IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT t)))+      run = run''' . run'' . run' . iterJenkinsIO m+    in+      f run++outoIO+  :: IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT b)))+  -> MaybeT (ReaderT Request (ResourceT IO)) b+outoIO = restoreT . restoreT . restoreT++prepareGet :: Method Complete f -> Request -> Request+prepareGet m = set Lens.method "GET" . over Lens.path (`slash` render m)++preparePost :: Method Complete f -> ByteString -> Request -> Request+preparePost m body =+    set Lens.checkStatus statusCheck+  . set Lens.redirectCount 0+  . set Lens.requestBody (RequestBodyLBS body)+  . set Lens.method "POST"+  . over Lens.path (`slash` render m)+ where+  statusCheck s@(Status st _) hs cookie_jar =+    if 200 <= st && st < 400 then Nothing else Just . toException $ StatusCodeException s hs cookie_jar++withException :: (MonadCatch m, Exception e, Exception e') => m a -> (e -> e') -> m a+withException io f = io `catch` \e -> throwM (f e)   -- | Default Jenkins connection settings

@@ -69,6 +69,7 @@ -- | Only to support number literals instance t ~ Complete => Num (Method t f) where   (+)         = error "Method.(+): not supposed to be used"+  (-)         = error "Method.(-): not supposed to be used"   (*)         = error "Method.(*): not supposed to be used"   abs         = error "Method.abs: not supposed to be used"   signum      = error "Method.signum: not supposed to be used"

@@ -1,15 +1,21 @@+{-# LANGUAGE OverloadedStrings #-} module Jenkins.Rest.InternalSpec (spec) where +import Control.Lens import Control.Exception (throwIO) import Control.Exception.Lens (throwingM, _IOException) import Control.Monad.IO.Class (liftIO)+import Network.HTTP.Conduit (HttpException)+import Network.HTTP.Types (Status(..)) import Test.Hspec.Lens import System.IO.Error import System.IO.Error.Lens (errorType, _NoSuchThing)  import Jenkins.Rest.Internal-import Network.HTTP.Conduit.Lens (_TooManyRetries)+import Network.HTTP.Conduit.Lens (_StatusCodeException, _TooManyRetries) +_JenkinsException :: Iso' JenkinsException HttpException+_JenkinsException = iso (\(JenkinsHttpException e) -> e) JenkinsHttpException  spec :: Spec spec = do@@ -18,15 +24,23 @@       raiseIO   = liftIO (throwIO (mkIOError doesNotExistErrorType "foo" Nothing Nothing))    describe "runJenkins" $ do-    it "catches 'HttpException' exceptions" $-      runJenkins defaultConnectInfo raiseHttp `shouldPerform` () `through` _Error._TooManyRetries+    it "wraps uncatched 'HttpException' exceptions from the queries in 'Error'" $+      runJenkins (defaultConnectInfo & jenkinsPort .~ 80) (liftJ (Get "hi" id))+     `shouldPerform`+      Status 404 ""+     `through`+      _Error._JenkinsException._StatusCodeException._1 -    it "does not catch 'IOException' exceptions" $-      runJenkins defaultConnectInfo raiseIO `shouldThrow` _IOException.errorType._NoSuchThing+    it "can catch 'HttpException' exceptions related from the queries" $+      runJenkins (defaultConnectInfo & jenkinsPort .~ 80)+        (liftJ (Or (liftJ (Get "hi" id) >> return 4) (return 7)))+     `shouldPerform`+      7+     `through`+      _Result -  describe "runJenkinsThrowing" $ do-    it "does not catch 'HttpException' exceptions" $-      runJenkinsThrowing defaultConnectInfo raiseHttp `shouldThrow` _TooManyRetries+    it "does not catch (and wrap) 'HttpException's not from the queries" $+      runJenkins defaultConnectInfo raiseHttp `shouldThrow` _TooManyRetries -    it "does not catch 'IOException' exceptions" $-      runJenkinsThrowing defaultConnectInfo raiseIO `shouldThrow` _IOException.errorType._NoSuchThing+    it "does not catch (and wrap) 'IOException's" $+      runJenkins defaultConnectInfo raiseIO `shouldThrow` _IOException.errorType._NoSuchThing

@@ -5,6 +5,7 @@ import           Control.Monad.Trans.State (State, evalState, get, put) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy+import qualified Data.Conduit as C import           Data.Monoid (mempty) import           Test.Hspec import qualified Jenkins.Rest as Rest@@ -33,9 +34,9 @@   context "GET requests" $     it "get sends GET requests" $ do       interpret $ do-        Rest.get "foo"-        Rest.get "bar"-        Rest.get "baz"+        Rest.getS "foo"+        Rest.getS "bar"+        Rest.getS "baz"      `shouldBe`       [QGet 0 "foo", QGet 1 "bar", QGet 2 "baz"] @@ -79,10 +80,10 @@   go :: JenkinsF (State (Requests Int) [Query]) -> State (Requests Int) [Query]   go (Get m n) = do     r <- render QGet m-    fmap (r :) (n mempty)+    fmap (r :) (n (C.newResumableSource (C.yield mempty)))   go (Post m body n) = do     r <- render (\x y -> QPost x body y) m-    fmap (r :) (n mempty)+    fmap (r :) n   go Dcon =     return [QDisconnect]