libjenkins (empty) → 0.1.0.0
raw patch · 14 files changed
+1058/−0 lines, 14 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, conduit, data-default, directory, doctest, filepath, free, http-conduit, http-types, lens, monad-control, network, text, transformers, xml-conduit, xml-lens
Files
- CHANGELOG.md +4/−0
- LICENSE +30/−0
- README.md +4/−0
- Setup.hs +2/−0
- examples/Discover.hs +29/−0
- examples/Jobs.hs +73/−0
- examples/Rename.hs +81/−0
- libjenkins.cabal +63/−0
- src/Jenkins/Discover.hs +95/−0
- src/Jenkins/REST.hs +201/−0
- src/Jenkins/REST/Internal.hs +114/−0
- src/Jenkins/REST/Lens.hs +56/−0
- src/Jenkins/REST/Method.hs +278/−0
- tests/Doctests.hs +28/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1.0.0+=======++Initial release. REST and Discovery APIs support.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Matvey Aksenov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Matvey Aksenov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+libjenkins+==========+[](https://drone.io/github.com/supki/libjenkins/latest)+[](http://travis-ci.org/supki/libjenkins)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Discover.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Discover Jenkins server on the network+module Main where++import Data.Monoid ((<>), mempty) -- base+import Data.Text (Text) -- text+import qualified Data.Text as T -- text+import qualified Data.Text.IO as T -- text+import Jenkins.Discover -- libjenkins+import System.Exit (exitFailure) -- base+++main :: IO ()+main = do+ -- send discover broadcast with 100ms timeout+ discoveries <- discover 100000+ case discoveries of+ -- no Jenkins responded+ [] -> exitFailure+ -- pretty print responses+ _ -> mapM_ (T.putStrLn . pretty) discoveries++-- | Pretty print Jenkins discovery responses+pretty :: Discover -> Text+pretty x = T.unwords $+ ["Jenkins", version x] ++ maybe mempty (return . between "(" ")") (server_id x) ++ ["at", url x]+ where+ between l r t = l <> t <> r+
+ examples/Jobs.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Show jobs status+module Main where++import Control.Lens -- lens+import Control.Lens.Aeson -- lens-aeson+import qualified Data.ByteString.Char8 as B -- bytestring+import Data.Text (Text) -- text+import qualified Data.Text.IO as T -- text+import Jenkins.REST hiding (render) -- libjenkins+import Options.Applicative -- optparse-applicative+import System.Console.ANSI -- ansi-terminal+import System.Exit (exitFailure) -- base++{-# ANN module ("HLint: Use camelCase" :: String) #-}+++-- | Job name and status+data Job = Job+ { name :: Text+ , color :: Color+ }+++main :: IO ()+main = do+ -- more useful help on error+ opts <- customExecParser (prefs showHelpOnError) options+ -- get all jobs (colored)+ jobs <- colorized_jobs opts+ case jobs of+ -- render them+ Right js -> mapM_ render js+ -- something bad happened, show it!+ Left e -> do+ print e+ exitFailure++-- get jobs names from jenkins "root" API+colorized_jobs :: Settings -> IO (Either Disconnect [Job])+colorized_jobs settings = runJenkins settings $ do+ res <- get (json -?- "tree" -=- "jobs[name]")+ let jobs = res ^.. key "jobs"._Array.each.key "name"._String+ concurrentlys (map colorize jobs)++-- get jobs colors as they appear on web UI+colorize :: Text -> Jenkins Job+colorize name = do+ res <- get (job name `as` json -?- "tree" -=- "color")+ return . Job name $ case res ^? key "color" of+ -- but sane+ Just "red" -> Red+ Just "blue" -> Green+ _ -> Yellow++-- render colored job (assumes ANSI terminal)+render :: Job -> IO ()+render Job { name, color } = do+ setSGR [SetColor Foreground Dull color]+ T.putStrLn name+ setSGR []+++-- | Quite a trivial jenkins settings parser+options :: ParserInfo Settings+options = info (helper <*> parser) fullDesc+ where+ parser = Settings+ <$> (Host <$> strOption (long "host"))+ <*> (Port <$> option (long "port"))+ <*> (User . B.pack <$> strOption (long "user"))+ <*> (APIToken . B.pack <$> strOption (long "token" <> long "password"))
+ examples/Rename.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Rename jobs matching supplied pattern+module 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.Foldable (for_) -- base+import Data.Function (fix) -- base+import Data.Text (Text) -- text+import qualified Data.Text as T -- text+import qualified Data.Text.IO as T -- text+import Jenkins.REST -- libjenkins+import Options.Applicative -- optparse-applicative+import System.Exit (exitFailure) -- base++{-# ANN module ("HLint: Use camelCase" :: String) #-}+++main :: IO ()+main = do+ -- more useful help on error+ opts <- customExecParser (prefs showHelpOnError) options+ res <- rename opts+ case res of+ Right () -> T.putStrLn "Done."+ -- something bad happened, show it!+ Left e -> do+ print e+ exitFailure++-- | Prompt to rename all jobs matching pattern+rename :: Options -> IO (Either Disconnect ())+rename (Options { settings, old, new }) = runJenkins settings $ do+ -- get jobs names from jenkins "root" API+ res <- get (json -?- "tree" -=- "jobs[name]")+ let jobs = res ^.. key "jobs"._Array.each.key "name"._String+ 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+ -- prompt for every matching job+ yes <- prompt $ T.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+ "Y" -> return True+ "N" -> return False+ _ -> loop+++-- | Program options+data Options = Options+ { settings :: Settings+ , old :: Text+ , new :: Text+ }++-- | Quite a trivial options parser+options :: ParserInfo Options+options = info (helper <*> parser) fullDesc+ where+ parser = Options+ <$> parse_settings+ <*> nullOption (reader (return . T.pack) <> long "old")+ <*> nullOption (reader (return . T.pack) <> long "new")++ parse_settings = Settings+ <$> (Host <$> strOption (long "host"))+ <*> (Port <$> option (long "port"))+ <*> (User . B.pack <$> strOption (long "user"))+ <*> (APIToken . B.pack <$> strOption (long "token" <> long "password"))
+ libjenkins.cabal view
@@ -0,0 +1,63 @@+name: libjenkins+version: 0.1.0.0+synopsis: Jenkins API interface+description: Jenkins API interface. It supports REST and Discovery APIs+license: BSD3+license-file: LICENSE+author: Matvey Aksenov+maintainer: matvey.aksenov@gmail.com+category: Network+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md+ examples/Jobs.hs+ examples/Rename.hs+ examples/Discover.hs+cabal-version: >= 1.10++library+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules:+ Jenkins.Discover+ Jenkins.REST+ Jenkins.REST.Internal+ Jenkins.REST.Lens+ Jenkins.REST.Method+ build-depends:+ async >= 2.0+ , base >= 4.5 && < 5+ , bytestring >= 0.9+ , conduit >= 1.0+ , data-default >= 0.5+ , free >= 4.1+ , http-conduit >= 1.9+ , http-types >= 0.8+ , lens >= 3.9+ , monad-control >= 0.3+ , network >= 2.4+ , text >= 0.11+ , transformers >= 0.3+ , xml-conduit >= 1.1+ , xml-lens >= 0.1++test-suite doctests+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ build-depends:+ base == 4.*+ , directory+ , doctest+ , filepath+ hs-source-dirs: tests+ main-is: Doctests.hs++source-repository head+ type: git+ location: https://github.com/supki/libjenkins++source-repository this+ type: git+ location: https://github.com/supki/libjenkins+ tag: 0.1.0.0
+ src/Jenkins/Discover.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+-- | Discover Jenkins on the network+module Jenkins.Discover+ ( Discover(..), discover+ ) where++import Control.Applicative (Applicative(..), (<$>))+import Control.Lens+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Network.BSD+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++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}+++-- | Jenkins information+data Discover = Discover+ { version :: Text+ , url :: Text+ , server_id :: Maybe Text+ } deriving (Show, Read)+++-- | Discover Jenkins on the network+discover+ :: Int -- ^ timeout+ -> 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++ msgs <- while (timeout t (readAnswer b))++ close b+ return (mapMaybe parse msgs)+ where+ while :: IO (Maybe a) -> IO [a]+ while io = go where+ go = do+ mr <- io+ case mr of+ Nothing -> return []+ Just r -> (r :) <$> go++broadcastSocket :: IO (Socket, SockAddr)+broadcastSocket = do+ s <- getProtocolNumber "udp" >>= socket AF_INET Datagram+ setSocketOption s Broadcast 1+ return (s, SockAddrInet port (-1) {- 255.255.255.255 -})+ where+ port = 33848++readAnswer :: Socket -> IO ByteString+readAnswer s = fst <$> B.recvFrom s 4096+++-- | Parse Jenkins discovery response XML+--+-- The \"Scheme\" is as follows:+--+-- @+-- <hudson>+-- <version>...</version>+-- <url>...</url>+-- <server-id>...</server-id>+-- </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
+ src/Jenkins/REST.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Jenkins REST API interface+module Jenkins.REST+ ( -- * Types+ Jenkins, Disconnect(..)+ , Settings(..), Host(..), Port(..), User(..), APIToken(..), Password+ , Request+ -- * Jenkins queries construction+ , get, post, post_, concurrently, io, disconnect, with+ -- ** Jenkins method construction+ , module Jenkins.REST.Method+ -- ** Little helpers+ , concurrentlys, concurrentlys_, postXML, reload, restart+ -- * Jenkins queries execution+ , runJenkins, runJenkinsP+ -- ** Lenses and prisms+ , jenkins_host, jenkins_port, jenkins_user, jenkins_api_token, jenkins_password+ , _Host, _Port, _User, _APIToken, _Password+ -- * Usable @http-conduit@ 'Request' type API+ , module Jenkins.REST.Lens+ ) where++import Control.Applicative ((<$))+import Control.Exception (handle)+import Control.Lens+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Data (Data, Typeable)+import Data.Default (Default(..))+import Data.Monoid (mempty)+import Data.String (IsString)+import GHC.Generics (Generic)+import Network.HTTP.Conduit (Request, HttpException, withManager, applyBasicAuth, parseUrl)+import Text.XML (Document, renderLBS)++import Jenkins.REST.Internal+import qualified Jenkins.REST.Lens+import Jenkins.REST.Lens as L+import Jenkins.REST.Method++{-# ANN module ("HLint: Use const" :: String) #-}+++-- | @GET@ query+get :: Method Complete f -> Jenkins BL.ByteString+get m = liftJ $ Get m id+{-# INLINE get #-}++-- | @POST@ query (with payload)+post :: (forall f. Method Complete f) -> BL.ByteString -> Jenkins ()+post m body = liftJ $ Post m body (\_ -> ())+{-# INLINE post #-}++-- | @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 arbitrary 'IO' action+io :: IO a -> Jenkins a+io = liftIO+{-# INLINE io #-}++-- | Disconnect from Jenkins+--+-- Following queries won't be executed+disconnect :: Jenkins a+disconnect = liftJ Dcon+{-# INLINE disconnect #-}++-- | Make custom local changes to 'Request'+with :: (forall m. Request m -> Request m) -> Jenkins a -> Jenkins a+with f j = liftJ $ With f j id+{-# INLINE with #-}+++-- * Convenience++-- | @POST@ job's @config.xml@ (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 #-}++-- | Do a list of queries 'concurrently'+concurrentlys :: [Jenkins a] -> Jenkins [a]+concurrentlys = foldr go (return [])+ where+ go x xs = do+ (y, ys) <- concurrently x xs+ return (y : ys)+{-# INLINE concurrentlys #-}++-- | Do a list of queries 'concurrently' ignoring their results+concurrentlys_ :: [Jenkins a] -> Jenkins ()+concurrentlys_ = foldr (\x xs -> () <$ concurrently x xs) (return ())+{-# INLINE concurrentlys_ #-}++-- | Reload jenkins configuration from disk+reload :: Jenkins a+reload = do+ post_ "reload"+ disconnect+{-# INLINE reload #-}++-- | Restart jenkins+restart :: Jenkins a+restart = do+ post_ "restart"+ disconnect+{-# INLINE restart #-}+++-- | Jenkins settings+--+-- '_jenkins_api_token' might as well be the user's password, Jenkins+-- does not make any distinction between these concepts+data Settings = Settings+ { _jenkins_host :: Host+ , _jenkins_port :: Port+ , _jenkins_user :: User+ , _jenkins_api_token :: APIToken+ } deriving (Show, Eq, Typeable, Data, Generic)++instance Default Settings where+ def = Settings+ { _jenkins_host = "http://example.com"+ , _jenkins_port = 80+ , _jenkins_user = "anonymous"+ , _jenkins_api_token = "secret"+ }++-- | Jenkins host address+newtype Host = Host { unHost :: String }+ deriving (Show, Eq, Typeable, Data, Generic, IsString)++-- | Jenkins port+newtype Port = Port { unPort :: Int }+ deriving (Show, Eq, Typeable, Data, Generic, Num)++-- | Jenkins user+newtype User = User { unUser :: B.ByteString }+ deriving (Show, Eq, Typeable, Data, Generic, IsString)++-- | Jenkins user API token+newtype APIToken = APIToken { unAPIToken :: B.ByteString }+ deriving (Show, Eq, Typeable, Data, Generic, IsString)++-- | Jenkins user password+type Password = APIToken++makeLenses ''Settings++jenkins_password :: Lens' Settings Password+jenkins_password = jenkins_api_token+{-# INLINE jenkins_password #-}++makePrisms ''Host+makePrisms ''Port+makePrisms ''User+makePrisms ''APIToken++_Password :: Prism' Password B.ByteString+_Password = _APIToken+{-# INLINE _Password #-}+++data Disconnect =+ Disconnect+ | JenkinsException HttpException+ deriving (Show, Typeable, Generic)++-- | Communicate with Jenkins REST API+--+-- Catches 'HttpException's thrown by @http-conduit@, but+-- does not catch exceptions thrown by embedded 'IO' actions+runJenkins :: Settings -> Jenkins a -> IO (Either Disconnect a)+runJenkins (Settings (Host h) (Port p) (User u) (APIToken t)) jenk =+ handle (return . Left . JenkinsException) $+ withManager $ \manager -> do+ req <- liftIO $ parseUrl h+ let req' = req+ & L.port .~ p+ & L.responseTimeout .~ Just (20 * 1000000)+ res <- runReaderT (runMaybeT (runJenkinsIO manager jenk)) (applyBasicAuth u t req')+ return $ maybe (Left Disconnect) Right res
+ src/Jenkins/REST/Internal.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Jenkins.REST.Internal where++import Control.Applicative (Applicative(..))+import Control.Concurrent.Async (concurrently)+import Control.Exception (toException)+import Control.Lens+import Control.Monad (join)+import Control.Monad.Free.Church (F, iterM, liftF)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Control (MonadTransControl(..))+import Control.Monad.Trans.Reader (ReaderT, ask, local)+import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)+import qualified Data.ByteString.Lazy as BL+import Data.Conduit (ResourceT)+import Network.HTTP.Conduit+import Network.HTTP.Types (Status(..))++import Jenkins.REST.Lens as L+import Jenkins.REST.Method+++-- | Jenkins REST API composable queries+newtype Jenkins a = Jenkins { unJenkins :: F JenkinsF a }+ deriving (Functor, Applicative, Monad)++instance MonadIO Jenkins where+ liftIO = liftJ . IO+ {-# INLINE liftIO #-}++-- | 'JenkinsF' terms+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+ Conc :: Jenkins a -> Jenkins b -> (a -> b -> c) -> JenkinsF c+ IO :: IO a -> JenkinsF a+ With :: (forall m. Request m -> Request m) -> 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 (Conc m n g) = Conc m n (\a b -> f (g a 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' query to the 'Jenkins' query language+liftJ :: JenkinsF a -> Jenkins a+liftJ = Jenkins . liftF+{-# INLINE liftJ #-}+++runJenkinsIO+ :: Manager+ -> Jenkins a+ -> MaybeT (ReaderT (Request (ResourceT IO)) (ResourceT IO)) a+runJenkinsIO manager = runJenkinsP (jenkinsIO manager)+{-# INLINE runJenkinsIO #-}++-- | Generic Jenkins REST API queries interpreter+--+-- Particularly useful for testing (with @m ≡ 'Identity'@)+runJenkinsP :: Monad m => (JenkinsF (m a) -> m a) -> Jenkins a -> m a+runJenkinsP go = iterM go . unJenkins+{-# INLINE runJenkinsP #-}++jenkinsIO+ :: Manager+ -> JenkinsF (MaybeT (ReaderT (Request (ResourceT IO)) (ResourceT IO)) a)+ -> MaybeT (ReaderT (Request (ResourceT IO)) (ResourceT IO)) a+jenkinsIO manager = go where+ go (Get m next) = do+ req <- lift ask+ let req' = req+ & L.path %~ (`slash` render m)+ & L.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 ->+ 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 (ResourceT IO))) (StT MaybeT t)))+ run = run''' . run'' . run' . runJenkinsIO manager+ in concurrently (run jenka) (run jenkb)+ c <- restoreT . restoreT . restoreT $ return a+ d <- restoreT . restoreT . restoreT $ return b+ next c d+ go (IO action) = join (liftIO action)+ go (With f jenk next) = do+ res <- mapMaybeT (local f) (runJenkinsIO manager jenk)+ next res+ go Dcon = fail "disconnect"
+ src/Jenkins/REST/Lens.hs view
@@ -0,0 +1,56 @@+-- | Lenses for 'Network.HTTP.Conduit' types+module Jenkins.REST.Lens+ ( -- * 'Request' lenses+ method, secure+ , host, port+ , path, queryString, requestBody, requestHeaders+ , redirectCount, checkStatus, responseTimeout+ ) where++import Control.Applicative ((<$>))+import Control.Exception (SomeException)+import Control.Lens+import Data.ByteString (ByteString)+import qualified Network.HTTP.Conduit as H+import qualified Network.HTTP.Types as H+++-- | HTTP request method, eg GET, POST.+method :: Lens' (H.Request m) H.Method+method f req = (\m' -> req { H.method = m' }) <$> f (H.method req)++-- | Whether to use HTTPS (ie, SSL).+secure :: Lens' (H.Request m) Bool+secure f req = (\s' -> req { H.secure = s' }) <$> f (H.secure req)++host :: Lens' (H.Request m) ByteString+host f req = (\h' -> req { H.host = h' }) <$> f (H.host req)++port :: Lens' (H.Request m) Int+port f req = (\p' -> req { H.port = p' }) <$> f (H.port req)++-- | Everything from the host to the query string.+path :: Lens' (H.Request m) ByteString+path f req = (\p' -> req { H.path = p' }) <$> f (H.path req)++queryString :: Lens' (H.Request m) ByteString+queryString f req = (\qs' -> req { H.queryString = qs' }) <$> f (H.queryString req)++requestBody :: Lens' (H.Request m) (H.RequestBody m)+requestBody f req = (\rb' -> req { H.requestBody = rb' }) <$> f (H.requestBody req)++requestHeaders :: Lens' (H.Request m) H.RequestHeaders+requestHeaders f req = (\rh' -> req { H.requestHeaders = rh' }) <$> f (H.requestHeaders req)++-- | How many redirects to follow when getting a resource. 0 means follow no redirects. Default value: 10.+redirectCount :: Lens' (H.Request m) Int+redirectCount f req = (\rc' -> req { H.redirectCount = rc' }) <$> f (H.redirectCount req)++-- | Check the status code. Note that this will run after all redirects are performed.+-- Default: return a StatusCodeException on non-2XX responses.+checkStatus :: Lens' (H.Request m) (H.Status -> H.ResponseHeaders -> H.CookieJar -> Maybe SomeException)+checkStatus f req = (\cs' -> req { H.checkStatus = cs' }) <$> f (H.checkStatus req)++-- | Number of microseconds to wait for a response. If Nothing, will wait indefinitely. Default: 5 seconds.+responseTimeout :: Lens' (H.Request m) (Maybe Int)+responseTimeout f req = (\rt' -> req { H.responseTimeout = rt' }) <$> f (H.responseTimeout req)
+ src/Jenkins/REST/Method.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Jenkins REST API method construction+module Jenkins.REST.Method+ ( -- * Types+ Method, Type(..), Format, As+ -- * Method construction+ , text, int, (-?-), (-/-), (-=-), (-&-), query+ , as, JSONy(..), XMLy(..), Pythony(..)+ -- ** Helpers+ , job, build, view, queue+ -- * Rendering+ , render, slash+ ) where++import Data.ByteString (ByteString)+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)+import Data.ByteString.Char8 ()+#endif+import qualified Data.ByteString as B+import Data.Data (Data, Typeable)+import Data.Monoid (Monoid(..), (<>))+import Data.String (IsString(..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.URI (escapeURIChar, isUnreserved)++-- $setup+-- >>> :set -XOverloadedStrings+++infix 1 :~?, -?-+infix 3 :~@, `as`+infix 7 :~=, -=-+infixr 5 :~/, -/-, :~&, -&-+-- | Jenkins RESTFul API method encoding+data Method :: Type -> Format -> * where+ Empty :: Method t f+ Text :: Text -> Method Complete f+ (:~/) :: Method Complete f -> Method Complete f -> Method Complete f+ (:~@) :: Method Complete f -> As f -> Method Complete f+ (:~=) :: Text -> Maybe Text -> Method Query f+ (:~&) :: Method Query f -> Method Query f -> Method Query f+ (:~?) :: Method Complete f -> Method Query f -> Method Complete f++deriving instance Show (As f) => Show (Method t f)++-- | Only to support number literals+instance Num (Method Complete f) where+ (+) = 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"+ fromInteger = fromString . show++instance IsString (Method Complete f) where+ fromString = Text . T.pack++instance IsString (Method Query f) where+ fromString str = T.pack str :~= Nothing++-- | Method types+data Type = Query | Complete+ deriving (Show, Eq, Typeable, Data, Generic)++-- | Response formats+data Format = JSON | XML | Python+ deriving (Show, Eq, Typeable, Data, Generic)++-- | Response format singleton type+data As :: Format -> * where+ AsJSON :: As JSON+ AsXML :: As XML+ AsPython :: As Python++deriving instance Show (As f)+deriving instance Eq (As f)++-- | Convert 'Text' to 'Method'+text :: Text -> Method Complete f+text = Text++-- | Convert 'Integer' to 'Method'+int :: Integer -> Method Complete f+int = fromInteger++-- | Append 2 paths+(-/-) :: Method Complete f -> Method Complete f -> Method Complete f+(-/-) = (:~/)++-- | Append 2 queries+(-&-) :: Method Query f -> Method Query f -> Method Query f+(-&-) = (:~&)++-- | Make a query+(-=-) :: Text -> Text -> Method Query f+x -=- y = x :~= Just y++-- | Choose response format+as :: Method Complete f -> As f -> Method Complete f+as = (:~@)++-- | JSON response format+class JSONy t where+ json :: t JSON++instance JSONy As where+ json = AsJSON++instance t ~ Complete => JSONy (Method t) where+ json = "" `as` json++-- | XML response format+class XMLy t where+ xml :: t XML++instance XMLy As where+ xml = AsXML++instance t ~ Complete => XMLy (Method t) where+ xml = "" `as` xml++-- | Python response format+class Pythony t where+ python :: t Python++instance Pythony As where+ python = AsPython++instance t ~ Complete => Pythony (Method t) where+ python = "" `as` python++-- | Append path and query+(-?-) :: Method Complete f -> Method Query f -> Method Complete f+(-?-) = (:~?)++-- | list-to-query combinator+--+-- >>> render (query [("foo", Nothing), ("bar", Just "baz"), ("quux", Nothing)])+-- "foo&bar=baz&quux"+--+-- >>> render (query [])+-- ""+query :: [(Text, Maybe Text)] -> Method Query f+query [] = Empty+query xs = foldr1 (:~&) (map (uncurry (:~=)) xs)+++-- | Render 'Method' to something that can be sent over the wire+--+-- >>> render ("" `as` xml)+-- "api/xml"+--+-- >>> render xml+-- "api/xml"+--+-- >>> render ("job" -/- 7 `as` xml)+-- "job/7/api/xml"+--+-- >>> render ("job" -/- 7 `as` xml)+-- "job/7/api/xml"+--+-- >>> render ("job" -/- 7 `as` json)+-- "job/7/api/json"+--+-- >>> render (text "restart")+-- "restart"+--+-- >>> render ("job" -?- "name" -=- "foo" -&- "title" -=- "bar")+-- "job?name=foo&title=bar"+--+-- >>> render ("job" -?- "name" -&- "title" -=- "bar")+-- "job?name&title=bar"+--+-- >>> render ("job" -/- 7 `as` json -?- "name" -&- "title" -=- "bar")+-- "job/7/api/json?name&title=bar"+--+-- >>> render ("job" -/- "ДМИТРИЙ" `as` xml)+-- "job/%D0%94%D0%9C%D0%98%D0%A2%D0%A0%D0%98%D0%99/api/xml"+render :: Method t f -> ByteString+render Empty = ""+render (Text s) = renderText s+render (x :~/ y) = render x `slash` render y+render (x :~@ f) =+ let prefix = render x+ postfix = renderFormat f+ in if B.null prefix then "api" `slash` postfix else prefix `slash` "api" `slash` postfix+render (x :~= Just y) = renderText x `equals` renderText y+render (x :~= Nothing) = renderText x+render (x :~& y) = render x `ampersand` render y+render (x :~? y) = render x `question` render y++renderFormat :: IsString s => As f -> s+renderFormat AsJSON = "json"+renderFormat AsXML = "xml"+renderFormat AsPython = "python"++-- | Render unicode text as query string+--+-- >>> renderText "foo-bar-baz"+-- "foo-bar-baz"+--+-- >>> renderText "foo bar baz"+-- "foo%20bar%20baz"+--+-- >>> renderText "ДМИТРИЙ МАЛИКОВ"+-- "%D0%94%D0%9C%D0%98%D0%A2%D0%A0%D0%98%D0%99%20%D0%9C%D0%90%D0%9B%D0%98%D0%9A%D0%9E%D0%92"+renderText :: Text -> ByteString+renderText = T.encodeUtf8 . T.concatMap (T.pack . escapeURIChar isUnreserved)++-- | Insert \"\/\" between two 'String'-like things and concat them.+slash :: (IsString m, Monoid m) => m -> m -> m+slash = insert "/"++-- | Insert \"=\" between two 'String'-like things and concat them.+equals :: (IsString m, Monoid m) => m -> m -> m+equals = insert "="++-- | Insert \"&\" between two 'String'-like things and concat them.+ampersand :: (IsString m, Monoid m) => m -> m -> m+ampersand = insert "&"++-- | Insert \"?\" between two 'String'-like things and concat them.+question :: (IsString m, Monoid m) => m -> m -> m+question = insert "?"++-- | Insert 'String'-like thing between two 'String'-like things and concat them.+--+-- >>> "foo" `slash` "bar"+-- "foo/bar"+--+-- >>> "" `ampersand` "foo"+-- "&foo"+--+-- >>> "foo" `question` ""+-- "foo?"+insert :: (IsString m, Monoid m) => m -> m -> m -> m+insert t x y = x <> t <> y+++-- | Job API method+--+-- >>> render (job "name" `as` json)+-- "job/name/api/json"+job :: Text -> Method Complete f+job name = "job" -/- text name++-- | Job build API method+--+-- >>> render (build "name" 4 `as` json)+-- "job/name/4/api/json"+build :: Integral a => Text -> a -> Method Complete f+build name num = "job" -/- text name -/- int (toInteger num)++-- | View API method+--+-- >>> render (view "name" `as` xml)+-- "view/name/api/xml"+view :: Text -> Method Complete f+view name = "view" -/- text name++-- | Queue API method+--+-- >>> render (queue `as` python)+-- "queue/api/python"+queue :: Method Complete f+queue = "queue"
+ tests/Doctests.hs view
@@ -0,0 +1,28 @@+module Main where++import Control.Applicative ((<$>))+import Control.Monad (forM, liftM)+import Data.List (isSuffixOf)+import System.Directory (getDirectoryContents, doesDirectoryExist)+import System.FilePath ((</>))+import Test.DocTest (doctest)+++main :: IO ()+main = sources "src" >>= doctest++sources :: FilePath -> IO [FilePath]+sources root = do+ files <- contents root+ liftM concat . forM files $ \file -> do+ let path = root </> file+ is_dir <- doesDirectoryExist path+ case is_dir of+ True -> sources path+ _ | isSource path -> return [path]+ | otherwise -> return []+ where+ isSource path = any (`isSuffixOf` path) [".hs", ".lhs"]++contents :: FilePath -> IO [FilePath]+contents dir = filter (`notElem` [".", ".."]) <$> getDirectoryContents dir