Commits

Anonymous committed b6fe8b8

Resolving service

Comments (0)

Files changed (3)

 import Data.Maybe(maybe)
 import System.Exit
 import System.IO
+import Data.IORef
+import Data.Either
+import Control.Monad.Trans
+import Control.Monad.Trans.List
 
 menuItems = 
-    [ ("Quit"                       , exitSuccess                       ) 
-    , ("Register SSH"               , registerSSH >>= runServiceFor 5   )
-    , ("Open NAT"                   , openNAT     >>= runServiceFor 5   )
-    , ("Browse all services"        , browseAll   >>= runServiceFor 5   )
-    , ("Enumerate domains"          , enumDomains >>= runServiceFor 5   )
-    , ("Get address info"           , getAddressInfo >>= runServiceFor 5)
+    [ ("Quit"                       , exitSuccess                             ) 
+    , ("Register SSH"               , registerSSH       >>= runServiceFor 5   )
+    , ("Open NAT"                   , openNAT           >>= runServiceFor 5   )
+    , ("Browse all services"        , browseAll         >>= runServiceFor 5   )
+    , ("Enumerate domains"          , enumDomains       >>= runServiceFor 5   )
+    , ("Get address info"           , getAddressInfo    >>= runServiceFor 5   )
+    , ("Resolve records"            , resolveService                          )
     ]
 
 menuItemsWithChars = zip ['1'..] menuItems
 registerSSH = 
     register Nothing "_ssh._tcp" Nothing Nothing (PortNum 1234) print [] DNSServiceInterfaceIndexAny 
 
-browseAll = 
-    browse "_services._dns-sd._udp" Nothing print [DNSServiceFlagsBrowseDomains] DNSServiceInterfaceIndexAny 
+browseServices :: (ServiceResult (BrowseReply String) -> IO ()) -> IO (ServiceResult ServiceRef)
+browseServices callback = 
+    browse "_services._dns-sd._udp" Nothing callback [DNSServiceFlagsBrowseDomains] DNSServiceInterfaceIndexAny 
+
+browseAll = browseServices print
 
 openNAT = createPortMapping
     [ DNSServiceProtocol_TCP]
     []
     DNSServiceInterfaceIndexAny 
 
+resolveAndPrintRecord :: ServiceResult (BrowseReply String) ->  IO ()
+
+resolveAndPrintRecord (Left err) = print err
+resolveAndPrintRecord (Right (BrowseReply (ReplyWithInterface _ iface) name regType domain)) =
+    do
+        putStrLn $ "name=" ++ name ++ ", regtype=" ++ regType ++ ",domain=" ++ domain 
+        resolve name regType domain print [] iface >>= runServiceFor 5
+
+
 getAddressInfo =
     getAddrInfo [DNSServiceProtocol_IPv4] "www.google.com" print [] DNSServiceInterfaceIndexAny
 
 enumDomains = enumerateDomainsS (print ) [DNSServiceFlagsBrowseDomains] DNSServiceInterfaceIndexAny 
 
+
+newtype EitherT l m r = EitherT {runEitherT :: m (Either l r)}
+
+instance Monad m => Monad (EitherT l m ) where
+    return = EitherT . return . Right
+    (EitherT me) >>= f = EitherT $ me >>= \a ->
+        case a of
+            Left l -> return (Left l) 
+            Right r -> runEitherT (f r)
+ 
+instance MonadTrans (EitherT l) where
+    lift = EitherT . liftM Right 
+
+resolveService = runEitherT resolveService' >>= print
+resolveService' = do
+    res <-  EitherT $ buildListFor 1 browseServices
+    lift $ putStrLn "Got list of services"
+    case rights res of
+        [] -> lift $ putStrLn "No service names"
+        (BrowseReply (ReplyWithInterface i f) name regType domain : _) -> do
+            lift $ putStrLn $ "Browsing for service " ++ name
+            b <- EitherT $ buildListFor 1 (\cb -> browse (name ++ "._tcp") Nothing cb [DNSServiceFlagsBrowseDomains] DNSServiceInterfaceIndexAny)
+            lift $ print b
+
+buildListFor :: CreateServiceRef t => Int -> ((a -> IO ()) -> IO (ServiceResult t)) -> IO (ServiceResult [a])
+buildListFor n f = do
+    listRef <- newIORef []
+    srv <- f (\t -> modifyIORef listRef (t :))
+    case srv of
+        Left e -> return $ Left e
+        Right s -> do
+            threadDelay (n * 1000000)
+            stopService s
+            liftM (Right . reverse) (readIORef listRef) 
+
+
 main :: IO ()
-main = mainLoop
+main = do
+    mainLoop

Network/DNSSD/Services.chs

     t           -- hosttarget
     PortNumber  -- port
     -- TODO: TXT
+    deriving Show
 
 data QueryRecordReply t = QueryRecordReply
     ReplyWithInterface
     build-depends     : base ==4.5.* 
                       , hs-bonjour
                       , network == 2.3.*
+                      , mtl == 2.1.*
+                      , transformers == 0.3.*
 executable browser
     main-is : Browser.hs
     build-depends : base == 4.5.*