1 module Network.DNS.Named
11 import Control.Concurrent
12 import Control.Exception
15 import qualified Data.ByteString as BS
16 import qualified Data.ByteString.Lazy as LBS
19 import qualified Network.Socket.ByteString as NB
20 import Network.DNS.Message
21 import Network.DNS.Named.Config
22 import System.Posix.Signals
25 class ZoneFinder a where
26 findZone :: a -> DomainName -> IO Zone
28 instance ZoneFinder (DomainName -> Zone) where
31 instance ZoneFinder (DomainName -> IO Zone) where
34 instance ZoneFinder (DomainName -> Maybe Zone) where
35 findZone = ((return . fromMaybe defaultRootZone) .)
37 instance ZoneFinder (DomainName -> IO (Maybe Zone)) where
38 findZone = (fmap (fromMaybe defaultRootZone) .)
43 zoneName :: !DomainName
46 defaultRootZone :: Zone
47 defaultRootZone = error "FIXME: defaultRootZone is not implemented yet"
50 runNamed :: ZoneFinder zf => Config -> zf -> IO ()
53 do installHandler sigPIPE Ignore Nothing
54 _tcpListenerTID <- forkIO $ tcpListen
58 udpListen = do -- FIXME: we should support IPv6 when the network package supports it.
59 so <- socket AF_INET Datagram defaultProtocol
61 bindSocket so $ cnfServerAddress cnf
64 udpLoop :: Socket -> IO ()
66 = do (packet, cameFrom) <- NB.recvFrom so 512
67 _handlerTID <- forkIO $ udpHandler so packet cameFrom
71 tcpListen = putStrLn "FIXME: tcpListen is not implemented yet."
73 udpHandler :: Socket -> BS.ByteString -> SockAddr -> IO ()
74 udpHandler so packet cameFrom
75 = do msg <- evaluate $ unpackMessage packet
76 msg' <- handleMessage msg
78 NB.sendTo so (packMessage $ makeServerFailure msg) cameFrom
79 _sent <- NB.sendTo so (packMessage $ msg' ) cameFrom
82 handleMessage :: Message -> IO Message
84 = fail (show msg) -- FIXME
87 packMessage :: Message -> BS.ByteString
88 packMessage = BS.concat . LBS.toChunks . encode
90 unpackMessage :: BS.ByteString -> Message
91 unpackMessage = decode . LBS.fromChunks . return
94 makeServerFailure :: Message -> Message
96 = let header = msgHeader msg
99 hdMessageType = Response
100 , hdIsAuthoritativeAnswer = False
101 , hdIsTruncated = False
102 , hdIsRecursionAvailable = False
103 , hdResponseCode = ServerFailure