module Net.DHCP where

-- Dynamic Host Configuration Protocol, RFC 2131
-- See http://www.networksorcery.com/enp/protocol/dhcp.htm
--     http://rfc.sunsite.dk/rfc/rfc2131.html
--     http://rfc.sunsite.dk/rfc/rfc1533.html (DHCP/BOOTP options)

import Net.Bits(Word8,Word16,Word32,testBit)
import qualified Net.IPv4 as IP
import qualified Net.Ethernet as Eth
import Net.PacketParsing
import Net.PortNumber

serverPort = bootps
clientPort = bootpc

data Packet = Packet
            { opcode::Operation, -- 1 byte
	      --hwType::Word8, -- always 0x01 (Ethernet)
	      --hLen::Word8, -- always 6
              --hOps::Word8, -- 0 except when booting via relay agents
	      xid::Word32, -- Transaction ID, randomly chosen by the client
	      secs::Word16,
	      flags::Flags, -- 2 bytes
	      ciaddr,yiaddr,siaddr,giaddr::IP.Addr,
	      chaddr::Eth.Addr, -- 16 bytes!
	      sname::String, -- null terminated, 64 bytes
	      file::String, -- null terminated, 128 bytes
	      options::Options -- upto 312 bytes for options
	    }
	    deriving (Show)

data Operation = BootRequest | BootReply deriving (Eq,Bounded,Enum,Show)
data Flags = Flags {broadcast::Bool} deriving (Eq,Show)

newtype Options = Options [Option] deriving (Eq,Show)

data Option
  = Pad -- 0
  | End -- 255
  | SubnetMask IP.Addr -- 1
  | TimeOffset -- 2
  | Routers [IP.Addr] -- 3
  | DNS_Servers [IP.Addr] -- 6
  | HostName String -- 12
  | DomainName String -- 15
  | BroadcastAddress IP.Addr -- 28
  | NTP_Servers [IP.Addr] -- 42
  | RequestedIPAddress IP.Addr -- 50
  | LeaseTime Word32 -- 51
  | OptionOverload Word8 -- 52
  | MessageType MessageType -- 53
  | ServerIdentifier IP.Addr -- 54
  | Unknown Word8 [Word8] -- unimplemented/unsupported option
  deriving (Eq,Show)

data MessageType
  = Discover -- 1
  | Offer
  | Request
  | Decline
  | Ack
  | Nak
  | Release
  | Inform -- 8
  deriving (Eq,Bounded,Enum,Show)

--------------------------------------------------------------------------------

template mac =
     Packet { opcode=BootRequest,
	      xid=0,
	      secs=0,
	      flags=Flags{broadcast=False},
	      ciaddr=z,yiaddr=z,siaddr=z,giaddr=z,
	      chaddr=mac,
	      sname="",
	      file="",
	      options=Options []
	    }
  where
    z = IP.Addr 0 0 0 0

--------------------------------------------------------------------------------

instance Parse Operation where parse = bounded 1 =<< word8
instance Parse MessageType where parse = bounded 1 =<< word8
instance Unparse MessageType where unparse t = unparse (unEnum 1 t::Word8)
instance Unparse Operation where unparse t = unparse (unEnum 1 t::Word8)

instance Parse Flags where
  parse = do w <- word16
	     return Flags{broadcast=testBit w 15}

instance Unparse Flags where
  unparse Flags{broadcast=b} = unparse (if b then 0x8000 else 0::Word16)

magic = [99,130,83,99::Word8]

instance Parse Options where
  parse = do bs <- bytes 4
	     if bs==magic
		then Options # po
		else return (Options [])
    where
      po = do o <- parse
	      case o of
	        End -> return []
		_ -> (o:) # po

instance Unparse Options where
  unparse (Options []) = unparse ()
  unparse (Options os) = unparse (magic,os,End) -- pad to 312 bytes?

instance Unparse Option where
  unparse End = unparse (255::Word8)
  unparse Pad = unparse (0::Word8)
  unparse (RequestedIPAddress ip) = unparse  ([50,4::Word8],ip)
  unparse (MessageType t) = unparse ([53,1::Word8],t)
  unparse (ServerIdentifier ip) = unparse  ([54,4::Word8],ip)
  unparse (Unknown b bs) = unparse (b,n,bs)
    where n = fromIntegral (length bs)::Word8

instance Parse Option where
  parse = do b <- word8
	     case b of
	       0   -> return Pad
	       1   -> do check8 4
		         SubnetMask # parse
	       3   -> Routers # ips
	       6   -> DNS_Servers # ips
	       255 -> return End
	       51  -> return LeaseTime        #! check8 4 <# parse
	       53  -> return MessageType      #! check8 1 <# parse
	       54  -> return ServerIdentifier #! check8 4 <# parse
	       _   -> do n <- fromIntegral # word8
		         bs <- bytes n
		         return (Unknown b bs)
    where
      ips = do n <- fromIntegral # word8
               parses (n `div` 4)

parses n = sequence (replicate n parse)

instance Parse Packet where
  parse = Packet #  parse #! check8 1 #! check8 6 #! word8
		 <# parse <# parse <# parse
		 <# parse <# parse <# parse <# parse
		 <# parse
		 #! bytes 10
		 <# zstring 64
		 <# zstring 128
		 <# parse
		 #! therest

instance Unparse Packet where
  unparse (Packet op xid secs flags ci yi si gi ch sname file options) =
      unparse ((op,[1,6,0::Word8],xid,secs,flags),(ci,yi,si,gi,ch),
	       replicate 10 (0::Word8),
	       (zstring 64 sname,zstring 128 file),
	       options)
   where
     zstring n s = take n (s++repeat '\0')

--------------------------------------------------------------------------------

zstring :: Int -> PacketParser String
zstring n = map (toEnum.fromIntegral) . takeWhile (/=0) # bytes n

bounded z n = bounded' undefined (fromIntegral n-z)
  where
    bounded' :: (Bounded a,Enum a) => a -> Int -> PacketParser a
    bounded' r i =
	     if 0<=i && i<=fromEnum (maxBound `asTypeOf` r)
		then return (toEnum i)
		else fail "out of range"

unEnum z t = fromIntegral (fromEnum t+z)