Commits

Anonymous committed 202abb3

Work in progress on demo application

Comments (0)

Files changed (6)

 resolveAndPrintRecord :: ServiceResult (BrowseReply String) ->  IO ()
 
 resolveAndPrintRecord (Left err) = print err
-resolveAndPrintRecord (Right (BrowseReply (ReplyWithInterface _ iface) name regType domain)) =
+resolveAndPrintRecord (Right (BrowseReply (ReplyWithInterface _ iface) fn@(FullServiceName name regType domain))) =
     do
         putStrLn $ "name=" ++ name ++ ", regtype=" ++ regType ++ ",domain=" ++ domain 
-        resolve name regType domain print [] iface >>= runServiceFor 5
+        resolve fn print [] iface >>= runServiceFor 5
 
 
 getAddressInfo =
     lift $ putStrLn "Got list of services"
     case rights res of
         [] -> lift $ putStrLn "No service names"
-        (BrowseReply (ReplyWithInterface i f) name regType domain : _) -> do
+        (BrowseReply (ReplyWithInterface i f) (FullServiceName name regType domain) : _) -> do
             lift $ putStrLn $ "Browsing for service " ++ name
             b <- EitherT $ buildListFor 1 (\cb -> browse (name ++ "._tcp") Nothing cb [DNSServiceFlagsBrowseDomains] DNSServiceInterfaceIndexAny)
             case (rights b) of
                 [] -> lift $ putStrLn "No services"
-                (BrowseReply (ReplyWithInterface f i) name regType domain :_ ) -> do
-                    lift $ resolve name regType domain print [] i >>= runServiceFor 5                   
+                (BrowseReply (ReplyWithInterface f i) fn :_ ) -> do
+                    lift $ resolve fn print [] i >>= runServiceFor 5                   
 
 buildListFor :: StopService t => Int -> ((a -> IO ()) -> IO (ServiceResult t)) -> IO (ServiceResult [a])
 buildListFor n f = do

Network/DNSSD.chs

 {-# LANGUAGE ForeignFunctionInterface #-}
 module Network.DNSSD
     ( dnsServiceGetVersion
+    , module Network.DNSSD.Services
+    , module Network.DNSSD.Error
     ) where
 import Data.Word
+import Network.DNSSD.Services
 import Foreign.C.Types (CUInt, CInt (..), CChar)
 import Foreign.Marshal.Alloc (alloca)
 import Foreign.C.String (withCString)

Network/DNSSD/Services.chs

      , StopService          (..)
      , CallbackFunc
      , Flags
+     , FullServiceName      (..)
      , InterfaceIndex
      , ServiceFunc
 -- * DNS-SD functionality
 -- | Most callbacks take 'InterfaceIndex' and 'Flags' parameters so we group them together
 data ReplyWithInterface = ReplyWithInterface Flags InterfaceIndex deriving Show 
 data EnumerateDomainsReply t = EnumerateDomainsReply ReplyWithInterface t deriving Show
-data BrowseReply t = BrowseReply {brIfaceFlag :: ReplyWithInterface , brServiceName :: t, brRegType :: t, brDomain :: t} deriving Show
+data FullServiceName t = FullServiceName {srvName :: t, srvRegType :: t, srvDomain :: t} deriving (Show, Eq)
+data BrowseReply t = BrowseReply {brIfaceFlag :: ReplyWithInterface , fullName :: FullServiceName t } deriving Show
 data RegisterReply t = RegisterReply 
     Flags
     t     --  name
             {# call DNSServiceBrowse as ^ #}
             mkBrowseReply
             (\f -> maybeAsCString domain $ \s -> asCString regType $ \r -> return $ f r s)  
-            (\_ f i e n r d _ -> createCallbackData cb e (BrowseReply (unmarshalReplyWithInterface f i) <$> fromCString n <*> fromCString r <*> fromCString d))
+            (\_ f i e n r d _ -> createCallbackData cb e (BrowseReply (unmarshalReplyWithInterface f i) <$> (FullServiceName <$> fromCString n <*> fromCString r <*> fromCString d)))
 -- }}}
 
 -- Register {{{
 foreign import ccall "wrapper"
     mkResolveReply :: DeFun DNSServiceResolveReply -> IO DNSServiceResolveReply
     
-resolve :: StringLike t => t -> t -> t -> ServiceFunc (ResolveReply t)
-resolve name regtype domain  cb = 
+resolve :: StringLike t => FullServiceName t -> ServiceFunc (ResolveReply t)
+resolve (FullServiceName name regtype domain)  cb = 
         createAll
             {# call DNSServiceResolve as ^ #}
             mkResolveReply
+{-# LANGUAGE Rank2Types #-}
 module Main where
+import Network.DNSSD
+import Network.DNSSD.InterfaceIndex
+import Network.DNSSD.StringLike
+import Control.Concurrent
+import Control.Monad
 
-main = putStrLn "Ping server"
+serviceName :: String
+serviceName = "_hs-ping._udp"
+
+logMsg :: Show a => MVar () -> a -> IO ()
+logMsg m a =  modifyMVar_ m $ \_ ->  putStrLn (show a)
+
+data ServiceEventType = Added | Removed deriving Show
+data ServiceEvent 
+    = Event ServiceEventType (FullServiceName String) 
+    | Error DNSServiceError
+     deriving Show
+
+data Event 
+    = Service ServiceEvent
+    deriving Show
+
+type LogMsg             = Event -> IO ()
+type ServiceEventProcessor     = ServiceEvent -> IO ()
+type AddAddress         = () -> IO ()
+type Browser            = ServiceEventProcessor -> IO (ServiceResult ServiceRef)
+
+startServiceBrowser :: Browser
+startServiceBrowser handler =  
+     browse serviceName Nothing callback [DNSServiceFlagsBrowseDomains] DNSServiceInterfaceIndexAny 
+  where
+     callback (Left err) = handler $ Error err
+     callback (Right (BrowseReply (ReplyWithInterface flags _) fullName)) = 
+        handler $ Event (if DNSServiceFlagsAdd `elem` flags then Added else Removed) fullName
+                
+startServiceRegistration :: IO (ServiceResult ServiceRef)     
+startServiceRegistration = undefined
+   
+
+main = do
+    lock <- newMVar ()
+    startServiceBrowser (logMsg lock) 
+    threadDelay 10000000
 - DONE representation of TXT records
 - DONE implement all TXT record functions
 - DONE update service implementation with missing TXT marshaling/unmarshaling
-- implement special functions 
-- think about having record type in RecordRef
+- DONE decide on using Either
+- DONE make getVersion instead of getProperty
+- remove prefices from names of flags, errors etc
+- visibility between modules and public API
 - read carefully comments in dns_sd.h (especially on flags) and probably change the API (kDNSServiceFlagsShareConnection is a prominent example)
-- DONE decide on using Either
-- make getVersion instead of getProperty
-- implement record manipulation functions and RegisterRecord
-- visibility between modules and public API
-- implement few record data
-- API levels (using threads, using FD, STM)
 - clean up the code
 - write haddock
 - write demo app
+- API levels (using threads, using FD, STM)
 - windows build
+- implement special functions 
+- implement record manipulation functions and RegisterRecord
+- think about having record type in RecordRef
+- implement few record data
 
     build-depends     : hs-bonjour
                       , base == 4.5.*
                       , network == 2.3.*
+    ghc-options       : -threaded
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.