libjenkins 0.3.0.0 → 0.4.0.0
raw patch · 9 files changed
+125/−152 lines, 9 filesdep −libjenkinsdep −xml-lensdep ~asyncdep ~conduitdep ~free
Dependencies removed: libjenkins, xml-lens
Dependency ranges changed: async, conduit, free, http-client, http-conduit, http-types, lens, monad-control, network, text, xml-conduit
Files
- CHANGELOG.md +7/−0
- example/discover.hs +1/−1
- example/grep-jobs.hs +1/−1
- example/rename-jobs.hs +13/−13
- example/running-jobs-count.hs +1/−1
- libjenkins.cabal +28/−15
- src/Jenkins/Discover.hs +18/−24
- src/Jenkins/Rest/Internal.hs +31/−29
- src/Network/HTTP/Conduit/Lens.hs +25/−68
CHANGELOG.md view
@@ -1,3 +1,10 @@+0.4.0.0+=======++ * Use `Text` for username and API token (password)++ * Support `lens-4.0`+ 0.3.0.0 =======
example/discover.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -- | Discover Jenkins server on the network-module Main where+module Main (main) where import Data.Monoid ((<>), mempty) -- base import Data.Text (Text) -- text
example/grep-jobs.hs view
@@ -5,8 +5,8 @@ import Control.Lens -- lens import Control.Exception.Lens -- lens-import Control.Lens.Aeson (key, values, _String) -- lens-aeson import Control.Monad -- base+import Data.Aeson.Lens (key, values, _String) -- lens import Data.String (fromString) -- base import Data.Text (Text) -- text import qualified Data.Text as Text -- text
example/rename-jobs.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -- | Rename jobs matching supplied pattern-module Main where+module Main (main) where import Control.Lens -- lens-import Control.Lens.Aeson -- lens-aeson import Control.Monad (when) -- base-import qualified Data.ByteString.Char8 as B -- bytestring+import Data.Aeson.Lens -- lens import Data.Foldable (for_) -- base import Data.Function (fix) -- base+import Data.String (fromString) -- base import Data.Text (Text) -- text-import qualified Data.Text as T -- text-import qualified Data.Text.IO as T -- text+import qualified Data.Text as Text -- text+import qualified Data.Text.IO as Text -- text import Jenkins.Rest -- libjenkins import System.Environment (getArgs) -- base import System.Exit (exitFailure) -- base@@ -32,10 +32,10 @@ main = do -- more useful help on error host:port:user:pass:o:n:_ <- getArgs- let opts = Options (ConnectInfo host (read port) (B.pack user) (B.pack pass)) (T.pack o) (T.pack n)+ let opts = Options (ConnectInfo host (read port) (fromString user) (fromString pass)) (fromString o) (fromString n) res <- rename opts case res of- Result _ -> T.putStrLn "Done."+ Result _ -> Text.putStrLn "Done." -- disconnected for some reason Disconnect -> die "disconnect!" -- something bad happened, show it!@@ -54,19 +54,19 @@ for_ jobs rename_job where rename_job :: Text -> Jenkins ()- rename_job name = when (old `T.isInfixOf` name) $ do- let name' = (old `T.replace` new) name+ rename_job name = when (old `Text.isInfixOf` name) $ do+ let name' = (old `Text.replace` new) name -- prompt for every matching job- yes <- prompt $ T.unwords ["Rename", name, "to", name', "? [y/n]"]+ yes <- prompt $ Text.unwords ["Rename", name, "to", name', "? [y/n]"] when yes $ -- if user agrees then voodoo comes post_ (job name -/- "doRename" -?- "newName" -=- name') -- asks user until she enters 'y' or 'n' prompt message = io . fix $ \loop -> do- T.putStrLn message- res <- T.getLine- case T.toUpper res of+ Text.putStrLn message+ res <- Text.getLine+ case Text.toUpper res of "Y" -> return True "N" -> return False _ -> loop
example/running-jobs-count.hs view
@@ -8,7 +8,7 @@ module Main (main) where import Control.Lens -- lens-import Control.Lens.Aeson -- lens-aeson+import Data.Aeson.Lens -- lens import Data.ByteString.Lazy (ByteString) -- bytestring import Data.String (fromString) -- bytestring import Jenkins.Rest -- libjenkins
libjenkins.cabal view
@@ -1,5 +1,5 @@ name: libjenkins-version: 0.3.0.0+version: 0.4.0.0 synopsis: Jenkins API interface description: Jenkins API interface. It supports REST and Discovery APIs license: BSD3@@ -19,6 +19,15 @@ example/running-jobs-count.hs cabal-version: >= 1.10 +source-repository head+ type: git+ location: https://github.com/supki/libjenkins++source-repository this+ type: git+ location: https://github.com/supki/libjenkins+ tag: 0.4.0.0+ library default-language: Haskell2010 hs-source-dirs: src@@ -37,13 +46,12 @@ , http-client >= 0.2.0.2 , http-conduit >= 2.0 && < 2.1 , http-types >= 0.8- , lens >= 3.9+ , lens >= 4.0 , monad-control >= 0.3 , network >= 2.4 , text >= 0.11 , transformers >= 0.3 , xml-conduit >= 1.1- , xml-lens >= 0.1 test-suite doctest default-language: Haskell2010@@ -60,21 +68,26 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 build-depends:- base == 4.*+ async+ , base == 4.* , bytestring+ , conduit+ , free , hspec- , libjenkins+ , http-client+ , http-conduit+ , http-types+ , lens+ , monad-control+ , network+ , text , transformers- hs-source-dirs: test+ , xml-conduit+ hs-source-dirs:+ src+ test main-is: Spec.hs other-modules: Jenkins.RestSpec--source-repository head- type: git- location: https://github.com/supki/libjenkins--source-repository this- type: git- location: https://github.com/supki/libjenkins- tag: 0.3.0.0+ cpp-options:+ -DTEST
src/Jenkins/Discover.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-} -- | Discover Jenkins on the network module Jenkins.Discover- ( Discover(..), discover+ ( Discover(..)+ , discover+#ifdef TEST+ , parse+#endif ) where import Control.Applicative (Applicative(..), (<$>))-import Control.Lens+import Control.Lens hiding (element) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -17,8 +20,8 @@ import Network.Socket import Network.Socket.ByteString as B import System.Timeout (timeout)-import qualified Text.XML as X-import qualified Text.XML.Lens as X+import Text.XML+import Text.XML.Cursor {-# ANN module ("HLint: ignore Use camelCase" :: String) #-} @@ -28,7 +31,7 @@ { version :: Text , url :: Text , server_id :: Maybe Text- } deriving (Show, Read)+ } deriving (Show, Eq) -- | Discover Jenkins on the network@@ -37,7 +40,7 @@ -> IO [Discover] discover t = do (b, addr) <- broadcastSocket- B.sendTo b (B.pack [0, 0, 0, 0]) addr -- does not matter what to send here+ B.sendTo b (B.pack [0, 0, 0, 0]) addr -- does not matter what to send msgs <- while (timeout t (readAnswer b)) @@ -76,20 +79,11 @@ -- </hudson> -- @ parse :: ByteString -> Maybe Discover-parse (X.parseLBS X.def . fromStrict -> bs) = case bs of- Left _ -> Nothing- Right parsed ->- let v = parsed^?deeper.X.el "version".content- u = parsed^?deeper.X.el "url".content- s = parsed^?deeper.X.el "server-id".content- in Discover <$> v <*> u <*> pure s- where- content = X.nodes.traverse.X._Content- deeper = X.root.X.nodes.traverse.X._Element--fromStrict :: ByteString -> BL.ByteString-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 706)-fromStrict = BL.fromStrict-#else-fromStrict = BL.fromChunks . pure-#endif+parse bs = either (const Nothing) Just (parseLBS def (BL.fromStrict bs)) >>= \doc ->+ let+ cursor = fromDocument doc+ tag t = preview _head (cursor $/ element t &// content)+ in Discover+ <$> tag "version"+ <*> tag "url"+ <*> pure (tag "server-id")
src/Jenkins/Rest/Internal.hs view
@@ -20,16 +20,17 @@ import Control.Monad.Trans.Control (MonadTransControl(..)) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, local) import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL+import Data.ByteString.Lazy (ByteString) import Data.Conduit (ResourceT) import Data.Data (Data, Typeable)+import Data.Text (Text)+import qualified Data.Text.Encoding as Text import GHC.Generics (Generic) import Network.HTTP.Conduit import Network.HTTP.Types (Status(..)) import Jenkins.Rest.Method-import qualified Network.HTTP.Conduit.Lens as L+import qualified Network.HTTP.Conduit.Lens as Lens -- | Jenkins REST API query sequence description@@ -42,8 +43,8 @@ -- | Jenkins REST API query data JenkinsF a where- Get :: Method Complete f -> (BL.ByteString -> a) -> JenkinsF a- Post :: (forall f. Method Complete f) -> BL.ByteString -> (BL.ByteString -> a) -> JenkinsF a+ Get :: Method Complete f -> (ByteString -> a) -> JenkinsF a+ Post :: (forall f. Method Complete f) -> ByteString -> (ByteString -> a) -> JenkinsF a Conc :: Jenkins a -> Jenkins b -> (a -> b -> c) -> JenkinsF c IO :: IO a -> JenkinsF a With :: (Request -> Request) -> Jenkins b -> (b -> a) -> JenkinsF a@@ -63,6 +64,17 @@ liftJ = Jenkins . liftF {-# INLINE liftJ #-} +-- | Jenkins connection settings+--+-- '_jenkinsApiToken' may be user's password, Jenkins+-- does not make any distinction between these concepts+data ConnectInfo = ConnectInfo+ { _jenkinsUrl :: String -- ^ Jenkins URL, e.g. @http:\/\/example.com\/jenkins@+ , _jenkinsPort :: Int -- ^ Jenkins port, e.g. @8080@+ , _jenkinsUser :: Text -- ^ Jenkins user, e.g. @jenkins@+ , _jenkinsApiToken :: Text -- ^ Jenkins user API token+ } deriving (Show, Eq, Typeable, Data, Generic)+ -- | The result of Jenkins REST API queries data Result e v = Error e -- ^ Exception @e@ was thrown while querying@@ -81,9 +93,10 @@ fmap result . try . withManager $ \manager -> do req <- liftIO $ parseUrl h let req' = req- & L.port .~ p- & L.responseTimeout .~ Just (20 * 1000000)- runReaderT (runMaybeT (iterJenkinsIO manager jenk)) (applyBasicAuth user token req')+ & Lens.port .~ p+ & Lens.responseTimeout .~ Just (20 * 1000000)+ & applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token)+ runReaderT (runMaybeT (iterJenkinsIO manager jenk)) req' where result :: Either e (Maybe v) -> Result e v result (Left e) = Error e@@ -135,18 +148,18 @@ go (Get m next) = do req <- lift ask let req' = req- & L.path %~ (`slash` render m)- & L.method .~ "GET"+ & Lens.path %~ (`slash` render m)+ & Lens.method .~ "GET" bs <- lift . lift $ httpLbs req' manager next (responseBody bs) go (Post m body next) = do req <- lift ask let req' = req- & L.path %~ (`slash` render m)- & L.method .~ "POST"- & L.requestBody .~ RequestBodyLBS body- & L.redirectCount .~ 0- & L.checkStatus .~ \s@(Status st _) hs cookie_jar ->+ & 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@@ -169,17 +182,6 @@ go Dcon = mzero --- | Jenkins connection settings------ '_jenkinsApiToken' may be user's password, Jenkins--- does not make any distinction between these concepts-data ConnectInfo = ConnectInfo- { _jenkinsUrl :: String -- ^ Jenkins URL, e.g. @http:\/\/example.com\/jenkins@- , _jenkinsPort :: Int -- ^ Jenkins port, e.g. @8080@- , _jenkinsUser :: B.ByteString -- ^ Jenkins user, e.g. @jenkins@- , _jenkinsApiToken :: B.ByteString -- ^ Jenkins user API token- } deriving (Show, Eq, Typeable, Data, Generic)- -- | Default Jenkins connection settings -- -- @@@ -209,12 +211,12 @@ {-# INLINE jenkinsPort #-} -- | A lens into Jenkins user-jenkinsUser :: Lens' ConnectInfo B.ByteString+jenkinsUser :: Lens' ConnectInfo Text jenkinsUser f req = (\u' -> req { _jenkinsUser = u' }) <$> f (_jenkinsUser req) {-# INLINE jenkinsUser #-} -- | A lens into Jenkins user API token-jenkinsApiToken :: Lens' ConnectInfo B.ByteString+jenkinsApiToken :: Lens' ConnectInfo Text jenkinsApiToken f req = (\a' -> req { _jenkinsApiToken = a' }) <$> f (_jenkinsApiToken req) {-# INLINE jenkinsApiToken #-} @@ -223,6 +225,6 @@ -- @ -- jenkinsPassword = jenkinsApiToken -- @-jenkinsPassword :: Lens' ConnectInfo B.ByteString+jenkinsPassword :: Lens' ConnectInfo Text jenkinsPassword = jenkinsApiToken {-# INLINE jenkinsPassword #-}
src/Network/HTTP/Conduit/Lens.hs view
@@ -45,7 +45,6 @@ , _IncompleteHeaders ) where -import Control.Applicative import Control.Exception (SomeException, IOException) import Control.Exception.Lens (exception) import Control.Lens@@ -152,112 +151,90 @@ -- | @http-conduit@ exceptions-class AsHttpException p f t where+class AsHttpException t where -- | @http-conduit@ exceptions overloading- _HttpException :: Overloaded' p f t H.HttpException+ _HttpException :: Prism' t H.HttpException -instance AsHttpException p f H.HttpException where+instance AsHttpException H.HttpException where _HttpException = id {-# INLINE _HttpException #-} -instance (Choice p, Applicative f) => AsHttpException p f SomeException where+instance AsHttpException SomeException where _HttpException = exception {-# INLINE _HttpException #-} -- | 'H.StatusCodeException' exception-_StatusCodeException- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t (H.Status, H.ResponseHeaders, H.CookieJar)+_StatusCodeException :: AsHttpException t => Prism' t (H.Status, H.ResponseHeaders, H.CookieJar) _StatusCodeException = _HttpException . prism' (uncurry3 H.StatusCodeException) go where go (H.StatusCodeException s rh cj) = Just (s, rh, cj) go _ = Nothing {-# INLINE _StatusCodeException #-} -- | 'H.InvalidUrlException' exception-_InvalidUrlException- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t (String, String)+_InvalidUrlException :: AsHttpException t => Prism' t (String, String) _InvalidUrlException = _HttpException . prism' (uncurry H.InvalidUrlException) go where go (H.InvalidUrlException s s') = Just (s, s') go _ = Nothing {-# INLINE _InvalidUrlException #-} -- | 'H.TooManyRedirects' exception-_TooManyRedirects- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t [H.Response Lazy.ByteString]+_TooManyRedirects :: AsHttpException t => Prism' t [H.Response Lazy.ByteString] _TooManyRedirects = _HttpException . prism' H.TooManyRedirects go where go (H.TooManyRedirects rs) = Just rs go _ = Nothing {-# INLINE _TooManyRedirects #-} -- | 'H.UnparseableRedirect' exception-_UnparseableRedirect- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t (H.Response Lazy.ByteString)+_UnparseableRedirect :: AsHttpException t => Prism' t (H.Response Lazy.ByteString) _UnparseableRedirect = _HttpException . prism' H.UnparseableRedirect go where go (H.UnparseableRedirect r) = Just r go _ = Nothing {-# INLINE _UnparseableRedirect #-} -- | 'H.TooManyRetries' exception-_TooManyRetries- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_TooManyRetries :: AsHttpException t => Prism' t () _TooManyRetries = _HttpException . prism' (const H.TooManyRetries) go where go H.TooManyRetries = Just () go _ = Nothing {-# INLINE _TooManyRetries #-} -- | 'H.HttpParserException' exception-_HttpParserException- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t String+_HttpParserException :: AsHttpException t => Prism' t String _HttpParserException = _HttpException . prism' H.HttpParserException go where go (H.HttpParserException s) = Just s go _ = Nothing {-# INLINE _HttpParserException #-} -- | 'H.HandshakeFailed' exception-_HandshakeFailed- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_HandshakeFailed :: AsHttpException t => Prism' t () _HandshakeFailed = _HttpException . prism' (const H.HandshakeFailed) go where go H.HandshakeFailed = Just () go _ = Nothing {-# INLINE _HandshakeFailed #-} -- | 'H.OverlongHeaders' exception-_OverlongHeaders- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_OverlongHeaders :: AsHttpException t => Prism' t () _OverlongHeaders = _HttpException . prism' (const H.OverlongHeaders) go where go H.OverlongHeaders = Just () go _ = Nothing {-# INLINE _OverlongHeaders #-} -- | 'H.ResponseTimeout' exception-_ResponseTimeout- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_ResponseTimeout :: AsHttpException t => Prism' t () _ResponseTimeout = _HttpException . prism' (const H.ResponseTimeout) go where go H.ResponseTimeout = Just () go _ = Nothing {-# INLINE _ResponseTimeout #-} -- | 'H.FailedConnectionException' exception-_FailedConnectionException- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t (String, Int)+_FailedConnectionException :: AsHttpException t => Prism' t (String, Int) _FailedConnectionException = _HttpException . prism' (uncurry H.FailedConnectionException) go where go (H.FailedConnectionException s i) = Just (s, i) go _ = Nothing {-# INLINE _FailedConnectionException #-} -- | 'H.ExpectedBlankAfter100Continue' exception-_ExpectedBlankAfter100Continue- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_ExpectedBlankAfter100Continue :: AsHttpException t => Prism' t () _ExpectedBlankAfter100Continue = _HttpException . prism' (const H.ExpectedBlankAfter100Continue) go where go H.ExpectedBlankAfter100Continue = Just ()@@ -265,90 +242,70 @@ {-# INLINE _ExpectedBlankAfter100Continue #-} -- | 'H.InvalidStatusLine' exception-_InvalidStatusLine- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ByteString+_InvalidStatusLine :: AsHttpException t => Prism' t ByteString _InvalidStatusLine = _HttpException . prism' H.InvalidStatusLine go where go (H.InvalidStatusLine b) = Just b go _ = Nothing {-# INLINE _InvalidStatusLine #-} -- | 'H.InvalidHeader' exception-_InvalidHeader- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ByteString+_InvalidHeader :: AsHttpException t => Prism' t ByteString _InvalidHeader = _HttpException . prism' H.InvalidHeader go where go (H.InvalidHeader b) = Just b go _ = Nothing {-# INLINE _InvalidHeader #-} -- | 'H.InternalIOException' exception-_InternalIOException- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t IOException+_InternalIOException :: AsHttpException t => Prism' t IOException _InternalIOException = _HttpException . prism' H.InternalIOException go where go (H.InternalIOException ioe) = Just ioe go _ = Nothing {-# INLINE _InternalIOException #-} -- | 'H.ProxyConnectException' exception-_ProxyConnectException- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t (ByteString, Int, Either ByteString H.HttpException)+_ProxyConnectException :: AsHttpException t => Prism' t (ByteString, Int, Either ByteString H.HttpException) _ProxyConnectException = _HttpException . prism' (uncurry3 H.ProxyConnectException) go where go (H.ProxyConnectException b i ebhe) = Just (b, i, ebhe) go _ = Nothing {-# INLINE _ProxyConnectException #-} -- | 'H.NoResponseDataReceived' exception-_NoResponseDataReceived- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_NoResponseDataReceived :: AsHttpException t => Prism' t () _NoResponseDataReceived = _HttpException . prism' (const H.NoResponseDataReceived) go where go H.NoResponseDataReceived = Just () go _ = Nothing {-# INLINE _NoResponseDataReceived #-} -- | 'H.TlsException' exception-_TlsException- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t SomeException+_TlsException :: AsHttpException t => Prism' t SomeException _TlsException = _HttpException . prism' H.TlsException go where go (H.TlsException se) = Just se go _ = Nothing {-# INLINE _TlsException #-} -- | 'H.TlsNotSupported' exception-_TlsNotSupported- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_TlsNotSupported :: AsHttpException t => Prism' t () _TlsNotSupported = _HttpException . prism' (const H.TlsNotSupported) go where go H.TlsNotSupported = Just () go _ = Nothing {-# INLINE _TlsNotSupported #-} -- | 'H.ResponseBodyTooShort' exception-_ResponseBodyTooShort- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t (Word64, Word64)+_ResponseBodyTooShort :: AsHttpException t => Prism' t (Word64, Word64) _ResponseBodyTooShort = _HttpException . prism' (uncurry H.ResponseBodyTooShort) go where go (H.ResponseBodyTooShort w w') = Just (w, w') go _ = Nothing {-# INLINE _ResponseBodyTooShort #-} -- | 'H.InvalidChunkHeaders' exception-_InvalidChunkHeaders- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_InvalidChunkHeaders :: AsHttpException t => Prism' t () _InvalidChunkHeaders = _HttpException . prism' (const H.InvalidChunkHeaders) go where go H.InvalidChunkHeaders = Just () go _ = Nothing {-# INLINE _InvalidChunkHeaders #-} -- | 'H.IncompleteHeaders' exception-_IncompleteHeaders- :: (AsHttpException p f t, Choice p, Applicative f)- => Overloaded' p f t ()+_IncompleteHeaders :: AsHttpException t => Prism' t () _IncompleteHeaders = _HttpException . prism' (const H.IncompleteHeaders) go where go H.IncompleteHeaders = Just () go _ = Nothing