libjenkins 0.7.0 → 0.8.0
raw patch · 10 files changed
+235/−306 lines, 10 filesdep +conduitdep +http-conduitdep +resourcetdep −http-client-tlsdep ~asyncdep ~freedep ~http-client
Dependencies added: conduit, http-conduit, resourcet
Dependencies removed: http-client-tls
Dependency ranges changed: async, free, http-client, lifted-async, lifted-base
Files
- CHANGELOG.markdown +12/−0
- LICENSE +1/−1
- example/grep-jobs.hs +12/−7
- example/rename-jobs.hs +20/−28
- example/running-jobs-count.hs +11/−12
- libjenkins.cabal +21/−18
- src/Jenkins/Rest.hs +38/−111
- src/Jenkins/Rest/Internal.hs +104/−81
- test/Jenkins/Rest/InternalSpec.hs +16/−20
- test/Jenkins/RestSpec.hs +0/−28
CHANGELOG.markdown view
@@ -1,3 +1,15 @@+0.8.0+=====++ * Dropped `lifted-base` and `lifted-async` dependencies++ * Simplified the Jenkins master node configuration record++ * Added `stream` to provide convenient streaming++ * Removed the support for disconnects, thus simplifying the public API slightly.+ Note that `reload`, `restart`, and `forceRestart` do not disconnect automatically anymore.+ 0.7.0 =====
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013-2014, Matvey Aksenov+Copyright (c) 2013-2015, Matvey Aksenov All rights reserved.
example/grep-jobs.hs view
@@ -7,10 +7,10 @@ import Control.Exception.Lens -- lens import Control.Monad -- base 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 import qualified Data.Text.IO as Text -- text+import Env -- envparse import Jenkins.Rest ((-?-), (-=-)) import qualified Jenkins.Rest as Jenkins -- libjenkins import System.Environment (getArgs) -- base@@ -21,21 +21,26 @@ main :: IO () main = do- url:user:token:regex:_ <- getArgs- jobs <- grep regex $ Jenkins.defaultMaster- & Jenkins.url .~ url- & Jenkins.user .~ fromString user- & Jenkins.apiToken .~ fromString token+ regex : _+ <- getArgs+ conf <- envConf+ jobs <- grep regex conf case jobs of [] -> throwingM _ExitFailure 1 _ -> mapM_ Text.putStrLn jobs +envConf :: IO Jenkins.Master+envConf = Env.parse (desc "Grep for jobs") $+ Jenkins.Master <$> var str "JENKINS_URL" (help "Jenkins URL")+ <*> var str "JENKINS_USERNAME" (help "Jenkins username")+ <*> var str "JENKINS_API_TOKEN" (help "Jenkins API token")+ -- | Filter matching job names grep :: String -> Jenkins.Master -> IO [Text] grep regex conn = do res <- Jenkins.run conn $ Jenkins.get Jenkins.json ("/" -?- "tree" -=- "jobs[name]")- filterM (match regex) (res ^.. Jenkins._Ok.key "jobs".values.key "name"._String)+ filterM (match regex) (res ^.. _Right.key "jobs".values.key "name"._String) -- | Match job name again Perl regex match :: String -> Text -> IO Bool
example/rename-jobs.hs view
@@ -13,47 +13,39 @@ import Data.Text (Text) -- text import qualified Data.Text as Text -- text import qualified Data.Text.IO as Text -- text-import Jenkins.Rest (Jenkins, (-?-), (-=-), (-/-), liftIO)+import Env -- envparse+import Jenkins.Rest (Jenkins, JenkinsException, (-?-), (-=-), (-/-), liftIO) import qualified Jenkins.Rest as Jenkins -- libjenkins import System.Environment (getArgs) -- base import System.Exit (exitFailure) -- base-import System.IO (hPutStrLn, stderr) -- base+import qualified System.IO as IO -- base {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} --- | Program options-data Options = Options- { settings :: Jenkins.Master- , old :: Text- , new :: Text- }-- main :: IO () main = do- -- more useful help on error- url:user:token:o:n:_ <- getArgs- let cinf = Jenkins.defaultMaster- & Jenkins.url .~ url- & Jenkins.user .~ fromString user- & Jenkins.apiToken .~ fromString token- opts = Options cinf (fromString o) (fromString n)- res <- rename opts+ o : n : _+ <- getArgs+ conf <- envConf+ res <- rename conf (fromString o) (fromString n) case res of- Jenkins.Ok _ -> Text.putStrLn "Done."- -- disconnected for some reason- Jenkins.Disconnect -> die "disconnect!"+ Right _ -> Text.putStrLn "Done." -- something bad happened, show it!- Jenkins.Exception e -> die (show e)- where- die message = do- hPutStrLn stderr message- exitFailure+ Left e -> die (show e) +die :: String -> IO a+die m = do IO.hPutStrLn IO.stderr m; exitFailure++envConf :: IO Jenkins.Master+envConf = Env.parse (desc "Rename jobs") $+ Jenkins.Master <$> var str "JENKINS_URL" (help "Jenkins URL")+ <*> var str "JENKINS_USERNAME" (help "Jenkins username")+ <*> var str "JENKINS_API_TOKEN" (help "Jenkins API token")+ -- | Prompt to rename all jobs matching pattern-rename :: Options -> IO (Jenkins.Result ())-rename (Options { settings, old, new }) = Jenkins.run settings $ do+rename :: Jenkins.Master -> Text -> Text -> IO (Either JenkinsException ())+rename conf old new = Jenkins.run conf $ do -- get jobs names from jenkins "root" API res <- Jenkins.get Jenkins.json ("/" -?- "tree" -=- "jobs[name]") let jobs = res ^.. key "jobs".values.key "name"._String
example/running-jobs-count.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- | Count running jobs on Jenkins instance ----- Usage: count-running-jobs HOST PORT USER APITOKEN--- -- Uses an awful hack, that is inspecting the job ball color. Jenkins sets -- it to "blue_anime", meaning "animated blue ball" if job is running module Main (main) where@@ -10,22 +8,23 @@ import Control.Lens -- lens import Data.Aeson.Lens -- lens-aeson import Data.ByteString.Lazy (ByteString) -- bytestring-import Data.String (fromString) -- bytestring+import Env -- envparse import Jenkins.Rest (Jenkins, (-?-), (-=-))-import qualified Jenkins.Rest as Jenkins -- libjenkins-import System.Environment (getArgs) -- base+import qualified Jenkins.Rest as Jenkins -- libjenkins import Text.Printf (printf) -- base main :: IO () main = do- url:user:token:_ <- getArgs- let creds = Jenkins.defaultMaster- & Jenkins.url .~ url- & Jenkins.user .~ fromString user- & Jenkins.apiToken .~ fromString token- jobs <- Jenkins.run creds getJobs- printf "Running jobs count: %d\n" (lengthOf (Jenkins._Ok.running) jobs)+ conf <- envConf+ jobs <- Jenkins.run conf getJobs+ printf "Running jobs count: %d\n" (lengthOf (_Right.running) jobs)++envConf :: IO Jenkins.Master+envConf = Env.parse (desc "Get running jobs count") $+ Jenkins.Master <$> var str "JENKINS_URL" (help "Jenkins URL")+ <*> var str "JENKINS_USERNAME" (help "Jenkins username")+ <*> var str "JENKINS_API_TOKEN" (help "Jenkins API token") getJobs :: Jenkins ByteString getJobs = Jenkins.get Jenkins.json ("/" -?- "tree" -=- "jobs[color]")
libjenkins.cabal view
@@ -1,5 +1,5 @@ name: libjenkins-version: 0.7.0+version: 0.8.0 synopsis: Jenkins API interface description: Jenkins API interface. It supports REST and Discovery APIs license: BSD2@@ -26,28 +26,29 @@ source-repository this type: git location: https://github.com/supki/libjenkins- tag: 0.7.0+ tag: 0.8.0 library default-language: Haskell2010 build-depends:- base >= 4.6 && < 5- , attoparsec >= 0.12- , bytestring >= 0.9+ base >= 4.6 && < 5+ , async >= 2.0+ , attoparsec >= 0.12+ , bytestring >= 0.9+ , conduit >= 1.2 , containers- , free >= 4.1- , http-client >= 0.3.8- , http-client-tls >= 0.2.2- , http-types >= 0.8- , lifted-async >= 0.2- , lifted-base >= 0.2.3- , monad-control >= 0.3- , profunctors >= 4.2- , mtl >= 2.1- , network >= 2.6- , network-uri >= 2.6- , text >= 0.11+ , free >= 4.10+ , http-conduit >= 2.1+ , http-client >= 0.4+ , http-types >= 0.8+ , monad-control >= 0.3+ , profunctors >= 4.2+ , mtl >= 2.1+ , network >= 2.6+ , network-uri >= 2.6+ , resourcet >= 1.1+ , text >= 0.11 , transformers hs-source-dirs: src@@ -85,12 +86,13 @@ , attoparsec , base == 4.* , bytestring+ , conduit , containers , free , hspec , hspec-expectations-lens , http-client- , http-client-tls+ , http-conduit , http-types , lens , lifted-async@@ -100,6 +102,7 @@ , network , network-uri , profunctors+ , resourcet , text , transformers , xml-conduit
src/Jenkins/Rest.hs view
@@ -12,18 +12,15 @@ run , JenkinsT , Jenkins- , Result(..)- , HasMaster(..)- , Master- , defaultMaster+ , Master(..) -- ** Combinators , get+ , stream , post , post_ , orElse , orElse_ , locally- , disconnect -- ** Method , module Jenkins.Rest.Method -- ** Concurrency@@ -36,10 +33,6 @@ , reload , restart , forceRestart- -- * Optics- , _Exception- , _Disconnect- , _Ok , JenkinsException(..) -- * Reexports , liftIO@@ -47,129 +40,67 @@ ) where import Control.Applicative ((<$))-import Control.Exception.Lifted (try)-import Control.Monad+import qualified Control.Exception as Unlifted import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Control (MonadBaseControl(..))+import Control.Monad.Trans.Resource (MonadResource) import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict+import Data.Conduit (ResumableSource) import Data.Data (Data, Typeable) import qualified Data.Foldable as F import Data.Monoid (mempty) import Data.Text (Text) import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Encoding as Text.Lazy-import qualified Network.HTTP.Client as Http+import Data.Traversable (sequence)+import qualified Network.HTTP.Conduit as Http import qualified Network.HTTP.Types as Http+import Prelude hiding (sequence) import Jenkins.Rest.Internal import Jenkins.Rest.Method import Jenkins.Rest.Method.Internal-import Network.HTTP.Client.Lens.Internal -- | Run a 'JenkinsT' action ----- A successful 'Result' is either @'Disconnect'@ or @'Ok' v@--- -- If a 'JenkinsException' is thrown by performing a request to Jenkins, -- 'runJenkins' will catch and wrap it in @'Exception'@. Other exceptions--- will propagate further-run- :: (MonadIO m, MonadBaseControl IO m, HasMaster t)- => t -> JenkinsT m a -> m (Result a)-run c jenk =- either Exception (maybe Disconnect Ok)- `liftM`- try (runInternal (c^.url) (c^.user) (c^.apiToken) jenk)+-- will propagate further untouched.+run :: (MonadIO m, MonadBaseControl IO m) => Master -> JenkinsT m a -> m (Either JenkinsException a)+run m jenk = try (runInternal (url m) (user m) (apiToken m) jenk) +try :: MonadBaseControl IO m => m a -> m (Either JenkinsException a)+try m = sequence . fmap restoreM =<< liftBaseWith (\magic -> Unlifted.try (magic m))+{-# INLINABLE try #-}+ -- | A handy type synonym for the kind of 'JenkinsT' actions that's used the most type Jenkins = JenkinsT IO --- | The result of Jenkins REST API queries-data Result v =- Exception JenkinsException- -- ^ Exception was thrown while making requests to Jenkins- | Disconnect- -- ^ The client was explicitly disconnected by the user- | Ok v- -- ^ The result of uninterrupted execution of a 'JenkinsT' value- deriving (Show, Typeable)---- | A prism into Jenkins error-_Exception :: Prism (Result a) (Result a) JenkinsException JenkinsException-_Exception = prism' Exception $ \case- Exception e -> Just e- _ -> Nothing-{-# INLINE _Exception #-}---- | A prism into disconnect-_Disconnect :: Prism' (Result a) ()-_Disconnect = prism' (\_ -> Disconnect) $ \case- Disconnect -> Just ()- _ -> Nothing-{-# INLINE _Disconnect #-}-{-# ANN _Disconnect ("HLint: ignore Use const" :: String) #-}---- | A prism into result-_Ok :: Prism (Result a) (Result b) a b-_Ok = prism Ok $ \case- Exception e -> Left (Exception e)- Disconnect -> Left Disconnect- Ok a -> Right a-{-# INLINE _Ok #-}---- | Jenkins master node connection settings-class HasMaster t where- master :: Lens' t Master-- -- | Jenkins master node URL- url :: HasMaster t => Lens' t String- url = master . \f x -> f (_url x) <&> \p -> x { _url = p }- {-# INLINE url #-}-- -- | Jenkins user- user :: HasMaster t => Lens' t Text- user = master . \f x -> f (_user x) <&> \p -> x { _user = p }- {-# INLINE user #-}-- -- | Jenkins user's password or API token- apiToken :: HasMaster t => Lens' t Text- apiToken = master . \f x -> f (_apiToken x) <&> \p -> x { _apiToken = p }- {-# INLINE apiToken #-}- -- | Jenkins master node connection settings token data Master = Master- { _url :: String -- ^ Jenkins URL- , _user :: Text -- ^ Jenkins user- , _apiToken :: Text -- ^ Jenkins user API token or password+ { url :: String -- ^ Jenkins URL+ , user :: Text -- ^ Jenkins user+ , apiToken :: Text -- ^ Jenkins user API token or password } deriving (Show, Eq, Typeable, Data) -instance HasMaster Master where- master = id- {-# INLINE master #-} --- | Default Jenkins master node connection settings token------ @--- view 'url' defaultConnectInfo = \"http:\/\/example.com\/jenkins\"--- view 'user' defaultConnectInfo = \"jenkins\"--- view 'apiToken' defaultConnectInfo = \"secret\"--- @-defaultMaster :: Master-defaultMaster = Master- { _url = "http://example.com/jenkins"- , _user = "jenkins"- , _apiToken = "secret"- }-- -- | Perform a @GET@ request ----- While the return type is the /lazy/ @Bytestring@, the entire response--- sits in the memory anyway: lazy I/O is not used at the least+-- While the return type is /lazy/ @Bytestring@, the entire response+-- sits in memory anyway: lazy I/O is not used at the least get :: Formatter f -> (forall g. Method Complete g) -> JenkinsT m Lazy.ByteString get (Formatter f) m = liftJ (Get (f m) id) +-- | Perform a streaming @GET@ request+--+-- 'stream', unlike 'get', is constant-space+stream+ :: MonadResource m+ => Formatter f -> (forall g. Method Complete g) -> JenkinsT m (ResumableSource m Strict.ByteString)+stream (Formatter f) m = liftJ (Stream (f m) id)+ -- | Perform a @POST@ request post :: (forall f. Method Complete f) -> Lazy.ByteString -> JenkinsT m Lazy.ByteString post m body = liftJ (Post m body id)@@ -199,11 +130,7 @@ locally :: (Http.Request -> Http.Request) -> JenkinsT m a -> JenkinsT m a locally f j = liftJ (With f j id) --- | Disconnect from Jenkins. The following actions are ignored.-disconnect :: JenkinsT m a-disconnect = liftJ Dcon - -- | Run two actions concurrently concurrently :: JenkinsT m a -> JenkinsT m b -> JenkinsT m (a, b) concurrently ja jb = liftJ (Conc ja jb (,))@@ -245,23 +172,23 @@ -- | Reload jenkins configuration from disk ----- Performs @/reload@ and disconnects-reload :: JenkinsT m a-reload = do post_ "reload"; disconnect+-- Performs @/reload@+reload :: JenkinsT m ()+reload = () <$ post_ "reload" -- | Restart jenkins safely ----- Performs @/safeRestart@ and /disconnects/+-- Performs @/safeRestart@ -- -- @/safeRestart@ allows all running jobs to complete-restart :: JenkinsT m a-restart = do post_ "safeRestart"; disconnect+restart :: JenkinsT m ()+restart = () <$ post_ "safeRestart" -- | Restart jenkins ----- Performs @/restart@ and /disconnects/+-- Performs @/restart@ -- -- @/restart@ restart Jenkins immediately, without waiting for the completion of -- the building and/or waiting jobs-forceRestart :: JenkinsT m a-forceRestart = do post_ "restart"; disconnect+forceRestart :: JenkinsT m ()+forceRestart = () <$ post_ "restart"
src/Jenkins/Rest/Internal.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}@@ -12,35 +12,39 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK hide #-} -- | Jenkins REST API interface internals-module Jenkins.Rest.Internal where+module Jenkins.Rest.Internal+ ( JenkinsT(..)+ , liftJ+ , runInternal+ , JF(..)+ , JenkinsException(..)+ , iter+ ) where import Control.Applicative-#if ! MIN_VERSION_free(5,0,0)-import Control.Applicative.Backwards (Backwards(..))-#endif-import Control.Concurrent.Async.Lifted (concurrently)-import Control.Exception (Exception(..))-import Control.Exception.Lifted (bracket, catch, throwIO)+import Control.Concurrent.Async (Async)+import qualified Control.Concurrent.Async as Unlifted+import Control.Exception (Exception(..), SomeException, throwIO)+import qualified Control.Exception as Unlifted import Control.Monad import Control.Monad.Free.Church (liftF) import Control.Monad.Error (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader (MonadReader(..)) import Control.Monad.State (MonadState(..))-import Control.Monad.Trans.Free.Church (FT, iterTM) import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Control (MonadTransControl(..), MonadBaseControl(..))-import Control.Monad.Trans.Reader (ReaderT)-import qualified Control.Monad.Trans.Reader as Reader-import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT)+import Control.Monad.Trans.Control (MonadBaseControl(..), control, liftBaseOp_)+import Control.Monad.Trans.Free.Church (FT, iterTM)+import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Writer (MonadWriter(..)) import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString as Strict+import Data.Conduit (ResumableSource) import Data.Text (Text) import qualified Data.Text.Encoding as Text import Data.Typeable (Typeable)-import Network.HTTP.Client (Request, HttpException)-import qualified Network.HTTP.Client as Http-import qualified Network.HTTP.Client.TLS as Http+import Network.HTTP.Conduit (Request, HttpException)+import qualified Network.HTTP.Conduit as Http import Network.HTTP.Types (Status(..)) import Jenkins.Rest.Method.Internal (Method, Type(..), render, slash)@@ -60,11 +64,7 @@ instance Applicative (JenkinsT m) where pure = JenkinsT . pure-#if MIN_VERSION_free(5,0,0) JenkinsT f <*> JenkinsT x = JenkinsT (f <*> x)-#else- JenkinsT f <*> JenkinsT x = JenkinsT (forwards (Backwards f <*> Backwards x))-#endif instance Monad (JenkinsT m) where return = JenkinsT . return@@ -90,21 +90,21 @@ m `catchError` f = JenkinsT (unJenkinsT m `catchError` (unJenkinsT . f)) -data JF m a where- Get :: Method Complete f -> (ByteString -> a) -> JF n a- Post :: (forall f. Method Complete f) -> ByteString -> (ByteString -> a) -> JF m a- Conc :: JenkinsT m a -> JenkinsT m b -> (a -> b -> c) -> JF m c- Or :: JenkinsT m a -> (JenkinsException -> JenkinsT m a) -> JF m a- With :: (Request -> Request) -> JenkinsT m b -> (b -> a) -> JF m a- Dcon :: JF m a+data JF :: (* -> *) -> * -> * where+ Get :: Method Complete f -> (ByteString -> a) -> JF m a+ Stream :: MonadResource m => Method Complete f -> (ResumableSource m Strict.ByteString -> a) -> JF m a+ Post :: (forall f. Method Complete f) -> ByteString -> (ByteString -> a) -> JF m a+ Conc :: JenkinsT m a -> JenkinsT m b -> (a -> b -> c) -> JF m c+ Or :: JenkinsT m a -> (JenkinsException -> JenkinsT m a) -> JF m a+ With :: (Request -> Request) -> JenkinsT m b -> (b -> a) -> JF m a instance Functor (JF m) where- fmap f (Get m g) = Get m (f . g)+ fmap f (Get m g) = Get m (f . g)+ fmap f (Stream m g) = Stream m (f . g) fmap f (Post m body g) = Post m body (f . g)- fmap f (Conc m n g) = Conc m n (\a b -> f (g a b))+ 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 (With h j g) = With h j (f . g)- fmap _ Dcon = Dcon+ fmap f (With h j g) = With h j (f . g) -- | Lift 'JF' to 'JenkinsT' liftJ :: JF m a -> JenkinsT m a@@ -122,11 +122,11 @@ runInternal :: (MonadIO m, MonadBaseControl IO m)- => String -> Text -> Text -> JenkinsT m a -> m (Maybe a)+ => String -> Text -> Text -> JenkinsT m a -> m a runInternal h user token jenk = do- url <- wrapException (liftIO (Http.parseUrl h))- bracket (newManager Http.tlsManagerSettings) closeManager $ \m ->- Reader.runReaderT (runMaybeT (runInterpT (iterInterpT m jenk)))+ url <- liftIO (wrapException (Http.parseUrl h))+ bracket (newManager Http.conduitManagerSettings) closeManager $ \m ->+ runInterpT (iterInterpT m jenk) . Http.applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token) $ url @@ -137,7 +137,7 @@ closeManager = liftIO . Http.closeManager newtype InterpT m a = InterpT- { runInterpT :: MaybeT (ReaderT Request m) a+ { runInterpT :: Request -> m a } deriving (Functor) instance (Functor m, Monad m) => Applicative (InterpT m) where@@ -145,19 +145,11 @@ (<*>) = ap instance Monad m => Monad (InterpT m) where- return = InterpT . return- InterpT m >>= k = InterpT (m >>= runInterpT . k)--instance (Functor m, Monad m) => Alternative (InterpT m) where- empty = mzero- (<|>) = mplus--instance Monad m => MonadPlus (InterpT m) where- mzero = InterpT mzero- InterpT x `mplus` InterpT y = InterpT (x `mplus` y)+ return = InterpT . return . return+ InterpT m >>= k = InterpT (\req -> m req >>= \a -> runInterpT (k a) req) instance MonadTrans InterpT where- lift = InterpT . lift . lift+ lift = InterpT . const -- | Interpret the 'JF' AST in 'InterpT' iterInterpT :: (MonadIO m, MonadBaseControl IO m) => Http.Manager -> JenkinsT m a -> InterpT m a@@ -176,47 +168,39 @@ -> JF m (InterpT m a) -> InterpT m a interpreter man = go where go :: JF m (InterpT m a) -> InterpT m a- go (Get m next) = InterpT $ do- res <- request man (prepareGet m)- runInterpT (next res)- go (Post m body next) = InterpT $ do- res <- request man (preparePost m body)- runInterpT (next res)+ go (Get m next) = InterpT $ \req -> do+ res <- oneshotReq (prepareGet m req) man+ runInterpT (next res) req+ go (Stream m next) = InterpT $ \req -> do+ res <- streamReq (prepareGet m req) man+ runInterpT (next res) req+ go (Post m body next) = InterpT $ \req -> do+ res <- oneshotReq (preparePost m body req) man+ runInterpT (next res) req go (Conc ja jb next) = do (a, b) <- intoM man $ \run -> concurrently (run ja) (run jb)- c <- outoM (return a)- d <- outoM (return b)- next c d+ next a b go (Or ja jb) = do- res <- intoM man $ \run -> run ja `catch` (run . jb)- next <- outoM (return res)- next- go (With f jenk next) = InterpT $ do- res <- mapMaybeT (Reader.local f) (runInterpT (iterInterpT man jenk))- runInterpT (next res)- go Dcon = mzero+ res <- intoM man $ \run -> run ja `catch` (run . jb)+ res+ go (With f jenk next) = InterpT $ \req -> do+ res <- runInterpT (iterInterpT man jenk) (f req)+ runInterpT (next res) req -request :: (MonadIO m, MonadReader e m) => Http.Manager -> (e -> Request) -> m ByteString-request man f = do- req <- ask- res <- liftIO $ wrapException (liftM Http.responseBody (Http.httpLbs (f req) man))- return res+oneshotReq :: MonadIO m => Request -> Http.Manager -> m ByteString+oneshotReq req = liftIO . wrapException . liftM Http.responseBody . Http.httpLbs req +streamReq+ :: (MonadBaseControl IO m, MonadResource m)+ => Request -> Http.Manager -> m (ResumableSource m Strict.ByteString)+streamReq req = wrapException . liftM Http.responseBody . Http.http req+ intoM :: forall m a. (MonadIO m, MonadBaseControl IO m) => Http.Manager- -> ((forall b. JenkinsT m b -> m (StT (ReaderT Request) (StT MaybeT b))) -> m a)+ -> ((forall b. JenkinsT m b -> m b) -> m a) -> InterpT m a-intoM m f = InterpT $- liftWith $ \run' -> liftWith $ \run''' ->- let- run :: JenkinsT m t -> m (StT (ReaderT Request) (StT MaybeT t))- run = run''' . run' . runInterpT . iterInterpT m- in- f run--outoM :: Monad m => m (StT (ReaderT Request) (StT MaybeT b)) -> InterpT m b-outoM = InterpT . restoreT . restoreT+intoM m f = InterpT $ \req -> f (\x -> runInterpT (iterInterpT m x) req) prepareGet :: Method Complete f -> Request -> Request prepareGet m r = r@@ -236,5 +220,44 @@ statusCheck s@(Status st _) hs cookie_jar = if 200 <= st && st < 400 then Nothing else Just . toException $ Http.StatusCodeException s hs cookie_jar -wrapException :: MonadBaseControl IO m => m a -> m a-wrapException m = m `catch` (throwIO . JenkinsHttpException)+wrapException :: (MonadBaseControl IO m, MonadIO m) => m a -> m a+wrapException m = m `catch` (liftIO . throwIO . JenkinsHttpException)++concurrently :: (MonadBaseControl IO m, MonadIO m) => m a -> m b -> m (a, b)+concurrently ma mb =+ withAsync ma $ \a ->+ withAsync mb $ \b ->+ waitBoth a b+{-# INLINABLE concurrently #-}++withAsync :: (MonadBaseControl IO m, MonadIO m) => m a -> (Async (StM m a) -> m b) -> m b+withAsync action inner = mask $ \restore -> do+ a <- liftBaseWith (\magic -> Unlifted.async (magic (restore action)))+ r <- restore (inner a) `catch` \e ->+ liftIO (do Unlifted.cancel a; throwIO (e :: SomeException))+ liftIO (Unlifted.cancel a)+ return r+{-# INLINABLE withAsync #-}++waitBoth :: (MonadBaseControl IO m, MonadIO m) => Async (StM m a) -> Async (StM m b) -> m (a, b)+waitBoth aa ab = do+ (ma, mb) <- liftIO (Unlifted.waitBoth aa ab)+ a <- restoreM ma+ b <- restoreM mb+ return (a, b)+{-# INLINABLE waitBoth #-}++mask :: MonadBaseControl IO m => ((forall a. m a -> m a) -> m b) -> m b+mask f = control $ \magic -> Unlifted.mask (\g -> magic (f (liftBaseOp_ g)))+{-# INLINABLE mask #-}++bracket :: (MonadBaseControl IO m) => m a -> (a -> m b) -> (a -> m c) -> m c+bracket f g h = control $ \magic ->+ Unlifted.bracket (magic f)+ (\b -> magic (restoreM b >>= g))+ (\c -> magic (restoreM c >>= h))+{-# INLINABLE bracket #-}++catch :: (MonadBaseControl IO m, Exception e) => m a -> (e -> m a) -> m a+catch m h = control (\magic -> Unlifted.catch (magic m) (magic . h))+{-# INLINABLE catch #-}
test/Jenkins/Rest/InternalSpec.hs view
@@ -23,32 +23,28 @@ let raiseHttp, raiseIO :: Jenkins a raiseHttp = liftIO (throwingM _TooManyRetries ()) raiseIO = liftIO (throwIO (mkIOError doesNotExistErrorType "foo" Nothing Nothing))+ master = Jenkins.Master {+ Jenkins.url = "http://example.com/jenkins"+ , Jenkins.user = "jenkins"+ , Jenkins.apiToken = "secret"+ } describe "runJenkins" $ do- it "wraps uncatched 'HttpException' exceptions from the queries in 'Error'" $- Jenkins.run Jenkins.defaultMaster (Jenkins.get Jenkins.plain "hi")- `shouldPerform`- Status 404 ""- `through`- Jenkins._Exception._JenkinsException._StatusCodeException._1+ it "wraps uncatched 'HttpException' exceptions from the queries in 'Error'" $ do+ r <- Jenkins.run master (Jenkins.get Jenkins.plain "hi")+ r `shouldPreview` Status 404 "" `through` _Left._JenkinsException._StatusCodeException._1 - it "wraps uncatched 'HttpException' exceptions from the URL parsing in 'Error'" $- Jenkins.run (Jenkins.defaultMaster & Jenkins.url .~ "foo") (Jenkins.get Jenkins.plain "hi")- `shouldPerform`- ("foo", "Invalid URL")- `through`- Jenkins._Exception._JenkinsException._InvalidUrlException+ it "wraps uncatched 'HttpException' exceptions from the URL parsing in 'Error'" $ do+ r <- Jenkins.run (master { Jenkins.url = "foo" }) (Jenkins.get Jenkins.plain "hi")+ r `shouldPreview` ("foo", "Invalid URL") `through` _Left._JenkinsException._InvalidUrlException - it "can catch 'HttpException' exceptions related from the queries" $- Jenkins.run Jenkins.defaultMaster+ it "can catch 'HttpException' exceptions related from the queries" $ do+ r <- Jenkins.run master (liftJ (Or (Jenkins.get Jenkins.plain "hi" >> return 4) (\_ -> return 7)))- `shouldPerform`- 7- `through`- Jenkins._Ok+ r `shouldPreview` 7 `through` _Right it "does not catch (and wrap) 'HttpException's not from the queries" $- Jenkins.run Jenkins.defaultMaster raiseHttp `shouldThrow` _TooManyRetries+ Jenkins.run master raiseHttp `shouldThrow` _TooManyRetries it "does not catch (and wrap) 'IOException's" $- Jenkins.run Jenkins.defaultMaster raiseIO `shouldThrow` _IOException.errorType._NoSuchThing+ Jenkins.run master raiseIO `shouldThrow` _IOException.errorType._NoSuchThing
test/Jenkins/RestSpec.hs view
@@ -44,35 +44,9 @@ [QGet 0 "foo", QGet 1 "bar", QGet 2 "baz"] - describe "reload" $- it "calls $jenkins_url/reload with POST query and then disconnects" $ do- interpret $ do- Jenkins.reload- Jenkins.post_ "foo"- `shouldBe`- [QPost 0 "" "reload", QDisconnect]-- describe "restart" $- it "calls $jenkins_url/safeRestart with POST query and then disconnects" $ do- interpret $ do- Jenkins.restart- Jenkins.post_ "bar"- `shouldBe`- [QPost 0 "" "safeRestart", QDisconnect]-- describe "forceRestart" $- it "calls $jenkins_url/restart with POST query and then disconnects" $ do- interpret $ do- Jenkins.forceRestart- Jenkins.post_ "baz"- `shouldBe`- [QPost 0 "" "restart", QDisconnect]-- data Query = QGet Int Strict.ByteString | QPost Int Lazy.ByteString Strict.ByteString- | QDisconnect deriving (Show, Eq) newtype Requests a = Requests [a]@@ -87,8 +61,6 @@ go (Post m body n) = do r <- render (\x y -> QPost x body y) m fmap (r :) (n mempty)- go Dcon =- return [QDisconnect] render :: (a -> Strict.ByteString -> Query) -> Jenkins.Method Method.Complete f -> State (Requests a) Query render f m = do