Many changes...

diff --git a/DNSUnitTest.hs b/DNSUnitTest.hs
index 76a677d9e4deb963e2c3dd062f1f07ea55c81310..e907c3b8acd16c8029b880d235d144eebb88da05 100644 (file)
--- a/DNSUnitTest.hs
+++ b/DNSUnitTest.hs
@@ -25,9 +25,10 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
                              , hdIsRecursionAvailable  = False
                              , hdResponseCode          = NoError
                              }
                              , hdIsRecursionAvailable  = False
                              , hdResponseCode          = NoError
                              }

-               , msgQuestions   = [ Question {
+               , msgQuestions   = [ wrapQuestion $
+                                    Question {

                                       qName  = mkDomainName "mail.cielonegro.org."
                                       qName  = mkDomainName "mail.cielonegro.org."

-                                    , qType  = wrapQueryType CNAME
+                                    , qType  = CNAME

                                     , qClass = IN
                                     }
                                   ]
                                     , qClass = IN
                                     }
                                   ]


@@ -59,9 +60,10 @@ messages = [ ( [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
                              , hdIsRecursionAvailable  = False
                              , hdResponseCode          = NoError
                              }
                              , hdIsRecursionAvailable  = False
                              , hdResponseCode          = NoError
                              }

-               , msgQuestions   = [ Question {
+               , msgQuestions   = [ wrapQuestion $
+                                    Question {

                                       qName  = mkDomainName "mail.cielonegro.org."
                                       qName  = mkDomainName "mail.cielonegro.org."

-                                    , qType  = wrapQueryType CNAME
+                                    , qType  = CNAME

                                     , qClass = IN
                                     }
                                   ]
                                     , qClass = IN
                                     }
                                   ]

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index ab1a15426430bb9b7d559561562a1e5fc4b35af8..570548ced67f03e55c1cbe42466bfb505b641e0c 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -14,7 +14,9 @@ module Network.DNS.Message
     , RecordClass(..)
 
     , SOAFields(..)
     , RecordClass(..)
 
     , SOAFields(..)

+    , WKSFields(..)

 
 

+    , SomeQ

     , SomeQT
     , SomeRR
     , SomeRT
     , SomeQT
     , SomeRR
     , SomeRT


@@ -29,15 +31,20 @@ module Network.DNS.Message
     , MG(..)
     , MR(..)
     , NULL(..)
     , MG(..)
     , MR(..)
     , NULL(..)

+    , WKS(..)

     , PTR(..)
     , HINFO(..)
     , MINFO(..)
     , MX(..)
     , TXT(..)
 
     , PTR(..)
     , HINFO(..)
     , MINFO(..)
     , MX(..)
     , TXT(..)
 

+    , AXFR(..)
+    , MAILB(..)
+    , MAILA(..)
+    , ANY(..)
+

     , mkDomainName
     , mkDomainName

-    , wrapQueryType
-    , wrapRecordType
+    , wrapQuestion

     , wrapRecord
     )
     where
     , wrapRecord
     )
     where


@@ -51,9 +58,12 @@ import           Data.Binary.Put as P'
 import           Data.Binary.Strict.BitGet as BG
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
 import           Data.Binary.Strict.BitGet as BG
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)

+import qualified Data.ByteString.Lazy as LBS

 import           Data.Typeable
 import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)
 import           Data.Typeable
 import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)

+import qualified Data.IntSet as IS
+import           Data.IntSet (IntSet)

 import qualified Data.Map as M
 import           Data.Map (Map)
 import           Data.Word
 import qualified Data.Map as M
 import           Data.Map (Map)
 import           Data.Word


@@ -65,7 +75,7 @@ import           Network.Socket
 data Message
     = Message {
         msgHeader      :: !Header
 data Message
     = Message {
         msgHeader      :: !Header

-      , msgQuestions   :: ![Question]
+      , msgQuestions   :: ![SomeQ]

       , msgAnswers     :: ![SomeRR]
       , msgAuthorities :: ![SomeRR]
       , msgAdditionals :: ![SomeRR]
       , msgAnswers     :: ![SomeRR]
       , msgAuthorities :: ![SomeRR]
       , msgAdditionals :: ![SomeRR]


@@ -113,31 +123,66 @@ data ResponseCode
     | Refused
     deriving (Show, Eq)
 
     | Refused
     deriving (Show, Eq)
 

-data Question
+data QueryType qt => Question qt

     = Question {
         qName  :: !DomainName
     = Question {
         qName  :: !DomainName

-      , qType  :: !SomeQT
+      , qType  :: !qt

       , qClass :: !RecordClass
       }
       , qClass :: !RecordClass
       }

-    deriving (Show, Eq)
+    deriving (Typeable)
+
+instance QueryType qt => Show (Question qt) where
+    show q = "Question { qName = " ++ show (qName q) ++
+             ", qType = " ++ show (qType q) ++
+             ", qClass = " ++ show (qClass q) ++ " }"
+
+instance QueryType qt => Eq (Question qt) where
+    a == b = qName  a == qName  b &&
+             qType  a == qType  b &&
+             qClass a == qClass b
+
+data SomeQ = forall qt. QueryType qt => SomeQ (Question qt)

 
 

-type SomeQT = SomeRT
+instance Show SomeQ where
+    show (SomeQ q) = show q

 
 

-putQ :: Question -> Packer CompTable ()
-putQ q
+instance Eq SomeQ where
+    (SomeQ a) == (SomeQ b) = Just a == cast b
+
+data SomeQT = forall qt. QueryType qt => SomeQT qt
+
+instance Show SomeQT where
+    show (SomeQT qt) = show qt
+
+instance Eq SomeQT where
+    (SomeQT a) == (SomeQT b) = Just a == cast b
+
+putSomeQ :: SomeQ -> Packer CompTable ()
+putSomeQ (SomeQ q)

     = do putDomainName $ qName q
     = do putDomainName $ qName q

-         putSomeRT $ qType q
+         putQueryType $ qType q

          putBinary $ qClass q
 
          putBinary $ qClass q
 

-getQ :: Unpacker DecompTable Question
-getQ = do nm <- getDomainName
-          ty <- getSomeRT
-          cl <- getBinary
-          return Question {
-                       qName  = nm
-                     , qType  = ty
-                     , qClass = cl
-                     }
+getSomeQ :: Unpacker DecompTable SomeQ
+getSomeQ
+    = do nm <- getDomainName
+         ty <- getSomeQT
+         cl <- getBinary
+         case ty of
+           SomeQT qt -> return $ SomeQ $
+                        Question {
+                          qName  = nm
+                        , qType  = qt
+                        , qClass = cl
+                        }
+
+getSomeQT :: Unpacker s SomeQT
+getSomeQT = do n <- liftM fromIntegral U.getWord16be
+               case IM.lookup n defaultQTTable of
+                 Just sqt
+                     -> return sqt
+                 Nothing
+                     -> fail ("Unknown query type: " ++ show n)

 
 
 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
 
 
 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)


@@ -299,6 +344,14 @@ putDomainName name
                        else
                          putDomainName rest
 
                        else
                          putDomainName rest
 

+class (Show qt, Eq qt, Typeable qt) => QueryType qt where
+    qtToInt :: qt -> Int
+
+    putQueryType :: qt -> Packer s ()
+    putQueryType = P.putWord16be . fromIntegral . qtToInt
+
+instance RecordType rt dt => QueryType rt where
+    qtToInt = rtToInt

 
 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
     rtToInt       :: rt -> Int
 
 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
     rtToInt       :: rt -> Int


@@ -319,8 +372,13 @@ class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType r
 
              -- Third, rewrite the dummy length to an actual value.
              offset' <- bytesWrote
 
              -- Third, rewrite the dummy length to an actual value.
              offset' <- bytesWrote

-             withOffset offset
-                 $ P.putWord16be (fromIntegral (offset' - offset - 2))
+             let len = offset' - offset - 2
+             if len <= 0xFFFF then
+                 withOffset offset
+                    $ P.putWord16be $ fromIntegral len
+               else
+                 fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
+                       ++ " bytes, which is way too long")

 
     putResourceRecord :: ResourceRecord rt dt -> Packer CompTable ()
     putResourceRecord rr
 
     putResourceRecord :: ResourceRecord rt dt -> Packer CompTable ()
     putResourceRecord rr


@@ -367,9 +425,6 @@ instance Show SomeRT where
 instance Eq SomeRT where
     (SomeRT a) == (SomeRT b) = Just a == cast b
 
 instance Eq SomeRT where
     (SomeRT a) == (SomeRT b) = Just a == cast b
 

-putSomeRT :: SomeRT -> Packer s ()
-putSomeRT (SomeRT rt) = putRecordType rt
-

 getSomeRT :: Unpacker s SomeRT
 getSomeRT = do n <- liftM fromIntegral U.getWord16be
                case IM.lookup n defaultRTTable of
 getSomeRT :: Unpacker s SomeRT
 getSomeRT = do n <- liftM fromIntegral U.getWord16be
                case IM.lookup n defaultRTTable of


@@ -378,6 +433,7 @@ getSomeRT = do n <- liftM fromIntegral U.getWord16be
                  Just srt
                      -> return srt
 
                  Just srt
                      -> return srt
 

+

 data SOAFields
     = SOAFields {
         soaMasterNameServer   :: !DomainName
 data SOAFields
     = SOAFields {
         soaMasterNameServer   :: !DomainName


@@ -390,6 +446,15 @@ data SOAFields
       }
     deriving (Show, Eq, Typeable)
 
       }
     deriving (Show, Eq, Typeable)
 

+data WKSFields
+    = WKSFields {
+        wksAddress  :: !HostAddress
+      , wksProtocol :: !ProtocolNumber
+      , wksServices :: !IntSet
+      }
+    deriving (Show, Eq, Typeable)
+
+

 data A = A deriving (Show, Eq, Typeable)
 instance RecordType A HostAddress where
     rtToInt       _ = 1
 data A = A deriving (Show, Eq, Typeable)
 instance RecordType A HostAddress where
     rtToInt       _ = 1


@@ -477,6 +542,53 @@ instance RecordType NULL BS.ByteString where
     getRecordDataWithLength _ = do len <- U.getWord16be
                                    U.getByteString $ fromIntegral len
 
     getRecordDataWithLength _ = do len <- U.getWord16be
                                    U.getByteString $ fromIntegral len
 

+data WKS = WKS deriving (Show, Eq, Typeable)
+instance RecordType WKS WKSFields where
+    rtToInt       _ = 11
+    putRecordData _ = \ wks ->
+                      do P.putWord32be $ wksAddress wks
+                         P.putWord8 $ fromIntegral $ wksProtocol wks
+                         P.putLazyByteString $ toBitmap $ wksServices wks
+        where
+          toBitmap :: IntSet -> LBS.ByteString
+          toBitmap is
+              = let maxPort   = IS.findMax is
+                    range     = [0 .. maxPort]
+                    isAvail p = p `IS.member` is
+                in
+                  runBitPut $ mapM_ putBit $ map isAvail range
+    getRecordData _ = fail "getRecordData WKS can't be defined"
+
+    getRecordDataWithLength _
+        = do len   <- U.getWord16be
+             addr  <- U.getWord32be
+             proto <- liftM fromIntegral U.getWord8
+             bits  <- U.getByteString $ fromIntegral $ len - 4 - 1
+             return WKSFields {
+                          wksAddress  = addr
+                        , wksProtocol = proto
+                        , wksServices = fromBitmap bits
+                        }
+        where
+          fromBitmap :: BS.ByteString -> IntSet
+          fromBitmap bs
+              = let Right is = runBitGet bs $ worker 0 IS.empty
+                in
+                  is
+
+          worker :: Int -> IntSet -> BitGet IntSet
+          worker pos is
+              = do remain <- BG.remaining
+                   if remain == 0 then
+                       return is
+                     else
+                       do bit <- getBit
+                          if bit then
+                              worker (pos + 1) (IS.insert pos is)
+                            else
+                              worker (pos + 1) is
+
+

 data PTR = PTR deriving (Show, Eq, Typeable)
 instance RecordType PTR DomainName where
     rtToInt       _ = 12
 data PTR = PTR deriving (Show, Eq, Typeable)
 instance RecordType PTR DomainName where
     rtToInt       _ = 12


@@ -526,32 +638,22 @@ instance RecordType TXT [BS.ByteString] where
           worker soFar n = do str <- getCharString
                               worker (str : soFar) (0 `max` n - 1 - BS.length str)
 
           worker soFar n = do str <- getCharString
                               worker (str : soFar) (0 `max` n - 1 - BS.length str)
 

-{-
-data RecordType
-    = A
-    | NS
-    | MD
-    | MF
-    | CNAME
-    | SOA
-    | MB
-    | MG
-    | MR
-    | NULL
-    | WKS
-    | PTR
-    | HINFO
-    | MINFO
-    | MX
-    | TXT
-
-    -- Only for queries:
-    | AXFR
-    | MAILB -- Obsolete
-    | MAILA -- Obsolete
-    | AnyType
-    deriving (Show, Eq)
--}
+data AXFR = AXFR deriving (Show, Eq, Typeable)
+instance QueryType AXFR where
+    qtToInt _ = 252
+
+data MAILB = MAILB deriving (Show, Eq, Typeable)
+instance QueryType MAILB where
+    qtToInt _ = 253
+
+data MAILA = MAILA deriving (Show, Eq, Typeable)
+instance QueryType MAILA where
+    qtToInt _ = 254
+
+data ANY = ANY deriving (Show, Eq, Typeable)
+instance QueryType ANY where
+    qtToInt _ = 255
+

 
 instance Binary Message where
     put m = P.liftToBinary M.empty $
 
 instance Binary Message where
     put m = P.liftToBinary M.empty $


@@ -560,7 +662,7 @@ instance Binary Message where
                P.putWord16be $ fromIntegral $ length $ msgAnswers m
                P.putWord16be $ fromIntegral $ length $ msgAuthorities m
                P.putWord16be $ fromIntegral $ length $ msgAdditionals m
                P.putWord16be $ fromIntegral $ length $ msgAnswers m
                P.putWord16be $ fromIntegral $ length $ msgAuthorities m
                P.putWord16be $ fromIntegral $ length $ msgAdditionals m

-               mapM_ putQ      $ msgQuestions m
+               mapM_ putSomeQ  $ msgQuestions m

                mapM_ putSomeRR $ msgAnswers m
                mapM_ putSomeRR $ msgAuthorities m
                mapM_ putSomeRR $ msgAdditionals m
                mapM_ putSomeRR $ msgAnswers m
                mapM_ putSomeRR $ msgAuthorities m
                mapM_ putSomeRR $ msgAdditionals m


@@ -571,7 +673,7 @@ instance Binary Message where
              nAns <- liftM fromIntegral U.getWord16be
              nAth <- liftM fromIntegral U.getWord16be
              nAdd <- liftM fromIntegral U.getWord16be
              nAns <- liftM fromIntegral U.getWord16be
              nAth <- liftM fromIntegral U.getWord16be
              nAdd <- liftM fromIntegral U.getWord16be

-             qs   <- replicateM nQ   getQ
+             qs   <- replicateM nQ   getSomeQ

              anss <- replicateM nAns getSomeRR
              aths <- replicateM nAth getSomeRR
              adds <- replicateM nAdd getSomeRR
              anss <- replicateM nAns getSomeRR
              aths <- replicateM nAth getSomeRR
              adds <- replicateM nAdd getSomeRR


@@ -655,30 +757,6 @@ instance Enum ResponseCode where
     toEnum 5 = Refused
     toEnum _ = undefined
 
     toEnum 5 = Refused
     toEnum _ = undefined
 

-{-
-instance Enum RecordType where
-    fromEnum A       = 1 /
-    fromEnum NS      = 2 /
-    fromEnum MD      = 3 /
-    fromEnum MF      = 4 /
-    fromEnum CNAME   = 5 /
-    fromEnum SOA     = 6 /
-    fromEnum MB      = 7 /
-    fromEnum MG      = 8 /
-    fromEnum MR      = 9 /
-    fromEnum NULL    = 10 /
-    fromEnum WKS     = 11
-    fromEnum PTR     = 12 /
-    fromEnum HINFO   = 13 /
-    fromEnum MINFO   = 14 /
-    fromEnum MX      = 15 /
-    fromEnum TXT     = 16 /
-    fromEnum AXFR    = 252
-    fromEnum MAILB   = 253
-    fromEnum MAILA   = 254
-    fromEnum AnyType = 255
--}
-

 instance Enum RecordClass where
     fromEnum IN       = 1
     fromEnum CS       = 2
 instance Enum RecordClass where
     fromEnum IN       = 1
     fromEnum CS       = 2


@@ -702,19 +780,56 @@ defaultRTTable :: IntMap SomeRT
 defaultRTTable = IM.fromList $ map toPair $
                  [ wrapRecordType A
                  , wrapRecordType NS
 defaultRTTable = IM.fromList $ map toPair $
                  [ wrapRecordType A
                  , wrapRecordType NS

+                 , wrapRecordType MD
+                 , wrapRecordType MF

                  , wrapRecordType CNAME
                  , wrapRecordType CNAME

+                 , wrapRecordType SOA
+                 , wrapRecordType MB
+                 , wrapRecordType MG
+                 , wrapRecordType MR
+                 , wrapRecordType NULL
+                 , wrapRecordType WKS
+                 , wrapRecordType PTR

                  , wrapRecordType HINFO
                  , wrapRecordType HINFO

+                 , wrapRecordType MINFO
+                 , wrapRecordType MX
+                 , wrapRecordType TXT

                  ]
     where
       toPair :: SomeRT -> (Int, SomeRT)
       toPair srt@(SomeRT rt) = (rtToInt rt, srt)
 
 
                  ]
     where
       toPair :: SomeRT -> (Int, SomeRT)
       toPair srt@(SomeRT rt) = (rtToInt rt, srt)
 
 

-wrapQueryType :: RecordType rt dt => rt -> SomeQT
-wrapQueryType = SomeRT
+defaultQTTable :: IntMap SomeQT
+defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
+                 [ wrapQueryType AXFR
+                 , wrapQueryType MAILB
+                 , wrapQueryType MAILA
+                 , wrapQueryType ANY
+                 ]
+    where
+      toPair :: SomeQT -> (Int, SomeQT)
+      toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)
+
+      mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
+      mergeWithRTTable rts qts
+          = IM.union (toQTTable rts) qts
+
+      toQTTable :: IntMap SomeRT -> IntMap SomeQT
+      toQTTable = IM.map toSomeQT
+
+      toSomeQT :: SomeRT -> SomeQT
+      toSomeQT (SomeRT rt) = SomeQT rt
+
+
+wrapQueryType :: QueryType qt => qt -> SomeQT
+wrapQueryType = SomeQT

 
 wrapRecordType :: RecordType rt dt => rt -> SomeRT
 wrapRecordType = SomeRT
 
 
 wrapRecordType :: RecordType rt dt => rt -> SomeRT
 wrapRecordType = SomeRT
 

+wrapQuestion :: QueryType qt => Question qt -> SomeQ
+wrapQuestion = SomeQ
+

 wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR
 wrapRecord = SomeRR
\ No newline at end of file
 wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR
 wrapRecord = SomeRR
\ No newline at end of file

diff --git a/dns.cabal b/dns.cabal
index b62c8714a7d20dc838cd9eeaff9a50bbfc79fadd..0702a10aa82063909a6b610573e8cad797311428 100644 (file)
--- a/dns.cabal
+++ b/dns.cabal
@@ -27,8 +27,10 @@ Library
 
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,
 
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,

-        FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses,
-        ScopedTypeVariables, TypeSynonymInstances
+        FlexibleInstances, FunctionalDependencies,
+        MultiParamTypeClasses, ScopedTypeVariables,
+        TypeSynonymInstances, UndecidableInstances,
+        IncoherentInstances

 
     GHC-Options:
         -Wall
 
     GHC-Options:
         -Wall


@@ -47,8 +49,10 @@ Executable DNSUnitTest
 
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,
 
     Extensions:
         DeriveDataTypeable, ExistentialQuantification,

-        FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses,
-        ScopedTypeVariables, TypeSynonymInstances
+        FlexibleInstances, FunctionalDependencies,
+        MultiParamTypeClasses, ScopedTypeVariables,
+        TypeSynonymInstances, UndecidableInstances,
+        IncoherentInstances

 
     GHC-Options:
         -Wall
 
     GHC-Options:
         -Wall