diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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: +