Network/DNS/Message.hs

   1 module Network.DNS.Message
   2     ( Header(..)
   3     , Opcode(..)
   4     , ResponseCode(..)
   5     )
   6     where
   7
   8 import           Data.Binary
   9 import           Data.Binary.Get
  10 import           Data.Binary.Put
  11 import           Data.Bits
  12 import           Data.Word
  13
  14
  15 data Header
  16     = QueryHeader {
  17         hdMessageID             :: !Word16
  18       , hdOpcode                :: !Opcode
  19       , hdIsTruncated           :: !Bool
  20       , hdIsRecursionDesired    :: !Bool
  21       }
  22     | ResponseHeader {
  23         hdMessageID             :: !Word16
  24       , hdOpcode                :: !Opcode
  25       , hdIsAuthoritativeAnswer :: !Bool
  26       , hdIsTruncated           :: !Bool
  27       , hdIsRecursionDesired    :: !Bool
  28       , hdIsRecursionAvailable  :: !Bool
  29       , hdResponseCode          :: !ResponseCode
  30       }
  31
  32 data Opcode
  33     = StandardQuery
  34     | InverseQuery
  35     | ServerStatusRequest
  36
  37 data ResponseCode
  38     = NoError
  39     | FormatError
  40     | ServerFailure
  41     | NameError
  42     | NotImplemented
  43     | Refused
  44     deriving (Show, Eq)
  45
  46 hdIsResponse :: Header -> Bool
  47 hdIsResponse (QueryHeader    _ _ _ _      ) = False
  48 hdIsResponse (ResponseHeader _ _ _ _ _ _ _) = True
  49
  50 instance Binary Header where
  51     put h = do putWord16be $ hdMessageID h
  52                let qr    = boolToNum $ hdIsResponse h
  53                    op    = fromIntegral $ fromEnum $ hdOpcode h
  54                    aa    = if hdIsResponse h then
  55                                boolToNum $ hdIsAuthoritativeAnswer h
  56                            else
  57                                0
  58                    tc    = boolToNum $ hdIsTruncated h
  59                    rd    = boolToNum $ hdIsRecursionDesired h
  60                    ra    = if hdIsResponse h then
  61                                boolToNum $ hdIsRecursionAvailable h
  62                            else
  63                                0
  64                    rc    = if hdIsResponse h then
  65                                fromIntegral $ fromEnum $ hdResponseCode h
  66                            else
  67                                0
  68                    flags = ((qr `shiftL` 15) .&. 0x01) .|.
  69                            ((op `shiftL` 11) .&. 0x0F) .|.
  70                            ((aa `shiftL` 10) .&. 0x01) .|.
  71                            ((tc `shiftL`  9) .&. 0x01) .|.
  72                            ((rd `shiftL`  8) .&. 0x01) .|.
  73                            ((ra `shiftL`  7) .&. 0x01) .|.
  74                            ((rc `shiftL`  0) .&. 0x0F)
  75                putWord16be flags
  76         where
  77           boolToNum :: Num a => Bool -> a
  78           boolToNum True  = 1
  79           boolToNum False = 0
  80
  81     get = do mID   <- getWord16be
  82              flags <- getWord16be
  83              let qr = testBit flags 15
  84                  op = toEnum $ fromIntegral ((flags `shiftR` 11) .&. 0x0F)
  85                  aa = testBit flags 10
  86                  tc = testBit flags 9
  87                  rd = testBit flags 8
  88                  ra = testBit flags 7
  89                  rc = toEnum $ fromIntegral (flags .&. 0x0F)
  90                  hd = if qr then
  91                           ResponseHeader {
  92                             hdMessageID             = mID
  93                           , hdOpcode                = op
  94                           , hdIsAuthoritativeAnswer = aa
  95                           , hdIsTruncated           = tc
  96                           , hdIsRecursionDesired    = rd
  97                           , hdIsRecursionAvailable  = ra
  98                           , hdResponseCode          = rc
  99                           }
 100                       else
 101                           QueryHeader {
 102                             hdMessageID          = mID
 103                           , hdOpcode             = op
 104                           , hdIsTruncated        = tc
 105                           , hdIsRecursionDesired = rd
 106                           }
 107              return hd
 108
 109 instance Enum Opcode where
 110     fromEnum StandardQuery       = 0
 111     fromEnum InverseQuery        = 1
 112     fromEnum ServerStatusRequest = 2
 113
 114     toEnum 0 = StandardQuery
 115     toEnum 1 = InverseQuery
 116     toEnum 2 = ServerStatusRequest
 117     toEnum _ = undefined
 118
 119 instance Bounded Opcode where
 120     minBound = StandardQuery
 121     maxBound = ServerStatusRequest
 122
 123 instance Enum ResponseCode where
 124     fromEnum NoError        = 0
 125     fromEnum FormatError    = 1
 126     fromEnum ServerFailure  = 2
 127     fromEnum NameError      = 3
 128     fromEnum NotImplemented = 4
 129     fromEnum Refused        = 5
 130
 131     toEnum 0 = NoError
 132     toEnum 1 = FormatError
 133     toEnum 2 = ServerFailure
 134     toEnum 3 = NameError
 135     toEnum 4 = NotImplemented
 136     toEnum 5 = Refused
 137     toEnum _ = undefined
 138
 139 instance Bounded ResponseCode where
 140     minBound = NoError
 141     maxBound = Refused