]> gitweb @ CieloNegro.org - haskell-dns.git/blob - Network/DNS/Message.hs
9f2b144968c7f394e84068dae3a8cccd84b9b259
[haskell-dns.git] / Network / DNS / Message.hs
1 module Network.DNS.Message
2     ( Message(..)
3     , MessageID
4     , MessageType(..)
5     , Header(..)
6     , Opcode(..)
7     , ResponseCode(..)
8     , Question(..)
9     , ResourceRecord(..)
10     , DomainName
11     , DomainLabel
12     , TTL
13
14     , QueryType
15     , QueryClass
16     , RecordType
17     , RecordClass
18
19     , SOAFields(..)
20     , WKSFields(..)
21
22     , SomeQ(..)
23     , SomeRR(..)
24
25     , A(..)
26     , NS(..)
27     , MD(..)
28     , MF(..)
29     , CNAME(..)
30     , SOA(..)
31     , MB(..)
32     , MG(..)
33     , MR(..)
34     , NULL(..)
35     , WKS(..)
36     , PTR(..)
37     , HINFO(..)
38     , MINFO(..)
39     , MX(..)
40     , TXT(..)
41
42     , AXFR(..)
43     , MAILB(..)
44     , MAILA(..)
45     , ANY(..)
46
47     , IN(..)
48     , CS(..)
49     , CH(..)
50     , HS(..)
51
52     , mkDomainName
53     , mkDN
54     , isZoneOf
55
56     , wrapQuestion
57     , wrapRecord
58     )
59     where
60
61 import           Control.Exception
62 import           Control.Monad
63 import           Data.Binary
64 import           Data.Binary.BitPut as BP
65 import           Data.Binary.Get as G
66 import           Data.Binary.Put as P'
67 import           Data.Binary.Strict.BitGet as BG
68 import qualified Data.ByteString as BS
69 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
70 import qualified Data.ByteString.Lazy as LBS
71 import           Data.Typeable
72 import qualified Data.IntMap as IM
73 import           Data.IntMap (IntMap)
74 import qualified Data.IntSet as IS
75 import           Data.IntSet (IntSet)
76 import           Data.List
77 import qualified Data.Map as M
78 import           Data.Map (Map)
79 import           Data.Word
80 import           Network.DNS.Packer as P
81 import           Network.DNS.Unpacker as U
82 import           Network.Socket
83
84
85 data Message
86     = Message {
87         msgHeader      :: !Header
88       , msgQuestions   :: ![SomeQ]
89       , msgAnswers     :: ![SomeRR]
90       , msgAuthorities :: ![SomeRR]
91       , msgAdditionals :: ![SomeRR]
92       }
93     deriving (Show, Eq)
94
95 data Header
96     = Header {
97         hdMessageID             :: !MessageID
98       , hdMessageType           :: !MessageType
99       , hdOpcode                :: !Opcode
100       , hdIsAuthoritativeAnswer :: !Bool
101       , hdIsTruncated           :: !Bool
102       , hdIsRecursionDesired    :: !Bool
103       , hdIsRecursionAvailable  :: !Bool
104       , hdResponseCode          :: !ResponseCode
105
106       -- These fields are supressed in this data structure:
107       -- + QDCOUNT
108       -- + ANCOUNT
109       -- + NSCOUNT
110       -- + ARCOUNT
111       }
112     deriving (Show, Eq)
113
114 type MessageID = Word16
115
116 data MessageType
117     = Query
118     | Response
119     deriving (Show, Eq)
120
121 data Opcode
122     = StandardQuery
123     | InverseQuery
124     | ServerStatusRequest
125     deriving (Show, Eq)
126
127 data ResponseCode
128     = NoError
129     | FormatError
130     | ServerFailure
131     | NameError
132     | NotImplemented
133     | Refused
134     deriving (Show, Eq)
135
136 data (QueryType qt, QueryClass qc) => Question qt qc
137     = Question {
138         qName  :: !DomainName
139       , qType  :: !qt
140       , qClass :: !qc
141       }
142     deriving (Typeable)
143
144 instance (QueryType qt, QueryClass qc) => Show (Question qt qc) where
145     show q = "Question { qName = " ++ show (qName q) ++
146              ", qType = " ++ show (qType q) ++
147              ", qClass = " ++ show (qClass q) ++ " }"
148
149 instance (QueryType qt, QueryClass qc) => Eq (Question qt qc) where
150     a == b = qName  a == qName  b &&
151              qType  a == qType  b &&
152              qClass a == qClass b
153
154 data SomeQ = forall qt qc. (QueryType qt, QueryClass qc) => SomeQ (Question qt qc)
155
156 instance Show SomeQ where
157     show (SomeQ q) = show q
158
159 instance Eq SomeQ where
160     (SomeQ a) == (SomeQ b) = Just a == cast b
161
162 data SomeQT = forall qt. QueryType qt => SomeQT qt
163
164 instance Show SomeQT where
165     show (SomeQT qt) = show qt
166
167 instance Eq SomeQT where
168     (SomeQT a) == (SomeQT b) = Just a == cast b
169
170 data SomeQC = forall qc. QueryClass qc => SomeQC qc
171
172 instance Show SomeQC where
173     show (SomeQC qc) = show qc
174
175 instance Eq SomeQC where
176     (SomeQC a) == (SomeQC b) = Just a == cast b
177
178 putSomeQ :: SomeQ -> Packer CompTable ()
179 putSomeQ (SomeQ q)
180     = do putDomainName $ qName q
181          putQueryType  $ qType q
182          putQueryClass $ qClass q
183
184 getSomeQ :: Unpacker DecompTable SomeQ
185 getSomeQ
186     = do nm <- getDomainName
187          ty <- getSomeQT
188          cl <- getSomeQC
189          case (ty, cl) of
190            (SomeQT qt, SomeQC qc)
191                -> return $ SomeQ $ Question {
192                          qName  = nm
193                        , qType  = qt
194                        , qClass = qc
195                        }
196
197 getSomeQT :: Unpacker s SomeQT
198 getSomeQT = do n <- liftM fromIntegral U.getWord16be
199                case IM.lookup n defaultQTTable of
200                  Just sqt
201                      -> return sqt
202                  Nothing
203                      -> fail ("Unknown query type: " ++ show n)
204
205 getSomeQC :: Unpacker s SomeQC
206 getSomeQC = do n <- liftM fromIntegral U.getWord16be
207                case IM.lookup n defaultQCTable of
208                  Just sqc
209                      -> return sqc
210                  Nothing
211                      -> fail ("Unknown query class: " ++ show n)
212
213
214 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
215 type DomainLabel    = BS.ByteString
216
217 rootName :: DomainName
218 rootName = DN [BS.empty]
219
220 isRootName :: DomainName -> Bool
221 isRootName (DN [_]) = True
222 isRootName _        = False
223
224 consLabel :: DomainLabel -> DomainName -> DomainName
225 consLabel x (DN ys) = DN (x:ys)
226
227 unconsLabel :: DomainName -> (DomainLabel, DomainName)
228 unconsLabel (DN (x:xs)) = (x, DN xs)
229 unconsLabel x           = error ("Illegal use of unconsLabel: " ++ show x)
230
231 isZoneOf :: DomainName -> DomainName -> Bool
232 isZoneOf (DN a) (DN b) = a `isSuffixOf` b
233
234 mkDomainName :: String -> DomainName
235 mkDomainName = DN . mkLabels [] . notEmpty
236     where
237       notEmpty :: String -> String
238       notEmpty xs = assert (not $ null xs) xs
239
240       mkLabels :: [DomainLabel] -> String -> [DomainLabel]
241       mkLabels soFar [] = reverse (C8.empty : soFar)
242       mkLabels soFar xs = case break (== '.') xs of
243                             (l, ('.':rest))
244                                 -> mkLabels (C8.pack l : soFar) rest
245                             _   -> error ("Illegal domain name: " ++ xs)
246
247 mkDN :: String -> DomainName
248 mkDN = mkDomainName
249
250
251 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
252     rcToInt :: rc -> Int
253
254     putRecordClass :: rc -> Packer s ()
255     putRecordClass = P.putWord16be . fromIntegral . rcToInt
256
257
258 data (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt
259     = ResourceRecord {
260         rrName  :: !DomainName
261       , rrType  :: !rt
262       , rrClass :: !rc
263       , rrTTL   :: !TTL
264       , rrData  :: !dt
265       }
266     deriving (Show, Eq, Typeable)
267
268
269 data SomeRR = forall rt rc dt. (RecordType rt dt, RecordClass rc) => SomeRR (ResourceRecord rt rc dt)
270
271 instance Show SomeRR where
272     show (SomeRR rr) = show rr
273
274 instance Eq SomeRR where
275     (SomeRR a) == (SomeRR b) = Just a == cast b
276
277
278 putSomeRR :: SomeRR -> Packer CompTable ()
279 putSomeRR (SomeRR rr) = putResourceRecord rr
280
281 getSomeRR :: Unpacker DecompTable SomeRR
282 getSomeRR = do (srt, src) <- U.lookAhead $
283                              do getDomainName -- skip
284                                 srt <- getSomeRT
285                                 src <- getSomeRC
286                                 return (srt, src)
287                case (srt, src) of
288                  (SomeRT rt, SomeRC rc)
289                      -> getResourceRecord rt rc >>= return . SomeRR
290
291 type CompTable   = Map DomainName Int
292 type DecompTable = IntMap DomainName
293 type TTL         = Word32
294
295 getDomainName :: Unpacker DecompTable DomainName
296 getDomainName = worker
297     where
298       worker :: Unpacker DecompTable DomainName
299       worker
300           = do offset <- U.bytesRead
301                hdr    <- getLabelHeader
302                case hdr of
303                  Offset n
304                      -> do dt <- U.getState
305                            case IM.lookup n dt of
306                              Just name
307                                  -> return name
308                              Nothing
309                                  -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
310                  Length 0
311                      -> return rootName
312                  Length n
313                      -> do label <- U.getByteString n
314                            rest  <- worker
315                            let name = consLabel label rest
316                            U.modifyState $ IM.insert offset name
317                            return name
318
319       getLabelHeader :: Unpacker s LabelHeader
320       getLabelHeader
321           = do header <- U.lookAhead $ U.getByteString 1
322                let Right h
323                        = runBitGet header $
324                          do a <- getBit
325                             b <- getBit
326                             n <- liftM fromIntegral (getAsWord8 6)
327                             case (a, b) of
328                               ( True,  True) -> return $ Offset n
329                               (False, False) -> return $ Length n
330                               _              -> fail "Illegal label header"
331                case h of
332                  Offset _
333                      -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
334                            let Right h'
335                                    = runBitGet header' $
336                                      do BG.skip 2
337                                         n <- liftM fromIntegral (getAsWord16 14)
338                                         return $ Offset n
339                            return h'
340                  len@(Length _)
341                      -> do U.skip 1
342                            return len
343
344
345 getCharString :: Unpacker s BS.ByteString
346 getCharString = do len <- U.getWord8
347                    U.getByteString (fromIntegral len)
348
349 putCharString :: BS.ByteString -> Packer s ()
350 putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs
351                       P.putByteString xs
352
353 data LabelHeader
354     = Offset !Int
355     | Length !Int
356
357 putDomainName :: DomainName -> Packer CompTable ()
358 putDomainName name
359     = do ct <- P.getState
360          case M.lookup name ct of
361            Just n
362                -> do let ptr = runBitPut $
363                                do putBit True
364                                   putBit True
365                                   putNBits 14 n
366                      P.putLazyByteString ptr
367            Nothing
368                -> do offset <- bytesWrote
369                      P.modifyState $ M.insert name offset
370
371                      let (label, rest) = unconsLabel name
372
373                      putCharString label
374
375                      if isRootName rest then
376                          P.putWord8 0
377                        else
378                          putDomainName rest
379
380 class (Show qt, Eq qt, Typeable qt) => QueryType qt where
381     qtToInt :: qt -> Int
382
383     putQueryType :: qt -> Packer s ()
384     putQueryType = P.putWord16be . fromIntegral . qtToInt
385
386 instance RecordType rt dt => QueryType rt where
387     qtToInt = rtToInt
388
389 class (Show qc, Eq qc, Typeable qc) => QueryClass qc where
390     qcToInt :: qc -> Int
391
392     putQueryClass :: qc -> Packer s ()
393     putQueryClass = P.putWord16be . fromIntegral . qcToInt
394
395 instance RecordClass rc => QueryClass rc where
396     qcToInt = rcToInt
397
398
399 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
400     rtToInt       :: rt -> Int
401     putRecordData :: rt -> dt -> Packer CompTable ()
402     getRecordData :: rt -> Unpacker DecompTable dt
403
404     putRecordType :: rt -> Packer s ()
405     putRecordType = P.putWord16be . fromIntegral . rtToInt
406
407     putRecordDataWithLength :: rt -> dt -> Packer CompTable ()
408     putRecordDataWithLength rt dt
409         = do -- First, write a dummy data length.
410              offset <- bytesWrote
411              P.putWord16be 0
412
413              -- Second, write data.
414              putRecordData rt dt
415
416              -- Third, rewrite the dummy length to an actual value.
417              offset' <- bytesWrote
418              let len = offset' - offset - 2
419              if len <= 0xFFFF then
420                  withOffset offset
421                     $ P.putWord16be $ fromIntegral len
422                else
423                  fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
424                        ++ " bytes, which is way too long")
425
426     putResourceRecord :: RecordClass rc => ResourceRecord rt rc dt -> Packer CompTable ()
427     putResourceRecord rr
428         = do putDomainName  $ rrName  rr
429              putRecordType  $ rrType  rr
430              putRecordClass $ rrClass rr
431              P.putWord32be  $ rrTTL   rr
432              putRecordDataWithLength (rrType rr) (rrData rr)
433
434     getRecordDataWithLength :: rt -> Unpacker DecompTable dt
435     getRecordDataWithLength rt
436         = do len     <- U.getWord16be
437              offset  <- U.bytesRead
438              dat     <- getRecordData rt
439              offset' <- U.bytesRead
440
441              let consumed = offset' - offset
442              when (consumed /= len)
443                       $ fail ("getRecordData " ++ show rt ++ " consumed " ++ show consumed ++
444                               " bytes but it had to consume " ++ show len ++ " bytes")
445
446              return dat
447
448     getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt)
449     getResourceRecord rt rc
450         = do name     <- getDomainName
451              U.skip 2 -- record type
452              U.skip 2 -- record class
453              ttl      <- U.getWord32be
454              dat      <- getRecordDataWithLength rt
455              return $ ResourceRecord {
456                           rrName  = name
457                         , rrType  = rt
458                         , rrClass = rc
459                         , rrTTL   = ttl
460                         , rrData  = dat
461                         }
462
463
464 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
465
466 instance Show SomeRT where
467     show (SomeRT rt) = show rt
468
469 instance Eq SomeRT where
470     (SomeRT a) == (SomeRT b) = Just a == cast b
471
472 getSomeRT :: Unpacker s SomeRT
473 getSomeRT = do n <- liftM fromIntegral U.getWord16be
474                case IM.lookup n defaultRTTable of
475                  Nothing
476                      -> fail ("Unknown resource record type: " ++ show n)
477                  Just srt
478                      -> return srt
479
480 data SomeRC = forall rc. RecordClass rc => SomeRC rc
481
482 instance Show SomeRC where
483     show (SomeRC rc) = show rc
484
485 instance Eq SomeRC where
486     (SomeRC a) == (SomeRC b) = Just a == cast b
487
488 getSomeRC :: Unpacker s SomeRC
489 getSomeRC = do n <- liftM fromIntegral U.getWord16be
490                case IM.lookup n defaultRCTable of
491                  Nothing
492                      -> fail ("Unknown resource record class: " ++ show n)
493                  Just src
494                      -> return src
495
496
497 data SOAFields
498     = SOAFields {
499         soaMasterNameServer   :: !DomainName
500       , soaResponsibleMailbox :: !DomainName
501       , soaSerialNumber       :: !Word32
502       , soaRefreshInterval    :: !Word32
503       , soaRetryInterval      :: !Word32
504       , soaExpirationLimit    :: !Word32
505       , soaMinimumTTL         :: !Word32
506       }
507     deriving (Show, Eq, Typeable)
508
509 data WKSFields
510     = WKSFields {
511         wksAddress  :: !HostAddress
512       , wksProtocol :: !ProtocolNumber
513       , wksServices :: !IntSet
514       }
515     deriving (Show, Eq, Typeable)
516
517
518 data A = A deriving (Show, Eq, Typeable)
519 instance RecordType A HostAddress where
520     rtToInt       _ = 1
521     putRecordData _ = P.putWord32be
522     getRecordData _ = U.getWord32be
523
524 data NS = NS deriving (Show, Eq, Typeable)
525 instance RecordType NS DomainName where
526     rtToInt       _ = 2
527     putRecordData _ = putDomainName
528     getRecordData _ = getDomainName
529
530 data MD = MD deriving (Show, Eq, Typeable)
531 instance RecordType MD DomainName where
532     rtToInt       _ = 3
533     putRecordData _ = putDomainName
534     getRecordData _ = getDomainName
535
536 data MF = MF deriving (Show, Eq, Typeable)
537 instance RecordType MF DomainName where
538     rtToInt       _ = 4
539     putRecordData _ = putDomainName
540     getRecordData _ = getDomainName
541
542 data CNAME = CNAME deriving (Show, Eq, Typeable)
543 instance RecordType CNAME DomainName where
544     rtToInt       _ = 5
545     putRecordData _ = putDomainName
546     getRecordData _ = getDomainName
547
548 data SOA = SOA deriving (Show, Eq, Typeable)
549 instance RecordType SOA SOAFields where
550     rtToInt       _ = 6
551     putRecordData _ = \ soa ->
552                       do putDomainName $ soaMasterNameServer soa
553                          putDomainName $ soaResponsibleMailbox soa
554                          P.putWord32be $ soaSerialNumber soa
555                          P.putWord32be $ soaRefreshInterval soa
556                          P.putWord32be $ soaRetryInterval soa
557                          P.putWord32be $ soaExpirationLimit soa
558                          P.putWord32be $ soaMinimumTTL soa
559     getRecordData _ = do master  <- getDomainName
560                          mail    <- getDomainName
561                          serial  <- U.getWord32be
562                          refresh <- U.getWord32be
563                          retry   <- U.getWord32be
564                          expire  <- U.getWord32be
565                          ttl     <- U.getWord32be
566                          return SOAFields {
567                                       soaMasterNameServer   = master
568                                     , soaResponsibleMailbox = mail
569                                     , soaSerialNumber       = serial
570                                     , soaRefreshInterval    = refresh
571                                     , soaRetryInterval      = retry
572                                     , soaExpirationLimit    = expire
573                                     , soaMinimumTTL         = ttl
574                                     }
575
576 data MB = MB deriving (Show, Eq, Typeable)
577 instance RecordType MB DomainName where
578     rtToInt       _ = 7
579     putRecordData _ = putDomainName
580     getRecordData _ = getDomainName
581
582 data MG = MG deriving (Show, Eq, Typeable)
583 instance RecordType MG DomainName where
584     rtToInt       _ = 8
585     putRecordData _ = putDomainName
586     getRecordData _ = getDomainName
587
588 data MR = MR deriving (Show, Eq, Typeable)
589 instance RecordType MR DomainName where
590     rtToInt       _ = 9
591     putRecordData _ = putDomainName
592     getRecordData _ = getDomainName
593
594 data NULL = NULL deriving (Show, Eq, Typeable)
595 instance RecordType NULL BS.ByteString where
596     rtToInt                 _ = 10
597     putRecordData         _ _ = fail "putRecordData NULL can't be defined"
598     getRecordData           _ = fail "getRecordData NULL can't be defined"
599     putRecordDataWithLength _ = \ dat ->
600                                 do P.putWord16be $ fromIntegral $ BS.length dat
601                                    P.putByteString dat
602     getRecordDataWithLength _ = do len <- U.getWord16be
603                                    U.getByteString $ fromIntegral len
604
605 data WKS = WKS deriving (Show, Eq, Typeable)
606 instance RecordType WKS WKSFields where
607     rtToInt       _ = 11
608     putRecordData _ = \ wks ->
609                       do P.putWord32be $ wksAddress wks
610                          P.putWord8 $ fromIntegral $ wksProtocol wks
611                          P.putLazyByteString $ toBitmap $ wksServices wks
612         where
613           toBitmap :: IntSet -> LBS.ByteString
614           toBitmap is
615               = let maxPort   = IS.findMax is
616                     range     = [0 .. maxPort]
617                     isAvail p = p `IS.member` is
618                 in
619                   runBitPut $ mapM_ putBit $ map isAvail range
620     getRecordData _ = fail "getRecordData WKS can't be defined"
621
622     getRecordDataWithLength _
623         = do len   <- U.getWord16be
624              addr  <- U.getWord32be
625              proto <- liftM fromIntegral U.getWord8
626              bits  <- U.getByteString $ fromIntegral $ len - 4 - 1
627              return WKSFields {
628                           wksAddress  = addr
629                         , wksProtocol = proto
630                         , wksServices = fromBitmap bits
631                         }
632         where
633           fromBitmap :: BS.ByteString -> IntSet
634           fromBitmap bs
635               = let Right is = runBitGet bs $ worker 0 IS.empty
636                 in
637                   is
638
639           worker :: Int -> IntSet -> BitGet IntSet
640           worker pos is
641               = do remain <- BG.remaining
642                    if remain == 0 then
643                        return is
644                      else
645                        do bit <- getBit
646                           if bit then
647                               worker (pos + 1) (IS.insert pos is)
648                             else
649                               worker (pos + 1) is
650
651
652 data PTR = PTR deriving (Show, Eq, Typeable)
653 instance RecordType PTR DomainName where
654     rtToInt       _ = 12
655     putRecordData _ = putDomainName
656     getRecordData _ = getDomainName
657
658 data HINFO = HINFO deriving (Show, Eq, Typeable)
659 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
660     rtToInt       _ = 13
661     putRecordData _ = \ (cpu, os) ->
662                       do putCharString cpu
663                          putCharString os
664     getRecordData _ = do cpu <- getCharString
665                          os  <- getCharString
666                          return (cpu, os)
667
668 data MINFO = MINFO deriving (Show, Eq, Typeable)
669 instance RecordType MINFO (DomainName, DomainName) where
670     rtToInt       _ = 14
671     putRecordData _ = \ (r, e) ->
672                       do putDomainName r
673                          putDomainName e
674     getRecordData _ = do r <- getDomainName
675                          e <- getDomainName
676                          return (r, e)
677
678 data MX = MX deriving (Show, Eq, Typeable)
679 instance RecordType MX (Word16, DomainName) where
680     rtToInt       _ = 15
681     putRecordData _ = \ (pref, exch) ->
682                       do P.putWord16be pref
683                          putDomainName exch
684     getRecordData _ = do pref <- U.getWord16be
685                          exch <- getDomainName
686                          return (pref, exch)
687
688 data TXT = TXT deriving (Show, Eq, Typeable)
689 instance RecordType TXT [BS.ByteString] where
690     rtToInt       _ = 16
691     putRecordData _ = mapM_ putCharString
692     getRecordData _ = fail "getRecordData TXT can't be defined"
693
694     getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral
695         where
696           worker :: [BS.ByteString] -> Int -> Unpacker s [BS.ByteString]
697           worker soFar 0 = return (reverse soFar)
698           worker soFar n = do str <- getCharString
699                               worker (str : soFar) (0 `max` n - 1 - BS.length str)
700
701 data AXFR = AXFR deriving (Show, Eq, Typeable)
702 instance QueryType AXFR where
703     qtToInt _ = 252
704
705 data MAILB = MAILB deriving (Show, Eq, Typeable)
706 instance QueryType MAILB where
707     qtToInt _ = 253
708
709 data MAILA = MAILA deriving (Show, Eq, Typeable)
710 instance QueryType MAILA where
711     qtToInt _ = 254
712
713 data ANY = ANY deriving (Show, Eq, Typeable)
714 instance QueryType ANY where
715     qtToInt _ = 255
716 instance QueryClass ANY where
717     qcToInt _ = 255
718
719 data IN = IN deriving (Show, Eq, Typeable)
720 instance RecordClass IN where
721     rcToInt _ = 1
722
723 data CS = CS deriving (Show, Eq, Typeable)
724 instance RecordClass CS where
725     rcToInt _ = 2
726
727 data CH = CH deriving (Show, Eq, Typeable)
728 instance RecordClass CH where
729     rcToInt _ = 3
730
731 data HS = HS deriving (Show, Eq, Typeable)
732 instance RecordClass HS where
733     rcToInt _ = 4
734
735
736 instance Binary Message where
737     put m = P.liftToBinary M.empty $
738             do putBinary $ msgHeader m
739                P.putWord16be $ fromIntegral $ length $ msgQuestions m
740                P.putWord16be $ fromIntegral $ length $ msgAnswers m
741                P.putWord16be $ fromIntegral $ length $ msgAuthorities m
742                P.putWord16be $ fromIntegral $ length $ msgAdditionals m
743                mapM_ putSomeQ  $ msgQuestions m
744                mapM_ putSomeRR $ msgAnswers m
745                mapM_ putSomeRR $ msgAuthorities m
746                mapM_ putSomeRR $ msgAdditionals m
747
748     get = U.liftToBinary IM.empty $
749           do hdr  <- getBinary
750              nQ   <- liftM fromIntegral U.getWord16be
751              nAns <- liftM fromIntegral U.getWord16be
752              nAth <- liftM fromIntegral U.getWord16be
753              nAdd <- liftM fromIntegral U.getWord16be
754              qs   <- replicateM nQ   getSomeQ
755              anss <- replicateM nAns getSomeRR
756              aths <- replicateM nAth getSomeRR
757              adds <- replicateM nAdd getSomeRR
758              return Message {
759                           msgHeader      = hdr
760                         , msgQuestions   = qs
761                         , msgAnswers     = anss
762                         , msgAuthorities = aths
763                         , msgAdditionals = adds
764                         }
765
766 instance Binary Header where
767     put h = do P'.putWord16be $ hdMessageID h
768                P'.putLazyByteString flags
769         where
770           flags = runBitPut $
771                   do putNBits 1 $ fromEnum $ hdMessageType h
772                      putNBits 4 $ fromEnum $ hdOpcode h
773                      putBit $ hdIsAuthoritativeAnswer h
774                      putBit $ hdIsTruncated h
775                      putBit $ hdIsRecursionDesired h
776                      putBit $ hdIsRecursionAvailable h
777                      putNBits 3 (0 :: Int)
778                      putNBits 4 $ fromEnum $ hdResponseCode h
779
780     get = do mID   <- G.getWord16be
781              flags <- G.getByteString 2
782              let Right hd
783                      = runBitGet flags $
784                        do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
785                           op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
786                           aa <- getBit
787                           tc <- getBit
788                           rd <- getBit
789                           ra <- getBit
790                           BG.skip 3
791                           rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
792                           return Header {
793                                        hdMessageID             = mID
794                                      , hdMessageType           = qr
795                                      , hdOpcode                = op
796                                      , hdIsAuthoritativeAnswer = aa
797                                      , hdIsTruncated           = tc
798                                      , hdIsRecursionDesired    = rd
799                                      , hdIsRecursionAvailable  = ra
800                                      , hdResponseCode          = rc
801                                      }
802              return hd
803
804 instance Enum MessageType where
805     fromEnum Query    = 0
806     fromEnum Response = 1
807
808     toEnum 0 = Query
809     toEnum 1 = Response
810     toEnum _ = undefined
811
812 instance Enum Opcode where
813     fromEnum StandardQuery       = 0
814     fromEnum InverseQuery        = 1
815     fromEnum ServerStatusRequest = 2
816
817     toEnum 0 = StandardQuery
818     toEnum 1 = InverseQuery
819     toEnum 2 = ServerStatusRequest
820     toEnum _ = undefined
821
822 instance Enum ResponseCode where
823     fromEnum NoError        = 0
824     fromEnum FormatError    = 1
825     fromEnum ServerFailure  = 2
826     fromEnum NameError      = 3
827     fromEnum NotImplemented = 4
828     fromEnum Refused        = 5
829
830     toEnum 0 = NoError
831     toEnum 1 = FormatError
832     toEnum 2 = ServerFailure
833     toEnum 3 = NameError
834     toEnum 4 = NotImplemented
835     toEnum 5 = Refused
836     toEnum _ = undefined
837
838
839 defaultRTTable :: IntMap SomeRT
840 defaultRTTable = IM.fromList $ map toPair $
841                  [ SomeRT A
842                  , SomeRT NS
843                  , SomeRT MD
844                  , SomeRT MF
845                  , SomeRT CNAME
846                  , SomeRT SOA
847                  , SomeRT MB
848                  , SomeRT MG
849                  , SomeRT MR
850                  , SomeRT NULL
851                  , SomeRT WKS
852                  , SomeRT PTR
853                  , SomeRT HINFO
854                  , SomeRT MINFO
855                  , SomeRT MX
856                  , SomeRT TXT
857                  ]
858     where
859       toPair :: SomeRT -> (Int, SomeRT)
860       toPair srt@(SomeRT rt) = (rtToInt rt, srt)
861
862 defaultQTTable :: IntMap SomeQT
863 defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
864                  [ SomeQT AXFR
865                  , SomeQT MAILB
866                  , SomeQT MAILA
867                  , SomeQT ANY
868                  ]
869     where
870       toPair :: SomeQT -> (Int, SomeQT)
871       toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)
872
873       mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
874       mergeWithRTTable rts qts
875           = IM.union (toQTTable rts) qts
876
877       toQTTable :: IntMap SomeRT -> IntMap SomeQT
878       toQTTable = IM.map toSomeQT
879
880       toSomeQT :: SomeRT -> SomeQT
881       toSomeQT (SomeRT rt) = SomeQT rt
882
883 defaultRCTable :: IntMap SomeRC
884 defaultRCTable = IM.fromList $ map toPair $
885                  [ SomeRC IN
886                  , SomeRC CS
887                  , SomeRC CH
888                  , SomeRC HS
889                  ]
890     where
891       toPair :: SomeRC -> (Int, SomeRC)
892       toPair src@(SomeRC rc) = (rcToInt rc, src)
893
894 defaultQCTable :: IntMap SomeQC
895 defaultQCTable = mergeWithRCTable defaultRCTable $ IM.fromList $ map toPair $
896                  [ SomeQC ANY
897                  ]
898     where
899       toPair :: SomeQC -> (Int, SomeQC)
900       toPair sqc@(SomeQC qc) = (qcToInt qc, sqc)
901
902       mergeWithRCTable :: IntMap SomeRC -> IntMap SomeQC -> IntMap SomeQC
903       mergeWithRCTable rcs qcs
904           = IM.union (toQCTable rcs) qcs
905
906       toQCTable :: IntMap SomeRC -> IntMap SomeQC
907       toQCTable = IM.map toSomeQC
908
909       toSomeQC :: SomeRC -> SomeQC
910       toSomeQC (SomeRC rc) = SomeQC rc
911
912
913 wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ
914 wrapQuestion = SomeQ
915
916 wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR
917 wrapRecord = SomeRR