libjenkins 0.5.0 → 0.6.0

raw patch · 20 files changed

+1322/−1005 lines, 20 filesdep +attoparsecdep +containersdep +http-client-tlsdep −conduitdep −exceptionsdep −http-conduitdep ~asyncdep ~http-clientdep ~lensPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, containers, http-client-tls, lifted-async, lifted-base, mtl, profunctors

Dependencies removed: conduit, exceptions, http-conduit, resourcet

Dependency ranges changed: async, http-client, lens, transformers, xml-conduit

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• bench/Concurrency.hs +16/−12
• example/discover.hs +5/−5
• example/grep-jobs.hs +11/−7
• example/rename-jobs.hs +16/−11
• example/running-jobs-count.hs +16/−12
• libjenkins.cabal +50/−34
• src/Jenkins/Discover.hs +44/−35
• src/Jenkins/Rest.hs +191/−74
• src/Jenkins/Rest/Internal.hs +171/−223
• src/Jenkins/Rest/Method.hs +126/−234
• src/Jenkins/Rest/Method/Internal.hs +141/−0
• src/Network/HTTP/Client/Lens.hs +316/−0
• src/Network/HTTP/Client/Lens/Internal.hs +42/−0
• src/Network/HTTP/Conduit/Lens.hs +0/−316
• test/Doctest.hs +1/−1
• test/Jenkins/DiscoverSpec.hs +66/−0
• test/Jenkins/Rest/InternalSpec.hs +26/−18
• test/Jenkins/Rest/Method/InternalSpec.hs +39/−0
• test/Jenkins/RestSpec.hs +26/−23

@@ -1,3 +1,22 @@+0.6.0+=====++  * Made `orElse` more powerful. The old version is available as `orElse_`++  * Renamed a bunch of things.  The `Jenkins.Rest` module is intended to be imported qualified.++  * Switched to the transformer version of the Church-encoded free monad++  * Removed `getS`. As a side-effect, `get` doesn't leak like crazy anymore++  * Generalized `traverseC_` (again)++  * Removed redundant `jenkinsPort` option: `jenkinsUrl` handles port numbers well enough++  * Reworked API method construction. The new version is safer (it's impossible to forget+    to specify the format of the response), less magical (format is a separate argument to+    the query function), and has fewer corner cases+ 0.5.0 ===== 

@@ -18,7 +18,8 @@ import           Data.Aeson.Lens               -- lens-aeson import           Data.Text (Text)              -- text import qualified Data.Text as Text             -- text-import           Jenkins.Rest                  -- libjenkins+import           Jenkins.Rest (Jenkins, (-?-), (-=-))+import qualified Jenkins.Rest as Jenkins       -- libjenkins import           System.Environment (getArgs)  -- base import           System.Exit (exitFailure)     -- base import           System.IO (hPutStrLn, stderr) -- base@@ -28,32 +29,35 @@  main :: IO () main = do-  m:host:port:user:pass:_ <- getArgs+  m:url:user:token:_ <- getArgs   ds <- descriptions (aggregate m) $-    ConnectInfo host (read port) (Text.pack user) (Text.pack pass)+    Jenkins.defaultMaster+    & Jenkins.url .~ url+    & Jenkins.user .~ Text.pack user+    & Jenkins.apiToken .~ Text.pack token   case ds of-    Result ds' -> mapM_ print ds'-    Disconnect -> die "disconnect!"-    Error e    -> die (show e)+    Jenkins.Ok ds'      -> mapM_ print ds'+    Jenkins.Disconnect  -> die "disconnect!"+    Jenkins.Exception e -> die (show e)  where   die message = do     hPutStrLn stderr message     exitFailure    aggregate :: String -> Aggregate a b-  aggregate "concurrent" = traverseC+  aggregate "concurrent" = Jenkins.traverse   aggregate "sequential" = mapM   aggregate _ = error "Unknown mode"  descriptions   :: Aggregate Text (Maybe Text)-  -> ConnectInfo-  -> IO (Result JenkinsException [Maybe Text])-descriptions aggregate settings = runJenkins settings $ do-  res <- get (json -?- "tree" -=- "jobs[name]")+  -> Jenkins.Master+  -> IO (Jenkins.Result [Maybe Text])+descriptions aggregate settings = Jenkins.run settings $ do+  res <- Jenkins.get Jenkins.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")+  desc <- Jenkins.get Jenkins.json (Jenkins.job name -?- "tree" -=- "description")   return (desc ^? key "description"._String)

@@ -4,8 +4,8 @@  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 qualified Data.Text as Text          -- text+import qualified Data.Text.IO as Text       -- text import           Jenkins.Discover           -- libjenkins import           System.Exit (exitFailure)  -- base @@ -18,12 +18,12 @@     -- no Jenkins responded     [] -> exitFailure     -- pretty print responses-    _  -> mapM_ (T.putStrLn . pretty) discoveries+    _  -> mapM_ (Text.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]+pretty x = Text.unwords $+  "Jenkins" : version x : maybe mempty (return . between "(" ")") (serverId x) ++ ["at", url x]  where   between l r t = l <> t <> r 

@@ -11,7 +11,8 @@ 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           Jenkins.Rest ((-?-), (-=-))+import qualified Jenkins.Rest as Jenkins                   -- libjenkins import           System.Environment (getArgs)              -- base import           System.Exit.Lens                          -- lens import           System.Process (readProcessWithExitCode)  -- process@@ -20,18 +21,21 @@  main :: IO () main = do-  user:pswd:host:port:regex:_ <- getArgs-  jobs <- grep regex (ConnectInfo host (read port) (fromString user) (fromString pswd))+  url:user:token:regex:_ <- getArgs+  jobs <- grep regex $ Jenkins.defaultMaster+    & Jenkins.url .~ url+    & Jenkins.user .~ fromString user+    & Jenkins.apiToken .~ fromString token   case jobs of     [] -> throwingM _ExitFailure 1     _  -> mapM_ Text.putStrLn jobs  -- | Filter matching job names-grep :: String -> ConnectInfo -> IO [Text]+grep :: String -> Jenkins.Master -> 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)+  res <- Jenkins.run conn $+    Jenkins.get Jenkins.json ("/" -?- "tree" -=- "jobs[name]")+  filterM (match regex) (res ^.. Jenkins._Ok.key "jobs".values.key "name"._String)  -- | Match job name again Perl regex match :: String -> Text -> IO Bool

@@ -12,7 +12,8 @@ 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           Jenkins.Rest (Jenkins, (-?-), (-=-), (-/-), liftIO)+import qualified Jenkins.Rest as Jenkins       -- libjenkins import           System.Environment (getArgs)  -- base import           System.Exit (exitFailure)     -- base import           System.IO (hPutStrLn, stderr) -- base@@ -22,7 +23,7 @@  -- | Program options data Options = Options-  { settings :: ConnectInfo+  { settings :: Jenkins.Master   , old      :: Text   , new      :: Text   }@@ -31,25 +32,29 @@ main :: IO () main = do   -- more useful help on error-  host:port:user:pass:o:n:_ <- getArgs-  let opts = Options (ConnectInfo host (read port) (fromString user) (fromString pass)) (fromString o) (fromString n)+  url:user:token:o:n:_ <- getArgs+  let cinf = Jenkins.defaultMaster+        & Jenkins.url .~ url+        & Jenkins.user .~ fromString user+        & Jenkins.apiToken .~ fromString token+      opts = Options cinf (fromString o) (fromString n)   res <- rename opts   case res of-    Result _ -> Text.putStrLn "Done."+    Jenkins.Ok _ -> Text.putStrLn "Done."     -- disconnected for some reason-    Disconnect -> die "disconnect!"+    Jenkins.Disconnect -> die "disconnect!"     -- something bad happened, show it!-    Error e -> die (show e)+    Jenkins.Exception e -> die (show e)  where   die message = do     hPutStrLn stderr message     exitFailure  -- | Prompt to rename all jobs matching pattern-rename :: Options -> IO (Result JenkinsException ())-rename (Options { settings, old, new }) = runJenkins settings $ do+rename :: Options -> IO (Jenkins.Result ())+rename (Options { settings, old, new }) = Jenkins.run settings $ do   -- get jobs names from jenkins "root" API-  res <- get (json -?- "tree" -=- "jobs[name]")+  res <- Jenkins.get Jenkins.json ("/" -?- "tree" -=- "jobs[name]")   let jobs = res ^.. key "jobs".values.key "name"._String   for_ jobs rename_job  where@@ -60,7 +65,7 @@     yes <- prompt $ Text.unwords ["Rename", name, "to", name', "? [y/n]"]     when yes $       -- if user agrees then voodoo comes-      post_ (job name -/- "doRename" -?- "newName" -=- name')+      Jenkins.post_ (Jenkins.job name -/- "doRename" -?- "newName" -=- name')    -- asks user until she enters 'y' or 'n'   prompt message = liftIO . fix $ \loop -> do

@@ -7,24 +7,28 @@ -- it to "blue_anime", meaning "animated blue ball" if job is running module Main (main) where -import Control.Lens                      -- lens-import Data.Aeson.Lens                   -- 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+import           Control.Lens                      -- lens+import           Data.Aeson.Lens                   -- lens-aeson+import           Data.ByteString.Lazy (ByteString) -- bytestring+import           Data.String (fromString)          -- bytestring+import           Jenkins.Rest (Jenkins, (-?-), (-=-))+import qualified Jenkins.Rest as Jenkins -- 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)+  url:user:token:_ <- getArgs+  let creds = Jenkins.defaultMaster+        & Jenkins.url .~ url+        & Jenkins.user .~ fromString user+        & Jenkins.apiToken .~ fromString token+  jobs <- Jenkins.run creds getJobs+  printf "Running jobs count: %d\n" (lengthOf (Jenkins._Ok.running) jobs)  getJobs :: Jenkins ByteString-getJobs = get (json -?- "tree" -=- "jobs[color]")+getJobs = Jenkins.get Jenkins.json ("/" -?- "tree" -=- "jobs[color]")  running :: Fold ByteString () running = key "jobs".values.key "color"._String.only "blue_anime"

@@ -1,5 +1,5 @@ name:                libjenkins-version:             0.5.0+version:             0.6.0 synopsis:            Jenkins API interface description:         Jenkins API interface. It supports REST and Discovery APIs license:             BSD3@@ -26,76 +26,92 @@ source-repository this   type:     git   location: https://github.com/supki/libjenkins-  tag:      0.5.0+  tag:      0.6.0  library-  default-language:  Haskell2010-  hs-source-dirs:    src+  default-language:+    Haskell2010+  build-depends:+      base            >= 4.6 && < 5+    , attoparsec      >= 0.12+    , bytestring      >= 0.9+    , containers+    , free            >= 4.1+    , http-client     >= 0.3.8+    , http-client-tls >= 0.2.2+    , http-types      >= 0.8+    , lifted-async    >= 0.2+    , lifted-base     >= 0.2.3+    , monad-control   >= 0.3+    , profunctors     >= 4.2+    , mtl             >= 2.1+    , network         >= 2.6+    , network-uri     >= 2.6+    , text            >= 0.11+    , transformers+  hs-source-dirs:+    src   exposed-modules:     Jenkins.Discover     Jenkins.Rest     Jenkins.Rest.Internal     Jenkins.Rest.Method-    Network.HTTP.Conduit.Lens-  build-depends:-      async         >= 2.0-    , base          >= 4.6 && < 5-    , bytestring    >= 0.9-    , conduit       >= 1.0-    , free          >= 4.1-    , exceptions    >= 0.6.1-    , http-client   >= 0.2.0.2-    , http-conduit  >= 2.0 && < 2.2-    , http-types    >= 0.8-    , lens          >= 4.0.1-    , monad-control >= 0.3-    , network       >= 2.6-    , network-uri   >= 2.6-    , resourcet     >= 1.1-    , text          >= 0.11-    , transformers  >= 0.3-    , xml-conduit   >= 1.1+    Jenkins.Rest.Method.Internal+    Network.HTTP.Client.Lens+    Network.HTTP.Client.Lens.Internal  test-suite doctest-  default-language:  Haskell2010-  type:              exitcode-stdio-1.0+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0   build-depends:       base          == 4.*     , directory     , doctest     , filepath-  hs-source-dirs:    test-  main-is:           Doctest.hs+  hs-source-dirs:+    test+  main-is:+    Doctest.hs  test-suite spec-  default-language:  Haskell2010-  type:              exitcode-stdio-1.0+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0   build-depends:       async+    , attoparsec     , base          == 4.*     , bytestring-    , conduit+    , containers     , free-    , exceptions     , hspec     , hspec-expectations-lens     , http-client-    , http-conduit+    , http-client-tls     , http-types     , lens+    , lifted-async+    , lifted-base     , monad-control+    , mtl     , network     , network-uri-    , resourcet+    , profunctors     , text     , transformers     , xml-conduit   hs-source-dirs:     src     test-  main-is:           Spec.hs+  main-is:+    Spec.hs   other-modules:+    Jenkins.DiscoverSpec     Jenkins.RestSpec     Jenkins.Rest.InternalSpec+    Jenkins.Rest.Method.InternalSpec   cpp-options:     -DTEST

@@ -5,32 +5,35 @@   ( Discover(..)   , discover #ifdef TEST-  , parse+  , parseXml #endif   ) where -import           Control.Applicative (Applicative(..), (<$>))-import           Control.Lens hiding (element)+import           Control.Applicative+import           Control.Monad+import           Data.Attoparsec.Text import           Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as ByteString+import           Data.Map (Map)+import qualified Data.Map as Map import           Data.Maybe (mapMaybe)+import           Data.Monoid ((<>)) import           Data.Text (Text)+import qualified Data.Text.Encoding as Text import           Network.BSD import           Network.Socket-import           Network.Socket.ByteString as B+import           Network.Socket.ByteString as ByteString import           System.Timeout (timeout)-import           Text.XML-import           Text.XML.Cursor  {-# ANN module ("HLint: ignore Use camelCase" :: String) #-}   -- | Jenkins information data Discover = Discover-  { version   :: Text-  , url       :: Text-  , server_id :: Maybe Text+  { version  :: Text+  , url      :: Text+  , port     :: Maybe Text+  , serverId :: Maybe Text   } deriving (Show, Eq)  @@ -40,12 +43,12 @@   -> IO [Discover] discover t = do   (b, addr) <- broadcastSocket-  B.sendTo b (B.pack [0, 0, 0, 0]) addr -- does not matter what to send+  ByteString.sendTo b (ByteString.pack [0, 0, 0, 0]) addr -- does not matter what to send    msgs <- while (timeout t (readAnswer b))    close b-  return (mapMaybe parse msgs)+  return (mapMaybe parseXml msgs)  where   while :: IO (Maybe a) -> IO [a]   while io = go where@@ -59,31 +62,37 @@ broadcastSocket = do   s <- getProtocolNumber "udp" >>= socket AF_INET Datagram   setSocketOption s Broadcast 1-  return (s, SockAddrInet port (-1) {- 255.255.255.255 -})+  return (s, SockAddrInet p (-1) {- 255.255.255.255 -})  where-  port = 33848+  p = 33848  readAnswer :: Socket -> IO ByteString-readAnswer s = fst <$> B.recvFrom s 4096+readAnswer s = fst <$> ByteString.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 bs = either (const Nothing) Just (parseLBS def (BL.fromStrict bs)) >>= \doc ->-  let-    cursor = fromDocument doc-    tag t  = preview _head (cursor $/ element t &// content)-  in Discover-    <$> tag "version"-    <*> tag "url"-    <*> pure (tag "server-id")+parseXml :: ByteString -> Maybe Discover+parseXml = fromMap <=< either (\_ -> Nothing) Just . parseOnly (parser <* endOfInput) . Text.decodeUtf8++fromMap :: Map Text Text -> Maybe Discover+fromMap m = do+  v <- Map.lookup "version" m+  u <- Map.lookup "url" m+  i <- return (Map.lookup "server-id" m)+  p <- return (Map.lookup "slave-port" m)+  return Discover { version = v, url = u, serverId = i, port = p }++parser :: Parser (Map Text Text)+parser = string "<hudson>" *> tags <* string "</hudson>"++tags :: Parser (Map Text Text)+tags = Map.fromList <$> many tag++tag :: Parser (Text, Text)+tag = do+  _ <- char '<'+  k <- takeWhile1 (/= '>')+  _ <- char '>'+  v <- takeWhile1 (/= '<')+  _ <- string ("</" <> k <> ">")+  return (k, v)

@@ -1,135 +1,252 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -- | Jenkins REST API interface+--+-- This module is intended to be imported qualified. module Jenkins.Rest   ( -- * Query Jenkins-    Jenkins-  , HasConnectInfo(..)-  , ConnectInfo(..)-  , defaultConnectInfo+    run+  , JenkinsT+  , Jenkins   , Result(..)-  , runJenkins+  , HasMaster(..)+  , Master+  , defaultMaster     -- ** Combinators   , get-  , getS   , post   , post_-  , concurrently   , orElse-  , liftIO-  , with+  , orElse_+  , locally+  , disconnect     -- ** Method   , module Jenkins.Rest.Method+    -- ** Concurrency+  , concurrently+  , Jenkins.Rest.traverse+  , Jenkins.Rest.traverse_     -- ** Convenience-  , postXML-  , traverseC-  , traverseC_+  , postXml   , reload   , restart   , forceRestart     -- * Optics-  , jenkinsUrl-  , jenkinsPort-  , jenkinsUser-  , jenkinsApiToken-  , jenkinsPassword-  , _Error+  , _Exception   , _Disconnect-  , _Result+  , _Ok   , JenkinsException(..)     -- * Reexports+  , liftIO   , Request-  , HttpException   ) where  import           Control.Applicative ((<$))-import           Control.Lens-import           Control.Monad.Trans.Resource (ResourceT, runResourceT)-import           Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString as Strict+import           Control.Exception.Lifted (try)+import           Control.Monad+import           Control.Monad.IO.Class (MonadIO(..))+import           Control.Monad.Trans.Control (MonadBaseControl(..)) import qualified Data.ByteString.Lazy as Lazy-import           Data.Conduit (ResumableSource, ($$+-))-import qualified Data.Conduit.List as CL+import           Data.Data (Data, Typeable)+import qualified Data.Foldable as F import           Data.Monoid (mempty)-import           Network.HTTP.Conduit (Request, HttpException)-import           Text.XML (Document, renderLBS, def)+import           Data.Text (Text)+import           Network.HTTP.Client (Request, requestHeaders)  import           Jenkins.Rest.Internal import           Jenkins.Rest.Method-import           Network.HTTP.Conduit.Lens+import           Jenkins.Rest.Method.Internal+import           Network.HTTP.Client.Lens.Internal  --- | @GET@ query+-- | Run a 'JenkinsT' action ----- While the return type is a lazy bytestring, the entire response--- sits in memory anyway: lazy I/O is not used-get :: Method Complete f -> Jenkins Lazy.ByteString-get m = fmap Lazy.fromChunks . liftIO . runResourceT =<< liftJ (Get m ($$+- CL.consume))+-- A successful 'Result' is either @'Disconnect'@ or @'Ok' v@+--+-- If a 'JenkinsException' is thrown by performing a request to Jenkins,+-- 'runJenkins' will catch and wrap it in @'Exception'@. Other exceptions+-- will propagate further+run+  :: (MonadIO m, MonadBaseControl IO m, HasMaster t)+  => t -> JenkinsT m a -> m (Result a)+run c jenk =+  either Exception (maybe Disconnect Ok)+ `liftM`+  try (runInternal (c^.url) (c^.user) (c^.apiToken) jenk) --- | @GET@ query+-- | A handy type synonym for the kind of 'JenkinsT' actions that's used the most+type Jenkins = JenkinsT IO++-- | The result of Jenkins REST API queries+data Result v =+    Exception JenkinsException+    -- ^ Exception was thrown while making requests to Jenkins+  | Disconnect+    -- ^ The client was explicitly disconnected by the user+  | Ok v+    -- ^ The result of uninterrupted execution of a 'JenkinsT' value+    deriving (Show, Typeable)++-- | A prism into Jenkins error+_Exception :: Prism (Result a) (Result a) JenkinsException JenkinsException+_Exception = prism' Exception $ \case+  Exception e -> Just e+  _           -> Nothing+{-# INLINE _Exception #-}++-- | A prism into disconnect+_Disconnect :: Prism' (Result a) ()+_Disconnect = prism' (\_ -> Disconnect) $ \case+  Disconnect -> Just ()+  _          -> Nothing+{-# INLINE _Disconnect #-}+{-# ANN _Disconnect ("HLint: ignore Use const" :: String) #-}++-- | A prism into result+_Ok :: Prism (Result a) (Result b) a b+_Ok = prism Ok $ \case+  Exception e -> Left (Exception e)+  Disconnect  -> Left Disconnect+  Ok a        -> Right a+{-# INLINE _Ok #-}++-- | Jenkins master node connection settings+class HasMaster t where+  master :: Lens' t Master++  -- | Jenkins master node URL+  url :: HasMaster t => Lens' t String+  url = master . \f x -> f (_url x) <&> \p -> x { _url = p }+  {-# INLINE url #-}++  -- | Jenkins user+  user :: HasMaster t => Lens' t Text+  user = master . \f x -> f (_user x) <&> \p -> x { _user = p }+  {-# INLINE user #-}++  -- | Jenkins user's password or API token+  apiToken :: HasMaster t => Lens' t Text+  apiToken = master . \f x -> f (_apiToken x) <&> \p -> x { _apiToken = p }+  {-# INLINE apiToken #-}++-- | Jenkins master node connection settings token+data Master = Master+  { _url      :: String -- ^ Jenkins URL+  , _user     :: Text   -- ^ Jenkins user+  , _apiToken :: Text   -- ^ Jenkins user API token or password+  } deriving (Show, Eq, Typeable, Data)++instance HasMaster Master where+  master = id+  {-# INLINE master #-}++-- | Default Jenkins master node connection settings token ----- If you don't close the source eventually (either explicitly with--- 'Data.Conduit.closeResumableSource' or implicitly by reading from it)--- it will leak a socket.-getS :: Method Complete f -> Jenkins (ResumableSource (ResourceT IO) Strict.ByteString)-getS m = liftJ (Get m id)+-- @+-- view 'url'      defaultConnectInfo = \"http:\/\/example.com\/jenkins\"+-- view 'user'     defaultConnectInfo = \"jenkins\"+-- view 'apiToken' defaultConnectInfo = \"secret\"+-- @+defaultMaster :: Master+defaultMaster = Master+  { _url      = "http://example.com/jenkins"+  , _user     = "jenkins"+  , _apiToken = "secret"+  } --- | @POST@ query (with a payload)-post :: (forall f. Method Complete f) -> Lazy.ByteString -> Jenkins ()++-- | Perform a @GET@ request+--+-- While the return type is the /lazy/ @Bytestring@, the entire response+-- sits in the memory anyway: lazy I/O is not used at the least+get :: Formatter f -> (forall g. Method Complete g) -> JenkinsT m Lazy.ByteString+get (Formatter f) m = liftJ (Get (f m) id)++-- | Perform a @POST@ request+post :: (forall f. Method Complete f) -> Lazy.ByteString -> JenkinsT m () post m body = liftJ (Post m body ()) --- | @POST@ query (without payload)-post_ :: (forall f. Method Complete f) -> Jenkins ()+-- | Perform a @POST@ request without a payload+post_ :: (forall f. Method Complete f) -> JenkinsT m () post_ m = post m mempty --- | Do both queries 'concurrently'-concurrently :: Jenkins a -> Jenkins b -> Jenkins (a, b)-concurrently ja jb = liftJ (Conc ja jb (,))+-- | A simple exception handler. If an exception is raised while the action is+-- executed the handler is executed with it as an argument+orElse :: JenkinsT m a -> (JenkinsException -> JenkinsT m a) -> JenkinsT m a+orElse a b = liftJ (Or a b) --- | @orElse a b@ runs @a@ and only runs @b@ if @a@ has thrown a @JenkinsException@-orElse :: Jenkins a -> Jenkins a -> Jenkins a-orElse ja jb = liftJ (Or ja jb)+-- | A simpler exception handler+--+-- @+-- orElse_ a b = 'orElse' a (\_ -> b)+-- @+orElse_ :: JenkinsT m a -> JenkinsT m a -> JenkinsT m a+orElse_ a b = orElse a (\_ -> b)+{-# ANN orElse_ ("HLint: ignore Use const" :: String) #-} --- | Make local changes to the 'Request'-with :: (Request -> Request) -> Jenkins a -> Jenkins a-with f j = liftJ $ With f j id+-- | @locally f x@ modifies the base 'Request' with @f@ for the execution of @x@+-- (think 'Control.Monad.Trans.Reader.local')+--+-- This is useful for setting the appropriate headers, response timeouts and the like+locally :: (Request -> Request) -> JenkinsT m a -> JenkinsT m a+locally f j = liftJ (With f j id) --- | @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+-- | Disconnect from Jenkins. The following actions are ignored.+disconnect :: JenkinsT m a+disconnect = liftJ Dcon --- | Make a bunch of queries 'concurrently'-traverseC :: (a -> Jenkins b) -> [a] -> Jenkins [b]-traverseC f = foldr go (return [])++-- | Run two actions concurrently+concurrently :: JenkinsT m a -> JenkinsT m b -> JenkinsT m (a, b)+concurrently ja jb = liftJ (Conc ja jb (,))++-- | Map every list element to an action, run them concurrently and collect the results+--+-- @'traverse' : 'Data.Traversable.traverse' :: 'concurrently' : 'Control.Applicative.liftA2' (,)@+traverse :: (a -> JenkinsT m b) -> [a] -> JenkinsT m [b]+traverse f = foldr go (return [])  where   go x xs = do (y, ys) <- concurrently (f x) xs; return (y : ys) --- | Make a bunch of queries 'concurrently' ignoring their results-traverseC_ :: (a -> Jenkins b) -> [a] -> Jenkins ()-traverseC_ f = foldr (\x xs -> () <$ concurrently (f x) xs) (return ())+-- | Map every list element to an action and run them concurrently ignoring the results+--+-- @'traverse_' : 'Data.Foldable.traverse_' :: 'concurrently' : 'Control.Applicative.liftA2' (,)@+traverse_ :: F.Foldable f => (a -> JenkinsT m b) -> f a -> JenkinsT m ()+traverse_ f = F.foldr (\x xs -> () <$ concurrently (f x) xs) (return ()) ++-- | Perform a @POST@ request to Jenkins with the XML document+--+-- Sets up the correct @Content-Type@ header. Mostly useful for updating @config.xml@+-- files for jobs, views, etc+postXml :: (forall f. Method Complete f) -> Lazy.ByteString -> JenkinsT m ()+postXml m = locally (\r -> r { requestHeaders = xmlHeader : requestHeaders r }) . post m+ where+  xmlHeader = ("Content-Type", "text/xml")+ -- | Reload jenkins configuration from disk ----- Calls @/reload@ and disconnects-reload :: Jenkins a+-- Performs @/reload@ and disconnects+reload :: JenkinsT m a reload = do post_ "reload"; disconnect  -- | Restart jenkins safely ----- Calls @/safeRestart@ and disconnects+-- Performs @/safeRestart@ and /disconnects/ -- -- @/safeRestart@ allows all running jobs to complete-restart :: Jenkins a+restart :: JenkinsT m a restart = do post_ "safeRestart"; disconnect --- | Force jenkins to restart without waiting for running jobs to finish+-- | Restart jenkins ----- Calls @/restart@ and disconnects-forceRestart :: Jenkins a+-- Performs @/restart@ and /disconnects/+--+-- @/restart@ restart Jenkins immediately, without waiting for the completion of+-- the building and/or waiting jobs+forceRestart :: JenkinsT m a forceRestart = do post_ "restart"; disconnect---- Disconnect from Jenkins. Any following queries won't be executed-disconnect :: Jenkins a-disconnect = liftJ Dcon-{-# INLINE disconnect #-}

@@ -1,289 +1,237 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK hide #-} -- | Jenkins REST API interface internals module Jenkins.Rest.Internal where  import           Control.Applicative-import           Control.Concurrent.Async (concurrently)-import           Control.Lens+#if ! MIN_VERSION_free(5,0,0)+import           Control.Applicative.Backwards (Backwards(..))+#endif+import           Control.Concurrent.Async.Lifted (concurrently)+import           Control.Exception (Exception(..))+import           Control.Exception.Lifted (bracket, catch, throwIO) import           Control.Monad-import           Control.Monad.Catch (MonadCatch, Exception(..), try, catch, throwM)-import           Control.Monad.Free.Church (F, iterM, liftF)+import           Control.Monad.Free.Church (liftF)+import           Control.Monad.Error (MonadError(..)) 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.Resource (ResourceT)+import           Control.Monad.Reader (MonadReader(..))+import           Control.Monad.State (MonadState(..))+import           Control.Monad.Trans.Free.Church (FT, iterTM)+import           Control.Monad.Trans.Class (MonadTrans(..))+import           Control.Monad.Trans.Control (MonadTransControl(..), MonadBaseControl(..))+import           Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.Reader as Reader import           Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT)+import           Control.Monad.Writer (MonadWriter(..)) import           Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString as Strict-import           Data.Conduit (ResumableSource)-import qualified Data.Conduit as C-import           Data.Data (Data, Typeable) import           Data.Text (Text) import qualified Data.Text.Encoding as Text-import           GHC.Generics (Generic)-import           Network.HTTP.Conduit+import           Data.Typeable (Typeable)+import           Network.HTTP.Client (Request, HttpException)+import qualified Network.HTTP.Client as Http+import qualified Network.HTTP.Client.TLS as Http import           Network.HTTP.Types (Status(..)) -import           Jenkins.Rest.Method (Method, Type(..), render, slash)-import qualified Network.HTTP.Conduit.Lens as Lens+import           Jenkins.Rest.Method.Internal (Method, Type(..), render, slash) -{-# ANN module ("HLint: ignore Use const" :: String) #-} {-# ANN module ("HLint: ignore Use join" :: String) #-}  --- | Jenkins REST API query sequence description-newtype Jenkins a = Jenkins { unJenkins :: F JenkinsF a }-  deriving (Functor, Applicative, Monad)+-- | The value of this type describes Jenkins REST API requests sequence+newtype JenkinsT m a = JenkinsT { unJenkinsT :: FT (JF m) m a }+  deriving (Functor) -instance MonadIO Jenkins where-  liftIO = liftJ . IO+instance MonadIO m => MonadIO (JenkinsT m) where+  liftIO = JenkinsT . liftIO --- | Jenkins REST API query-data JenkinsF a where-  Get  :: Method Complete f -> (ResumableSource (ResourceT IO) Strict.ByteString -> a) -> JenkinsF a-  Post :: (forall f. Method Complete f) -> ByteString -> a -> JenkinsF a-  Conc :: Jenkins a -> Jenkins b -> (a -> b -> c) -> JenkinsF c-  Or   :: Jenkins a -> Jenkins a -> JenkinsF a-  IO   :: IO a -> JenkinsF a-  With :: (Request -> Request) -> Jenkins b -> (b -> a) -> JenkinsF a-  Dcon :: JenkinsF a+instance MonadTrans JenkinsT where+  lift = JenkinsT . lift -instance Functor JenkinsF where+instance Applicative (JenkinsT m) where+  pure = JenkinsT . pure+#if MIN_VERSION_free(5,0,0)+  JenkinsT f <*> JenkinsT x = JenkinsT (f <*> x)+#else+  -- https://github.com/ekmett/free/pull/80+  JenkinsT f <*> JenkinsT x = JenkinsT (forwards (Backwards f <*> Backwards x))+#endif++instance Monad (JenkinsT m) where+  return = JenkinsT . return+  JenkinsT m >>= k = JenkinsT (m >>= unJenkinsT . k)++instance MonadReader r m => MonadReader r (JenkinsT m) where+  ask = JenkinsT ask+  local f = JenkinsT . local f . unJenkinsT++instance MonadWriter w m => MonadWriter w (JenkinsT m) where+  tell = JenkinsT . tell+  listen = JenkinsT . listen . unJenkinsT+  pass = JenkinsT . pass . unJenkinsT+  writer = JenkinsT . writer++instance MonadState s m => MonadState s (JenkinsT m) where+  get = JenkinsT get+  put = JenkinsT . put+  state = JenkinsT . state++instance MonadError e m => MonadError e (JenkinsT m) where+  throwError = JenkinsT . throwError+  m `catchError` f = JenkinsT (unJenkinsT m `catchError` (unJenkinsT . f))+++data JF m a where+  Get :: Method Complete f -> (ByteString -> a) -> JF n a+  Post :: (forall f. Method Complete f) -> ByteString -> a -> JF m a+  Conc :: JenkinsT m a -> JenkinsT m b -> (a -> b -> c) -> JF m c+  Or   :: JenkinsT m a -> (JenkinsException -> JenkinsT m a) -> JF m a+  With :: (Request -> Request) -> JenkinsT m b -> (b -> a) -> JF m a+  Dcon :: JF m a++instance Functor (JF m) where   fmap f (Get  m g)      = Get  m      (f . g)   fmap f (Post m body a) = Post m body (f a)   fmap f (Conc m n g)    = Conc m n    (\a b -> f (g a b))-  fmap f (Or a b)        = Or (fmap f a) (fmap f b)-  fmap f (IO a)          = IO (fmap f a)+  fmap f (Or a b)        = Or (fmap f a) (fmap f . b)   fmap f (With h j g)    = With h j    (f . g)   fmap _ Dcon            = Dcon --- | Lift 'JenkinsF' to 'Jenkins'-liftJ :: JenkinsF a -> Jenkins a-liftJ = Jenkins . liftF+-- | Lift 'JF' to 'JenkinsT'+liftJ :: JF m a -> JenkinsT m a+liftJ = JenkinsT . liftF --- | Jenkins connection settings------ '_jenkinsApiToken' may be user's password, Jenkins--- does not make any distinction between these concepts-data ConnectInfo = ConnectInfo-  { _jenkinsUrl      :: String -- ^ Jenkins URL, e.g. @http:\/\/example.com\/jenkins@-  , _jenkinsPort     :: Int    -- ^ Jenkins port, e.g. @8080@-  , _jenkinsUser     :: Text   -- ^ Jenkins user, e.g. @jenkins@-  , _jenkinsApiToken :: Text   -- ^ Jenkins user API token-  } deriving (Show, Eq, Typeable, Data, Generic) --- | The result of Jenkins REST API queries-data Result e v =-    Error e    -- ^ Exception @e@ was thrown while querying Jenkins-  | Disconnect -- ^ The client was explicitly disconnected-  | Result v   -- ^ Querying successfully finished the with value @v@-    deriving (Show, Eq, Ord, Typeable, Data, Generic)-+-- | The kind of exceptions that can be thrown by performing requests+-- to the Jenkins REST API newtype JenkinsException   = JenkinsHttpException HttpException     deriving (Show, Typeable)  instance Exception JenkinsException --- | Query Jenkins API using 'Jenkins' description------ Successful result is either 'Disconnect' or @ 'Result' v @------ If 'HttpException' was thrown by @http-conduit@, 'runJenkins' catches it--- and wraps in 'Error'. Other exceptions are /not/ catched-runJenkins :: HasConnectInfo t => t -> Jenkins a -> IO (Result JenkinsException a)-runJenkins conn jenk = either Error (maybe Disconnect Result) <$> try (runJenkinsInternal conn jenk) -runJenkinsInternal :: HasConnectInfo t => t -> Jenkins a -> IO (Maybe a)-runJenkinsInternal (view connectInfo -> ConnectInfo h p user token) jenk = do-  url <- parseUrl h-  withManager $ \m ->-    runReaderT (runMaybeT (iterJenkinsIO m jenk))-      . set Lens.port p-      . applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token)+runInternal+  :: (MonadIO m, MonadBaseControl IO m)+  => String -> Text -> Text -> JenkinsT m a -> m (Maybe a)+runInternal h user token jenk = do+  url <- wrapException (liftIO (Http.parseUrl h))+  bracket (newManager Http.tlsManagerSettings) closeManager $ \m ->+    Reader.runReaderT (runMaybeT (runInterpT (iterInterpT m jenk)))+      . Http.applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token)       $ url +newManager :: MonadIO m => Http.ManagerSettings -> m Http.Manager+newManager = liftIO . Http.newManager --- | 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 #-}+closeManager :: MonadIO m => Http.Manager -> m ()+closeManager = liftIO . Http.closeManager --- | A prism into disconnect-_Disconnect :: Prism' (Result e a) ()-_Disconnect = prism' (\_ -> Disconnect) $ \case-  Disconnect -> Just ()-  _          -> Nothing-{-# INLINE _Disconnect #-}+newtype InterpT m a = InterpT+  { runInterpT :: MaybeT (ReaderT Request m) a+  } deriving (Functor) --- | 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 #-}+instance (Functor m, Monad m) => Applicative (InterpT m) where+  pure = return+  (<*>) = ap --- | Interpret 'JenkinsF' AST in 'IO'-iterJenkinsIO-  :: Manager-  -> Jenkins a-  -> MaybeT (ReaderT Request (ResourceT IO)) a-iterJenkinsIO manager = iterJenkins (interpreter manager)+instance Monad m => Monad (InterpT m) where+  return = InterpT . return+  InterpT m >>= k = InterpT (m >>= runInterpT . k) --- | 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+instance (Functor m, Monad m) => Alternative (InterpT m) where+  empty = mzero+  (<|>) = mplus --- | 'JenkinsF' AST interpreter+instance Monad m => MonadPlus (InterpT m) where+  mzero = InterpT mzero+  InterpT x `mplus` InterpT y = InterpT (x `mplus` y)++instance MonadTrans InterpT where+  lift = InterpT . lift . lift++-- | Interpret the 'JF' AST in 'InterpT'+iterInterpT :: (MonadIO m, MonadBaseControl IO m) => Http.Manager -> JenkinsT m a -> InterpT m a+iterInterpT manager = iter (interpreter manager)++-- | Tear down the 'JF' AST with a 'JF'-algebra+iter+  :: (Monad m, Monad (t m), MonadTrans t)+  => (JF m (t m a) -> t m a) -> JenkinsT m a -> t m a+iter go = iterTM go . unJenkinsT++-- | 'JF' AST interpreter interpreter-  :: Manager-  -> JenkinsF (MaybeT (ReaderT Request (ResourceT IO)) a)-  -> MaybeT (ReaderT Request (ResourceT IO)) a+  :: forall m a. (MonadIO m, MonadBaseControl IO m)+  => Http.Manager+  -> JF m (InterpT m a) -> InterpT m a interpreter man = go where-  go (Get m next) = do-    req <- lift ask-    res <- lift . lift $ http (prepareGet m req) man `withException` JenkinsHttpException-    next (responseBody res)-  go (Post m body next) = do-    req <- lift ask-    res <- lift . lift $ http (preparePost m body req) man `withException` JenkinsHttpException-    ()  <- lift . lift $ C.closeResumableSource (responseBody res)-    next+  go :: JF m (InterpT m a) -> InterpT m a+  go (Get m next) = InterpT $ do+    req <- lift Reader.ask+    res <- liftIO $ wrapException (liftM Http.responseBody (Http.httpLbs (prepareGet m req) man))+    runInterpT (next res)+  go (Post m body next) = InterpT $ do+    req <- lift Reader.ask+    _   <- liftIO $ wrapException (Http.httpNoBody (preparePost m body req) man)+    runInterpT next   go (Conc ja jb next) = do-    (a, b) <- intoIO man $ \run -> concurrently (run ja) (run jb)-    c      <- outoIO (return a)-    d      <- outoIO (return b)+    (a, b) <- intoM man $ \run -> concurrently (run ja) (run jb)+    c      <- outoM (return a)+    d      <- outoM (return b)     next c d   go (Or ja jb) = do-    res  <- intoIO man $ \run -> run ja `catch` \(JenkinsHttpException _) -> run jb-    next <- outoIO (return res)+    res  <- intoM man $ \run -> run ja `catch` (run . jb)+    next <- outoM (return res)     next-  go (IO action) = join (liftIO action)-  go (With f jenk next) = do-    res <- mapMaybeT (local f) (iterJenkinsIO man jenk)-    next res+  go (With f jenk next) = InterpT $ do+    res <- mapMaybeT (Reader.local f) (runInterpT (iterInterpT man jenk))+    runInterpT (next res)   go Dcon = mzero -intoIO-  :: Monad m-  => Manager-  -> ((forall b. Jenkins b -> IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT b)))) -> m a)-  -> MaybeT (ReaderT Request (ResourceT m)) a-intoIO m f =-  liftWith $ \run' -> liftWith $ \run'' -> liftWith $ \run''' ->+intoM+  :: forall m a. (MonadIO m, MonadBaseControl IO m)+  => Http.Manager+  -> ((forall b. JenkinsT m b -> m (StT (ReaderT Request) (StT MaybeT b))) -> m a)+  -> InterpT m a+intoM m f = InterpT $+  liftWith $ \run' -> liftWith $ \run''' ->     let-      run :: Jenkins t -> IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT t)))-      run = run''' . run'' . run' . iterJenkinsIO m+      run :: JenkinsT m t -> m (StT (ReaderT Request) (StT MaybeT t))+      run = run''' . run' . runInterpT . iterInterpT m     in       f run -outoIO-  :: IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT b)))-  -> MaybeT (ReaderT Request (ResourceT IO)) b-outoIO = restoreT . restoreT . restoreT+outoM :: Monad m => m (StT (ReaderT Request) (StT MaybeT b)) -> InterpT m b+outoM = InterpT . restoreT . restoreT  prepareGet :: Method Complete f -> Request -> Request-prepareGet m = set Lens.method "GET" . over Lens.path (`slash` render m)+prepareGet m r = r+  { Http.method = "GET"+  , Http.path   = Http.path r `slash` render m+  }  preparePost :: Method Complete f -> ByteString -> Request -> Request-preparePost m body =-    set Lens.checkStatus statusCheck-  . set Lens.redirectCount 0-  . set Lens.requestBody (RequestBodyLBS body)-  . set Lens.method "POST"-  . over Lens.path (`slash` render m)+preparePost m body r = r+  { Http.checkStatus   = statusCheck+  , Http.redirectCount = 0+  , Http.requestBody   = Http.RequestBodyLBS body+  , Http.method        = "POST"+  , Http.path          = Http.path r `slash` render m+  }  where   statusCheck s@(Status st _) hs cookie_jar =-    if 200 <= st && st < 400 then Nothing else Just . toException $ StatusCodeException s hs cookie_jar--withException :: (MonadCatch m, Exception e, Exception e') => m a -> (e -> e') -> m a-withException io f = io `catch` \e -> throwM (f e)----- | Default Jenkins connection settings------ @--- 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 = ""-  }---- | Convenience class aimed at elimination of long--- chains of lenses to access jenkins connection configuration------ For example, if you have a configuration record in your application:------ @--- data Config = Config---   { ...---   , _jenkinsConnectInfo :: ConnectInfo---   , ...---   }--- @------ you can make it an instance of 'HasConnectInfo':------ @--- instance HasConnectInfo Config where---   connectInfo f x = (\p -> x { _jenkinsConnectInfo = p }) \<$\> f (_jenkinsConnectInfo x)--- @------ and then use e.g. @view jenkinsUrl config@ to get the url part of the jenkins connection-class HasConnectInfo t where-  connectInfo :: Lens' t ConnectInfo--instance HasConnectInfo ConnectInfo where-  connectInfo = id-  {-# INLINE connectInfo #-}---- | A lens into Jenkins URL-jenkinsUrl :: HasConnectInfo t => Lens' t String-jenkinsUrl = connectInfo . \f x ->  f (_jenkinsUrl x) <&> \p -> x { _jenkinsUrl = p }-{-# INLINE jenkinsUrl #-}---- | A lens into Jenkins port-jenkinsPort :: HasConnectInfo t => Lens' t Int-jenkinsPort = connectInfo . \f x -> f (_jenkinsPort x) <&> \p -> x { _jenkinsPort = p }-{-# INLINE jenkinsPort #-}---- | A lens into Jenkins user-jenkinsUser :: HasConnectInfo t => Lens' t Text-jenkinsUser = connectInfo . \f x -> f (_jenkinsUser x) <&> \p -> x { _jenkinsUser = p }-{-# INLINE jenkinsUser #-}---- | A lens into Jenkins user API token-jenkinsApiToken :: HasConnectInfo t => Lens' t Text-jenkinsApiToken = connectInfo . \f x -> f (_jenkinsApiToken x) <&> \p -> x { _jenkinsApiToken = p }-{-# INLINE jenkinsApiToken #-}+    if 200 <= st && st < 400 then Nothing else Just . toException $ Http.StatusCodeException s hs cookie_jar --- | A lens into Jenkins password------ @--- jenkinsPassword = jenkinsApiToken--- @-jenkinsPassword :: HasConnectInfo t => Lens' t Text-jenkinsPassword = jenkinsApiToken-{-# INLINE jenkinsPassword #-}+wrapException :: MonadBaseControl IO m => m a -> m a+wrapException m = m `catch` (throwIO .  JenkinsHttpException)

@@ -1,303 +1,195 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}--- | Jenkins REST API method construction+{-# LANGUAGE RankNTypes #-}+-- | Jenkins REST API methods module Jenkins.Rest.Method-  ( -- * Types-    Method-  , Type(..)-  , Format-  , As-    -- * Method construction-  , text, int-  , (-?-), (-/-), (-=-), (-&-)+  ( -- * Construct URLs+    -- ** Path+    text+  , int+  , (-/-)+    -- ** Query+  , (-=-)+  , (-&-)   , query-  , as-  , JSONy(..)-  , XMLy(..)-  , Pythony(..)-    -- * Shortcuts-  , job+    -- ** Put together the segments and the query+  , (-?-)+    -- ** Format+  , Formatter+  , json+  , xml+  , python+  , plain+  , -- * Shortcuts+    job   , build   , view   , queue   , overallLoad   , computer-    -- * Rendering-  , render-  , slash+    -- * Types+  , Method+  , Type(..)+  , Format(..)   ) 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)+import Data.Text (Text) +import Jenkins.Rest.Method.Internal++ -- $setup+-- >>> :set -XDataKinds -- >>> :set -XOverloadedStrings+-- >>> class P t where pp :: Method t f -> Data.ByteString.ByteString+-- >>> instance P Complete where pp = render+-- >>> instance P Query    where pp = renderQ'+-- >>> let pp' = render  -infix  1 :~?, -?--infix  3 :~@, `as`-infix  7 :~=, -=--infixr 5 :~/, -/-, :~&, -&-+infix  1 -?-+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"-  (*)         = 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'+-- | Use a string as an URI segment+--+-- >>> pp (text "foo")+-- "foo"+--+-- /Note:/ with @-XOverloadedStrings@ extension enabled it's possible to use string+-- literals as segments of the Jenkins API method URL+--+-- >>> pp' "foo"+-- "foo"+--+-- /Note:/ don't put @/@ in the string literal unless you want it URL-encoded,+-- use @(-/-)@ instead+--+-- >>> pp' "foo/bar"+-- "foo%2Fbar" text :: Text -> Method Complete f text = Text --- | Convert 'Integer' to 'Method'-int :: Integer -> Method Complete f-int = fromInteger+-- | Use an integer as an URI segment+--+-- >>> pp (int 4)+-- "4"+int :: Int -> Method Complete f+int = fromIntegral --- | Combine 2 paths+-- | Combine two paths+--+-- >>> pp ("foo" -/- "bar" -/- "baz")+-- "foo/bar/baz" (-/-) :: 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+-- | Make a key-value pair+--+-- >>> pp ("foo" -=- "bar")+-- "foo=bar" (-=-) :: 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+x -=- y = x := Just y --- | Combine path and query-(-?-) :: Method Complete f -> Method Query f -> Method Complete f-(-?-) = (:~?)+-- | Create the union of two queries+--+-- >>> pp ("foo" -=- "bar" -&- "baz")+-- "foo=bar&baz"+(-&-) :: Method Query f -> Method Query f -> Method Query f+(-&-) = (:&) --- | List-to-query convenience combinator+-- | Take a list of key-value pairs and render them as a query ----- >>> render (query [("foo", Nothing), ("bar", Just "baz"), ("quux", Nothing)])+-- >>> pp (query [("foo", Nothing), ("bar", Just "baz"), ("quux", Nothing)]) -- "foo&bar=baz&quux" ----- >>> render (query [])+-- >>> pp (query []) -- "" query :: [(Text, Maybe Text)] -> Method Query f-query [] = Empty-query xs = foldr1 (:~&) (map (uncurry (:~=)) xs)-+query = foldr ((:&) . uncurry (:=)) Empty --- | 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"+-- | Put path and query together ----- >>> 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"+-- >>> pp ("qux" -/- "quux" -?- "foo" -=- "bar" -&- "baz")+-- "qux/quux?foo=bar&baz"+(-?-) :: Method Complete f -> Method Query f -> Method Complete f+(-?-) = (:?) --- | Render unicode text as a query string------ >>> renderText "foo-bar-baz"--- "foo-bar-baz"------ >>> renderText "foo bar baz"--- "foo%20bar%20baz"+-- | Append the JSON formatting request to the method URL ----- >>> 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 "?"+-- >>> format json "foo"+-- "foo/api/json"+json :: Formatter Json+json = Formatter (\m -> m :@ SJson)+{-# ANN json ("HLint: ignore Avoid lambda" :: String) #-} --- | Insert 'String'-like thing between two 'String'-like things and concatenate everything.+-- | Append the XML formatting request to the method URL ----- >>> "foo" `slash` "bar"--- "foo/bar"+-- >>> format xml "foo"+-- "foo/api/xml"+xml :: Formatter Xml+xml = Formatter (\m -> m :@ SXml)+{-# ANN xml ("HLint: ignore Avoid lambda" :: String) #-}++-- | Append the Python formatting request to the method URL ----- >>> "" `ampersand` "foo"--- "&foo"+-- >>> format python "foo"+-- "foo/api/python"+python :: Formatter Python+python = Formatter (\m -> m :@ SPython)+{-# ANN python ("HLint: ignore Avoid lambda" :: String) #-}++-- | The formatter that does exactly nothing ----- >>> "foo" `question` ""--- "foo?"-insert :: (IsString m, Monoid m) => m -> m -> m -> m-insert t x y = x <> t <> y+-- >>> format plain "foo"+-- "foo"+plain :: Formatter f+plain = Formatter (\m -> m)+{-# ANN plain ("HLint: ignore Use id" :: String) #-}  --- | Job API method+-- | Job data ----- >>> render (job "name" `as` json)+-- >>> format json (job "name") -- "job/name/api/json"+--+-- >>> pp (job "name" -/- "config.xml")+-- "job/name/config.xml" job :: Text -> Method Complete f job name = "job" -/- text name --- | Job build API method+-- | Job build data ----- >>> render (build "name" 4 `as` json)+-- >>> format json (build "name" 4) -- "job/name/4/api/json"-build :: Integral a => Text -> a -> Method Complete f-build name num = "job" -/- text name -/- int (toInteger num)+build :: Text -> Int -> Method Complete f+build name num = "job" -/- text name -/- int num --- | View API method+-- | View data ----- >>> render (view "name" `as` xml)+-- >>> format xml (view "name") -- "view/name/api/xml" view :: Text -> Method Complete f view name = "view" -/- text name --- | Queue API method+-- | Build queue data ----- >>> render (queue `as` python)+-- >>> format python queue -- "queue/api/python" queue :: Method Complete f queue = "queue" --- | Statistics API method+-- | Server statistics ----- >>> render (overallLoad `as` xml)+-- >>> format xml overallLoad -- "overallLoad/api/xml" overallLoad :: Method Complete f overallLoad = "overallLoad" --- | Node API method+-- | Nodes data ----- >>> render (computer `as` python)+-- >>> format python computer -- "computer/api/python" computer :: Method Complete f computer = "computer"

@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_HADDOCK hide #-}+-- | Jenkins REST API method construction+module Jenkins.Rest.Method.Internal where++import           Control.Applicative+import           Data.ByteString (ByteString)+import           Data.Data (Data, Typeable)+import           Data.Monoid (Monoid(..), (<>))+import           Data.String (IsString(..))+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import           Data.Text (Text)+import           Network.URI (escapeURIChar, isUnreserved)++-- $setup+-- >>> :set -XOverloadedStrings+++infix  1 :?+infix  3 :@+infix  7 :=+infixr 5 :/, :&++-- | Jenkins RESTFul API method encoding+data Method :: Type -> Format -> * where+  Empty :: Method Query f+  Text  :: Text -> Method Complete f+  (:/)  :: Method Complete f -> Method Complete 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+  (:@)  :: Method Complete f -> SFormat f -> Method Complete f++deriving instance Show (SFormat f) => Show (Method t f)++-- | Only to support numeric literals+instance t ~ Complete => Num (Method t f) where+  (+)         = error "Method.(+): not supposed to be used"+  (-)         = error "Method.(-): not supposed to be used"+  (*)         = error "Method.(*): not supposed to be used"+  abs         = error "Method.abs: not supposed to be used"+  signum      = error "Method.signum: not supposed to be used"+  fromInteger = fromString . show++instance IsString (Method Complete f) where+  fromString = Text . fromString++instance IsString (Method Query f) where+  fromString str = fromString str := Nothing++-- | Method types+data Type = Query | Complete+  deriving (Show, Eq, Typeable, Data)++-- | Response formats+data Format = Json | Xml | Python+  deriving (Show, Eq, Typeable, Data)++data SFormat :: Format -> * where+  SJson   :: SFormat Json+  SXml    :: SFormat Xml+  SPython :: SFormat Python+++-- | 'Formatter's know how to append the \"api/$format\" string to the method URL+newtype Formatter g = Formatter+  { unFormatter :: (forall f. Method Complete f) -> Method Complete g+  }++format :: Formatter f -> (forall g. Method Complete g) -> ByteString+format f m = render (unFormatter f m)++-- | Render 'Method' to something that can be sent over the wire+render :: Method Complete f -> ByteString+render m = maybe id (flip (insert "?")) (renderQ m) . maybe id (flip (insert "/")) (renderF m) . renderP $ m++-- | Render the method path+renderP :: Method Complete f -> ByteString+renderP (Text s) = renderT s+renderP (x :/ y) = renderP x `slash` renderP y+renderP (x :? _) = renderP x+renderP (x :@ _) = renderP x++-- | Render the query string+renderQ :: Method Complete f -> Maybe ByteString+renderQ (Text _)  = Nothing+renderQ (q :/ q') = renderQ q <|> renderQ q'+renderQ (q :@ _)  = renderQ q+renderQ (_ :? q)  = Just (renderQ' q)++renderQ' :: Method Query f -> ByteString+renderQ' (x :& y)       = insert "&" (renderQ' x) (renderQ' y)+renderQ' (x := Just y)  = insert "=" (renderT x)  (renderT y)+renderQ' (x := Nothing) = renderT x+renderQ' Empty          = renderT ""++-- | Render the response format string+renderF :: Method Complete f -> Maybe ByteString+renderF (_ :@ SJson)   = Just "api/json"+renderF (_ :@ SXml)    = Just "api/xml"+renderF (_ :@ SPython) = Just "api/python"+renderF _              = Nothing++-- | Render unicode text as a query string+--+-- >>> renderT "foo-bar-baz"+-- "foo-bar-baz"+--+-- >>> renderT "foo bar baz"+-- "foo%20bar%20baz"+--+-- >>> renderT "ДМИТРИЙ МАЛИКОВ"+-- "%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"+renderT :: Text -> ByteString+renderT = Text.encodeUtf8 . Text.concatMap (fromString . escapeURIChar isUnreserved)++-- | Insert \"\/\" between two 'String'-like things and concatenate everything.+slash :: (IsString m, Monoid m, Eq m) => m -> m -> m+slash = insert "/"++-- | Insert 'String'-like thing between two 'String'-like things and concatenate everything.+--+-- >>> "foo" `slash` "bar"+-- "foo/bar"+--+-- >>> "foo" `slash` ""+-- "foo"+insert :: (Monoid m, Eq m) => m -> m -> m -> m+insert t x y+  | x == mempty = y+  | y == mempty = x+  | otherwise   = x <> t <> y

@@ -0,0 +1,316 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Optics for @http-client@ types+module Network.HTTP.Client.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.Exception (SomeException, IOException)+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as Lazy+import           Data.Word (Word64)+import qualified Network.HTTP.Client as H+import qualified Network.HTTP.Client.Internal as H+import qualified Network.HTTP.Types as H+import           Network.Socket (HostAddress)++import           Network.HTTP.Client.Lens.Internal+++-- | '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 t where+  -- | @http-conduit@ exceptions overloading+  _HttpException :: Prism' t H.HttpException++instance AsHttpException H.HttpException where+  _HttpException = id+  {-# INLINE _HttpException #-}++instance AsHttpException SomeException where+  _HttpException = exception+  {-# INLINE _HttpException #-}++-- | 'H.StatusCodeException' exception+_StatusCodeException :: AsHttpException t => Prism' t (H.Status, H.ResponseHeaders, H.CookieJar)+_StatusCodeException = _HttpException . prism' (uncurry3 H.StatusCodeException) go where+  go (H.StatusCodeException s rh cj) = Just (s, rh, cj)+  go _ = Nothing+{-# INLINE _StatusCodeException #-}++-- | 'H.InvalidUrlException' exception+_InvalidUrlException :: AsHttpException t => Prism' t (String, String)+_InvalidUrlException = _HttpException . prism' (uncurry H.InvalidUrlException) go where+  go (H.InvalidUrlException s s') = Just (s, s')+  go _ = Nothing+{-# INLINE _InvalidUrlException #-}++-- | 'H.TooManyRedirects' exception+_TooManyRedirects :: AsHttpException t => Prism' t [H.Response Lazy.ByteString]+_TooManyRedirects = _HttpException . prism' H.TooManyRedirects go where+  go (H.TooManyRedirects rs) = Just rs+  go _ = Nothing+{-# INLINE _TooManyRedirects #-}++-- | 'H.UnparseableRedirect' exception+_UnparseableRedirect :: AsHttpException t => Prism' t (H.Response Lazy.ByteString)+_UnparseableRedirect = _HttpException . prism' H.UnparseableRedirect go where+  go (H.UnparseableRedirect r) = Just r+  go _ = Nothing+{-# INLINE _UnparseableRedirect #-}++-- | 'H.TooManyRetries' exception+_TooManyRetries :: AsHttpException t => Prism' t ()+_TooManyRetries = _HttpException . prism' (const H.TooManyRetries) go where+  go H.TooManyRetries = Just ()+  go _ = Nothing+{-# INLINE _TooManyRetries #-}++-- | 'H.HttpParserException' exception+_HttpParserException :: AsHttpException t => Prism' t String+_HttpParserException = _HttpException . prism' H.HttpParserException go where+  go (H.HttpParserException s) = Just s+  go _ = Nothing+{-# INLINE _HttpParserException #-}++-- | 'H.HandshakeFailed' exception+_HandshakeFailed :: AsHttpException t => Prism' t ()+_HandshakeFailed = _HttpException . prism' (const H.HandshakeFailed) go where+  go H.HandshakeFailed = Just ()+  go _ = Nothing+{-# INLINE _HandshakeFailed #-}++-- | 'H.OverlongHeaders' exception+_OverlongHeaders :: AsHttpException t => Prism' t ()+_OverlongHeaders = _HttpException . prism' (const H.OverlongHeaders) go where+  go H.OverlongHeaders = Just ()+  go _ = Nothing+{-# INLINE _OverlongHeaders #-}++-- | 'H.ResponseTimeout' exception+_ResponseTimeout :: AsHttpException t => Prism' t ()+_ResponseTimeout = _HttpException . prism' (const H.ResponseTimeout) go where+  go H.ResponseTimeout = Just ()+  go _ = Nothing+{-# INLINE _ResponseTimeout #-}++-- | 'H.FailedConnectionException' exception+_FailedConnectionException :: AsHttpException t => Prism' t (String, Int)+_FailedConnectionException = _HttpException . prism' (uncurry H.FailedConnectionException) go where+  go (H.FailedConnectionException s i) = Just (s, i)+  go _ = Nothing+{-# INLINE _FailedConnectionException #-}++-- | 'H.ExpectedBlankAfter100Continue' exception+_ExpectedBlankAfter100Continue :: AsHttpException t => Prism' t ()+_ExpectedBlankAfter100Continue =+  _HttpException . prism' (const H.ExpectedBlankAfter100Continue) go where+    go H.ExpectedBlankAfter100Continue = Just ()+    go _ = Nothing+{-# INLINE _ExpectedBlankAfter100Continue #-}++-- | 'H.InvalidStatusLine' exception+_InvalidStatusLine :: AsHttpException t => Prism' t ByteString+_InvalidStatusLine = _HttpException . prism' H.InvalidStatusLine go where+  go (H.InvalidStatusLine b) = Just b+  go _ = Nothing+{-# INLINE _InvalidStatusLine #-}++-- | 'H.InvalidHeader' exception+_InvalidHeader :: AsHttpException t => Prism' t ByteString+_InvalidHeader = _HttpException . prism' H.InvalidHeader go where+  go (H.InvalidHeader b) = Just b+  go _ = Nothing+{-# INLINE _InvalidHeader #-}++-- | 'H.InternalIOException' exception+_InternalIOException :: AsHttpException t => Prism' t IOException+_InternalIOException = _HttpException . prism' H.InternalIOException go where+  go (H.InternalIOException ioe) = Just ioe+  go _ = Nothing+{-# INLINE _InternalIOException #-}++-- | 'H.ProxyConnectException' exception+_ProxyConnectException :: AsHttpException t => Prism' t (ByteString, Int, Either ByteString H.HttpException)+_ProxyConnectException = _HttpException . prism' (uncurry3 H.ProxyConnectException) go where+  go (H.ProxyConnectException b i ebhe) = Just (b, i, ebhe)+  go _ = Nothing+{-# INLINE _ProxyConnectException #-}++-- | 'H.NoResponseDataReceived' exception+_NoResponseDataReceived :: AsHttpException t => Prism' t ()+_NoResponseDataReceived = _HttpException . prism' (const H.NoResponseDataReceived) go where+  go H.NoResponseDataReceived = Just ()+  go _ = Nothing+{-# INLINE _NoResponseDataReceived #-}++-- | 'H.TlsException' exception+_TlsException :: AsHttpException t => Prism' t SomeException+_TlsException = _HttpException . prism' H.TlsException go where+  go (H.TlsException se) = Just se+  go _ = Nothing+{-# INLINE _TlsException #-}++-- | 'H.TlsNotSupported' exception+_TlsNotSupported :: AsHttpException t => Prism' t ()+_TlsNotSupported = _HttpException . prism' (const H.TlsNotSupported) go where+  go H.TlsNotSupported = Just ()+  go _ = Nothing+{-# INLINE _TlsNotSupported #-}++-- | 'H.ResponseBodyTooShort' exception+_ResponseBodyTooShort :: AsHttpException t => Prism' t (Word64, Word64)+_ResponseBodyTooShort = _HttpException . prism' (uncurry H.ResponseBodyTooShort) go where+  go (H.ResponseBodyTooShort w w') = Just (w, w')+  go _ = Nothing+{-# INLINE _ResponseBodyTooShort #-}++-- | 'H.InvalidChunkHeaders' exception+_InvalidChunkHeaders :: AsHttpException t => Prism' t ()+_InvalidChunkHeaders = _HttpException . prism' (const H.InvalidChunkHeaders) go where+  go H.InvalidChunkHeaders = Just ()+  go _ = Nothing+{-# INLINE _InvalidChunkHeaders #-}++-- | 'H.IncompleteHeaders' exception+_IncompleteHeaders :: AsHttpException t => Prism' 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 #-}

@@ -0,0 +1,42 @@+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK hide #-}+module Network.HTTP.Client.Lens.Internal where++import Control.Applicative+import Control.Exception (Exception(..), SomeException)+import Data.Profunctor (Profunctor(..), Choice(..))+++type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)++type Prism' s a = Prism s s a a++type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++type Lens' s a = Lens s s a a+++view :: Lens' s a -> s -> a+view l = getConst . l Const+{-# INLINE view #-}++(^.) :: s -> Lens' s a -> a+(^.) = flip view+{-# INLINE (^.) #-}++prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism bt seta = dimap seta (either pure (fmap bt)) . right'+{-# INLINE prism #-}++prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b+prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))+{-# INLINE prism' #-}++exception :: Exception a => Prism' SomeException a+exception = prism' toException fromException+{-# INLINE exception #-}++infixl 1 <&>+(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = flip fmap+{-# INLINE (<&>) #-}

@@ -1,316 +0,0 @@-{-# 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.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 t where-  -- | @http-conduit@ exceptions overloading-  _HttpException :: Prism' t H.HttpException--instance AsHttpException H.HttpException where-  _HttpException = id-  {-# INLINE _HttpException #-}--instance AsHttpException SomeException where-  _HttpException = exception-  {-# INLINE _HttpException #-}---- | 'H.StatusCodeException' exception-_StatusCodeException :: AsHttpException t => Prism' t (H.Status, H.ResponseHeaders, H.CookieJar)-_StatusCodeException = _HttpException . prism' (uncurry3 H.StatusCodeException) go where-  go (H.StatusCodeException s rh cj) = Just (s, rh, cj)-  go _ = Nothing-{-# INLINE _StatusCodeException #-}---- | 'H.InvalidUrlException' exception-_InvalidUrlException :: AsHttpException t => Prism' t (String, String)-_InvalidUrlException = _HttpException . prism' (uncurry H.InvalidUrlException) go where-  go (H.InvalidUrlException s s') = Just (s, s')-  go _ = Nothing-{-# INLINE _InvalidUrlException #-}---- | 'H.TooManyRedirects' exception-_TooManyRedirects :: AsHttpException t => Prism' t [H.Response Lazy.ByteString]-_TooManyRedirects = _HttpException . prism' H.TooManyRedirects go where-  go (H.TooManyRedirects rs) = Just rs-  go _ = Nothing-{-# INLINE _TooManyRedirects #-}---- | 'H.UnparseableRedirect' exception-_UnparseableRedirect :: AsHttpException t => Prism' t (H.Response Lazy.ByteString)-_UnparseableRedirect = _HttpException . prism' H.UnparseableRedirect go where-  go (H.UnparseableRedirect r) = Just r-  go _ = Nothing-{-# INLINE _UnparseableRedirect #-}---- | 'H.TooManyRetries' exception-_TooManyRetries :: AsHttpException t => Prism' t ()-_TooManyRetries = _HttpException . prism' (const H.TooManyRetries) go where-  go H.TooManyRetries = Just ()-  go _ = Nothing-{-# INLINE _TooManyRetries #-}---- | 'H.HttpParserException' exception-_HttpParserException :: AsHttpException t => Prism' t String-_HttpParserException = _HttpException . prism' H.HttpParserException go where-  go (H.HttpParserException s) = Just s-  go _ = Nothing-{-# INLINE _HttpParserException #-}---- | 'H.HandshakeFailed' exception-_HandshakeFailed :: AsHttpException t => Prism' t ()-_HandshakeFailed = _HttpException . prism' (const H.HandshakeFailed) go where-  go H.HandshakeFailed = Just ()-  go _ = Nothing-{-# INLINE _HandshakeFailed #-}---- | 'H.OverlongHeaders' exception-_OverlongHeaders :: AsHttpException t => Prism' t ()-_OverlongHeaders = _HttpException . prism' (const H.OverlongHeaders) go where-  go H.OverlongHeaders = Just ()-  go _ = Nothing-{-# INLINE _OverlongHeaders #-}---- | 'H.ResponseTimeout' exception-_ResponseTimeout :: AsHttpException t => Prism' t ()-_ResponseTimeout = _HttpException . prism' (const H.ResponseTimeout) go where-  go H.ResponseTimeout = Just ()-  go _ = Nothing-{-# INLINE _ResponseTimeout #-}---- | 'H.FailedConnectionException' exception-_FailedConnectionException :: AsHttpException t => Prism' t (String, Int)-_FailedConnectionException = _HttpException . prism' (uncurry H.FailedConnectionException) go where-  go (H.FailedConnectionException s i) = Just (s, i)-  go _ = Nothing-{-# INLINE _FailedConnectionException #-}---- | 'H.ExpectedBlankAfter100Continue' exception-_ExpectedBlankAfter100Continue :: AsHttpException t => Prism' t ()-_ExpectedBlankAfter100Continue =-  _HttpException . prism' (const H.ExpectedBlankAfter100Continue) go where-    go H.ExpectedBlankAfter100Continue = Just ()-    go _ = Nothing-{-# INLINE _ExpectedBlankAfter100Continue #-}---- | 'H.InvalidStatusLine' exception-_InvalidStatusLine :: AsHttpException t => Prism' t ByteString-_InvalidStatusLine = _HttpException . prism' H.InvalidStatusLine go where-  go (H.InvalidStatusLine b) = Just b-  go _ = Nothing-{-# INLINE _InvalidStatusLine #-}---- | 'H.InvalidHeader' exception-_InvalidHeader :: AsHttpException t => Prism' t ByteString-_InvalidHeader = _HttpException . prism' H.InvalidHeader go where-  go (H.InvalidHeader b) = Just b-  go _ = Nothing-{-# INLINE _InvalidHeader #-}---- | 'H.InternalIOException' exception-_InternalIOException :: AsHttpException t => Prism' t IOException-_InternalIOException = _HttpException . prism' H.InternalIOException go where-  go (H.InternalIOException ioe) = Just ioe-  go _ = Nothing-{-# INLINE _InternalIOException #-}---- | 'H.ProxyConnectException' exception-_ProxyConnectException :: AsHttpException t => Prism' t (ByteString, Int, Either ByteString H.HttpException)-_ProxyConnectException = _HttpException . prism' (uncurry3 H.ProxyConnectException) go where-  go (H.ProxyConnectException b i ebhe) = Just (b, i, ebhe)-  go _ = Nothing-{-# INLINE _ProxyConnectException #-}---- | 'H.NoResponseDataReceived' exception-_NoResponseDataReceived :: AsHttpException t => Prism' t ()-_NoResponseDataReceived = _HttpException . prism' (const H.NoResponseDataReceived) go where-  go H.NoResponseDataReceived = Just ()-  go _ = Nothing-{-# INLINE _NoResponseDataReceived #-}---- | 'H.TlsException' exception-_TlsException :: AsHttpException t => Prism' t SomeException-_TlsException = _HttpException . prism' H.TlsException go where-  go (H.TlsException se) = Just se-  go _ = Nothing-{-# INLINE _TlsException #-}---- | 'H.TlsNotSupported' exception-_TlsNotSupported :: AsHttpException t => Prism' t ()-_TlsNotSupported = _HttpException . prism' (const H.TlsNotSupported) go where-  go H.TlsNotSupported = Just ()-  go _ = Nothing-{-# INLINE _TlsNotSupported #-}---- | 'H.ResponseBodyTooShort' exception-_ResponseBodyTooShort :: AsHttpException t => Prism' t (Word64, Word64)-_ResponseBodyTooShort = _HttpException . prism' (uncurry H.ResponseBodyTooShort) go where-  go (H.ResponseBodyTooShort w w') = Just (w, w')-  go _ = Nothing-{-# INLINE _ResponseBodyTooShort #-}---- | 'H.InvalidChunkHeaders' exception-_InvalidChunkHeaders :: AsHttpException t => Prism' t ()-_InvalidChunkHeaders = _HttpException . prism' (const H.InvalidChunkHeaders) go where-  go H.InvalidChunkHeaders = Just ()-  go _ = Nothing-{-# INLINE _InvalidChunkHeaders #-}---- | 'H.IncompleteHeaders' exception-_IncompleteHeaders :: AsHttpException t => Prism' 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 #-}

@@ -9,7 +9,7 @@   main :: IO ()-main = sources "src" >>= doctest+main = sources "src" >>= doctest . (["-optP-include", "-optPdist/build/autogen/cabal_macros.h"] ++)  sources :: FilePath -> IO [FilePath] sources root = do

@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+module Jenkins.DiscoverSpec (spec) where++import Data.ByteString (ByteString)+import Test.Hspec++import Jenkins.Discover+++spec :: Spec+spec =+  describe "parse" $ do+    it "parses a real Jenkins response" $+      parseXml fullResponse+      `shouldBe`+      Just Discover+        { version  = "1.587"+        , url      = "https://example.com/jenkins/"+        , serverId = Just "1abcfaefb01da8b19ede7c35ced24f0f"+        , port     = Just "51667"+        }++    it "parses a Jenkins response without a server id" $+        parseXml noServerId+       `shouldBe`+        Just Discover+          { version  = "1.587"+          , url      = "https://example.com/jenkins/"+          , serverId = Nothing+          , port     = Just "51667"+          }++    it "parses a Jenkins response without a slave port" $+        parseXml noSlavePort+       `shouldBe`+        Just Discover+          { version  = "1.587"+          , url      = "https://example.com/jenkins/"+          , serverId = Just "1abcfaefb01da8b19ede7c35ced24f0f"+          , port     = Nothing+          }++fullResponse :: ByteString+fullResponse =+  "<hudson>\+  \<version>1.587</version>\+  \<url>https://example.com/jenkins/</url>\+  \<server-id>1abcfaefb01da8b19ede7c35ced24f0f</server-id>\+  \<slave-port>51667</slave-port>\+  \</hudson>"++noServerId :: ByteString+noServerId =+  "<hudson>\+  \<version>1.587</version>\+  \<url>https://example.com/jenkins/</url>\+  \<slave-port>51667</slave-port>\+  \</hudson>"++noSlavePort :: ByteString+noSlavePort =+  "<hudson>\+  \<version>1.587</version>\+  \<url>https://example.com/jenkins/</url>\+  \<server-id>1abcfaefb01da8b19ede7c35ced24f0f</server-id>\+  \</hudson>"

@@ -1,18 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} module Jenkins.Rest.InternalSpec (spec) where -import Control.Lens-import Control.Exception (throwIO)-import Control.Exception.Lens (throwingM, _IOException)-import Control.Monad.IO.Class (liftIO)-import Network.HTTP.Conduit (HttpException)-import Network.HTTP.Types (Status(..))-import Test.Hspec.Lens-import System.IO.Error-import System.IO.Error.Lens (errorType, _NoSuchThing)+import           Control.Lens+import           Control.Exception (throwIO)+import           Control.Exception.Lens (throwingM, _IOException)+import           Network.HTTP.Client (HttpException)+import           Network.HTTP.Types (Status(..))+import           Test.Hspec.Lens+import           System.IO.Error+import           System.IO.Error.Lens (errorType, _NoSuchThing) -import Jenkins.Rest.Internal-import Network.HTTP.Conduit.Lens (_StatusCodeException, _TooManyRetries)+import           Jenkins.Rest (Jenkins, liftIO)+import qualified Jenkins.Rest as Jenkins+import           Jenkins.Rest.Internal+import           Network.HTTP.Client.Lens (_StatusCodeException, _InvalidUrlException, _TooManyRetries)  _JenkinsException :: Iso' JenkinsException HttpException _JenkinsException = iso (\(JenkinsHttpException e) -> e) JenkinsHttpException@@ -25,22 +26,29 @@    describe "runJenkins" $ do     it "wraps uncatched 'HttpException' exceptions from the queries in 'Error'" $-      runJenkins (defaultConnectInfo & jenkinsPort .~ 80) (liftJ (Get "hi" id))+      Jenkins.run Jenkins.defaultMaster (Jenkins.get Jenkins.plain "hi")      `shouldPerform`       Status 404 ""      `through`-      _Error._JenkinsException._StatusCodeException._1+      Jenkins._Exception._JenkinsException._StatusCodeException._1 +    it "wraps uncatched 'HttpException' exceptions from the URL parsing in 'Error'" $+      Jenkins.run (Jenkins.defaultMaster & Jenkins.url .~ "foo") (Jenkins.get Jenkins.plain "hi")+     `shouldPerform`+      ("foo", "Invalid URL")+     `through`+      Jenkins._Exception._JenkinsException._InvalidUrlException+     it "can catch 'HttpException' exceptions related from the queries" $-      runJenkins (defaultConnectInfo & jenkinsPort .~ 80)-        (liftJ (Or (liftJ (Get "hi" id) >> return 4) (return 7)))+      Jenkins.run Jenkins.defaultMaster+        (liftJ (Or (Jenkins.get Jenkins.plain "hi" >> return 4) (\_ -> return 7)))      `shouldPerform`       7      `through`-      _Result+      Jenkins._Ok      it "does not catch (and wrap) 'HttpException's not from the queries" $-      runJenkins defaultConnectInfo raiseHttp `shouldThrow` _TooManyRetries+      Jenkins.run Jenkins.defaultMaster raiseHttp `shouldThrow` _TooManyRetries      it "does not catch (and wrap) 'IOException's" $-      runJenkins defaultConnectInfo raiseIO `shouldThrow` _IOException.errorType._NoSuchThing+      Jenkins.run Jenkins.defaultMaster raiseIO `shouldThrow` _IOException.errorType._NoSuchThing

@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Jenkins.Rest.Method.InternalSpec where++import Test.Hspec++import Jenkins.Rest.Method.Internal+import Jenkins.Rest.Method++spec :: Spec+spec =+  describe "render" $++    it "has a bunch of example input/output pairs" $ do++      format xml ""+        `shouldBe` "api/xml"++      format xml ("job" -/- 7)+        `shouldBe` "job/7/api/xml"++      format json ("job" -/- 7)+        `shouldBe` "job/7/api/json"++      render (text "restart")+        `shouldBe` "restart"++      render ("job" -?- "name" -=- "foo" -&- "title" -=- "bar")+        `shouldBe` "job?name=foo&title=bar"++      render ("job" -?- "name" -&- "title" -=- "bar")+        `shouldBe` "job?name&title=bar"++      format json ("job" -/- 7 -?- "name" -&- "title" -=- "bar")+        `shouldBe` "job/7/api/json?name&title=bar"++      format xml ("job" -/- "ДМИТРИЙ")+        `shouldBe` "job/%D0%94%D0%9C%D0%98%D0%A2%D0%A0%D0%98%D0%99/api/xml"

@@ -1,15 +1,18 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} 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 qualified Data.Conduit as C+import           Data.Functor.Identity (Identity) import           Data.Monoid (mempty) import           Test.Hspec-import qualified Jenkins.Rest as Rest+import qualified Jenkins.Rest as Jenkins import           Jenkins.Rest.Internal+import qualified Jenkins.Rest.Method.Internal as Method   spec :: Spec@@ -17,26 +20,26 @@   context "POST requests" $ do     it "post_ sends POST request with empty body" $ do       interpret $ do-        Rest.post_ "foo"-        Rest.post_ "bar"-        Rest.post_ "baz"+        Jenkins.post_ "foo"+        Jenkins.post_ "bar"+        Jenkins.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"+        Jenkins.post "foo" "qux"+        Jenkins.post "bar" "quux"+        Jenkins.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.getS "foo"-        Rest.getS "bar"-        Rest.getS "baz"+        Jenkins.get Jenkins.plain "foo"+        Jenkins.get Jenkins.plain "bar"+        Jenkins.get Jenkins.plain "baz"      `shouldBe`       [QGet 0 "foo", QGet 1 "bar", QGet 2 "baz"] @@ -44,24 +47,24 @@   describe "reload" $     it "calls $jenkins_url/reload with POST query and then disconnects" $ do       interpret $ do-        Rest.reload-        Rest.post_ "foo"+        Jenkins.reload+        Jenkins.post_ "foo"      `shouldBe`       [QPost 0 "" "reload", QDisconnect]    describe "restart" $     it "calls $jenkins_url/safeRestart with POST query and then disconnects" $ do       interpret $ do-        Rest.restart-        Rest.post_ "bar"+        Jenkins.restart+        Jenkins.post_ "bar"      `shouldBe`       [QPost 0 "" "safeRestart", QDisconnect]    describe "forceRestart" $     it "calls $jenkins_url/restart with POST query and then disconnects" $ do       interpret $ do-        Rest.forceRestart-        Rest.post_ "baz"+        Jenkins.forceRestart+        Jenkins.post_ "baz"      `shouldBe`       [QPost 0 "" "restart", QDisconnect] @@ -75,22 +78,22 @@ 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]+interpret :: JenkinsT Identity a -> [Query]+interpret adt = evalState (iter go ([] <$ adt)) (Requests [0..]) where+  go :: JF Identity (State (Requests Int) [Query]) -> State (Requests Int) [Query]   go (Get m n) = do     r <- render QGet m-    fmap (r :) (n (C.newResumableSource (C.yield mempty)))+    fmap (r :) (n mempty)   go (Post m body n) = do     r <- render (\x y -> QPost x body y) m     fmap (r :) n   go Dcon =     return [QDisconnect] -render :: (a -> Strict.ByteString -> Query) -> Rest.Method f x -> State (Requests a) Query+render :: (a -> Strict.ByteString -> Query) -> Jenkins.Method Method.Complete f -> State (Requests a) Query render f m = do   n <- next-  return $ f n (Rest.render m)+  return $ f n (Method.render m)  next :: State (Requests a) a next = do