import qualified Data.ByteString.Lazy as LBS
import Data.Word
import Network.DNS.Message
-import Network.Socket
-import System.IO.Unsafe
+import Network.Socket.IsString ()
import Test.HUnit
}
, msgQuestions = [ wrapQuestion $
Question {
- qName = mkDomainName "mail.cielonegro.org."
+ qName = "mail.cielonegro.org."
, qType = CNAME
, qClass = IN
}
}
, msgQuestions = [ wrapQuestion $
Question {
- qName = mkDomainName "mail.cielonegro.org."
+ qName = "mail.cielonegro.org."
, qType = CNAME
, qClass = IN
}
]
, msgAnswers = [ wrapRecord $
ResourceRecord {
- rrName = mkDomainName "mail.cielonegro.org."
+ rrName = "mail.cielonegro.org."
, rrType = CNAME
, rrClass = IN
, rrTTL = 86400
- , rrData = mkDomainName "nem.cielonegro.org."
+ , rrData = "nem.cielonegro.org."
}
]
, msgAuthorities = [ wrapRecord $
ResourceRecord {
- rrName = mkDomainName "cielonegro.org."
+ rrName = "cielonegro.org."
, rrType = NS
, rrClass = IN
, rrTTL = 3600
- , rrData = mkDomainName "nem.cielonegro.org."
+ , rrData = "nem.cielonegro.org."
}
]
, msgAdditionals = [ wrapRecord $
ResourceRecord {
- rrName = mkDomainName "nem.cielonegro.org."
+ rrName = "nem.cielonegro.org."
, rrType = A
, rrClass = IN
, rrTTL = 3600
- , rrData = unsafePerformIO (inet_addr "219.94.130.139")
+ , rrData = "219.94.130.139"
}
]
}
}
, msgQuestions = [ wrapQuestion $
Question {
- qName = mkDomainName "cielonegro.org."
+ qName = "cielonegro.org."
, qType = SOA
, qClass = IN
}
}
, msgQuestions = [ wrapQuestion $
Question {
- qName = mkDomainName "cielonegro.org."
+ qName = "cielonegro.org."
, qType = SOA
, qClass = IN
}
]
, msgAnswers = [ wrapRecord $
ResourceRecord {
- rrName = mkDomainName "cielonegro.org."
+ rrName = "cielonegro.org."
, rrType = SOA
, rrClass = IN
, rrTTL = 3600
, rrData = SOAFields {
- soaMasterNameServer = mkDomainName "nem.cielonegro.org."
- , soaResponsibleMailbox = mkDomainName "root.nem.cielonegro.org."
+ soaMasterNameServer = "nem.cielonegro.org."
+ , soaResponsibleMailbox = "root.nem.cielonegro.org."
, soaSerialNumber = 2008022148
, soaRefreshInterval = 3600
, soaRetryInterval = 900
]
, msgAuthorities = [ wrapRecord $
ResourceRecord {
- rrName = mkDomainName "cielonegro.org."
+ rrName = "cielonegro.org."
, rrType = NS
, rrClass = IN
, rrTTL = 3600
- , rrData = mkDomainName "nem.cielonegro.org."
+ , rrData = "nem.cielonegro.org."
}
]
, msgAdditionals = [ wrapRecord $
ResourceRecord {
- rrName = mkDomainName "nem.cielonegro.org."
+ rrName = "nem.cielonegro.org."
, rrType = A
, rrClass = IN
, rrTTL = 3600
- , rrData = unsafePerformIO (inet_addr "219.94.130.139")
+ , rrData = "219.94.130.139"
}
]
}
import Network.DNS.Named
import Network.DNS.Named.Config
import Network.DNS.Named.Zone
-import Network.Socket
-import System.IO.Unsafe
+import Network.Socket.IsString ()
main :: IO ()
main = runNamed cnf (return . findZone)
zone :: Zone
zone = Zone {
- zoneName = mkDN "cielonegro.org."
+ zoneName = "cielonegro.org."
, zoneSOA = Just SOAFields {
- soaMasterNameServer = mkDN "ns.cielonegro.org."
- , soaResponsibleMailbox = mkDN "root.ns.cielonegro.org."
+ soaMasterNameServer = "ns.cielonegro.org."
+ , soaResponsibleMailbox = "root.ns.cielonegro.org."
, soaSerialNumber = 2008022148
, soaRefreshInterval = 3600
, soaRetryInterval = 900
, soaExpirationLimit = 3600000
, soaMinimumTTL = 3600
}
- , zoneRecordNames = return [ mkDN "ns.cielonegro.org."
- , mkDN "www.cielonegro.org."
- , mkDN "git.cielonegro.org."
+ , zoneRecordNames = return [ "ns.cielonegro.org."
+ , "www.cielonegro.org."
+ , "git.cielonegro.org."
]
, zoneResponder = return . responder
}
responder :: DomainName -> [SomeRR]
responder name
- | name == mkDN "ns.cielonegro.org."
+ | name == "ns.cielonegro.org."
= [ wrapRecord ResourceRecord {
rrName = name
, rrType = A
, rrClass = IN
, rrTTL = 9600
- , rrData = inetAddr "127.0.0.1"
+ , rrData = "127.0.0.1"
+ }
+ , wrapRecord ResourceRecord {
+ rrName = name
+ , rrType = AAAA
+ , rrClass = IN
+ , rrTTL = 9600
+ , rrData = "::1"
}
]
- | name == mkDN "www.cielonegro.org."
+ | name == "www.cielonegro.org."
= [ wrapRecord ResourceRecord {
rrName = name
, rrType = A
, rrClass = IN
, rrTTL = 9600
- , rrData = inetAddr "127.0.0.2"
+ , rrData = "127.0.0.2"
+ }
+ , wrapRecord ResourceRecord {
+ rrName = name
+ , rrType = AAAA
+ , rrClass = IN
+ , rrTTL = 9600
+ , rrData = "fe80::216:cbff:fe39:56a4"
}
]
- | name == mkDN "git.cielonegro.org."
+ | name == "git.cielonegro.org."
= [ wrapRecord ResourceRecord {
rrName = name
, rrType = CNAME
, rrClass = IN
, rrTTL = 9600
- , rrData = mkDN "www.cielonegro.org."
+ , rrData = "www.cielonegro.org."
}
]
| otherwise
= [] -- This means NXDOMAIN.
-
-inetAddr :: String -> HostAddress
-inetAddr = unsafePerformIO . inet_addr
, SomeRR(..)
, A(..)
+ , AAAA(..)
, NS(..)
, MD(..)
, MF(..)
, HS(..)
, mkDomainName
- , mkDN
, rootName
, isRootName
, consLabel
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import qualified Data.ByteString.Lazy as LBS
+import Data.String
import Data.Typeable
import qualified Data.IntMap as IM
import Data.IntMap (IntMap)
newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
type DomainLabel = BS.ByteString
+instance IsString DomainName where
+ fromString = mkDomainName
+
rootName :: DomainName
rootName = DN [BS.empty]
-> mkLabels (C8.pack l : soFar) rest
_ -> error ("Illegal domain name: " ++ xs)
-mkDN :: String -> DomainName
-mkDN = mkDomainName
-
class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
rcToInt :: rc -> Int
putRecordData _ = P.putWord32be
getRecordData _ = U.getWord32be
+data AAAA = AAAA deriving (Show, Eq, Typeable)
+instance RecordType AAAA HostAddress6 where
+ rtToInt _ = 28
+ putRecordData _ = \ (a, b, c, d) ->
+ do P.putWord32be a
+ P.putWord32be b
+ P.putWord32be c
+ P.putWord32be d
+ getRecordData _ = do a <- U.getWord32be
+ b <- U.getWord32be
+ c <- U.getWord32be
+ d <- U.getWord32be
+ return (a, b, c, d)
+
data NS = NS deriving (Show, Eq, Typeable)
instance RecordType NS DomainName where
rtToInt _ = 2
defaultRTTable :: IntMap SomeRT
defaultRTTable = IM.fromList $ map toPair $
[ SomeRT A
+ , SomeRT AAAA
, SomeRT NS
, SomeRT MD
, SomeRT MF
udpListen :: AddrInfo -> IO ()
udpListen ai
= do so <- socket (addrFamily ai) Datagram defaultProtocol
+ setSocketOption so ReuseAddr 1
bindSocket so (addrAddress ai)
udpLoop so
tcpListen :: AddrInfo -> IO ()
tcpListen ai
= do so <- socket (addrFamily ai) Stream defaultProtocol
+ setSocketOption so ReuseAddr 1
bindSocket so (addrAddress ai)
listen so 255
tcpLoop so
Just name
-> do allRecords <- zoneResponder zone name
- let filtered = filterRecords (SomeQ q') allRecords
- q' = Question {
- qName = name
- , qType = A
- , qClass = IN
- }
- return filtered
+ let rA = filterRecords (SomeQ qA) allRecords
+ rB = filterRecords (SomeQ qB) allRecords
+ qA = Question {
+ qName = name
+ , qType = A
+ , qClass = IN
+ }
+ qB = Question {
+ qName = name
+ , qType = AAAA
+ , qClass = IN
+ }
+ return (rA ++ rB)
filterRecords :: SomeQ -> [SomeRR] -> [SomeRR]
- filterRecords (SomeQ q)
- | Just (qType q) == cast ANY &&
- Just (qClass q) == cast ANY = id
- | Just (qType q) == cast ANY = filter matchClass
- | Just (qClass q) == cast ANY = filter matchType
- | otherwise = filter matchBoth
+ filterRecords (SomeQ q) = filter predicate
where
- matchClass (SomeRR rr)
- = Just (qClass q) == cast (rrClass rr)
+ predicate rr
+ = predForType rr && predForClass rr
- matchType (SomeRR rr)
- = Just (qType q) == cast (rrType rr) ||
- Just CNAME == cast (rrType rr)
+ predForType (SomeRR rr)
+ | typeOf (qType q) == typeOf ANY
+ = True
- matchBoth rr
- = matchType rr && matchClass rr
+ | typeOf (qType q) == typeOf MAILB
+ = typeOf (rrType rr) == typeOf MR ||
+ typeOf (rrType rr) == typeOf MB ||
+ typeOf (rrType rr) == typeOf MG ||
+ typeOf (rrType rr) == typeOf MINFO
+
+ | otherwise
+ = typeOf (rrType rr) == typeOf (qType q) ||
+ typeOf (rrType rr) == typeOf CNAME
+
+ predForClass (SomeRR rr)
+ | typeOf (qClass q) == typeOf ANY
+ = True
+
+ | otherwise
+ = typeOf (rrClass rr) == typeOf (qClass q)
handleAXFR :: SomeQ -> Zone -> IO (Builder ())
handleAXFR (SomeQ q) zone
--- /dev/null
+module Network.Socket.IsString () where
+
+import Data.String
+import Network.Socket
+import System.IO.Unsafe
+
+instance IsString HostAddress where
+ fromString str
+ = let hint = defaultHints {
+ addrFlags = [AI_NUMERICHOST]
+ , addrFamily = AF_INET
+ }
+ ret = unsafePerformIO $
+ getAddrInfo (Just hint) (Just str) Nothing
+ in
+ case ret of
+ [] -> error (str ++ " seems not to be a valid IPv4 address")
+ (x:xs) -> case addrAddress x of
+ SockAddrInet _ addr
+ -> addr
+ _ -> error ("getAddrInfo (" ++ str ++ ") returned a strange result: " ++ show (x:xs))
+
+instance IsString HostAddress6 where
+ fromString str
+ = let hint = defaultHints {
+ addrFlags = [AI_NUMERICHOST]
+ , addrFamily = AF_INET6
+ }
+ ret = unsafePerformIO $
+ getAddrInfo (Just hint) (Just str) Nothing
+ in
+ case ret of
+ [] -> error (str ++ " seems not to be a valid IPv6 address")
+ (x:xs) -> case addrAddress x of
+ SockAddrInet6 _ _ addr _
+ -> addr
+ _ -> error ("getAddrInfo (" ++ str ++ ") returned a strange result: " ++ show (x:xs))
Network.DNS.Named.Zone
Network.DNS.Packer
Network.DNS.Unpacker
+ Network.Socket.IsString
Extensions:
DeriveDataTypeable, ExistentialQuantification,
Extensions:
DeriveDataTypeable, ExistentialQuantification,
FlexibleInstances, FunctionalDependencies,
- MultiParamTypeClasses, ScopedTypeVariables,
+ MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables,
TypeSynonymInstances, UndecidableInstances,
IncoherentInstances
Extensions:
DeriveDataTypeable, ExistentialQuantification,
FlexibleInstances, FunctionalDependencies,
- MultiParamTypeClasses, ScopedTypeVariables,
+ MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables,
TypeSynonymInstances, UndecidableInstances,
IncoherentInstances
projects / haskell-dns.git / commitdiff