2 files changed, 88 insertions, 0 deletions

diff --git a/nalias.hs b/nalias.hs
new file mode 100644
index 00000000..fa1b6f71
--- /dev/null
+++ b/nalias.hs
@@ -0,0 +1,70 @@
+import Network.Socket
+import qualified Network.BSD as BSD
+import ControlMaybe
+import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
+import System.IO.Error (isDoesNotExistError)
+import System.Endian
+import Data.List (nub)
+import qualified Data.Text as Text
+import GetHostByAddr (getHostByAddr)
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import System.Environment
+
+unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
+    SockAddrInet port (toBE32 a)
+unmap6mapped4 addr = addr
+
+make6mapped4 addr@(SockAddrInet6 {}) = addr
+make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
+
+
+reverseResolve addr = 
+    handleIO_ (return []) $ do
+        ent <- getHostByAddr (unmap6mapped4 addr) --  AF_UNSPEC addr
+        let names = BSD.hostName ent : BSD.hostAliases ent
+        return $ map Text.pack $ nub names
+
+forwardResolve addrtext = do
+    r <- atomically newEmptyTMVar
+    mvar <- atomically newEmptyTMVar
+    rt <- forkOS $ resolver r mvar
+    tt <- forkIO $ timer r rt
+    atomically $ putTMVar mvar tt
+    atomically $ readTMVar r
+ where
+    resolver r mvar = do
+      xs <- handle (\e -> let _ = isDoesNotExistError e in return [])
+            $ do fmap (map $ make6mapped4 . addrAddress) $ 
+                  getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
+                    (Just $ Text.unpack $ strip_brackets addrtext)
+                    (Just "5269")
+      did <- atomically $ tryPutTMVar r (nub xs)
+      when did $ do
+      tt <- atomically $ readTMVar mvar
+      throwTo tt (ErrorCall "Interrupted delay")
+      return ()
+    timer r rt = do
+      handle (\(ErrorCall _)-> return ()) $ do
+      threadDelay 2000000
+      did <- atomically $ tryPutTMVar r []
+      when did $ do
+      putStrLn $ "timeout resolving: "++show addrtext
+      killThread rt
+    strip_brackets s = 
+      case Text.uncons s of
+          Just ('[',t) -> Text.takeWhile (/=']') t
+          _            -> s
+
+main = do
+    args <- getArgs
+    forM args $ \arg -> do
+    putStrLn $ arg ++ ":"
+    let targ = Text.pack arg
+    addrs <- forwardResolve targ
+    putStrLn $ "  forward: " ++ show addrs
+    forM addrs $ \addr -> do
+        names <- reverseResolve addr
+        putStrLn $ "  reverse "++show addr++": "++show names
+    return ()
diff --git a/nalias2.hs b/nalias2.hs
new file mode 100644
index 00000000..609f2ec6
--- /dev/null
+++ b/nalias2.hs
@@ -0,0 +1,18 @@
+import System.Environment
+import Control.Monad
+import qualified Data.Text as Text
+
+import DNSCache
+
+main = do
+    dns <- newDNSCache
+    args <- getArgs
+    forM args $ \arg -> do
+    putStrLn $ arg ++ ":"
+    let targ = Text.pack arg
+    addrs <- forwardResolve dns targ
+    putStrLn $ "  forward: " ++ show addrs
+    forM addrs $ \addr -> do
+        names <- reverseResolve dns addr
+        putStrLn $ "  reverse "++show addr++": "++show names
+    return ()