module Jenkins.Rest.Internal where
import Control.Applicative
import Control.Concurrent.Async (concurrently)
import Control.Exception (Exception, try, toException)
import Control.Lens
import Control.Monad
import Control.Monad.Free.Church (F, iterM, liftF)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Control (MonadTransControl(..))
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, local)
import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT)
import Data.ByteString.Lazy (ByteString)
import Data.Conduit (ResourceT)
import Data.Data (Data, Typeable)
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import GHC.Generics (Generic)
import Network.HTTP.Conduit
import Network.HTTP.Types (Status(..))
import Jenkins.Rest.Method (Method, Type(..), render, slash)
import qualified Network.HTTP.Conduit.Lens as Lens
newtype Jenkins a = Jenkins { unJenkins :: F JenkinsF a }
deriving (Functor, Applicative, Monad)
instance MonadIO Jenkins where
liftIO = liftJ . IO
data JenkinsF a where
Get :: Method Complete f -> (ByteString -> a) -> JenkinsF a
Post :: (forall f. Method Complete f) -> ByteString -> (ByteString -> a) -> JenkinsF a
Conc :: Jenkins a -> Jenkins b -> (a -> b -> c) -> JenkinsF c
IO :: IO a -> JenkinsF a
With :: (Request -> Request) -> Jenkins b -> (b -> a) -> JenkinsF a
Dcon :: JenkinsF a
instance Functor JenkinsF where
fmap f (Get m g) = Get m (f . g)
fmap f (Post m body g) = Post m body (f . g)
fmap f (Conc m n g) = Conc m n (\a b -> f (g a b))
fmap f (IO a) = IO (fmap f a)
fmap f (With h j g) = With h j (f . g)
fmap _ Dcon = Dcon
liftJ :: JenkinsF a -> Jenkins a
liftJ = Jenkins . liftF
data ConnectInfo = ConnectInfo
{ _jenkinsUrl :: String
, _jenkinsPort :: Int
, _jenkinsUser :: Text
, _jenkinsApiToken :: Text
} deriving (Show, Eq, Typeable, Data, Generic)
data Result e v =
Error e
| Disconnect
| Result v
deriving (Show, Eq, Ord, Typeable, Data, Generic)
runJenkins :: HasConnectInfo t => t -> Jenkins a -> IO (Result HttpException a)
runJenkins conn jenk = either Error (maybe Disconnect Result) <$> try (runJenkinsInternal conn jenk)
runJenkinsThrowing :: HasConnectInfo t => t -> Jenkins a -> IO (Result e a)
runJenkinsThrowing conn jenk = maybe Disconnect Result <$> runJenkinsInternal conn jenk
runJenkinsInternal :: HasConnectInfo t => t -> Jenkins a -> IO (Maybe a)
runJenkinsInternal (view connectInfo -> ConnectInfo h p user token) jenk =
withManager $ \manager -> do
req <- liftIO $ parseUrl h
let req' = req
& Lens.port .~ p
& Lens.responseTimeout .~ Just (20 * 1000000)
& applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token)
runReaderT (runMaybeT (iterJenkinsIO manager jenk)) req'
_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)
_Disconnect :: Prism' (Result e a) ()
_Disconnect = prism' (\_ -> Disconnect) $ \case
Disconnect -> Just ()
_ -> Nothing
_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
iterJenkinsIO
:: Manager
-> Jenkins a
-> MaybeT (ReaderT Request (ResourceT IO)) a
iterJenkinsIO manager = iterJenkins (interpreter manager)
iterJenkins :: Monad m => (JenkinsF (m a) -> m a) -> Jenkins a -> m a
iterJenkins go = iterM go . unJenkins
interpreter
:: Manager
-> JenkinsF (MaybeT (ReaderT Request (ResourceT IO)) a)
-> MaybeT (ReaderT Request (ResourceT IO)) a
interpreter manager = go where
go (Get m next) = do
req <- lift ask
let req' = req
& Lens.path %~ (`slash` render m)
& Lens.method .~ "GET"
bs <- lift . lift $ httpLbs req' manager
next (responseBody bs)
go (Post m body next) = do
req <- lift ask
let req' = req
& Lens.path %~ (`slash` render m)
& Lens.method .~ "POST"
& Lens.requestBody .~ RequestBodyLBS body
& Lens.redirectCount .~ 0
& Lens.checkStatus .~ \s@(Status st _) hs cookie_jar ->
if 200 <= st && st < 400
then Nothing
else Just . toException $ StatusCodeException s hs cookie_jar
res <- lift . lift $ httpLbs req' manager
next (responseBody res)
go (Conc jenka jenkb next) = do
(a, b) <- liftWith $ \run' -> liftWith $ \run'' -> liftWith $ \run''' ->
let
run :: Jenkins t -> IO (StT ResourceT (StT (ReaderT Request) (StT MaybeT t)))
run = run''' . run'' . run' . iterJenkinsIO manager
in
concurrently (run jenka) (run jenkb)
c <- restoreT . restoreT . restoreT $ return a
d <- restoreT . restoreT . restoreT $ return b
next c d
go (IO action) = join (liftIO action)
go (With f jenk next) = do
res <- mapMaybeT (local f) (iterJenkinsIO manager jenk)
next res
go Dcon = mzero
defaultConnectInfo :: ConnectInfo
defaultConnectInfo = ConnectInfo
{ _jenkinsUrl = "http://example.com/jenkins"
, _jenkinsPort = 8080
, _jenkinsUser = "jenkins"
, _jenkinsApiToken = ""
}
class HasConnectInfo t where
connectInfo :: Lens' t ConnectInfo
instance HasConnectInfo ConnectInfo where
connectInfo = id
jenkinsUrl :: HasConnectInfo t => Lens' t String
jenkinsUrl = connectInfo . \f x -> f (_jenkinsUrl x) <&> \p -> x { _jenkinsUrl = p }
jenkinsPort :: HasConnectInfo t => Lens' t Int
jenkinsPort = connectInfo . \f x -> f (_jenkinsPort x) <&> \p -> x { _jenkinsPort = p }
jenkinsUser :: HasConnectInfo t => Lens' t Text
jenkinsUser = connectInfo . \f x -> f (_jenkinsUser x) <&> \p -> x { _jenkinsUser = p }
jenkinsApiToken :: HasConnectInfo t => Lens' t Text
jenkinsApiToken = connectInfo . \f x -> f (_jenkinsApiToken x) <&> \p -> x { _jenkinsApiToken = p }
jenkinsPassword :: HasConnectInfo t => Lens' t Text
jenkinsPassword = jenkinsApiToken