module Net.DHCP_Client where

import Control.Monad(unless)
import Data.Maybe(fromMaybe,listToMaybe)
import Data.Bits(xor)
import Monad.Util(whileM)

import Net.DHCP
import qualified Net.IPv4 as IP
import qualified Net.Ethernet as Eth
import qualified Net.UDP as UDP
import Net.PacketParsing(doParse,doUnparse)
import Net.Concurrent(fork,delay,newRef,readRef,writeRef)
import Net.Utils({-emap,-}contents)
--import System.Random(randomIO) -- Missing in hOp
--import Kernel.Timer(readTimer)
--import H.Monad(runH)

init putStrLn eth =
  do --xid <- fmap (xor 0x7f23ae64 . fromIntegral) ({-runH-} readTimer)
     let xid = 0x7f23ae64
        -- xid should be chosen randomly!!!
     let d = dhcpDiscover xid
     (offer,serverMAC) <- let req = do debug $ "Discover " -- ++show d
				       tx d
                          in solicit req (rx (isOffer xid))
     debug $ "Offer " -- ++show offer
     let myIP = yiaddr offer
	 Options os = options offer
	 serverIP = head [sIP|ServerIdentifier sIP<-os]
         request = dhcpRequest xid serverIP serverMAC myIP
     (ack,_) <- let req = do debug $ "Request " -- ++show request
			     tx request
		in solicit req (rx (isAck xid serverMAC))
     debug $ "Ack " -- ++show ack
     let ip = yiaddr ack
	 Options os = options ack
         router = listToMaybe [r|Routers rs<-os,r<-rs]
	 dm = IP.defaultNetmask ip
	 netmask = fromMaybe dm $ listToMaybe [m|SubnetMask m<-os]
	 net = (ip,router,netmask)
     --debug $ show net
     return net
  where
    debug = putStrLn . ("DHCP init: "++)

    mac = Eth.myMAC eth

    tx p = Eth.tx eth (fmap doUnparse p)

    rx expected =
        do ep <- Eth.rx eth
	   if Eth.packType ep/=Eth.IPv4
	      then again "" --"Eth type IPv4"
	      else try "IP" ep $ \ ip ->
		   if IP.protocol ip/=IP.UDP
		   then again "protocol UDP"
		   else try "UDP" ip $ \ udp ->
		        if UDP.sourcePort udp/=serverPort ||
			   UDP.destPort udp/=clientPort
			then again "DHCP ports"
			else try "DHCP" udp $ \ dhcp ->
			     cont dhcp (Eth.source ep)
      where try msg = flip (maybe (again msg)) . doParse . contents
            again msg = do unless (null msg) $ debug $ "not "++msg
			   rx expected
            cont p sMAC =
		if expected sMAC p
		then return (p,sMAC)
		else do debug "unexpected DHCP packet"
			rx expected

    isAck uid sMac sMac' p =
        opcode p==BootReply && ack && sMac'==sMac && xid p == uid
      where
	Options os = options p
	ack = not $ null [()|MessageType Ack<-os]

    isOffer uid _ p = opcode p==BootReply && offer && xid p == uid
      where
	Options os = options p
	offer = not $ null [()|MessageType Offer<-os]

    --c3 = contents . contents . contents
    --c3 = id

    dhcpDiscover uid = bcastIP (dhcpUDP discover)
      where
        discover = (template mac){xid=uid,
				  options=Options [MessageType Discover]}

    dhcpRequest uid sIP sMAC myIP =
        ucastIP myIP sIP sMAC (dhcpUDP request)
      where
        request = (template mac){xid=uid,
				 options=Options [MessageType Request,
						  ServerIdentifier sIP,
						  RequestedIPAddress myIP]}

    dhcpUDP p =  UDP.template clientPort serverPort p

    bcastIP p = bcastEth (IP.template IP.UDP z bcast p)
      where
        z     = IP.Addr 0 0 0 0
	bcast = IP.Addr 255 255 255 255

    bcastEth p = Eth.Packet Eth.broadcastAddr mac Eth.IPv4 p

    ucastIP srcIP dstIP dstMAC p =
      ucastEth dstMAC (IP.template IP.UDP srcIP dstIP p)

    ucastEth dst p = Eth.Packet dst mac Eth.IPv4 p

-- Nice enough to move to Net.Utils?
solicit req = solicit' 3000000 req -- microseconds

solicit' timeout request response =
  do waiting <- newRef True
     fork $ whileM (readRef waiting) $
	    do request
	       delay timeout
     r <- response
     writeRef waiting False
     return r