diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ======= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/bench/Concurrency.hs b/bench/Concurrency.hs --- a/bench/Concurrency.hs +++ b/bench/Concurrency.hs @@ -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) diff --git a/example/grep-jobs.hs b/example/grep-jobs.hs --- a/example/grep-jobs.hs +++ b/example/grep-jobs.hs @@ -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 diff --git a/example/rename-jobs.hs b/example/rename-jobs.hs --- a/example/rename-jobs.hs +++ b/example/rename-jobs.hs @@ -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 diff --git a/example/running-jobs-count.hs b/example/running-jobs-count.hs --- a/example/running-jobs-count.hs +++ b/example/running-jobs-count.hs @@ -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 diff --git a/libjenkins.cabal b/libjenkins.cabal --- a/libjenkins.cabal +++ b/libjenkins.cabal @@ -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 diff --git a/src/Jenkins/Rest.hs b/src/Jenkins/Rest.hs --- a/src/Jenkins/Rest.hs +++ b/src/Jenkins/Rest.hs @@ -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 #-} diff --git a/src/Jenkins/Rest/Internal.hs b/src/Jenkins/Rest/Internal.hs --- a/src/Jenkins/Rest/Internal.hs +++ b/src/Jenkins/Rest/Internal.hs @@ -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 diff --git a/src/Jenkins/Rest/Method.hs b/src/Jenkins/Rest/Method.hs --- a/src/Jenkins/Rest/Method.hs +++ b/src/Jenkins/Rest/Method.hs @@ -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" diff --git a/test/Jenkins/Rest/InternalSpec.hs b/test/Jenkins/Rest/InternalSpec.hs --- a/test/Jenkins/Rest/InternalSpec.hs +++ b/test/Jenkins/Rest/InternalSpec.hs @@ -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 diff --git a/test/Jenkins/RestSpec.hs b/test/Jenkins/RestSpec.hs --- a/test/Jenkins/RestSpec.hs +++ b/test/Jenkins/RestSpec.hs @@ -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]