module ADNS.Resolver
( Resolver
, initResolver
, toPTR
, resolveA, resolvePTR, resolveMX, resolveSRV
, query
, dummyDNS
)
where
import Control.Concurrent ( forkIO )
import Control.Concurrent.MVar
import Control.Monad ( when )
import Data.List ( sortBy )
import Data.Map ( Map )
import qualified Data.Map as Map
import Network
import Network.Socket ( HostAddress )
import ADNS.Base
import ADNS.Endian
type Resolver = String -> RRType -> [QueryFlag] -> IO (MVar Answer)
initResolver :: [InitFlag] -> (Resolver -> IO a) -> IO a
initResolver flags f =
adnsInit flags $ \dns ->
newMVar (RState dns Map.empty) >>= f . resolve
resolveA :: Resolver -> HostName -> IO (Either Status [HostAddress])
resolveA resolver x = do
Answer rc _ _ _ rs <- resolver x A [] >>= takeMVar
if rc /= sOK
then return (Left rc)
else return (Right [ addr | RRA (RRAddr addr) <- rs ])
resolveSRV :: Resolver -> HostName -> IO (Either Status [(HostName, PortID)])
resolveSRV resolver x = do
Answer rc _ _ _ rs <- resolver x SRV [] >>= takeMVar
if rc /= sOK
then return (Left rc)
else do
let cmp (RRSRV p1 _ _ _) (RRSRV p2 _ _ _) = compare p1 p2
cmp _ _ = error $ showString "unexpected record in SRV lookup: " (show rs)
rs' = sortBy cmp rs
as = [ (host, PortNumber $ toEnum port) | (RRSRV _ _ port host) <- rs' ]
return (Right as)
resolvePTR :: Resolver -> HostAddress -> IO (Either Status [HostName])
resolvePTR resolver x = do
Answer rc _ _ _ rs <- resolver (toPTR x) PTR [] >>= takeMVar
if rc /= sOK
then return (Left rc)
else return (Right [ addr | RRPTR addr <- rs ])
resolveMX :: Resolver -> HostName -> IO (Either Status [(HostName, HostAddress)])
resolveMX resolver x = do
Answer rc _ _ _ rs <- resolver x MX [] >>= takeMVar
if rc /= sOK
then return (Left rc)
else do
let cmp (RRMX p1 _) (RRMX p2 _) = compare p1 p2
cmp _ _= error $ showString "unexpected record in MX lookup: " (show rs)
rs' = sortBy cmp rs
as = [ (hn,a) | RRMX _ (RRHostAddr hn stat has) <- rs'
, stat == sOK && not (null has)
, RRAddr a <- has ]
return (Right as)
query :: (Resolver -> a -> IO (Either Status [b]))
-> (Resolver -> a -> IO (Maybe [b]))
query f dns x = fmap toMaybe (f dns x)
where
toMaybe (Left rc)
| rc == sNXDOMAIN = Just []
| rc == sNODATA = Just []
| otherwise = Nothing
toMaybe (Right r) = Just r
dummyDNS :: Resolver
dummyDNS host _ _ = newMVar
(Answer sSYSTEMFAIL Nothing (Just host) (1) [])
toPTR :: HostAddress -> String
toPTR ha = shows b4 . ('.':) .
shows b3 . ('.':) .
shows b2 . ('.':) .
shows b1 $ ".in-addr.arpa."
where
(b1,b2,b3,b4) = readWord32 ha
data ResolverState = RState
{ adns :: AdnsState
, queries :: Map Query (MVar Answer)
}
resolve :: MVar ResolverState -> Resolver
resolve mst r rt qfs = modifyMVar mst $ \st -> do
res <- newEmptyMVar
q <- adnsSubmit (adns st) r rt qfs
when (Map.null (queries st))
(forkIO (resolveLoop mst) >> return ())
let st' = st { queries = Map.insert q res (queries st) }
return (st', res)
resolveLoop :: MVar ResolverState -> IO ()
resolveLoop mst = do
more <- modifyMVar mst $ \(RState dns qs) -> do
r <- adnsWait dns
case r of
Nothing -> return (RState dns qs, False)
Just (q,a) -> do mv <- maybe (fail "inconsistent ADNS state") return (Map.lookup q qs)
putMVar mv a
return (RState dns (Map.delete q qs), True)
when more (resolveLoop mst)