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