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
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 :: ConnectInfo -> Jenkins a -> IO (Result HttpException a)
runJenkins (ConnectInfo h p user token) jenk =
fmap result . try . withManager $ \manager -> do
req <- liftIO $ parseUrl h
let req' = req
& Lens.port .~ p
& Lens.responseTimeout .~ Just (20 * 1000000)
& applyBasicAuth (Text.encodeUtf8 user) (Text.encodeUtf8 token)
runReaderT (runMaybeT (iterJenkinsIO manager jenk)) req'
where
result :: Either e (Maybe v) -> Result e v
result (Left e) = Error e
result (Right Nothing) = Disconnect
result (Right (Just val)) = Result val
_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 = ""
}
jenkinsUrl :: Lens' ConnectInfo String
jenkinsUrl f req = (\u' -> req { _jenkinsUrl = u' }) <$> f (_jenkinsUrl req)
jenkinsPort :: Lens' ConnectInfo Int
jenkinsPort f req = (\p' -> req { _jenkinsPort = p' }) <$> f (_jenkinsPort req)
jenkinsUser :: Lens' ConnectInfo Text
jenkinsUser f req = (\u' -> req { _jenkinsUser = u' }) <$> f (_jenkinsUser req)
jenkinsApiToken :: Lens' ConnectInfo Text
jenkinsApiToken f req = (\a' -> req { _jenkinsApiToken = a' }) <$> f (_jenkinsApiToken req)
jenkinsPassword :: Lens' ConnectInfo Text
jenkinsPassword = jenkinsApiToken