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(contents)
init putStrLn eth =
do
let xid = 0x7f23ae64
let d = dhcpDiscover xid
(offer,serverMAC) <- let req = do debug $ "Discover "
tx d
in solicit req (rx (isOffer xid))
debug $ "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 "
tx request
in solicit req (rx (isAck xid serverMAC))
debug $ "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)
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 ""
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]
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
solicit req = solicit' 3000000 req
solicit' timeout request response =
do waiting <- newRef True
fork $ whileM (readRef waiting) $
do request
delay timeout
r <- response
writeRef waiting False
return r