summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIlyaPortnov <>2018-09-17 18:32:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-09-17 18:32:00 (GMT)
commitbb67e9c8678e4e1694b2e94cbc9ce7faf983233f (patch)
treea89d1a0f0dbf5b470e8d8626159c3d097575b983
parent081a0a82808735eb1d9c22d1a5b1e9713e17f07b (diff)
version 0.2.0HEAD0.2.0master
-rw-r--r--Network/Avahi/Announce.hs15
-rw-r--r--Network/Avahi/Browse.hs73
-rw-r--r--Network/Avahi/Common.hs13
-rw-r--r--avahi.cabal30
-rw-r--r--browse.hs26
5 files changed, 102 insertions, 55 deletions
diff --git a/Network/Avahi/Announce.hs b/Network/Avahi/Announce.hs
index 844e5fe..40257fa 100644
--- a/Network/Avahi/Announce.hs
+++ b/Network/Avahi/Announce.hs
@@ -5,8 +5,8 @@ import Data.Int
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 @@ import Network.Avahi.Common
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 @@ announce (Service {..}) = do
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
index 18556fb..dff2b82 100644
--- a/Network/Avahi/Browse.hs
+++ b/Network/Avahi/Browse.hs
@@ -10,57 +10,60 @@ import Data.Text (Text)
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 @@ on_service_found callback signal = do
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
index 182f9ae..46a2b50 100644
--- 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 {
@@ -77,3 +80,11 @@ avahiBrowser = interfaceName_ "org.freedesktop.Avahi.ServiceBrowser"
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
index d5c35cb..29c246d 100644
--- 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 @@ Build-type: Simple
-- 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 @@ Library
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
index 0000000..e394d14
--- /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
+