{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Hans.IP4.Dhcp.Codec where

import Hans.Ethernet (Mac,getMac,putMac)
import Hans.IP4.Packet (IP4,IP4Mask(..),getIP4,putIP4)

import Data.List (find)
import Data.Serialize.Get
import Data.Serialize.Put
import Data.Word (Word8, Word16, Word32)


class CodecAtom a where
  getAtom :: Get a
  putAtom :: a -> Put
  atomSize :: a -> Int

instance (CodecAtom a, CodecAtom b) => CodecAtom (a,b) where
  getAtom       = do a <- getAtom
                     b <- getAtom
                     return (a,b)
  putAtom (a,b) = do putAtom a
                     putAtom b
  atomSize (a,b)= atomSize a + atomSize b

instance CodecAtom Word8 where
  getAtom       = getWord8
  putAtom n     = putWord8 n
  atomSize _    = 1

instance CodecAtom Word16 where
  getAtom       = getWord16be
  putAtom n     = putWord16be n
  atomSize _    = 2

instance CodecAtom Word32 where
  getAtom       = getWord32be
  putAtom n     = putWord32be n
  atomSize _    = 4

instance CodecAtom Bool where
  getAtom       = do b <- getWord8
                     case b of
                       0 -> return False
                       1 -> return True
                       _ -> fail "Expected 0/1 in boolean option"
  putAtom False = putWord8 0
  putAtom True  = putWord8 1
  atomSize _    = 1

instance CodecAtom IP4 where
  getAtom       = getIP4
  putAtom       = putIP4
  atomSize _    = 4

instance CodecAtom IP4Mask where
  getAtom =
    do addr            <- getAtom
       SubnetMask mask <- getAtom
       return $! IP4Mask addr mask

  putAtom (IP4Mask addr mask) =
    do putAtom addr
       putAtom (SubnetMask mask)

  atomSize _    = atomSize (undefined :: IP4)
                + atomSize (undefined :: SubnetMask)

instance CodecAtom Mac where
  getAtom       = getMac
  putAtom       = putMac
  atomSize _    = 6

-----------------------------------------------------------------------
-- Subnet parser/unparser operations ----------------------------------
-----------------------------------------------------------------------

newtype SubnetMask = SubnetMask { unmask :: Int
                                } deriving (Show, Eq)

word32ToSubnetMask :: Word32 -> Maybe SubnetMask
word32ToSubnetMask mask =
  do i <- find (\ i -> computeMask i == mask) [0..32]
     return (SubnetMask i)

subnetMaskToWord32 :: SubnetMask -> Word32
subnetMaskToWord32 (SubnetMask n) = computeMask n

computeMask :: Int -> Word32
computeMask n = 0-2^(32-n)

instance CodecAtom SubnetMask where
  getAtom       = do x <- getAtom
                     case word32ToSubnetMask x of
                       Just mask -> return mask
                       Nothing   -> fail "Invalid subnet mask"
  putAtom       = putAtom . subnetMaskToWord32
  atomSize _    = atomSize (undefined :: Word32)