libjenkins-0.5.0: bench/Concurrency.hs

{-# LANGUAGE OverloadedStrings #-}
-- | Concurrency benchmark
--
-- The benchmark does the folllowing:
--
--   * it asks Jenkins instance for accessible jobs
--
--   * it sends queries to get jobs descriptions
--
--   * it prints all descriptions
--
-- The benchmark can be run sequentially or concurrently
--
-- See @bench/README.md@ for usage instructions
module Main (main) where

import           Control.Lens                  -- lens
import           Data.Aeson.Lens               -- lens-aeson
import           Data.Text (Text)              -- text
import qualified Data.Text as Text             -- text
import           Jenkins.Rest                  -- libjenkins
import           System.Environment (getArgs)  -- base
import           System.Exit (exitFailure)     -- base
import           System.IO (hPutStrLn, stderr) -- base


type Aggregate a b = (a -> Jenkins b) -> [a] -> Jenkins [b]

main :: IO ()
main = do
  m:host:port:user:pass:_ <- getArgs
  ds <- descriptions (aggregate m) $
    ConnectInfo host (read port) (Text.pack user) (Text.pack pass)
  case ds of
    Result ds' -> mapM_ print ds'
    Disconnect -> die "disconnect!"
    Error e    -> die (show e)
 where
  die message = do
    hPutStrLn stderr message
    exitFailure

  aggregate :: String -> Aggregate a b
  aggregate "concurrent" = traverseC
  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]")
  aggregate describe (res ^.. key "jobs".values.key "name"._String)

describe :: Text -> Jenkins (Maybe Text)
describe name = do
  desc <- get (job name `as` json -?- "tree" -=- "description")
  return (desc ^? key "description"._String)