mDNSResponder-client (empty) → 1.0.0
raw patch · 7 files changed
+1146/−0 lines, 7 filesdep +Cabaldep +basedep +bytestringsetup-changed
Dependencies added: Cabal, base, bytestring, ctrie, data-endian, mDNSResponder-client, network, network-msg, transformers
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Network/DNS/MDNSResponder/Client.hsc +701/−0
- Setup.hs +2/−0
- Test.hs +139/−0
- include/dnssd_ipc.h +220/−0
- mDNSResponder-client.cabal +49/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for mDNSResponder-client++## 1.0.0 -- 2017-01-03++* First version, with support for registering, browsing, and resolving.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Obsidian Systems LLC++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 Obsidian Systems LLC 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.
+ Network/DNS/MDNSResponder/Client.hsc view
@@ -0,0 +1,701 @@+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification, Rank2Types #-}+{-|+Module : Network.DNS.MDNSResponder.Client+Description : Library for talking to the mDNSResponder daemon.+Copyright : (c) 2016, Obsidian Systems LLC+License: BSD3+Maintainer : shea@shealevy.com+Stability : experimental+-}+module Network.DNS.MDNSResponder.Client+ ( -- * Managing connections+ Connection+ , connect+ , disconnect+ , defaultAddr+ , AsyncConnectionError (..)+ , AsyncConnectionErrorHandler+ -- * Data types+ , NullFreeByteString+ -- ** Flags+ , DNSServiceFlags+ -- ** Error codes+ , DNSServiceErrorType+ , kDNSServiceErr_NoError+ , kDNSServiceErr_ServiceNotRunning+ , kDNSServiceErr_ShortResponse+ -- ** Interface indices+ , InterfaceIndex+ , kDNSServiceInterfaceIndexAny+ , kDNSServiceInterfaceIndexLocalOnly+ -- * Requests+ , Request (..)+ , request+ -- * Responses+ , AsyncResponseHandler+ , ResponseHeader (..)+ , Response (..)+ , NTDResponse (..)+ , ResolveResponse (..)+ ) where++#include "dnssd_ipc.h"+#include <sys/socket.h>++import Data.Word+import Data.Int+import Data.Bits+import Data.IORef+import Data.Typeable+import System.Environment+import Control.Exception+import Control.Concurrent+import Control.Monad+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import Foreign.Storable+import Foreign.C.Types+import Foreign.C.String++import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class++import Data.ByteString as BS+import Data.ByteString.Unsafe++import Data.Endian++import qualified Control.Concurrent.Map as CM++import qualified Network.Socket as S++import Network.Socket.Msg++-- | Flag type for API calls. +newtype DNSServiceFlags =+ DNSServiceFlags #{type DNSServiceFlags} deriving (Eq, Bits)++instance Monoid DNSServiceFlags where+ mempty = DNSServiceFlags 0+ mappend = (.|.)++-- | An index to specify on which interface a service exists.+newtype InterfaceIndex = InterfaceIndex Word32++-- | The service is served on any interface.+kDNSServiceInterfaceIndexAny :: InterfaceIndex+kDNSServiceInterfaceIndexAny =+ InterfaceIndex #{const kDNSServiceInterfaceIndexAny}++-- | The service is only served to the local host.+kDNSServiceInterfaceIndexLocalOnly :: InterfaceIndex+kDNSServiceInterfaceIndexLocalOnly =+ InterfaceIndex #{const kDNSServiceInterfaceIndexLocalOnly}++-- | Error codes returned by the daemon.+newtype DNSServiceErrorType =+ DNSServiceErrorType #{type DNSServiceErrorType}+ deriving (Eq, Show)++-- | There was no error.+kDNSServiceErr_NoError :: DNSServiceErrorType+kDNSServiceErr_NoError =+ DNSServiceErrorType #{const kDNSServiceErr_NoError}++-- | The daemon is not running/closed the connection.+--+-- You should still call 'disconnect' to clean up resources!+kDNSServiceErr_ServiceNotRunning :: DNSServiceErrorType+kDNSServiceErr_ServiceNotRunning =+ DNSServiceErrorType (#{const kDNSServiceErr_ServiceNotRunning})++-- | The response sent by the daemon was too short.+--+-- This is not an upstream error code, the official Apple client just+-- declines to call the callback in this case. It is outside of the+-- documented range for mDNS error codes.+kDNSServiceErr_ShortResponse :: DNSServiceErrorType+kDNSServiceErr_ShortResponse = DNSServiceErrorType 1++-- | A 'ByteString' with no null characters.+--+-- This invariant must be maintained by the caller.+type NullFreeByteString = ByteString++-- | The shared header for daemon responses.+--+-- The header also contains an error code on the wire, but it's always+-- 'kDNSServiceErr_NoError' on code paths that get passed a header.+data ResponseHeader = ResponseHeader+ { reshdr_flags :: !DNSServiceFlags -- ^ Flags applicable to the+ -- response.+ , reshdr_ifi :: !InterfaceIndex -- ^ The interface in question.+ }++-- | A response with its header.+data Response a = Response !ResponseHeader !a++-- | A response containing a name, registration type, and domain.+data NTDResponse = NTDResponse+ { ntd_name :: !NullFreeByteString -- ^ The service name.+ , ntd_regtype :: !NullFreeByteString -- ^ The service registration+ -- type.+ , ntd_domain :: !NullFreeByteString -- ^ The domain on which the+ -- service is registered.+ }++-- | A response to a 'ServiceResolve' request.+data ResolveResponse = ResolveResponse+ { resolve_fullname :: !NullFreeByteString -- ^ The full service+ -- domain name.+ , resolve_hosttarget :: !NullFreeByteString -- ^ The hostname of the+ -- machine providing+ -- the service.+ , resolve_port :: !S.PortNumber -- ^ The port number the service is+ -- served on.+ , resolve_txt :: !ByteString -- ^ The primary TXT record for the+ -- service.+ }++-- | A request to the mDNSResponder daemon.+--+-- Parameterized by the type of the response.+--+-- Constructor fields documented with the constructor due to+-- https://ghc.haskell.org/trac/ghc/ticket/12050+--+-- See also the documentation for these requests in dns_sd.h+data Request a where+ -- | Register a service.+ --+ -- Fields:+ --+ -- 1. flags: Indicate behavior on name conflict.+ -- 2. index: The interface(s) on which to register the service.+ -- 3. name: The service name to be registered, or 'empty' for the+ -- default.+ -- 4. type: The service type followed by the protocol, separated by+ -- a dot.+ -- 5. domain: The domain on which to advertise, or 'empty' for the+ -- default domains.+ -- 6. host: The SRV target host name, or 'empty' for the default+ -- host name(s).+ -- 7. port: The port the service listens on.+ -- 8. txt: The text record data, or 'empty' for none.+ ServiceRegister :: !DNSServiceFlags+ -> !InterfaceIndex+ -> !NullFreeByteString+ -> !NullFreeByteString+ -> !NullFreeByteString+ -> !NullFreeByteString+ -> !S.PortNumber+ -> !ByteString+ -> Request NTDResponse+ -- | Browse for a service.+ --+ -- Fields:+ --+ -- 1. index: The interface(s) on which to browse.+ -- 2. regtype: The service type being browsed for followed by the+ -- protocol, with optional subtypes or group IDs.+ -- 3. domain: The domain on which to browse, or 'empty' for the+ -- default.+ ServiceBrowse :: !InterfaceIndex+ -> !NullFreeByteString+ -> !NullFreeByteString+ -> Request NTDResponse+ -- | Resolve a service.+ --+ -- You probably want to populate the name, regtype, and domain from+ -- the results of a 'ServiceBrowse' request.+ --+ -- Fields:+ --+ -- 1. flags: Specify multicast behavior.+ -- 2. index: The interface(s) on which to resolve.+ -- 3. name: The name of the service to be resolved.+ -- 4. regtype: The type of the service to be resolved.+ -- 5. domain: The domain of the service to be resolved.+ ServiceResolve :: !DNSServiceFlags+ -> !InterfaceIndex+ -> !NullFreeByteString+ -> !NullFreeByteString+ -> !NullFreeByteString+ -> Request ResolveResponse++-- | A connection to the daemon.+data Connection = Connection+ { sock :: !S.Socket+ , counter :: !(IORef Word64)+ , requestQueue :: !(Chan AnyRequestRegistration)+ , responseMap :: !(CM.Map Word64 AnyAsyncResponseHandler)+ , recvThreadId :: !ThreadId+ , sendThreadId :: !ThreadId+ }++-- | An error communicating with the daemon.+data AsyncConnectionError+ = AsyncConnectionIOError !IOError -- ^ An 'IOError' occured while+ -- using the socket.+ | AsyncConnectionClosedError -- ^ The daemon closed the socket+ -- unexpectedly.+ | AsyncConnectionBadDaemonVersionError !Word32 -- ^ The daemon+ -- reported a version+ -- we can't handle.+ deriving (Show, Typeable)++instance Exception AsyncConnectionError++-- | Handle a generic error communicating with the daemon.+--+-- These errors may occur at any time, are not associated with any+-- particular request, and are not generally recoverable. You should+-- still call 'disconnect' to clean up resources after recieving an+-- error.+--+-- The handler is called in its own thread.+type AsyncConnectionErrorHandler = AsyncConnectionError -> IO ()++-- | Connect to the daemon.+connect :: S.SockAddr -- ^ The address of the daemon.+ --+ -- You probably want 'defaultAddr'. In any case,+ -- the implementation currently only works for+ -- AF_UNIX-based daemons, even though there are+ -- AF_INET-based daemons in existence.+ -> AsyncConnectionErrorHandler+ -> IO (Either DNSServiceErrorType Connection)+connect addr e_handler = bracketOnError makeSocket S.close $ \s -> do+ S.connect s addr+ allocaBytes ipcMsgHdrSz $ \hdr -> do+ pokeHdr (IpcMsgHdr 0 #{const connection_request} 0) hdr+ sendAll s (castPtr hdr) ipcMsgHdrSz+ err <- recvError s+ case err of+ DNSServiceErrorType #{const kDNSServiceErr_NoError} -> do+ chan <- newChan+ handlers <- CM.empty+ sTidVar <- newEmptyMVar+ rTidVar <- newEmptyMVar+ counter' <- newIORef 0+ bracketOnError+ (createSendThread s chan sTidVar rTidVar)+ killThread $ \sTid -> do+ bracketOnError+ (createRecvThread s handlers sTidVar rTidVar)+ killThread $ \rTid -> do+ return . Right $+ Connection s counter' chan handlers rTid sTid+ _ -> return $ Left err+ where+ makeSocket = S.socket S.AF_UNIX S.Stream S.defaultProtocol++ createSendThread s chan sTidVar rTidVar =+ mask_ $ forkIOWithUnmask $+ sendThread s chan e_handler sTidVar rTidVar++ createRecvThread s handlers sTidVar rTidVar =+ mask_ $ forkIOWithUnmask $+ recvThread s handlers e_handler sTidVar rTidVar++-- | The default address for the daemon.+defaultAddr :: IO S.SockAddr+defaultAddr = do+ m_def <- lookupEnv #{const_str MDNS_UDS_SERVERPATH_ENVVAR}+ let p = case m_def of+ Just p' -> p'+ Nothing -> #{const_str MDNS_UDS_SERVERPATH}+ return $ S.SockAddrUnix p++-- | Disconnect from the daemon.+--+-- It is an error to use the passed in 'Connection' during or after+-- this call, though it is safe to call this again if it fails due+-- to an asynchronous exception.+disconnect :: Connection+ -> IO ()+disconnect (Connection {..}) = do+ killThread recvThreadId+ killThread sendThreadId+ S.close sock++-- | Handle asynchronous responses to a request.+--+-- Some requests result in multiple responses.+--+-- The handler is called on its own thread.+type AsyncResponseHandler a = Either DNSServiceErrorType (Response a)+ -> IO ()++recvError :: S.Socket -> IO DNSServiceErrorType+recvError s = alloca $ \buf -> do+ res <- recvAll s (castPtr buf) #{size DNSServiceErrorType}+ case res of+ RecvAllOK -> DNSServiceErrorType . fromBigEndian <$> peek buf+ RecvAllClosed -> return kDNSServiceErr_ServiceNotRunning++-- | Send a request to the daemon.+--+-- The 'PeekableResponse' constraint is an implementation detail, all+-- 'Request's have a type appropriate for 'request'. Unfortunately,+-- it doesn't seem possible to hide this constraint from the haddock+-- docs.+request :: PeekableResponse a+ => Connection+ -> Request a+ -> AsyncResponseHandler a+ -> IO DNSServiceErrorType -- ^ The immediate error from the+ -- daemon, if any. Even if+ -- 'kDNSServiceErr_NoError' is+ -- returned here, there still may be+ -- asynchronous errors for this+ -- request.+request (Connection {..}) req handler =+ bracket makeSocks closeSocks $ \(us, them) -> do+ ctx <- atomicModifyIORef' counter (\x -> (x + 1, x + 1))+ CM.insert ctx (AnyAsyncResponseHandler handler) responseMap+ writeChan requestQueue (AnyRequestRegistration ctx req them)+ recvError us+ where+ makeSocks = S.socketPair S.AF_UNIX S.Stream S.defaultProtocol+ closeSocks (us, them) = S.close us >> S.close them++data AnyAsyncResponseHandler = forall a . PeekableResponse a =>+ AnyAsyncResponseHandler !(AsyncResponseHandler a)++data AnyRequestRegistration =+ forall a . AnyRequestRegistration !Word64 !(Request a) !S.Socket++data IpcMsgHdr = IpcMsgHdr+ { datalen :: !Word32+ , op :: !Word32+ , context :: !Word64+ }++ipcMsgHdrSz :: Int+ipcMsgHdrSz = #{size ipc_msg_hdr}++pokeHdr :: IpcMsgHdr+ -> (Ptr IpcMsgHdr)+ -> IO ()+pokeHdr (IpcMsgHdr {..}) hdr = do+ #{poke ipc_msg_hdr, version} hdr $+ toBigEndian (#{const VERSION} :: Word32)+ #{poke ipc_msg_hdr, datalen} hdr $ toBigEndian datalen+ #{poke ipc_msg_hdr, ipc_flags} hdr (0 :: Word32)+ #{poke ipc_msg_hdr, op} hdr $ toBigEndian op+ #{poke ipc_msg_hdr, client_context} hdr context+ #{poke ipc_msg_hdr, reg_index} hdr (0 :: Word32)++peekHdr :: Ptr IpcMsgHdr -> IO IpcMsgHdr+peekHdr hdr = do+ ver <-+ (fromBigEndian <$> #{peek ipc_msg_hdr, version} hdr) :: IO Word32+ case ver of+ #{const VERSION} -> do+ datalen <- fromBigEndian <$> #{peek ipc_msg_hdr, datalen} hdr+ op <- fromBigEndian <$> #{peek ipc_msg_hdr, op} hdr+ context <- #{peek ipc_msg_hdr, client_context} hdr+ return $ IpcMsgHdr datalen op context+ _ -> throwIO $ AsyncConnectionBadDaemonVersionError ver++size :: Request a -> Int+size (ServiceRegister _ _ name ty domain host _ txt) =+ #{size DNSServiceFlags} ++ 4 + -- InterfaceIndex, Word32+ (BS.length name) + 1 ++ (BS.length ty) + 1 ++ (BS.length domain) + 1 ++ (BS.length host) + 1 ++ 2 + -- Port+ 2 + -- txtLen+ (BS.length txt)+size (ServiceBrowse _ ty domain) =+ #{size DNSServiceFlags} ++ 4 + -- InterfaceIndex, Word32+ (BS.length ty) + 1 ++ (BS.length domain) + 1+size (ServiceResolve _ _ name regtype domain) =+ #{size DNSServiceFlags} ++ 4 + -- InterfaceIndex, Word32+ (BS.length name) + 1 ++ (BS.length regtype) + 1 ++ (BS.length domain) + 1++operation :: Request a -> Word32+operation (ServiceRegister _ _ _ _ _ _ _ _) =+ #{const reg_service_request}+operation (ServiceBrowse _ _ _) = #{const browse_request}+operation (ServiceResolve _ _ _ _ _) = #{const resolve_request}++type Poke =+ (Ptr Word8 -> IO (), Int)++runPokes :: Ptr Word8 -> [ Poke ] -> IO ()+runPokes _ [] = return ()+runPokes p ((io, sz) : pokes) = do+ io p+ runPokes (plusPtr p sz) pokes++pokeBSNull :: Int -> ByteString -> Ptr Word8 -> IO ()+pokeBSNull sz bs ptr = do+ pokeBS sz bs ptr+ poke (plusPtr ptr sz) (0 :: Word8)++pokeBS :: Int -> ByteString -> Ptr Word8 -> IO ()+pokeBS sz bs ptr = unsafeUseAsCString bs $ \buf -> do+ copyBytes ptr (castPtr buf) sz++pokeBody :: Request a -> Ptr (Request a) -> IO ()+pokeBody (ServiceRegister+ (DNSServiceFlags flags)+ (InterfaceIndex ifi)+ name+ ty+ domain+ host+ port+ txt+ ) ptr = runPokes (castPtr ptr)+ [ (flip poke (toBigEndian flags) . castPtr, 4)+ , (flip poke (toBigEndian ifi) . castPtr, 4)+ , (pokeBSNull name_sz name, name_sz + 1)+ , (pokeBSNull ty_sz ty, ty_sz + 1)+ , (pokeBSNull domain_sz domain, domain_sz + 1)+ , (pokeBSNull host_sz host, host_sz + 1)+ , (flip poke port . castPtr, 2)+ , (flip poke (toBigEndian txtln) . castPtr, 2)+ , (pokeBS txt_sz txt, txt_sz)+ ]+ where+ name_sz = BS.length name+ ty_sz = BS.length ty+ domain_sz = BS.length domain+ host_sz = BS.length host+ txtln :: Word16+ txtln = fromIntegral txt_sz+ txt_sz = BS.length txt+pokeBody (ServiceBrowse (InterfaceIndex ifi) ty domain) ptr =+ runPokes (castPtr ptr)+ [ (flip poke (0 :: Word32) . castPtr, 4)+ , (flip poke (toBigEndian ifi) . castPtr, 4)+ , (pokeBSNull ty_sz ty, ty_sz + 1)+ , (pokeBSNull domain_sz domain, domain_sz + 1)+ ]+ where+ ty_sz = BS.length ty+ domain_sz = BS.length domain+pokeBody (ServiceResolve+ (DNSServiceFlags flags)+ (InterfaceIndex ifi)+ name+ ty+ domain+ ) ptr = runPokes (castPtr ptr)+ [ (flip poke (toBigEndian flags) . castPtr, 4)+ , (flip poke (toBigEndian ifi) . castPtr, 4)+ , (pokeBSNull name_sz name, name_sz + 1)+ , (pokeBSNull ty_sz ty, ty_sz + 1)+ , (pokeBSNull domain_sz domain, domain_sz + 1)+ ]+ where+ name_sz = BS.length name+ ty_sz = BS.length ty+ domain_sz = BS.length domain++data RecvAllResult = RecvAllOK | RecvAllClosed++recvAll :: S.Socket -> Ptr Word8 -> Int -> IO RecvAllResult+recvAll s = loop+ where+ loop ptr i = do+ cnt <- S.recvBuf s ptr i+ if cnt == i+ then return RecvAllOK+ else if cnt == 0+ then return RecvAllClosed+ else loop (plusPtr ptr cnt) (i - cnt)++sendAll :: S.Socket -> Ptr Word8 -> Int -> IO ()+sendAll s = loop+ where+ loop ptr' i' = do+ cnt <- S.sendBuf s ptr' i'+ if cnt == i'+ then return ()+ else loop (plusPtr ptr' cnt) (i' - cnt)++data SockEx = SockEx deriving (Show, Typeable)++instance Exception SockEx++sendThread :: S.Socket+ -> Chan AnyRequestRegistration+ -> AsyncConnectionErrorHandler+ -> MVar ThreadId+ -> MVar ThreadId+ -> (forall a. IO a -> IO a)+ -> IO ()+sendThread sock chan e_handler sTidVar rTidVar unmask = do+ _ <- (try :: IO () -> IO (Either SockEx ())) . unmask $ do+ myThreadId >>= putMVar sTidVar+ Left e <- (try loop) :: IO (Either IOError ())+ takeMVar rTidVar >>= flip throwTo SockEx+ _ <- forkIO . e_handler $ AsyncConnectionIOError e+ drain+ unmask drain+ where+ loop = do+ (AnyRequestRegistration ctx req them) <- readChan chan+ let sz = size req+ full_sz = ipcMsgHdrSz + sz+ op = operation req+ allocaBytes (full_sz + 1) $ \reqptr -> do+ pokeHdr (IpcMsgHdr (fromIntegral $ sz + 1) op ctx) reqptr+ poke (plusPtr reqptr ipcMsgHdrSz) (0 :: CChar)+ pokeBody req $ (plusPtr reqptr (ipcMsgHdrSz + 1))+ sendAll sock (castPtr reqptr) full_sz+ alloca $ \cmsgptr -> do+ poke cmsgptr (S.fdSocket them)+ cmsg <- unsafePackCStringLen (castPtr cmsgptr, #{size int})+ body <- unsafePackCStringLen ((plusPtr reqptr full_sz), 1)+ sendMsg sock body (S.SockAddrUnix "")+ [ CMsg #{const SOL_SOCKET} #{const SCM_RIGHTS} cmsg ]+ S.close them+ loop++ drain = do+ (AnyRequestRegistration _ _ them) <- readChan chan+ S.close them+ drain++class PeekableResponse a where+ peekResponseBody :: Ptr a -> Int -> IO (Maybe a)++instance PeekableResponse NTDResponse where+ peekResponseBody buf sz = runMaybeT $ do+ name_null <- findNull (castPtr buf) sz+ name <- lift $ packCStringLen (castPtr buf, name_null)+ let buf' = plusPtr buf (name_null + 1)+ sz' = sz - (name_null + 1)+ regtype_null <- findNull buf' sz'+ regtype <- lift $ packCStringLen (buf', regtype_null)+ let buf'' = plusPtr buf' (regtype_null + 1)+ sz'' = sz' - (regtype_null + 1)+ domain_null <- findNull buf'' sz''+ domain <- lift $ packCStringLen (buf'', domain_null)+ return $ NTDResponse name regtype domain++instance PeekableResponse ResolveResponse where+ peekResponseBody buf sz = runMaybeT $ do+ name_null <- findNull (castPtr buf) sz+ name <- lift $ packCStringLen (castPtr buf, name_null)+ let buf' = plusPtr buf (name_null + 1)+ sz' = sz - (name_null + 1)+ target_null <- findNull buf' sz'+ target <- lift $ packCStringLen (buf', target_null)+ let buf'' = plusPtr buf' (target_null + 1)+ sz'' = sz' - (target_null + 1)+ port_sz = sizeOf (undefined :: S.PortNumber)+ when (sz'' < port_sz) mzero+ port <- lift $ peek buf''+ let buf''' = plusPtr buf'' port_sz+ sz''' = sz'' - port_sz+ len_sz = 2 -- uint16+ when (sz''' < len_sz) mzero+ len <- (lift $ fromBigEndian <$> peek buf''') :: MaybeT IO Word16+ let buf'''' = plusPtr buf''' len_sz+ sz'''' = sz''' - len_sz+ len' = fromIntegral len+ when (sz'''' < len') mzero+ txt <- lift $ packCStringLen (buf'''', len')+ return $ ResolveResponse name target port txt++findNull :: CString -> Int -> MaybeT IO Int+findNull = go 0+ where+ go _ _ 0 = mzero+ go acc ptr n = do+ c <- lift $ peek ptr :: MaybeT IO CChar+ case c of+ 0 -> return acc+ _ -> go (acc + 1) (plusPtr ptr 1) (n - 1)++-- TODO: We should buffer reads here.+recvThread :: S.Socket+ -> CM.Map Word64 AnyAsyncResponseHandler+ -> AsyncConnectionErrorHandler+ -> MVar ThreadId+ -> MVar ThreadId+ -> (forall a. IO a -> IO a)+ -> IO ()+recvThread sock handlers e_handler sTidVar rTidVar unmask = do+ _ <- (try :: IO () -> IO (Either SockEx ())) $ do+ myThreadId >>= putMVar rTidVar+ err <- try $ do+ Left ex <- try $ unmask loop+ return ex+ readMVar sTidVar >>= flip throwTo SockEx+ -- After here we can't get a SockEx from the send thread+ unmask $ do+ _ <- forkIO . e_handler $ case err of+ Left e -> AsyncConnectionIOError e+ Right e -> e+ drain+ unmask drain+ where+ loop = do+ hdr <- allocaBytes ipcMsgHdrSz $ \buf -> do+ res <- recvAll sock (castPtr buf) ipcMsgHdrSz+ case res of+ RecvAllClosed -> throwIO AsyncConnectionClosedError+ RecvAllOK -> peekHdr buf+ m_handler <- CM.lookup (context hdr) handlers+ let len = fromIntegral $ datalen hdr+ allocaBytes len $ \buf -> do+ res <- recvAll sock buf len+ case res of+ RecvAllClosed -> throwIO AsyncConnectionClosedError+ RecvAllOK -> return ()+ case m_handler of+ Nothing -> return ()+ Just (AnyAsyncResponseHandler handler) -> do+ e_r_hdr <- peekResponseHeader buf len+ case e_r_hdr of+ Left err -> void . forkIO . handler $ Left err+ Right r_hdr -> do+ m_r_body <- peekResponseBody+ (plusPtr buf responseHdrSz)+ (len - responseHdrSz)+ let response = case m_r_body of+ Just r_body -> Right $ Response r_hdr r_body+ Nothing -> Left $ kDNSServiceErr_ShortResponse+ void . forkIO $ handler response+ loop++ drain = do+ entries <- CM.unsafeToList handlers+ mapM_ (\(ctx, _) -> CM.delete ctx handlers) entries+ -- This is ugly, but this is also an unlikely error path...+ threadDelay 5000+ drain++ responseHdrSz =+ #{size DNSServiceFlags} ++ 4 + -- interface index+ #{size DNSServiceErrorType}++ peekResponseHeader buf len = if len < responseHdrSz+ then return $ Left kDNSServiceErr_ShortResponse+ else do+ flags <- DNSServiceFlags . fromBigEndian <$> peek (castPtr buf)+ ifi <- InterfaceIndex . fromBigEndian <$>+ peek (plusPtr buf #{size DNSServiceFlags})+ err <- DNSServiceErrorType . fromBigEndian <$>+ peek (plusPtr buf (#{size DNSServiceFlags} + 4))+ return $ case err of+ DNSServiceErrorType #{const kDNSServiceErr_NoError} ->+ Right (ResponseHeader flags ifi)+ _ -> Left err
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+module Test (tests) where++import Data.Maybe+import Control.Concurrent+import Control.Monad++import Data.ByteString++import Distribution.TestSuite++import Network.DNS.MDNSResponder.Client++handle_err :: MVar (Maybe String) -> AsyncConnectionErrorHandler+handle_err var err = putMVar var . Just $+ "connect async: " ++ (show err)++register_req :: Request NTDResponse+register_req = ServiceRegister+ mempty+ kDNSServiceInterfaceIndexLocalOnly+ empty+ "_test._tcp"+ empty+ empty+ 80+ empty++browse_req :: Request NTDResponse+browse_req = ServiceBrowse+ kDNSServiceInterfaceIndexLocalOnly+ "_test._tcp"+ empty++resolve_req :: NullFreeByteString+ -> NullFreeByteString+ -> NullFreeByteString+ -> Request ResolveResponse+resolve_req = ServiceResolve+ mempty+ kDNSServiceInterfaceIndexLocalOnly++handle_register_res :: MVar (Maybe String) -> AsyncResponseHandler a+handle_register_res var (Left err) = putMVar var . Just $+ "register async: " ++ (show err)+handle_register_res var (Right _) = putMVar var Nothing++handle_browse_res :: MVar (Either String (Response a))+ -> AsyncResponseHandler a+handle_browse_res var (Left err) = putMVar var . Left $+ "browse async: " ++ (show err)+handle_browse_res var (Right res) = putMVar var $ Right res++handle_resolve_res :: MVar (Maybe String) -> AsyncResponseHandler a+handle_resolve_res var (Left err) = putMVar var . Just $+ "resolve async: " ++ (show err)+handle_resolve_res var (Right _) = putMVar var Nothing++resolve :: IO ()+ -> Connection+ -> Response NTDResponse+ -> MVar (Either String a)+ -> IO Progress+resolve cleanup' con (Response _ (NTDResponse {..})) var' = do+ var <- newEmptyMVar+ tid <- forkIO $ do+ Left str <- takeMVar var'+ putMVar var $ Just str+ let cleanup = do+ killThread tid+ cleanup'+ req = resolve_req ntd_name ntd_regtype ntd_domain+ err <- request con req (handle_resolve_res var)+ when (err /= kDNSServiceErr_NoError) $+ putMVar var . Just $ "resolve sync: " ++ (show err)+ res <- takeMVar var+ case res of+ Just msg -> do+ cleanup+ return . Finished $ Fail msg+ Nothing -> return $ Finished Pass++browseThen :: IO ()+ -> Connection+ -> MVar (Maybe String)+ -> IO Progress+browseThen cleanup' con var' = do+ var <- newEmptyMVar+ tid <- forkIO $ takeMVar var' >>= putMVar var . Left . fromJust+ let cleanup = do+ killThread tid+ cleanup'+ err <- request con browse_req (handle_browse_res var)+ when (err /= kDNSServiceErr_NoError) $+ putMVar var . Left $ "browse sync: " ++ (show err)+ res <- takeMVar var+ case res of+ Left msg -> do+ cleanup+ return . Finished $ Fail msg+ Right res' -> return $+ Progress "browse" (resolve cleanup con res' var)++registerThen :: IO ()+ -> Connection+ -> MVar (Maybe String)+ -> IO Progress+registerThen cleanup con var = do+ err <- request con register_req (handle_register_res var)+ when (err /= kDNSServiceErr_NoError) $+ putMVar var . Just $ "register sync: " ++ (show err)+ res <- takeMVar var+ case res of+ Just msg -> do+ cleanup+ return . Finished $ Fail msg+ Nothing -> return $+ Progress "register" (browseThen cleanup con var)++connectThen :: IO Progress+connectThen = do+ var <- newEmptyMVar+ addr <- defaultAddr+ e_con <- connect addr (handle_err var)+ return $ case e_con of+ Left err -> Finished . Fail $ "connect: " ++ (show err)+ Right con ->+ Progress "connect" (registerThen (disconnect con) con var)++tests :: IO [Test]+tests = return [ (Test registerAndResolve) ]+ where+ registerAndResolve = TestInstance+ { run = connectThen+ , name = "Register and resolve a service"+ , tags = []+ , options = []+ , setOption = \_ _ -> Right registerAndResolve+ }
+ include/dnssd_ipc.h view
@@ -0,0 +1,220 @@+/* -*- Mode: C; tab-width: 4 -*-+ *+ * Copyright (c) 2003-2015 Apple Inc. All rights reserved.+ *+ * Redistribution and use in source and binary forms, with or without+ * modification, are permitted provided that the following conditions are met:+ *+ * 1. Redistributions of source code must retain the above copyright notice,+ * this list of conditions and the following disclaimer.+ * 2. 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.+ * 3. Neither the name of Apple Inc. ("Apple") nor the names of its+ * contributors may be used to endorse or promote products derived from this+ * software without specific prior written permission.+ *+ * THIS SOFTWARE IS PROVIDED BY APPLE AND ITS 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 APPLE OR ITS 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.+ */++#ifndef DNSSD_IPC_H+#define DNSSD_IPC_H++#include "dns_sd.h"++//+// Common cross platform services+//+#if defined(WIN32)+# include <winsock2.h>+# define dnssd_InvalidSocket INVALID_SOCKET+# define dnssd_SocketValid(s) ((s) != INVALID_SOCKET)+# define dnssd_EWOULDBLOCK WSAEWOULDBLOCK+# define dnssd_EINTR WSAEINTR+# define dnssd_ECONNRESET WSAECONNRESET+# define dnssd_socklen_t int+# define dnssd_close(sock) closesocket(sock)+# define dnssd_errno WSAGetLastError()+# define dnssd_strerror(X) win32_strerror(X)+# define ssize_t int+# define getpid _getpid+# define unlink _unlink+extern char *win32_strerror(int inErrorCode);+#else+# include <sys/types.h>+# include <unistd.h>+# include <sys/un.h>+# include <string.h>+# include <stdio.h>+# include <stdlib.h>+# include <sys/stat.h>+# include <sys/socket.h>+# include <netinet/in.h>+# include <arpa/inet.h>+# define dnssd_InvalidSocket -1+# define dnssd_SocketValid(s) ((s) >= 0)+# define dnssd_EWOULDBLOCK EWOULDBLOCK+# define dnssd_EINTR EINTR+# define dnssd_ECONNRESET ECONNRESET+# define dnssd_EPIPE EPIPE+# define dnssd_socklen_t unsigned int+# define dnssd_close(sock) close(sock)+# define dnssd_errno errno+# define dnssd_strerror(X) strerror(X)+#endif++#if defined(USE_TCP_LOOPBACK)+# define AF_DNSSD AF_INET+# define MDNS_TCP_SERVERADDR "127.0.0.1"+# define MDNS_TCP_SERVERPORT 5354+# define LISTENQ 5+# define dnssd_sockaddr_t struct sockaddr_in+#else+# define AF_DNSSD AF_LOCAL+# ifndef MDNS_UDS_SERVERPATH+# define MDNS_UDS_SERVERPATH "/var/run/mDNSResponder"+# endif+# define MDNS_UDS_SERVERPATH_ENVVAR "DNSSD_UDS_PATH"+# define LISTENQ 100+// longest legal control path length+# define MAX_CTLPATH (sizeof(((struct sockaddr_un*)0)->sun_path))+# define dnssd_sockaddr_t struct sockaddr_un+#endif++// Compatibility workaround+#ifndef AF_LOCAL+#define AF_LOCAL AF_UNIX+#endif++// General UDS constants+#define TXT_RECORD_INDEX ((uint32_t)(-1)) // record index for default text record++// IPC data encoding constants and types+#define VERSION 1+#define IPC_FLAGS_NOREPLY 1 // set flag if no asynchronous replies are to be sent to client++// Structure packing macro. If we're not using GNUC, it's not fatal. Most compilers naturally pack the on-the-wire+// structures correctly anyway, so a plain "struct" is usually fine. In the event that structures are not packed+// correctly, our compile-time assertion checks will catch it and prevent inadvertent generation of non-working code.+#ifndef packedstruct+ #if ((__GNUC__ > 2) || ((__GNUC__ == 2) && (__GNUC_MINOR__ >= 9)))+ #define packedstruct struct __attribute__((__packed__))+ #define packedunion union __attribute__((__packed__))+ #else+ #define packedstruct struct+ #define packedunion union+ #endif+#endif++typedef enum+{+ request_op_none = 0, // No request yet received on this connection+ connection_request = 1, // connected socket via DNSServiceConnect()+ reg_record_request, // reg/remove record only valid for connected sockets+ remove_record_request,+ enumeration_request,+ reg_service_request,+ browse_request,+ resolve_request,+ query_request,+ reconfirm_record_request,+ add_record_request,+ update_record_request,+ setdomain_request, // Up to here is in Tiger and B4W 1.0.3+ getproperty_request, // New in B4W 1.0.4+ port_mapping_request, // New in Leopard and B4W 2.0+ addrinfo_request,+ send_bpf, // New in SL+ getpid_request,+ release_request,+ connection_delegate_request,++ cancel_request = 63+} request_op_t;++typedef enum+{+ enumeration_reply_op = 64,+ reg_service_reply_op,+ browse_reply_op,+ resolve_reply_op,+ query_reply_op,+ reg_record_reply_op, // Up to here is in Tiger and B4W 1.0.3+ getproperty_reply_op, // New in B4W 1.0.4+ port_mapping_reply_op, // New in Leopard and B4W 2.0+ addrinfo_reply_op+} reply_op_t;++#if defined(_WIN64)+# pragma pack(push,4)+#endif++// Define context object big enough to hold a 64-bit pointer,+// to accomodate 64-bit clients communicating with 32-bit daemon.+// There's no reason for the daemon to ever be a 64-bit process, but its clients might be+typedef packedunion+{+ void *context;+ uint32_t u32[2];+} client_context_t;++typedef packedstruct+{+ uint32_t version;+ uint32_t datalen;+ uint32_t ipc_flags;+ uint32_t op; // request_op_t or reply_op_t+ client_context_t client_context; // context passed from client, returned by server in corresponding reply+ uint32_t reg_index; // identifier for a record registered via DNSServiceRegisterRecord() on a+ // socket connected by DNSServiceCreateConnection(). Must be unique in the scope of the connection, such that and+ // index/socket pair uniquely identifies a record. (Used to select records for removal by DNSServiceRemoveRecord())+} ipc_msg_hdr;++#if defined(_WIN64)+# pragma pack(pop)+#endif++// routines to write to and extract data from message buffers.+// caller responsible for bounds checking.+// ptr is the address of the pointer to the start of the field.+// it is advanced to point to the next field, or the end of the message++void put_uint32(const uint32_t l, char **ptr);+uint32_t get_uint32(const char **ptr, const char *end);++void put_uint16(uint16_t s, char **ptr);+uint16_t get_uint16(const char **ptr, const char *end);++#define put_flags put_uint32+#define get_flags get_uint32++#define put_error_code put_uint32+#define get_error_code get_uint32++int put_string(const char *str, char **ptr);+int get_string(const char **ptr, const char *const end, char *buffer, int buflen);++void put_rdata(const int rdlen, const unsigned char *rdata, char **ptr);+const char *get_rdata(const char **ptr, const char *end, int rdlen); // return value is rdata pointed to by *ptr -+// rdata is not copied from buffer.++void ConvertHeaderBytes(ipc_msg_hdr *hdr);++struct CompileTimeAssertionChecks_dnssd_ipc+{+ // Check that the compiler generated our on-the-wire packet format structure definitions+ // properly packed, without adding padding bytes to align fields on 32-bit or 64-bit boundaries.+ char assert0[(sizeof(client_context_t) == 8) ? 1 : -1];+ char assert1[(sizeof(ipc_msg_hdr) == 28) ? 1 : -1];+};++#endif // DNSSD_IPC_H
+ mDNSResponder-client.cabal view
@@ -0,0 +1,49 @@+name: mDNSResponder-client+version: 1.0.0+synopsis: Library for talking to the mDNSResponder daemon.+description:+ On OS X, iOS, and Bonjour for Windows, mDNSResponder is+ the daemon responsible for providing the Bonjour services.+ This is a client implementation directly on top of the+ (not documented outside of the open source code) Unix+ domain socket protocol, as the "low level" dns_sd C API+ provided by Apple relies on heavy use of callbacks and+ does not allow for nonblocking connections.+homepage: https://github.com/obsidiansystems/mDNSResponder-client+license: BSD3+license-file: LICENSE+author: Shea Levy+maintainer: shea@shealevy.com+copyright: (c) 2016, Obsidian Systems LLC+category: Network+build-type: Simple+extra-source-files: ChangeLog.md, include/dnssd_ipc.h+cabal-version: >=1.10++library+ exposed-modules: Network.DNS.MDNSResponder.Client+ build-depends: base >=4.9 && <4.10,+ network >=2.6.3.1 && <2.7,+ bytestring >=0.10.8.1 && <0.11,+ network-msg >=0.8 && <0.9,+ ctrie >=0.1.1.0 && <0.2,+ data-endian >=0.1.1 && <0.2,+ transformers >=0.5.2.0 && <0.6+ default-language: Haskell2010+ build-tools: hsc2hs+ include-dirs: include+ ghc-options: -Wall++test-suite test+ type: detailed-0.9+ test-module: Test+ build-depends: mDNSResponder-client,+ base,+ bytestring,+ Cabal >=1.24 && <1.25+ default-language: Haskell2010+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/obsidiansystems/haskell-socket.git