packages feed

libjenkins 0.2.0.0 → 0.3.0.0

raw patch · 23 files changed

+1434/−877 lines, 23 filesdep +hspecdep +http-clientdep +libjenkinsdep −data-defaultdep ~basedep ~bytestringdep ~transformers

Dependencies added: hspec, http-client, libjenkins

Dependencies removed: data-default

Dependency ranges changed: base, bytestring, transformers

Files

CHANGELOG.md view
@@ -1,9 +1,22 @@+0.3.0.0+=======++  * `restart` does not send requests to `$jenkins_url/restart` anymore. Instead, it calls+  `$jenkins_url/safe-restart` which waits running jobs to complete. New `forceRestart` function+  does now what `restart` did before++  * Massive refactoring++  * More optics in `Network.HTTP.Conduit.Lens`++  * Add `overallLoad` and `computer` REST API methods shortcuts+ 0.2.0.0 ======= -  * Move onto http-conduit 2.0 API+  * Move onto http-conduit 2.0 API.  0.1.0.0 ======= -Initial release. REST and Discovery APIs support.+  * Initial release. REST and Discovery APIs support.
+ bench/Concurrency.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+-- | Concurrency benchmark+--+-- The benchmark does the folllowing:+--+--   * it asks Jenkins instance for accessible jobs+--+--   * it sends queries to get jobs descriptions+--+--   * it prints all descriptions+--+-- The benchmark can be run sequentially or concurrently+--+-- See @bench/README.md@ for usage instructions+module Main (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           Jenkins.Rest                  -- libjenkins+import           System.Environment (getArgs)  -- base+import           System.Exit (exitFailure)     -- base+import           System.IO (hPutStrLn, stderr) -- base+++type Aggregate a b = (a -> Jenkins b) -> [a] -> Jenkins [b]++main :: IO ()+main = do+  m:host:port:user:pass:_ <- getArgs+  ds <- descriptions (aggregate m) $+    ConnectInfo host (read port) (B.pack user) (B.pack pass)+  case ds of+    Result ds  -> mapM_ print ds+    Disconnect -> die "disconnect!"+    Error e    -> die (show e)+ where+  die message = do+    hPutStrLn stderr message+    exitFailure++  aggregate :: String -> Aggregate a b+  aggregate "concurrent" = (concurrentlys .) . map+  aggregate "sequential" = mapM+  aggregate _ = error "Unknown mode"++descriptions+  :: Aggregate Text (Maybe Text)+  -> ConnectInfo+  -> IO (Result HttpException [Maybe Text])+descriptions aggregate settings = runJenkins settings $ do+  res <- get (json -?- "tree" -=- "jobs[name]")+  aggregate describe (res ^.. key "jobs".values.key "name"._String)++describe :: Text -> Jenkins (Maybe Text)+describe name = do+  desc <- get (job name `as` json -?- "tree" -=- "description")+  return (desc ^? key "description"._String)
+ bench/README.md view
@@ -0,0 +1,14 @@+# Benchmarks++## `Concurrent.hs`++    ./bench/Concurrency (concurrent|sequential) HOST PORT USERNAME PASSWORD++Measures the concurrency impact on time API queries take.++Concurrency is the most useful if you:++  * Do not use any kind of "proxy" servers (apache2, nginx, etc) and _especially_ https+  * Try to run queries from the nearest machine possible: network latency matters++Under these conditions, expect to get ~2x speedup from using `concurrent` mode on Jenkins server with ~500 jobs.
+ example/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+
+ example/grep-jobs.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Grep Jenkins instance jobs with Perl regex+module Main (main) where++import           Control.Lens                              -- lens+import           Control.Exception.Lens                    -- lens+import           Control.Lens.Aeson (key, values, _String) -- lens-aeson+import           Control.Monad                             -- base+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           Jenkins.Rest                              -- libjenkins+import           System.Environment (getArgs)              -- base+import           System.Exit.Lens                          -- lens+import           System.Process (readProcessWithExitCode)  -- process+import           Text.Printf (printf)                      -- base+++main :: IO ()+main = do+  user:pswd:host:port:regex:_ <- getArgs+  jobs <- grep regex (ConnectInfo host (read port) (fromString user) (fromString pswd))+  case jobs of+    [] -> throwingM _ExitFailure 1+    _  -> mapM_ Text.putStrLn jobs++-- | Filter matching job names+grep :: String -> ConnectInfo -> IO [Text]+grep regex conn = do+  jobs <- runJenkins conn $+    get (json -?- "tree" -=- "jobs[name]") <&> \res -> res ^.. key "jobs".values.key "name"._String+  filterM (match regex) (jobs ^.. _Result.folded)++-- | Match job name again Perl regex+match :: String -> Text -> IO Bool+match regex name = do+  (exitcode, _, _) <-+    readProcessWithExitCode "perl" ["-n", "-e", printf "/%s/ or die" regex] (Text.unpack name)+  return $ has _ExitSuccess exitcode
+ example/rename-jobs.hs view
@@ -0,0 +1,72 @@+{-# 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           System.Environment (getArgs)  -- base+import           System.Exit (exitFailure)     -- base+import           System.IO (hPutStrLn, stderr) -- base++{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}+++-- | Program options+data Options = Options+  { settings :: ConnectInfo+  , old      :: Text+  , new      :: Text+  }+++main :: IO ()+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)+  res <- rename opts+  case res of+    Result _ -> T.putStrLn "Done."+    -- disconnected for some reason+    Disconnect -> die "disconnect!"+    -- something bad happened, show it!+    Error e -> die (show e)+ where+  die message = do+    hPutStrLn stderr message+    exitFailure++-- | Prompt to rename all jobs matching pattern+rename :: Options -> IO (Result HttpException ())+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".values.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
+ example/running-jobs-count.hs view
@@ -0,0 +1,30 @@+{-# 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++import Control.Lens                      -- lens+import Control.Lens.Aeson                -- lens-aeson+import Data.ByteString.Lazy (ByteString) -- bytestring+import Data.String (fromString)          -- bytestring+import Jenkins.Rest                      -- libjenkins+import System.Environment (getArgs)      -- base+import Text.Printf (printf)              -- base+++main :: IO ()+main = do+  host:port:user:apiToken:_ <- getArgs+  let creds = ConnectInfo host (read port) (fromString user) (fromString apiToken)+  jobs <- runJenkins creds getJobs+  printf "Running jobs count: %d\n" (lengthOf (_Result.running) jobs)++getJobs :: Jenkins ByteString+getJobs = get (json -?- "tree" -=- "jobs[color]")++running :: Fold ByteString ()+running = key "jobs".values.key "color"._String.only "blue_anime"
− examples/Discover.hs 
@@ -1,29 +0,0 @@-{-# 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 
@@ -1,73 +0,0 @@-{-# 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 
@@ -1,81 +0,0 @@-{-# 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
@@ -1,5 +1,5 @@ name:                libjenkins-version:             0.2.0.0+version:             0.3.0.0 synopsis:            Jenkins API interface description:         Jenkins API interface. It supports REST and Discovery APIs license:             BSD3@@ -11,9 +11,12 @@ extra-source-files:   README.md   CHANGELOG.md-  examples/Jobs.hs-  examples/Rename.hs-  examples/Discover.hs+  bench/Concurrency.hs+  bench/README.md+  example/grep-jobs.hs+  example/rename-jobs.hs+  example/discover.hs+  example/running-jobs-count.hs cabal-version:       >= 1.10  library@@ -21,17 +24,17 @@   hs-source-dirs:    src   exposed-modules:     Jenkins.Discover-    Jenkins.REST-    Jenkins.REST.Internal-    Jenkins.REST.Lens-    Jenkins.REST.Method+    Jenkins.Rest+    Jenkins.Rest.Internal+    Jenkins.Rest.Method+    Network.HTTP.Conduit.Lens   build-depends:       async         >= 2.0-    , base          >= 4.5 && < 5+    , base          >= 4.6 && < 5     , bytestring    >= 0.9     , conduit       >= 1.0-    , data-default  >= 0.5     , free          >= 4.1+    , http-client   >= 0.2.0.2     , http-conduit  >= 2.0 && < 2.1     , http-types    >= 0.8     , lens          >= 3.9@@ -42,17 +45,31 @@     , xml-conduit   >= 1.1     , xml-lens      >= 0.1 -test-suite doctests+test-suite doctest   default-language:  Haskell2010   type:              exitcode-stdio-1.0   build-depends:-      base == 4.*+      base          == 4.*     , directory     , doctest     , filepath-  hs-source-dirs:    tests-  main-is:           Doctests.hs+  hs-source-dirs:    test+  main-is:           Doctest.hs +test-suite spec+  default-language:  Haskell2010+  type:              exitcode-stdio-1.0+  build-depends:+      base          == 4.*+    , bytestring+    , hspec+    , libjenkins+    , transformers+  hs-source-dirs:    test+  main-is:           Spec.hs+  other-modules:+    Jenkins.RestSpec+ source-repository head   type:     git   location: https://github.com/supki/libjenkins@@ -60,4 +77,4 @@ source-repository this   type:     git   location: https://github.com/supki/libjenkins-  tag:      0.2.0.0+  tag:      0.3.0.0
− src/Jenkins/REST.hs 
@@ -1,201 +0,0 @@-{-# 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 :: (Request -> Request) -> 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 
@@ -1,114 +0,0 @@-{-# 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 :: (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 (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)) 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)) a)-  -> MaybeT (ReaderT Request (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) (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 
@@ -1,56 +0,0 @@--- | 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 H.Method-method f req = (\m' -> req { H.method = m' }) <$> f (H.method req)---- | Whether to use HTTPS (ie, SSL).-secure :: Lens' H.Request Bool-secure f req = (\s' -> req { H.secure = s' }) <$> f (H.secure req)--host :: Lens' H.Request ByteString-host f req = (\h' -> req { H.host = h' }) <$> f (H.host req)--port :: Lens' H.Request 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 ByteString-path f req = (\p' -> req { H.path = p' }) <$> f (H.path req)--queryString :: Lens' H.Request ByteString-queryString f req = (\qs' -> req { H.queryString = qs' }) <$> f (H.queryString req)--requestBody :: Lens' H.Request H.RequestBody-requestBody f req = (\rb' -> req { H.requestBody = rb' }) <$> f (H.requestBody req)--requestHeaders :: Lens' H.Request 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 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 (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 (Maybe Int)-responseTimeout f req = (\rt' -> req { H.responseTimeout = rt' }) <$> f (H.responseTimeout req)
− src/Jenkins/REST/Method.hs 
@@ -1,278 +0,0 @@-{-# 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"
+ src/Jenkins/Rest.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+-- | Jenkins REST API interface+module Jenkins.Rest+  ( -- * Query Jenkins+    runJenkins, ConnectInfo(..), defaultConnectInfo, Jenkins, Result(..)+    -- ** Combinators+  , get, post, post_, concurrently, io, disconnect, with+    -- ** Method+  , module Jenkins.Rest.Method+    -- ** Convenience+  , postXML, concurrentlys, concurrentlys_, reload, restart, forceRestart+    -- * Lensy things+  , jenkinsUrl, jenkinsPort, jenkinsUser, jenkinsApiToken, jenkinsPassword+  , _Error, _Disconnect, _Result+    -- * Type 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 Jenkins.Rest.Internal+import Jenkins.Rest.Method+import Network.HTTP.Conduit.Lens++{-# ANN module ("HLint: ignore Use const" :: String) #-}+++-- | @GET@ query+get :: Method Complete f -> Jenkins ByteString+get m = liftJ $ Get m id+{-# INLINE get #-}++-- | @POST@ query (with a payload)+post :: (forall f. Method Complete f) -> 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+--+-- Any following queries won't be executed+disconnect :: Jenkins a+disconnect = liftJ Dcon+{-# INLINE disconnect #-}++-- | 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 #-}++-- | Send a list of queries 'concurrently'+concurrentlys :: Foldable f => f (Jenkins a) -> Jenkins [a]+concurrentlys = foldr go (return [])+ where+  go x xs = do+    (y, ys) <- concurrently x xs+    return (y : ys)+{-# INLINE concurrentlys #-}++-- | 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_ #-}++-- | Reload jenkins configuration from disk+--+-- Calls @/reload@ and disconnects+reload :: Jenkins a+reload = do+  post_ "reload"+  disconnect+{-# INLINE reload #-}++-- | Restart jenkins safely+--+-- Calls @/safeRestart@ and disconnects+--+-- @/safeRestart@ allows all running jobs to complete+restart :: Jenkins a+restart = do+  post_ "safeRestart"+  disconnect+{-# INLINE restart #-}++-- | 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 #-}
+ src/Jenkins/Rest/Internal.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+-- | Jenkins REST API interface internals+module Jenkins.Rest.Internal where++import           Control.Applicative+import           Control.Concurrent.Async (concurrently)+import           Control.Exception (Exception, try, toException)+import           Control.Lens+import           Control.Monad+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, 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.Conduit (ResourceT)+import           Data.Data (Data, Typeable)+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+++-- | 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 -> (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 :: (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 (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' to 'Jenkins'+liftJ :: JenkinsF a -> Jenkins a+liftJ = Jenkins . liftF+{-# INLINE liftJ #-}++-- | The result of Jenkins REST API queries+data Result e v =+    Error e    -- ^ Exception @e@ was thrown while querying+  | Disconnect -- ^ The client was explicitly disconnected+  | Result v   -- ^ Querying successfully finished the with value @v@+    deriving (Show, Eq, Ord, Typeable, Data, Generic)++-- | 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 :: ConnectInfo -> Jenkins a -> IO (Result HttpException a)+runJenkins (ConnectInfo h p user token) jenk =+  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')+ where+  result :: Either e (Maybe v) -> Result e v+  result (Left e)           = Error e+  result (Right Nothing)    = Disconnect+  result (Right (Just val)) = Result val++-- | A prism into Jenkins error+_Error :: Prism (Result e a) (Result e' a) e e'+_Error = prism Error $ \case+  Error e    -> Right e+  Disconnect -> Left Disconnect+  Result a   -> Left (Result a)+{-# INLINE _Error #-}++-- | A prism into disconnect+_Disconnect :: Prism' (Result e a) ()+_Disconnect = prism' (\_ -> Disconnect) $ \case+  Disconnect -> Just ()+  _          -> Nothing+{-# INLINE _Disconnect #-}++-- | A prism into result+_Result :: Prism (Result e a) (Result e b) a b+_Result = prism Result $ \case+  Error e    -> Left (Error e)+  Disconnect -> Left Disconnect+  Result a   -> Right a+{-# INLINE _Result #-}++-- | Interpret 'JenkinsF' AST in 'IO'+iterJenkinsIO+  :: Manager+  -> 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+  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) (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+    next c d+  go (IO action) = join (liftIO action)+  go (With f jenk next) = do+    res <- mapMaybeT (local f) (iterJenkinsIO manager jenk)+    next res+  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+--+-- @+-- defaultConnectInfo = ConnectInfo+--   { _jenkinsUrl      = \"http:\/\/example.com\/jenkins\"+--   , _jenkinsPort     = 8080+--   , _jenkinsUser     = \"jenkins\"+--   , _jenkinsApiToken = \"\"+--   }+-- @+defaultConnectInfo :: ConnectInfo+defaultConnectInfo = ConnectInfo+  { _jenkinsUrl      = "http://example.com/jenkins"+  , _jenkinsPort     = 8080+  , _jenkinsUser     = "jenkins"+  , _jenkinsApiToken = ""+  }++-- | A lens into Jenkins URL+jenkinsUrl :: Lens' ConnectInfo String+jenkinsUrl f req = (\u' -> req { _jenkinsUrl = u' }) <$> f (_jenkinsUrl req)+{-# INLINE jenkinsUrl #-}++-- | A lens into Jenkins port+jenkinsPort :: Lens' ConnectInfo Int+jenkinsPort f req = (\p' -> req { _jenkinsPort = p' }) <$> f (_jenkinsPort req)+{-# INLINE jenkinsPort #-}++-- | A lens into Jenkins user+jenkinsUser :: Lens' ConnectInfo B.ByteString+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 f req = (\a' -> req { _jenkinsApiToken = a' }) <$> f (_jenkinsApiToken req)+{-# INLINE jenkinsApiToken #-}++-- | A lens into Jenkins password+--+-- @+-- jenkinsPassword = jenkinsApiToken+-- @+jenkinsPassword :: Lens' ConnectInfo B.ByteString+jenkinsPassword = jenkinsApiToken+{-# INLINE jenkinsPassword #-}
+ src/Jenkins/Rest/Method.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Jenkins REST API method construction+module Jenkins.Rest.Method+  ( -- * Types+    Method+  , Type(..)+  , Format+  , As+    -- * Method construction+  , text, int+  , (-?-), (-/-), (-=-), (-&-)+  , query+  , as+  , JSONy(..)+  , XMLy(..)+  , Pythony(..)+    -- * Shortcuts+  , job+  , build+  , view+  , queue+  , overallLoad+  , computer+    -- * Rendering+  , render+  , slash+  ) where++import           Data.ByteString (ByteString)+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 t ~ Complete => Num (Method t 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++-- | Combine 2 paths+(-/-) :: Method Complete f -> Method Complete f -> Method Complete f+(-/-) = (:~/)++-- | Combine 2 queries+(-&-) :: Method Query f -> Method Query f -> Method Query f+(-&-) = (:~&)++-- | Make a field-value pair+(-=-) :: 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++-- | Combine path and query+(-?-) :: Method Complete f -> Method Query f -> Method Complete f+(-?-) = (:~?)++-- | List-to-query convenience 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 a 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 concatenate everything.+slash :: (IsString m, Monoid m) => m -> m -> m+slash = insert "/"++-- | Insert \"=\" between two 'String'-like things and concatenate everything.+equals :: (IsString m, Monoid m) => m -> m -> m+equals = insert "="++-- | Insert \"&\" between two 'String'-like things and concatenate everything.+ampersand :: (IsString m, Monoid m) => m -> m -> m+ampersand = insert "&"++-- | Insert \"?\" between two 'String'-like things and concatenate everything.+question :: (IsString m, Monoid m) => m -> m -> m+question = insert "?"++-- | Insert 'String'-like thing between two 'String'-like things and concatenate everything.+--+-- >>> "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"++-- | Statistics API method+--+-- >>> render (overallLoad `as` xml)+-- "overallLoad/api/xml"+overallLoad :: Method Complete f+overallLoad = "overallLoad"++-- | Node API method+--+-- >>> render (computer `as` python)+-- "computer/api/python"+computer :: Method Complete f+computer = "computer"
+ src/Network/HTTP/Conduit/Lens.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Optics for @http-conduit@ types+module Network.HTTP.Conduit.Lens+  ( -- * 'Request' lenses+    method+  , secure+  , host+  , port+  , path+  , queryString+  , requestBody+  , requestHeaders+  , proxy+  , hostAddress+  , rawBody+  , decompress+  , redirectCount+  , checkStatus+  , responseTimeout+  , cookieJar+  , getConnectionWrapper+    -- * 'HttpException' prisms+  , AsHttpException(..)+  , _StatusCodeException+  , _InvalidUrlException+  , _TooManyRedirects+  , _UnparseableRedirect+  , _TooManyRetries+  , _HttpParserException+  , _HandshakeFailed+  , _OverlongHeaders+  , _ResponseTimeout+  , _FailedConnectionException+  , _ExpectedBlankAfter100Continue+  , _InvalidStatusLine+  , _InvalidHeader+  , _InternalIOException+  , _ProxyConnectException+  , _NoResponseDataReceived+  , _TlsException+  , _TlsNotSupported+  , _ResponseBodyTooShort+  , _InvalidChunkHeaders+  , _IncompleteHeaders+  ) where++import           Control.Applicative+import           Control.Exception (SomeException, IOException)+import           Control.Exception.Lens (exception)+import           Control.Lens+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as Lazy+import           Data.Word (Word64)+import qualified Network.HTTP.Conduit as H+import qualified Network.HTTP.Client.Internal as H+import qualified Network.HTTP.Types as H+import           Network.Socket (HostAddress)+++-- | 'H.method' lens+method :: Lens' H.Request H.Method+method f req = f (H.method req) <&> \m' -> req { H.method = m' }+{-# INLINE method #-}++-- | 'H.secure' lens+secure :: Lens' H.Request Bool+secure f req = f (H.secure req) <&> \s' -> req { H.secure = s' }+{-# INLINE secure #-}++-- | 'H.host' lens+host :: Lens' H.Request ByteString+host f req = f (H.host req) <&> \h' -> req { H.host = h' }+{-# INLINE host #-}++-- | 'H.port' lens+port :: Lens' H.Request Int+port f req = f (H.port req) <&> \p' -> req { H.port = p' }+{-# INLINE port #-}++-- | 'H.path' lens+path :: Lens' H.Request ByteString+path f req = f (H.path req) <&> \p' -> req { H.path = p' }+{-# INLINE path #-}++-- | 'H.queryString' lens+queryString :: Lens' H.Request ByteString+queryString f req = f (H.queryString req) <&> \qs' -> req { H.queryString = qs' }+{-# INLINE queryString #-}++-- | 'H.requestBody' lens+requestBody :: Lens' H.Request H.RequestBody+requestBody f req = f (H.requestBody req) <&> \rb' -> req { H.requestBody = rb' }+{-# INLINE requestBody #-}++-- | 'H.requestHeaders' lens+requestHeaders :: Lens' H.Request H.RequestHeaders+requestHeaders f req = f (H.requestHeaders req) <&> \rh' -> req { H.requestHeaders = rh' }+{-# INLINE requestHeaders #-}++-- | 'H.proxy'+proxy :: Lens' H.Request (Maybe H.Proxy)+proxy f req = f (H.proxy req) <&> \mp' -> req { H.proxy = mp' }+{-# INLINE proxy #-}++-- | 'H.hostAddress'+hostAddress :: Lens' H.Request (Maybe HostAddress)+hostAddress f req = f (H.hostAddress req) <&> \ha' -> req { H.hostAddress = ha' }+{-# INLINE hostAddress #-}++-- | 'H.rawBody'+rawBody :: Lens' H.Request Bool+rawBody f req = f (H.rawBody req) <&> \b' -> req { H.rawBody = b' }+{-# INLINE rawBody #-}++-- | 'H.decompress'+decompress :: Lens' H.Request (ByteString -> Bool)+decompress f req = f (H.decompress req) <&> \btb' -> req { H.decompress = btb' }+{-# INLINE decompress #-}++-- | 'H.redirectCount' lens+redirectCount :: Lens' H.Request Int+redirectCount f req = f (H.redirectCount req) <&> \rc' -> req { H.redirectCount = rc' }+{-# INLINE redirectCount #-}++-- | 'H.checkStatus' lens+checkStatus :: Lens' H.Request (H.Status -> H.ResponseHeaders -> H.CookieJar -> Maybe SomeException)+checkStatus f req = f (H.checkStatus req) <&> \cs' -> req { H.checkStatus = cs' }+{-# INLINE checkStatus #-}++-- | 'H.responseTimeout' lens+responseTimeout :: Lens' H.Request (Maybe Int)+responseTimeout f req = f (H.responseTimeout req) <&> \rt' -> req { H.responseTimeout = rt' }+{-# INLINE responseTimeout #-}++-- | 'H.cookieJar'+cookieJar :: Lens' H.Request (Maybe H.CookieJar)+cookieJar f req = f (H.cookieJar req) <&> \mcj' -> req { H.cookieJar = mcj' }+{-# INLINE cookieJar #-}++-- | 'H.getConnectionWrapper'+getConnectionWrapper+  :: Lens' H.Request+      ( Maybe Int+      -> H.HttpException+      -> IO (H.ConnRelease, H.Connection, H.ManagedConn)+      -> IO (Maybe Int, (H.ConnRelease, H.Connection, H.ManagedConn))+      )+getConnectionWrapper f req =+  f (H.getConnectionWrapper req) <&> \wat' -> req { H.getConnectionWrapper = wat' }+{-# INLINE getConnectionWrapper #-}+++-- | @http-conduit@ exceptions+class AsHttpException p f t where+  -- | @http-conduit@ exceptions overloading+  _HttpException :: Overloaded' p f t H.HttpException++instance AsHttpException p f H.HttpException where+  _HttpException = id+  {-# INLINE _HttpException #-}++instance (Choice p, Applicative f) => AsHttpException p f 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 = _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 = _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 = _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 = _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 = _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 = _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 = _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 = _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 = _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 = _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 =+  _HttpException . prism' (const H.ExpectedBlankAfter100Continue) go where+    go H.ExpectedBlankAfter100Continue = Just ()+    go _ = Nothing+{-# INLINE _ExpectedBlankAfter100Continue #-}++-- | 'H.InvalidStatusLine' exception+_InvalidStatusLine+  :: (AsHttpException p f t, Choice p, Applicative f)+  => Overloaded' p f 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 = _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 = _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 = _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 = _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 = _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 = _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 = _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 = _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 = _HttpException . prism' (const H.IncompleteHeaders) go where+  go H.IncompleteHeaders = Just ()+  go _ = Nothing+{-# INLINE _IncompleteHeaders #-}++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c+{-# INLINE uncurry3 #-}
+ test/Doctest.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
+ test/Jenkins/RestSpec.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+module Jenkins.RestSpec (spec) where++import           Control.Applicative+import           Control.Monad.Trans.State (State, evalState, get, put)+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy+import           Data.Monoid (mempty)+import           Test.Hspec+import qualified Jenkins.Rest as Rest+import           Jenkins.Rest.Internal+++spec :: Spec+spec = do+  context "POST requests" $ do+    it "post_ sends POST request with empty body" $ do+      interpret $ do+        Rest.post_ "foo"+        Rest.post_ "bar"+        Rest.post_ "baz"+     `shouldBe`+      [QPost 0 "" "foo", QPost 1 "" "bar", QPost 2 "" "baz"]++    it "post sends POST request with non-empty body" $ do+      interpret $ do+        Rest.post "foo" "qux"+        Rest.post "bar" "quux"+        Rest.post "baz" "xyzzy"+     `shouldBe`+      [QPost 0 "qux" "foo", QPost 1 "quux" "bar", QPost 2 "xyzzy" "baz"]++  context "GET requests" $+    it "get sends GET requests" $ do+      interpret $ do+        Rest.get "foo"+        Rest.get "bar"+        Rest.get "baz"+     `shouldBe`+      [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+        Rest.reload+        Rest.post_ "foo"+     `shouldBe`+      [QPost 0 "" "reload", QDisconnect]++  describe "restart" $+    it "calls $jenkins_url/safeRestart with POST query and then disconnects" $ do+      interpret $ do+        Rest.restart+        Rest.post_ "bar"+     `shouldBe`+      [QPost 0 "" "safeRestart", QDisconnect]++  describe "forceRestart" $+    it "calls $jenkins_url/restart with POST query and then disconnects" $ do+      interpret $ do+        Rest.forceRestart+        Rest.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]+  deriving (Show, Eq)++interpret :: Rest.Jenkins a -> [Query]+interpret adt = evalState (iterJenkins go ([] <$ adt)) (Requests [0..]) where+  go :: JenkinsF (State (Requests Int) [Query]) -> State (Requests Int) [Query]+  go (Get m n) = do+    r <- render QGet m+    fmap (r :) (n mempty)+  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) -> Rest.Method f x -> State (Requests a) Query+render f m = do+  n <- next+  return $ f n (Rest.render m)++next :: State (Requests a) a+next = do+  Requests (x:xs) <- get+  put (Requests xs)+  return x
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− tests/Doctests.hs 
@@ -1,28 +0,0 @@-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