Commits

Anonymous committed f0012ac

AsyncMonad

  • Participants
  • Parent commits a254353

Comments (0)

Files changed (3)

File Ping/AsyncMonad.hs

+module AsyncMonad where
+import Control.Monad.Cont
+import Data.Monoid
+import Control.Monad.Reader
+import Control.Monad.Trans.Either
+
+data ErrorSource = ErrorSource deriving Show
+data ErrType = ServiceStart | AsyncError deriving Show
+type Err src e = (src , ErrType, e)
+type LogCategory = String
+type LogEvent    = String
+type Logger =   LogCategory -> LogEvent -> IO () 
+type AsyncFunc e a = EitherT e (ReaderT Logger (ContT () IO)) a
+
+runAsyncFunc :: AsyncFunc e a -> Logger -> (Either e a -> IO ()) -> IO ()
+runAsyncFunc af lgr f =  runContT (runReaderT (runEitherT af)  lgr)  f
+
+call :: errSrc -> ((Either e a -> IO ()) -> IO (Maybe e)) ->  AsyncFunc (Err errSrc e) a
+call src f = EitherT $ ReaderT $ \logger -> ContT $ \func ->  do
+   res <- f $ \r -> 
+        case r of
+            Left err -> func (Left (src, AsyncError, err))
+            Right res -> func (Right res)
+   case res of
+        Just err -> func $ Left (src , ServiceStart,  err)
+        Nothing  -> return ()
+

File Ping/Main.hs

 {-# LANGUAGE ExistentialQuantification #-}
-module Main where
+{-# LANGUAGE Rank2Types #-}
+module Main (main) where
 import Network.DNSSD
 import Control.Concurrent
 import Control.Monad
-import Network.Socket
+import Network.Socket hiding (getAddrInfo)
+import Network.DNSSD.StringLike
+import AsyncMonad
 
 class Closable t where  
     doClose :: t -> IO ()
 serviceName :: String
 serviceName = "_hs-ping._udp"
 
-logMsg :: Show a => MVar () -> a -> IO ()
-logMsg m a =  modifyMVar_ m $ \_ ->  putStrLn (show a)
+logMsg :: Show a => MVar () -> String -> a -> IO ()
+logMsg m src a =  modifyMVar_ m $ \_ ->  putStrLn ( src ++ ": " ++ show a)
 
 data ServiceEventType = Added | Removed deriving Show
 data ServiceEvent 
     where
         callback = handler . makeServiceEvent
 
-   
+type OneShotRes = IO (Maybe DNSServiceError)
 
+-- TODO : Result type should be Maybe DNSServiceError 
+oneShotService :: StopService t => ((ServiceResult repl -> IO ()) -> IO (ServiceResult t))  -> (ServiceResult repl -> IO ()) -> OneShotRes
+oneShotService startService handler = do
+    srvVar <- newEmptyMVar
+    srv    <- startService (callback srvVar)
+    case srv of
+        Right s -> putMVar srvVar s >> forkIO (threadDelay 1000000 >> stopService s) >> return Nothing
+        Left e  -> return $ Just e
+ where
+    callback srvVar repl = do
+        handler repl
+        case repl of
+            Right r   -> takeMVar srvVar >>= stopService
+            _         -> return ()
+-- | resolveService starts dns-sd service resolution. The callback terminates the service after the first result 
+-- | received. Watchdog thread stops te service after 1 second. TODO: log service timeout
+
+resolveService :: StringLike t => FullServiceName t -> (ServiceResult (t, PortNumber)  -> IO ()) -> OneShotRes
+resolveService fullName handleHost = 
+    oneShotService
+         (\cb -> resolve fullName cb [] DNSServiceInterfaceIndexAny)
+         (handleHost . fmap (\(ResolveReply _ _ host port _) -> (host, port)))
+
+
+resolveHost :: (String, PortNumber) -> (ServiceResult (HostAddress, PortNumber) -> IO ()) -> OneShotRes
+resolveHost (host, port) handle = 
+    oneShotService
+        (\cb -> getAddrInfo [DNSServiceProtocol_IPv4] host cb [] DNSServiceInterfaceIndexAny)
+        callback
+ where
+    replToResult (GetAddrInfoReply _ _ (SockAddrInet _ addr) _ ) = (addr, port)
+    callback = handle . fmap replToResult
+
+
+resolveHostAsync :: (String, PortNumber) -> AsyncFunc Err (HostAddress, PortNumber) 
+resolveHostAsync = call ErrorSource . resolveHost 
+
+processServiceEvent :: (forall a. Show a=> String -> a -> IO ()) -> (ServiceResult (String, PortNumber) -> IO ()) -> ServiceEvent -> IO ()
+processServiceEvent log handleHost ev = do
+    log "Browsing" ev
+    case ev of
+       Event Added fn -> do
+            srv <- resolveService fn handleHost
+            case srv of
+                Just e -> log "Resolving error: " e
+                _      -> return ()
+       _ -> return ()
+
+
+instance Closable () where doClose _ = return ()
+data Tst a = forall t. Closable t => Tst ((a -> IO ()) -> IO (ServiceResult t))
+instance Monad Tst  where
+    return a = Tst (\h -> h a >> return (Right ()))
+    (Tst f) >>= g = undefined
+        
 main = do
     lock <- newMVar ()
     s <- createServerSocket
     port <- socketPort s
-    startServiceRegistration port (logMsg lock) 
-    startServiceBrowser           (logMsg lock) 
+    startServiceRegistration port (logMsg lock "Registration") 
+    startServiceBrowser           (processServiceEvent (logMsg lock) (logMsg lock "Resolving"))
     threadDelay 10000000

File hs-bonjour.cabal

 executable Ping
     hs-source-dirs    : Ping
     main-is           : Main.hs
+    other-modules     : AsyncMonad
     build-depends     : hs-bonjour
                       , base == 4.5.*
                       , network == 2.3.*
+                      , either == 3.4.*
+                      , mtl == 2.1.*
     ghc-options       : -threaded