1. ppavel
  2. hs-bonjour

Commits

Pavel Perikov  committed 2c81fa0

TXT record building and parsing

  • Participants
  • Parent commits 0b9e816
  • Branches default

Comments (0)

Files changed (3)

File Main.hs

View file
  • Ignore whitespace
 import Network.DNSSD.InterfaceIndex 
 import Network.DNSSD.Flags
 import Network.DNSSD.ServicesUtils
+import Network.DNSSD.TXT
 import Control.Concurrent
 import Foreign.Ptr
 import Network.Socket hiding (getAddrInfo) -- TODO
     , ("Enumerate domains"          , enumDomains       >>= runServiceFor 5   )
     , ("Get address info"           , getAddressInfo    >>= runServiceFor 5   )
     , ("Resolve records"            , resolveService                          )
+    , ("TXT record building"        , txtExample                              )
     ]
 
+
+
+
 menuItemsWithChars = zip ['1'..] menuItems
 menuLines = map (\(n, (t, _)) -> show n ++ "\t" ++ t)  menuItemsWithChars
 
     threadDelay (seconds * 1000000)
     stopService srv
 
+txtExample :: IO ()
+txtExample = print $ buildTXTRecord [("key1", Just "val1"), ("key2" , Just "val2") , ("key3", Nothing)]
+
 registerSSH = 
     register Nothing "_ssh._tcp" Nothing Nothing 1234 Nothing print [] DNSServiceInterfaceIndexAny 
 

File Network/DNSSD/StringLike.hs

View file
  • Ignore whitespace
 class StringLike t where
     asCString   :: t -> (CString -> IO a) -> IO a
     fromCString :: CString -> IO t
+    fromCStringLen :: CString -> Int -> IO t
     cStringLen  :: t -> Int
 
 instance StringLike String where
     asCString  = withCString 
     fromCString = peekCString
+    fromCStringLen = curry peekCStringLen
     cStringLen  = length
 
 instance StringLike ByteString where
     asCString = useAsCString
     fromCString  = packCString
+    fromCStringLen = curry packCStringLen
     cStringLen  = B.length
 

File Network/DNSSD/TXT.chs

View file
  • Ignore whitespace
 {-# LANGUAGE ForeignFunctionInterface #-}
--- | Manipulating TXT records
--- | TODO : Data parsing
-module Network.DNSSD.TXT (
-        TXTRecordRef
-    ,   txtRecordCreate
-    ,   txtRecordSetValue
-    ,   txtRecordGetLength
-    ,   txtRecordRemoveValue
-    ,   withTXTRecordBytes
-) where
+module Network.DNSSD.TXT 
+    ( buildTXTRecord
+    , parseTXTRecord
+    ) where
 
 #define _DNS_SD_LIBDISPATCH 0
 #include <dns_sd.h>
 import Foreign.ForeignPtr
 import Foreign.C.Types
 import Foreign.C.String
+import Foreign.Marshal.Alloc (alloca, allocaBytes)
+import Foreign.Storable (peek)
 import Network.DNSSD.Error
+import Network.DNSSD.StringLike
+import Data.ByteString hiding (length, map)
+import Data.Maybe (catMaybes)
+import System.IO.Unsafe
+import Control.Monad (forM_)
+
+buildTXTRecord :: StringLike t => [(t,Maybe t)] -> ByteString
+buildTXTRecord keyvals = unsafePerformIO $ do
+    rec <- txtRecordCreate
+    forM_ keyvals    $ uncurry (txtRecordSetValue rec)
+    len <- txtRecordGetLength rec
+    res <- withTXTRecordBytes rec $ \p ->  packCStringLen (castPtr p , len)
+    return res
+
+
 
 withTXTRecordRef :: TXTRecordRef -> (Ptr TXTRecordRef -> IO b) -> IO b
 {# pointer *TXTRecordRef as TXTRecordRef foreign newtype#}
 txtRecordCreate = do
     rec <- mkTXTRecord
     withTXTRecordRef rec $ \r -> do
-         {# call TXTRecordCreate as ^ #} r 0 nullPtr
+         {# call unsafe TXTRecordCreate as ^ #} r 0 nullPtr
          let (TXTRecordRef fp) = rec
          addForeignPtrFinalizer pDealloc fp 
     return rec 
     -- }}}
 
-txtRecordSetValue :: TXTRecordRef -> String -> Maybe String -> IO DNSServiceError -- {{{
+
+txtRecordSetValue :: StringLike t => TXTRecordRef -> t -> Maybe t -> IO DNSServiceError -- {{{
 txtRecordSetValue r key mbs = 
     case mbs of
         Nothing -> setVal 0 nullPtr
-        (Just s) -> withCString s $ \cVal -> setVal (fromIntegral $ length s) cVal
+        (Just s) -> asCString s $ \cVal -> setVal (fromIntegral $ cStringLen s) cVal
     where
         setVal :: CUChar -> CString -> IO DNSServiceError
         setVal len s =
             fmap unmarshalError $ 
-            withCString key $  \cKey ->
+            asCString key $  \cKey ->
             withTXTRecordRef r $ \ptr ->
-            {# call TXTRecordSetValue as ^ #} ptr cKey len (castPtr s)
+            {# call unsafe TXTRecordSetValue as ^ #} ptr cKey len (castPtr s)
   --}}}
 
 txtRecordRemoveValue :: TXTRecordRef -> String -> IO DNSServiceError -- {{{
 withTXTRecordBytes :: TXTRecordRef -> (Ptr () -> IO a) -> IO a
 withTXTRecordBytes rec func =
     withTXTRecordRef rec  $ \r ->
-    {# call TXTRecordGetBytesPtr as ^ #} r >>= func
+    {# call unsafe TXTRecordGetBytesPtr as ^ #} r >>= func
 
 
+txtRecordContainsKey :: StringLike t => t -> ByteString -> Bool
+txtRecordContainsKey t bs = unsafePerformIO $ 
+    asCString t     $ \tp  ->
+    asCString bs    $ \bsp -> return $ {# call pure unsafe TXTRecordContainsKey as ^ #} (fromIntegral $ cStringLen bs) (castPtr bsp) tp /= 0
 
+txtRecordGetValue :: StringLike t => t -> ByteString -> Maybe t
+txtRecordGetValue key bs = unsafePerformIO $ 
+    asCString key   $ \keyP ->
+    asCString bs    $ \bsP  ->
+    alloca          $ \valLenP -> do
+        res <- {# call unsafe TXTRecordGetValuePtr as ^ #} (fromIntegral $ cStringLen bs) (castPtr bsP) keyP valLenP
+        if res /= nullPtr 
+            then do
+                valLen <- peek valLenP
+                fmap Just $ fromCStringLen (castPtr res)  (fromIntegral valLen)
+            else 
+                return Nothing
+
+txtRecordGetCount :: ByteString -> Int
+txtRecordGetCount bs = unsafePerformIO $
+    asCString bs $ \bsP -> fmap fromIntegral $ {# call unsafe TXTRecordGetCount as ^ #} (fromIntegral $ cStringLen bs) (castPtr bsP)
+
+txtRecordGetItemAtIndex :: StringLike t => Int -> ByteString -> Maybe (t, Maybe t)
+txtRecordGetItemAtIndex i bs = 
+    unsafePerformIO     $
+    asCString bs        $ \bsP      ->
+    alloca              $ \valLenP  -> 
+    alloca              $ \valP     ->
+    allocaBytes bufLen  $ \keyP     -> do
+      err <- fmap unmarshalError $ {# call unsafe TXTRecordGetItemAtIndex as ^ #} 
+                    (fromIntegral $ cStringLen bs)
+                    (castPtr      $ bsP)
+                    (fromIntegral $ i  )
+                    (fromIntegral $ bufLen)
+                    keyP   
+                    valLenP
+                    valP
+      if err == DNSServiceErr_NoError 
+         then 
+          do
+            key     <- fromCString keyP
+            val     <- peek valP
+            valS    <- if val /= nullPtr 
+                    then 
+                        do
+                            valLen  <- peek valLenP
+                            v       <- fromCStringLen (castPtr val) (fromIntegral valLen)
+                            return $ Just v
+                    else
+                        return Nothing
+            return $ Just (key,valS)
+         else
+            return Nothing
+ where
+    bufLen = 256
+
+            
+parseTXTRecord :: StringLike t => ByteString -> [(t , Maybe t)]
+parseTXTRecord bs = catMaybes $ map (flip txtRecordGetItemAtIndex  bs) [0..txtRecordGetCount bs]
+
+