{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-overflowed-literals #-}
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) #-}
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
:: Int
-> 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
[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) )
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
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)