Network/DNS/Message.hs

   1 module Network.DNS.Message
   2     ( Message(..)
   3     , MessageType(..)
   4     , Header(..)
   5     , Opcode(..)
   6     , ResponseCode(..)
   7     , Question(..)
   8     , ResourceRecord(..)
   9     , RecordType(..)
  10     , RecordClass(..)
  11     )
  12     where
  13
  14 import           Data.Binary
  15 import           Data.Binary.Get
  16 import           Data.Binary.Put
  17 import           Data.Bits
  18 import           Data.Word
  19
  20
  21 data Message
  22     = Message {
  23         msgHeader      :: !Header
  24       , msgQuestions   :: ![Question]
  25       , msgAnswers     :: ![ResourceRecord]
  26       , msgAuthorities :: ![ResourceRecord]
  27       , msgAdditionals :: ![ResourceRecord]
  28       }
  29
  30 data Header
  31     = Header {
  32         hdMessageID             :: !Word16
  33       , hdMessageType           :: !MessageType
  34       , hdOpcode                :: !Opcode
  35       , hdIsAuthoritativeAnswer :: !Bool
  36       , hdIsTruncated           :: !Bool
  37       , hdIsRecursionDesired    :: !Bool
  38       , hdIsRecursionAvailable  :: !Bool
  39       , hdResponseCode          :: !ResponseCode
  40
  41       -- These fields are supressed in this data structure:
  42       -- * QDCOUNT
  43       -- * ANCOUNT
  44       -- * NSCOUNT
  45       -- * ARCOUNT
  46       }
  47
  48 data MessageType
  49     = Query
  50     | Response
  51     deriving (Show, Eq)
  52
  53 data Opcode
  54     = StandardQuery
  55     | InverseQuery
  56     | ServerStatusRequest
  57     deriving (Show, Eq)
  58
  59 data ResponseCode
  60     = NoError
  61     | FormatError
  62     | ServerFailure
  63     | NameError
  64     | NotImplemented
  65     | Refused
  66     deriving (Show, Eq)
  67
  68 data Question
  69     = Question {
  70         qName  :: !DomainName
  71       , qType  :: !RecordType
  72       , qClass :: !RecordClass
  73       }
  74     deriving (Show, Eq)
  75
  76 type DomainName = [[Word8]]
  77
  78 data RecordClass
  79     = IN
  80     | CS -- Obsolete
  81     | CH
  82     | HS
  83     | AnyClass -- Only for queries
  84     deriving (Show, Eq)
  85
  86 data ResourceRecord
  87     = ResourceRecord {
  88         rrName  :: !DomainName
  89       , rrType  :: !RecordType
  90       , rrClass :: !RecordClass
  91       , rrTTL   :: !Word32
  92       , rrData  :: ![Word8]
  93       }
  94     deriving (Show, Eq)
  95
  96 data RecordType
  97     = A
  98     | NS
  99     | MD
 100     | MF
 101     | CNAME
 102     | SOA
 103     | MB
 104     | MG
 105     | MR
 106     | NULL
 107     | WKS
 108     | PTR
 109     | HINFO
 110     | MINFO
 111     | MX
 112     | TXT
 113
 114     -- Only for queries:
 115     | AXFR
 116     | MAILB -- Obsolete
 117     | MAILA -- Obsolete
 118     | AnyType
 119     deriving (Show, Eq)
 120
 121 instance Binary Header where
 122     put h = do putWord16be $ hdMessageID h
 123                let qr    = fromIntegral $ fromEnum $ hdMessageType h
 124                    op    = fromIntegral $ fromEnum $ hdOpcode h
 125                    aa    = boolToNum $ hdIsAuthoritativeAnswer h
 126                    tc    = boolToNum $ hdIsTruncated h
 127                    rd    = boolToNum $ hdIsRecursionDesired h
 128                    ra    = boolToNum $ hdIsRecursionAvailable h
 129                    rc    = fromIntegral $ fromEnum $ hdResponseCode h
 130                    flags = ((qr `shiftL` 15) .&. 0x01) .|.
 131                            ((op `shiftL` 11) .&. 0x0F) .|.
 132                            ((aa `shiftL` 10) .&. 0x01) .|.
 133                            ((tc `shiftL`  9) .&. 0x01) .|.
 134                            ((rd `shiftL`  8) .&. 0x01) .|.
 135                            ((ra `shiftL`  7) .&. 0x01) .|.
 136                            ((rc `shiftL`  0) .&. 0x0F)
 137                putWord16be flags
 138         where
 139           boolToNum :: Num a => Bool -> a
 140           boolToNum True  = 1
 141           boolToNum False = 0
 142
 143     get = do mID   <- getWord16be
 144              flags <- getWord16be
 145              let qr = toEnum $ fromIntegral ((flags `shiftR` 15) .&. 0x01)
 146                  op = toEnum $ fromIntegral ((flags `shiftR` 11) .&. 0x0F)
 147                  aa = testBit flags 10
 148                  tc = testBit flags 9
 149                  rd = testBit flags 8
 150                  ra = testBit flags 7
 151                  rc = toEnum $ fromIntegral (flags .&. 0x0F)
 152                  hd = Header {
 153                          hdMessageID             = mID
 154                        , hdMessageType           = qr
 155                        , hdOpcode                = op
 156                        , hdIsAuthoritativeAnswer = aa
 157                        , hdIsTruncated           = tc
 158                        , hdIsRecursionDesired    = rd
 159                        , hdIsRecursionAvailable  = ra
 160                        , hdResponseCode          = rc
 161                        }
 162              return hd
 163
 164 instance Enum MessageType where
 165     fromEnum Query    = 0
 166     fromEnum Response = 1
 167
 168     toEnum 0 = Query
 169     toEnum 1 = Response
 170     toEnum _ = undefined
 171
 172 instance Enum Opcode where
 173     fromEnum StandardQuery       = 0
 174     fromEnum InverseQuery        = 1
 175     fromEnum ServerStatusRequest = 2
 176
 177     toEnum 0 = StandardQuery
 178     toEnum 1 = InverseQuery
 179     toEnum 2 = ServerStatusRequest
 180     toEnum _ = undefined
 181
 182 instance Enum ResponseCode where
 183     fromEnum NoError        = 0
 184     fromEnum FormatError    = 1
 185     fromEnum ServerFailure  = 2
 186     fromEnum NameError      = 3
 187     fromEnum NotImplemented = 4
 188     fromEnum Refused        = 5
 189
 190     toEnum 0 = NoError
 191     toEnum 1 = FormatError
 192     toEnum 2 = ServerFailure
 193     toEnum 3 = NameError
 194     toEnum 4 = NotImplemented
 195     toEnum 5 = Refused
 196     toEnum _ = undefined
 197
 198 instance Enum RecordType where
 199     fromEnum A       = 1
 200     fromEnum NS      = 2
 201     fromEnum MD      = 3
 202     fromEnum MF      = 4
 203     fromEnum CNAME   = 5
 204     fromEnum SOA     = 6
 205     fromEnum MB      = 7
 206     fromEnum MG      = 8
 207     fromEnum MR      = 9
 208     fromEnum NULL    = 10
 209     fromEnum WKS     = 11
 210     fromEnum PTR     = 12
 211     fromEnum HINFO   = 13
 212     fromEnum MINFO   = 14
 213     fromEnum MX      = 15
 214     fromEnum TXT     = 16
 215     fromEnum AXFR    = 252
 216     fromEnum MAILB   = 253
 217     fromEnum MAILA   = 254
 218     fromEnum AnyType = 255
 219
 220     toEnum 1  = A
 221     toEnum 2  = NS
 222     toEnum 3  = MD
 223     toEnum 4  = MF
 224     toEnum 5  = CNAME
 225     toEnum 6  = SOA
 226     toEnum 7  = MB
 227     toEnum 8  = MG
 228     toEnum 9  = MR
 229     toEnum 10 = NULL
 230     toEnum 11 = WKS
 231     toEnum 12 = PTR
 232     toEnum 13 = HINFO
 233     toEnum 14 = MINFO
 234     toEnum 15 = MX
 235     toEnum 16 = TXT
 236     toEnum 252 = AXFR
 237     toEnum 253 = MAILB
 238     toEnum 254 = MAILA
 239     toEnum 255 = AnyType
 240     toEnum _  = undefined
 241
 242 instance Enum RecordClass
 243     fromEnum IN       = 1
 244     fromEnum CS       = 2
 245     fromEnum CH       = 3
 246     fromEnum HS       = 4
 247     fromEnum AnyClass = 255
 248
 249     toEnum 1   = IN
 250     toEnum 2   = CS
 251     toEnum 3   = CH
 252     toEnum 4   = HS
 253     toEnum 255 = AnyClass
 254     toEnum _   = undefined