Commits

Anonymous committed a254353

More work on demo app

  • Participants
  • Parent commits 202abb3

Comments (0)

Files changed (3)

Network/DNSSD.chs

     ( dnsServiceGetVersion
     , module Network.DNSSD.Services
     , module Network.DNSSD.Error
+    , module Network.DNSSD.InterfaceIndex
     ) where
 import Data.Word
 import Network.DNSSD.Services
+import Network.DNSSD.InterfaceIndex
 import Foreign.C.Types (CUInt, CInt (..), CChar)
 import Foreign.Marshal.Alloc (alloca)
 import Foreign.C.String (withCString)

Network/DNSSD/Services.chs

 -- * Common types
        ServiceResult
      , ServiceRef
+     , RecServiceRefAdd
      , ReplyWithInterface   (..)
      , DNSServiceProtocol   (..)
      , Proto
 data EnumerateDomainsReply t = EnumerateDomainsReply ReplyWithInterface 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
-    t     --  regtype
-    t     --  domain
- deriving Show
+data RegisterReply t = RegisterReply Flags (FullServiceName t) deriving Show
 
 data PortMappingReply = PortMappingReply
     ReplyWithInterface
                 maybeAsCString hq       $ \h                 ->
                 maybeAsCStringLen txt   $ \(txtP, txtLen)    -> 
                 (return $ f n r d h (marshalPort p) txtLen txtP)) 
-            (\_ f e n r d _ -> createCallbackData cb e (RegisterReply (unmarshalFlags f) <$> fromCString n <*> fromCString r <*> fromCString d))
+            (\_ f e n r d _ -> createCallbackData cb e (RegisterReply (unmarshalFlags f) <$> (FullServiceName <$> fromCString n <*> fromCString r <*> fromCString d)))
 
 -- }}}
 
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ExistentialQuantification #-}
 module Main where
 import Network.DNSSD
-import Network.DNSSD.InterfaceIndex
-import Network.DNSSD.StringLike
 import Control.Concurrent
 import Control.Monad
+import Network.Socket
+
+class Closable t where  
+    doClose :: t -> IO ()
+
+instance Closable ThreadId                  where doClose = killThread
+instance Closable Socket                    where doClose = sClose
+instance Closable ServiceRef                where doClose = stopService
+instance Closable RecServiceRefAdd          where doClose = stopService
+
 
 serviceName :: String
 serviceName = "_hs-ping._udp"
 
 data Event 
     = Service ServiceEvent
+    | PingFrom SockAddr 
     deriving Show
 
 type LogMsg             = Event -> IO ()
 type AddAddress         = () -> IO ()
 type Browser            = ServiceEventProcessor -> IO (ServiceResult ServiceRef)
 
+class NameAndFlags t where
+    getName  :: t s -> FullServiceName s
+    getFlags :: t s -> Flags
+
+instance NameAndFlags BrowseReply where
+    getName  (BrowseReply  _                       n) = n
+    getFlags (BrowseReply (ReplyWithInterface f _) _) = f
+
+instance NameAndFlags RegisterReply where
+    getName     (RegisterReply _ n) = n
+    getFlags    (RegisterReply f _) = f
+
+
+makeServiceEvent :: NameAndFlags t => ServiceResult (t String) -> ServiceEvent
+makeServiceEvent (Left  err) = Error err
+makeServiceEvent (Right res) = Event eventType (getName res)
+    where 
+        eventType = if isAddition then Added else Removed
+        isAddition = DNSServiceFlagsAdd `elem` (getFlags res)
+
+
 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
+     callback = handler . makeServiceEvent
+
+bindServerSocket :: Socket -> IO ()
+bindServerSocket = flip bindSocket (SockAddrInet aNY_PORT 0)
+
+createSocket :: IO Socket
+createSocket = socket AF_INET Datagram udp 
+  where udp = 17
+
+createServerSocket :: IO Socket
+createServerSocket = do
+    s <- createSocket
+    bindServerSocket s
+    return s
+
+startEcho :: Socket -> (SockAddr -> IO ()) -> IO ThreadId
+startEcho sock log = forkIO $ do
+    (_ , _ , peer) <- recvFrom sock 0
+    log peer
+    sendTo sock "Pong" peer 
+    return ()
+
                 
-startServiceRegistration :: IO (ServiceResult ServiceRef)     
-startServiceRegistration = undefined
+startServiceRegistration :: PortNumber -> (ServiceEvent -> IO ()) -> IO (ServiceResult RecServiceRefAdd)     
+startServiceRegistration port handler = 
+    register 
+        Nothing      -- instance name
+        serviceName
+        Nothing      -- host
+        Nothing      -- domain
+        port
+        Nothing    -- TXT
+        callback
+        []
+        DNSServiceInterfaceIndexAny
+    where
+        callback = handler . makeServiceEvent
+
    
 
 main = do
     lock <- newMVar ()
-    startServiceBrowser (logMsg lock) 
+    s <- createServerSocket
+    port <- socketPort s
+    startServiceRegistration port (logMsg lock) 
+    startServiceBrowser           (logMsg lock) 
     threadDelay 10000000