module Network.DNS.Message
    ( Header(..)
    , Opcode(..)
    , ResponseCode(..)
    )
    where

import           Data.Binary
import           Data.Binary.Get
import           Data.Binary.Put
import           Data.Bits
import           Data.Word


data Header
    = QueryHeader {
        hdMessageID             :: !Word16
      , hdOpcode                :: !Opcode
      , hdIsTruncated           :: !Bool
      , hdIsRecursionDesired    :: !Bool
      }
    | ResponseHeader {
        hdMessageID             :: !Word16
      , hdOpcode                :: !Opcode
      , hdIsAuthoritativeAnswer :: !Bool
      , hdIsTruncated           :: !Bool
      , hdIsRecursionDesired    :: !Bool
      , hdIsRecursionAvailable  :: !Bool
      , hdResponseCode          :: !ResponseCode
      }

data Opcode
    = StandardQuery
    | InverseQuery
    | ServerStatusRequest

data ResponseCode
    = NoError
    | FormatError
    | ServerFailure
    | NameError
    | NotImplemented
    | Refused
    deriving (Show, Eq)

hdIsResponse :: Header -> Bool
hdIsResponse (QueryHeader    _ _ _ _      ) = False
hdIsResponse (ResponseHeader _ _ _ _ _ _ _) = True

instance Binary Header where
    put h = do putWord16be $ hdMessageID h
               let qr    = boolToNum $ hdIsResponse h
                   op    = fromIntegral $ fromEnum $ hdOpcode h
                   aa    = if hdIsResponse h then
                               boolToNum $ hdIsAuthoritativeAnswer h
                           else
                               0
                   tc    = boolToNum $ hdIsTruncated h
                   rd    = boolToNum $ hdIsRecursionDesired h
                   ra    = if hdIsResponse h then
                               boolToNum $ hdIsRecursionAvailable h
                           else
                               0
                   rc    = if hdIsResponse h then
                               fromIntegral $ fromEnum $ hdResponseCode h
                           else
                               0
                   flags = ((qr `shiftL` 15) .&. 0x01) .|.
                           ((op `shiftL` 11) .&. 0x0F) .|.
                           ((aa `shiftL` 10) .&. 0x01) .|.
                           ((tc `shiftL`  9) .&. 0x01) .|.
                           ((rd `shiftL`  8) .&. 0x01) .|.
                           ((ra `shiftL`  7) .&. 0x01) .|.
                           ((rc `shiftL`  0) .&. 0x0F)
               putWord16be flags
        where
          boolToNum :: Num a => Bool -> a
          boolToNum True  = 1
          boolToNum False = 0

    get = do mID   <- getWord16be
             flags <- getWord16be
             let qr = testBit flags 15
                 op = toEnum $ fromIntegral ((flags `shiftR` 11) .&. 0x0F)
                 aa = testBit flags 10
                 tc = testBit flags 9
                 rd = testBit flags 8
                 ra = testBit flags 7
                 rc = toEnum $ fromIntegral (flags .&. 0x0F)
                 hd = if qr then
                          ResponseHeader {
                            hdMessageID             = mID
                          , hdOpcode                = op
                          , hdIsAuthoritativeAnswer = aa
                          , hdIsTruncated           = tc
                          , hdIsRecursionDesired    = rd
                          , hdIsRecursionAvailable  = ra
                          , hdResponseCode          = rc
                          }
                      else
                          QueryHeader {
                            hdMessageID          = mID
                          , hdOpcode             = op
                          , hdIsTruncated        = tc
                          , hdIsRecursionDesired = rd
                          }
             return hd

instance Enum Opcode where
    fromEnum StandardQuery       = 0
    fromEnum InverseQuery        = 1
    fromEnum ServerStatusRequest = 2

    toEnum 0 = StandardQuery
    toEnum 1 = InverseQuery
    toEnum 2 = ServerStatusRequest
    toEnum _ = undefined

instance Bounded Opcode where
    minBound = StandardQuery
    maxBound = ServerStatusRequest

instance Enum ResponseCode where
    fromEnum NoError        = 0
    fromEnum FormatError    = 1
    fromEnum ServerFailure  = 2
    fromEnum NameError      = 3
    fromEnum NotImplemented = 4
    fromEnum Refused        = 5

    toEnum 0 = NoError
    toEnum 1 = FormatError
    toEnum 2 = ServerFailure
    toEnum 3 = NameError
    toEnum 4 = NotImplemented
    toEnum 5 = Refused
    toEnum _ = undefined

instance Bounded ResponseCode where
    minBound = NoError
    maxBound = Refused