2 files changed, 24 insertions, 5 deletions

diff --git a/src/Network/Address.hs b/src/Network/Address.hs
index cc06ac0d..9a601dcd 100644
--- a/src/Network/Address.hs
+++ b/src/Network/Address.hs
@@ -648,6 +648,10 @@ genBucketSample' gen self (q,m,b)
     | otherwise        =  either error id . S.decode .  build <$> gen (nodeIdSize - q + 1)
  where
     nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
+
+    -- Prepends q bytes to modified input:
+    --   applies mask m
+    --   toggles bit b
     build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
      where
         hd = BS.take q $ S.encode self
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 1346174f..41e25486 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -30,6 +30,7 @@ import Data.Maybe
 import Data.Typeable
 import Network.Socket
 import Network.Socket.ByteString    as B
+import System.Endian
 import System.IO
 import System.IO.Error
 import System.Timeout
@@ -120,15 +121,15 @@ onInbound f tr = addHandler (\addr x -> f addr x >> return (Just id)) tr
 --  Example usage:
 --
 --  > -- Start client.
---  > quitServer <- forkListener (clientNet client)
+--  > quitServer <- forkListener "listener" (clientNet client)
 --  > -- Send a query q, recieve a response r.
 --  > r <- sendQuery client method q
 --  > -- Quit client.
 --  > quitServer
-forkListener :: Transport err addr x -> IO (IO ())
-forkListener client = do
+forkListener :: String -> Transport err addr x -> IO (IO ())
+forkListener name client = do
     thread_id <- forkIO $ do
-        myThreadId >>= flip labelThread "listener"
+        myThreadId >>= flip labelThread ("listener."++name)
         fix $ awaitMessage client . const
     return $ do
         closeTransport client
@@ -470,9 +471,23 @@ udpTransport bind_address = do
         r <- handle (ignoreEOF $ Just $ Right (B.empty, SockAddrInet 0 0)) $ do
                 Just . Right <$!> B.recvFrom sock udpBufferSize
         kont $! r
-    , sendMessage = \addr bs -> void $ B.sendTo sock bs addr
+    , sendMessage = case family of
         -- TODO: sendTo: does not exist (Network is unreachable)
         --       Occurs when IPv6 network is not available.
         --       Currently, we require -threaded to prevent a forever-hang in this case.
+        AF_INET6 -> \case
+            (SockAddrInet port addr) -> \bs ->
+                -- Change IPv4 to 4mapped6 address.
+                void $ B.sendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0
+            addr6 -> \bs -> void $ B.sendTo sock bs addr6
+        AF_INET  -> \case
+            (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do
+                let host4 = toBE32 raw4
+                -- Change 4mapped6 to ordinary IPv4.
+                -- hPutStrLn stderr $ "4mapped6 -> "++show (SockAddrInet port host4)
+                void $ B.sendTo sock bs (SockAddrInet port host4)
+            addr@(SockAddrInet6 {}) -> \bs -> hPutStrLn stderr ("Discarding packet to "++show addr)
+            addr4 -> \bs -> void $ B.sendTo sock bs addr4
+        _ -> \addr bs -> void $ B.sendTo sock bs addr
     , closeTransport = close sock
     }