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.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Network.BSD
import Network.Socket
import Network.Socket.ByteString as ByteString
import System.Timeout (timeout)
data Discover = Discover
{ version :: Text
, url :: Text
, port :: Maybe Text
, serverId :: Maybe Text
} deriving (Show, Eq)
discover
:: Int
-> IO [Discover]
discover t = do
(b, addr) <- broadcastSocket
_ <- ByteString.sendTo b (ByteString.pack [0, 0, 0, 0]) addr
msgs <- while (timeout t (readAnswer b))
close b
return (mapMaybe parseXml msgs)
where
while :: IO (Maybe a) -> IO [a]
while io = go where
go = do
mr <- io
case mr of
Nothing -> return []
Just r -> (r :) <$> go
broadcastSocket :: IO (Socket, SockAddr)
broadcastSocket = do
s <- getProtocolNumber "udp" >>= socket AF_INET Datagram
setSocketOption s Broadcast 1
return (s, SockAddrInet p (1) )
where
p = 33848
readAnswer :: Socket -> IO ByteString
readAnswer s = fst <$> ByteString.recvFrom s 4096
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)