diff --git a/Network/Avahi/Announce.hs b/Network/Avahi/Announce.hs --- a/Network/Avahi/Announce.hs +++ b/Network/Avahi/Announce.hs @@ -5,8 +5,8 @@ import Data.Word import Data.Char import Data.Maybe -import qualified DBus.Client as C -import DBus.Client.Simple +import DBus.Client +import DBus.Internal.Types import Network.Avahi.Common @@ -14,12 +14,11 @@ announce :: Service -- ^ Service to announce -> IO () announce (Service {..}) = do - bus <- connectSystem - server <- proxy bus avahiBus "/" - [newGroup] <- call server serverInterface "EntryGroupNew" [] - new <- proxy bus avahiBus (fromJust $ fromVariant newGroup) + client <- connectSystem + [newGroup] <- call' client "/" serverInterface "EntryGroupNew" [] + let path = fromJust $ fromVariant newGroup let text' = [map (fromIntegral . ord) serviceText] :: [[Word8]] - call new entryGroupInterface "AddService" [toVariant (-1 :: Int32), -- IF_UNSPEC + call' client path entryGroupInterface "AddService" [toVariant (-1 :: Int32), -- IF_UNSPEC proto2variant serviceProtocol, flags_empty, toVariant serviceName, @@ -28,6 +27,6 @@ toVariant serviceHost, toVariant servicePort, toVariant text'] - call new entryGroupInterface "Commit" [] + call' client path entryGroupInterface "Commit" [] return () diff --git a/Network/Avahi/Browse.hs b/Network/Avahi/Browse.hs --- a/Network/Avahi/Browse.hs +++ b/Network/Avahi/Browse.hs @@ -10,57 +10,60 @@ import Data.Word import Data.Int import Data.Char -import qualified DBus.Client as C -import DBus.Message -import DBus.Client.Simple +import DBus.Client as C +import DBus.Internal.Types +import DBus.Internal.Message import Network.Avahi.Common +import Data.ByteString (ByteString) +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text as Text -listenAvahi :: Maybe BusName -> C.MatchRule -listenAvahi name = C.MatchRule { - C.matchSender = name, - C.matchDestination = Nothing, - C.matchPath = Nothing, - C.matchInterface = Nothing, - C.matchMember = Nothing } +listenAvahi :: Maybe BusName -> Maybe MemberName -> C.MatchRule +listenAvahi name member = matchAny { matchSender = name, matchMember = member } -- | Browse for specified service browse :: BrowseQuery -> IO () browse (BrowseQuery {..}) = do - bus <- connectSystem - server <- proxy bus avahiBus "/" - [sb] <- call server serverInterface "ServiceBrowserNew" [iface_unspec, - proto2variant lookupProtocol, - toVariant lookupServiceName, - toVariant lookupDomain, - flags_empty ] - C.listen bus (listenAvahi $ fromVariant sb) (handler server lookupCallback) - C.listen bus (listenAvahi $ Just serviceResolver) (handler server lookupCallback) + client <- connectSystem + -- We have to set up callback for ItemNew signal before we actually create a browser. + -- Otherwise, the signal can arrive sooner then we managed to set up a callback for it. + -- See also https://github.com/cocagne/txdbus/issues/8, https://github.com/lathiat/avahi/issues/9 + addMatch client (listenAvahi Nothing Nothing) (handler client lookupCallback) + [sb] <- call' client "/" serverInterface "ServiceBrowserNew" [iface_unspec, + proto2variant lookupProtocol, + toVariant lookupServiceName, + toVariant lookupDomain, + flags_empty ] + -- print sb + addMatch client (listenAvahi (Just serviceResolver) (Just "Found")) (handler client lookupCallback) + return () -- | Dispatch signal and call corresponding function. -dispatch :: [(Text, Signal -> IO b)] -> Signal -> IO () +dispatch :: [(String, Signal -> IO b)] -> Signal -> IO () dispatch pairs signal = do let signame = signalMember signal + -- putStrLn $ "signame: " ++ show signame ++ ", sender: " ++ show (signalSender signal) let good = [callback | (name, callback) <- pairs, memberName_ name == signame] forM_ good $ \callback -> callback signal -handler :: Proxy -> (Service -> IO ()) -> BusName -> Signal -> IO () -handler server callback busname signal = do - dispatch [("ItemNew", on_new_item server), +handler :: Client -> (Service -> IO ()) -> Signal -> IO () +handler client callback signal = do + dispatch [("ItemNew", on_new_item client), ("Found", on_service_found callback) ] signal -on_new_item :: Proxy -> Signal -> IO () -on_new_item server signal = do +on_new_item :: Client -> Signal -> IO () +on_new_item client signal = do let body = signalBody signal [iface,proto,name,stype,domain,flags] = body - call server serverInterface "ServiceResolverNew" [iface, - proto, - name, - stype, - domain, - proto2variant PROTO_UNSPEC, - flags_empty ] + call' client "/" serverInterface "ServiceResolverNew" [iface, + proto, + name, + stype, + domain, + proto2variant PROTO_UNSPEC, + flags_empty ] return () on_service_found :: (Service -> IO ()) -> Signal -> IO () @@ -75,9 +78,9 @@ serviceHost = fromVariant_ "service host" host, serviceAddress = fromVariant addr, servicePort = fromVariant_ "service port" port, - serviceText = maybe "" toString (fromVariant text :: Maybe [[Word8]]) } + serviceText = maybe "" toString (fromVariant text :: Maybe [ByteString]) } callback service -toString :: [[Word8]] -> String -toString list = concatMap (map (chr . fromIntegral)) list +toString :: [ByteString] -> String +toString = Text.unpack . Text.concat . fmap (decodeUtf8) diff --git a/Network/Avahi/Common.hs b/Network/Avahi/Common.hs --- a/Network/Avahi/Common.hs +++ b/Network/Avahi/Common.hs @@ -1,9 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Avahi.Common where +import Control.Exception import Data.Int import Data.Word -import DBus.Client.Simple +import DBus +import DBus.Client +import DBus.Internal.Types -- | Service specification data Service = Service { @@ -76,4 +79,12 @@ entryGroupInterface :: InterfaceName entryGroupInterface = interfaceName_ "org.freedesktop.Avahi.EntryGroup" + +call' :: Client -> ObjectPath -> InterfaceName -> MemberName -> [Variant] -> IO [Variant] +call' client object interface method args = do + reply <- call_ client (methodCall object interface method) { + methodCallDestination = Just avahiBus, + methodCallBody = args + } + return $ methodReturnBody reply diff --git a/avahi.cabal b/avahi.cabal --- a/avahi.cabal +++ b/avahi.cabal @@ -1,7 +1,7 @@ -- The name of the package. Name: avahi -Version: 0.1.1 +Version: 0.2.0 Synopsis: Minimal DBus bindings for Avahi daemon (http://avahi.org) @@ -30,10 +30,10 @@ -- Extra files to be distributed with the package, such as examples or -- a README. --- Extra-source-files: +Extra-source-files: browse.hs -- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.6 +Cabal-version: >=1.8 Library @@ -44,12 +44,20 @@ Network.Avahi.Announce -- Packages needed in order to build this package. - Build-depends: base >= 4 && < 5, dbus-core >= 0.9.2.1, - text >= 0.11.1 - - -- Modules not exported by this package. - -- Other-modules: - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: + Build-depends: base >= 4 && < 5, dbus >= 0.10.13, + text >= 0.11.1, bytestring + +Executable avahi-browse + Main-is: browse.hs + Other-modules: Network.Avahi + Network.Avahi.Announce + Network.Avahi.Browse + Network.Avahi.Common + Build-depends: base >= 4 && < 5, dbus >= 0.10.13, + text >= 0.11.1, + avahi, bytestring +Source-repository head + type: git + location: https://github.com/portnov/hs-avahi.git + diff --git a/browse.hs b/browse.hs new file mode 100644 --- /dev/null +++ b/browse.hs @@ -0,0 +1,26 @@ + +import Network.Avahi +import System.Environment + +main :: IO () +main = do + args <- getArgs + case args of + [domain, service] -> do + let query = BrowseQuery { + lookupProtocol = PROTO_UNSPEC, + lookupServiceName = service, + lookupDomain = domain, + lookupCallback = callback + } + browse query + putStrLn "hit enter when done" + getLine + return () + + _ -> putStrLn "Synopsis: browse DOMAIN SERVICE\n\n\tFor example: browse local _printer._tcp" + +callback :: Service -> IO () +callback service = do + print service +