summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIlyaPortnov <>2011-10-14 12:10:52 (GMT)
committerhdiff <hdiff@luite.com>2011-10-14 12:10:52 (GMT)
commitdf90dd15cbe89eda8defaed19f1b5504687e49c2 (patch)
treef9a512d2182def722e66c8f2f4b6b8cf3a1791a1
version 0.10.1
-rw-r--r--LICENSE30
-rw-r--r--Network/Avahi.hs11
-rw-r--r--Network/Avahi/Announce.hs33
-rw-r--r--Network/Avahi/Browse.hs86
-rw-r--r--Network/Avahi/Common.hs79
-rw-r--r--Setup.hs2
-rw-r--r--avahi.cabal55
7 files changed, 296 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..3a268cd
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2011, Ilya Portnov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Ilya Portnov nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Network/Avahi.hs b/Network/Avahi.hs
new file mode 100644
index 0000000..1f783f0
--- /dev/null
+++ b/Network/Avahi.hs
@@ -0,0 +1,11 @@
+
+module Network.Avahi
+ (module Network.Avahi.Common,
+ module Network.Avahi.Browse,
+ module Network.Avahi.Announce
+ ) where
+
+import Network.Avahi.Common
+import Network.Avahi.Browse
+import Network.Avahi.Announce
+
diff --git a/Network/Avahi/Announce.hs b/Network/Avahi/Announce.hs
new file mode 100644
index 0000000..844e5fe
--- /dev/null
+++ b/Network/Avahi/Announce.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+module Network.Avahi.Announce where
+
+import Data.Int
+import Data.Word
+import Data.Char
+import Data.Maybe
+import qualified DBus.Client as C
+import DBus.Client.Simple
+
+import Network.Avahi.Common
+
+-- | Announce network service
+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)
+ let text' = [map (fromIntegral . ord) serviceText] :: [[Word8]]
+ call new entryGroupInterface "AddService" [toVariant (-1 :: Int32), -- IF_UNSPEC
+ proto2variant serviceProtocol,
+ flags_empty,
+ toVariant serviceName,
+ toVariant serviceType,
+ toVariant serviceDomain,
+ toVariant serviceHost,
+ toVariant servicePort,
+ toVariant text']
+ call new entryGroupInterface "Commit" []
+ return ()
+
diff --git a/Network/Avahi/Browse.hs b/Network/Avahi/Browse.hs
new file mode 100644
index 0000000..15cc76d
--- /dev/null
+++ b/Network/Avahi/Browse.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+module Network.Avahi.Browse
+ (browse,
+ dispatch
+ ) where
+
+import Control.Monad
+import Control.Concurrent
+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 Network.Avahi.Common
+
+listenAvahi :: Maybe BusName -> C.MatchRule
+listenAvahi name = C.MatchRule {
+ C.matchSender = name,
+ C.matchDestination = Nothing,
+ C.matchPath = Nothing,
+ C.matchInterface = Nothing,
+ C.matchMember = Nothing }
+
+-- | 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)
+
+-- | Dispatch signal and call corresponding function.
+dispatch :: [(Text, Signal -> IO b)] -> Signal -> IO ()
+dispatch pairs signal = do
+ let signame = signalMember 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
+-- print (signalMember signal)
+ dispatch [("ItemNew", on_new_item server),
+ ("Found", on_service_found callback) ] signal
+
+on_new_item :: Proxy -> Signal -> IO ()
+on_new_item server signal = do
+ let body = signalBody signal
+ [iface,proto,name,stype,domain,flags] = body
+-- putStrLn $ "New item: " ++ show body
+ call server serverInterface "ServiceResolverNew" [iface,
+ proto,
+ name,
+ stype,
+ domain,
+ proto2variant PROTO_UNSPEC,
+ flags_empty ]
+ return ()
+
+on_service_found :: (Service -> IO ()) -> Signal -> IO ()
+on_service_found callback signal = do
+ let body = signalBody signal
+ [iface, proto, name, stype, domain, host, aproto, addr, port, text, flags] = body
+ service = Service {
+ serviceProtocol = variant2proto proto,
+ serviceName = fromVariant_ "service name" name,
+ serviceType = fromVariant_ "service type" stype,
+ serviceDomain = fromVariant_ "domain" domain,
+ serviceHost = fromVariant_ "service host" host,
+ serviceAddress = fromVariant addr,
+ servicePort = fromVariant_ "service port" port,
+ serviceText = maybe "" toString (fromVariant text :: Maybe [[Word8]]) }
+ putStrLn $ "Service resolved: " ++ show service
+ callback service
+
+toString :: [[Word8]] -> String
+toString list = concatMap (map (chr . fromIntegral)) list
+
diff --git a/Network/Avahi/Common.hs b/Network/Avahi/Common.hs
new file mode 100644
index 0000000..182f9ae
--- /dev/null
+++ b/Network/Avahi/Common.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Network.Avahi.Common where
+
+import Data.Int
+import Data.Word
+import DBus.Client.Simple
+
+-- | Service specification
+data Service = Service {
+ serviceProtocol :: InetProtocol,
+ serviceName :: String,
+ serviceType :: String,
+ serviceDomain :: String,
+ serviceHost :: String,
+ serviceAddress :: Maybe String,
+ servicePort :: Word16,
+ serviceText :: String }
+ deriving (Eq,Show)
+
+-- | Service browsing query
+data BrowseQuery = BrowseQuery {
+ lookupProtocol :: InetProtocol, -- ^ Protocol to be used for lookup
+ lookupServiceName :: String, -- ^ Service name to find
+ lookupDomain :: String, -- ^ Domain to search in (usually `local')
+ lookupCallback :: Service -> IO () -- ^ Function to be called on found service
+ }
+
+-- | Internet protocol specification
+data InetProtocol =
+ PROTO_UNSPEC -- ^ Unspecified (any) protocol (-1)
+ | PROTO_INET -- ^ IPv4 protocol (0)
+ | PROTO_INET6 -- ^ IPv6 protocol (1)
+ deriving (Eq,Show)
+
+proto2variant :: InetProtocol -> Variant
+proto2variant PROTO_UNSPEC = toVariant (-1 :: Int32)
+proto2variant PROTO_INET = toVariant (0 :: Int32)
+proto2variant PROTO_INET6 = toVariant (1 :: Int32)
+
+variant2proto :: Variant -> InetProtocol
+variant2proto x =
+ case fromVariant x :: Maybe Int32 of
+ Nothing -> error $ "Erroneus PROTO: " ++ show x
+ Just (-1) -> PROTO_UNSPEC
+ Just 0 -> PROTO_INET
+ Just 1 -> PROTO_INET6
+ Just y -> error $ "Erroneus PROTO: " ++ show y
+
+forceMaybe :: String -> Maybe a -> a
+forceMaybe msg Nothing = error msg
+forceMaybe _ (Just x) = x
+
+fromVariant_ :: (IsVariant a) => String -> Variant -> a
+fromVariant_ msg x = forceMaybe msg (fromVariant x)
+
+iface_unspec :: Variant
+iface_unspec = toVariant (-1 :: Int32)
+
+flags_empty :: Variant
+flags_empty = toVariant (0 :: Word32)
+
+avahiBus :: BusName
+avahiBus = busName_ "org.freedesktop.Avahi"
+
+hostNameResolver :: BusName
+hostNameResolver = busName_ "org.freedesktop.Avahi.HostNameResolver"
+
+serviceResolver :: BusName
+serviceResolver = busName_ "org.freedesktop.Avahi.ServiceResolver"
+
+serverInterface :: InterfaceName
+serverInterface = interfaceName_ "org.freedesktop.Avahi.Server"
+
+avahiBrowser :: InterfaceName
+avahiBrowser = interfaceName_ "org.freedesktop.Avahi.ServiceBrowser"
+
+entryGroupInterface :: InterfaceName
+entryGroupInterface = interfaceName_ "org.freedesktop.Avahi.EntryGroup"
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/avahi.cabal b/avahi.cabal
new file mode 100644
index 0000000..6b5ff5d
--- /dev/null
+++ b/avahi.cabal
@@ -0,0 +1,55 @@
+-- The name of the package.
+Name: avahi
+
+Version: 0.1
+
+Synopsis: Minimal DBus bindings for Avahi daemon (http://avahi.org)
+
+Description: This package provides minimal DBus bindings for Avahi daemon.
+ It can be used to browse for network service via Zeroconf protocol
+ or to announce a service.
+
+License: BSD3
+
+-- The file containing the license text.
+License-file: LICENSE
+
+-- The package author(s).
+Author: Ilya Portnov
+
+-- An email address to which users can send suggestions, bug reports,
+-- and patches.
+Maintainer: portnov84@rambler.ru
+
+-- A copyright notice.
+-- Copyright:
+
+Category: Network
+
+Build-type: Simple
+
+-- Extra files to be distributed with the package, such as examples or
+-- a README.
+-- Extra-source-files:
+
+-- Constraint on the version of Cabal needed to build this package.
+Cabal-version: >=1.6
+
+
+Library
+ -- Modules exported by the library.
+ Exposed-modules: Network.Avahi
+ Network.Avahi.Common
+ Network.Avahi.Browse
+ 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:
+