{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-overflowed-literals #-}
-- | Discover Jenkins on the network
module Jenkins.Discover
  ( Discover(..)
  , discover
#ifdef TEST
  , parseXml
#endif
  ) where

import           Control.Applicative
import           Control.Monad
import           Data.Attoparsec.Text
import           Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (mapMaybe)
import           Data.Text (Text)
import qualified Data.Text.Encoding as Text
import           Network.BSD (getProtocolNumber)
import           Network.Socket
import           Network.Socket.ByteString as ByteString
import           System.Timeout (timeout)

{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}


-- | Jenkins information
data Discover = Discover
  { Discover -> Text
version  :: Text
  , Discover -> Text
url      :: Text
  , Discover -> Maybe Text
port     :: Maybe Text
  , Discover -> Maybe Text
serverId :: Maybe Text
  } deriving (Int -> Discover -> ShowS
[Discover] -> ShowS
Discover -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Discover] -> ShowS
$cshowList :: [Discover] -> ShowS
show :: Discover -> String
$cshow :: Discover -> String
showsPrec :: Int -> Discover -> ShowS
$cshowsPrec :: Int -> Discover -> ShowS
Show, Discover -> Discover -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Discover -> Discover -> Bool
$c/= :: Discover -> Discover -> Bool
== :: Discover -> Discover -> Bool
$c== :: Discover -> Discover -> Bool
Eq)


-- | Discover Jenkins on the network
discover
  :: Int           -- ^ timeout
  -> IO [Discover]
discover :: Int -> IO [Discover]
discover Int
t = do
  (Socket
b, SockAddr
addr) <- IO (Socket, SockAddr)
broadcastSocket
  Int
_ <- Socket -> ByteString -> SockAddr -> IO Int
ByteString.sendTo Socket
b ([Word8] -> ByteString
ByteString.pack [Word8
0, Word8
0, Word8
0, Word8
0]) SockAddr
addr -- does not matter what to send

  [ByteString]
msgs <- forall a. IO (Maybe a) -> IO [a]
while (forall a. Int -> IO a -> IO (Maybe a)
timeout Int
t (Socket -> IO ByteString
readAnswer Socket
b))

  Socket -> IO ()
close Socket
b
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe Discover
parseXml [ByteString]
msgs)
 where
  while :: IO (Maybe a) -> IO [a]
  while :: forall a. IO (Maybe a) -> IO [a]
while IO (Maybe a)
io = IO [a]
go where
    go :: IO [a]
go = do
      Maybe a
mr <- IO (Maybe a)
io
      case Maybe a
mr of
        Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just a
r  -> (a
r forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [a]
go

broadcastSocket :: IO (Socket, SockAddr)
broadcastSocket :: IO (Socket, SockAddr)
broadcastSocket = do
  Socket
s <- String -> IO ProtocolNumber
getProtocolNumber String
"udp" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Datagram
  Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
Broadcast Int
1
  forall (m :: * -> *) a. Monad m => a -> m a
return (Socket
s, PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
p (-HostAddress
1) {- 255.255.255.255 -})
 where
  p :: PortNumber
p = PortNumber
33848

readAnswer :: Socket -> IO ByteString
readAnswer :: Socket -> IO ByteString
readAnswer Socket
s = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO (ByteString, SockAddr)
ByteString.recvFrom Socket
s Int
4096


-- | Parse Jenkins discovery response XML
parseXml :: ByteString -> Maybe Discover
parseXml :: ByteString -> Maybe Discover
parseXml = Map Text Text -> Maybe Discover
fromMap forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
_ -> forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either String a
parseOnly (Parser Text (Map Text Text)
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8

fromMap :: Map Text Text -> Maybe Discover
fromMap :: Map Text Text -> Maybe Discover
fromMap Map Text Text
m = do
  Text
v <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"version" Map Text Text
m
  Text
u <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"url" Map Text Text
m
  Maybe Text
i <- forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"server-id" Map Text Text
m)
  Maybe Text
p <- forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"slave-port" Map Text Text
m)
  forall (m :: * -> *) a. Monad m => a -> m a
return Discover { version :: Text
version = Text
v, url :: Text
url = Text
u, serverId :: Maybe Text
serverId = Maybe Text
i, port :: Maybe Text
port = Maybe Text
p }

parser :: Parser (Map Text Text)
parser :: Parser Text (Map Text Text)
parser = Text -> Parser Text
string Text
"<hudson>" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text (Map Text Text)
tags forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
string Text
"</hudson>"

tags :: Parser (Map Text Text)
tags :: Parser Text (Map Text Text)
tags = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser (Text, Text)
tag

tag :: Parser (Text, Text)
tag :: Parser (Text, Text)
tag = do
  Char
_ <- Char -> Parser Char
char Char
'<'
  Text
k <- (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'>')
  Char
_ <- Char -> Parser Char
char Char
'>'
  Text
v <- (Char -> Bool) -> Parser Text
takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'<')
  Text
_ <- Text -> Parser Text
string (Text
"</" forall a. Semigroup a => a -> a -> a
<> Text
k forall a. Semigroup a => a -> a -> a
<> Text
">")
  forall (m :: * -> *) a. Monad m => a -> m a
return (Text
k, Text
v)