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 :: ([Char] -> m ())
-> Interface m (Packet InPacket) (Packet OutPacket)
-> m (Addr, Maybe Addr, Addr)
init [Char] -> m ()
putStrLn Interface m (Packet InPacket) (Packet OutPacket)
eth =
  do --xid <- fmap (xor 0x7f23ae64 . fromIntegral) ({-runH-} readTimer)
     let xid :: Word32
xid = Word32
0x7f23ae64
        -- xid should be chosen randomly!!!
     let d :: Packet (Packet (Packet Packet))
d = Word32 -> Packet (Packet (Packet Packet))
dhcpDiscover Word32
xid
     (Packet
offer,Addr
serverMAC) <- let req :: m ()
req = do [Char] -> m ()
debug ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Discover " -- ++show d
				       Packet (Packet (Packet Packet)) -> m ()
forall {a}. Unparse a => Packet a -> m ()
tx Packet (Packet (Packet Packet))
d
                          in m () -> m (Packet, Addr) -> m (Packet, Addr)
forall {r :: * -> *} {m :: * -> *} {a} {b}.
(RefIO r m, ForkIO m, DelayIO m) =>
m a -> m b -> m b
solicit m ()
req ((Addr -> Packet -> Bool) -> m (Packet, Addr)
forall {a}. Parse a => (Addr -> a -> Bool) -> m (a, Addr)
rx (Word32 -> Addr -> Packet -> Bool
forall {p}. Word32 -> p -> Packet -> Bool
isOffer Word32
xid))
     [Char] -> m ()
debug ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Offer " -- ++show offer
     let myIP :: Addr
myIP = Packet -> Addr
yiaddr Packet
offer
	 Options [Option]
os = Packet -> Options
options Packet
offer
	 serverIP :: Addr
serverIP = [Addr] -> Addr
forall a. HasCallStack => [a] -> a
head [Addr
sIP|ServerIdentifier Addr
sIP<-[Option]
os]
         request :: Packet (Packet (Packet Packet))
request = Word32 -> Addr -> Addr -> Addr -> Packet (Packet (Packet Packet))
dhcpRequest Word32
xid Addr
serverIP Addr
serverMAC Addr
myIP
     (Packet
ack,Addr
_) <- let req :: m ()
req = do [Char] -> m ()
debug ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Request " -- ++show request
			     Packet (Packet (Packet Packet)) -> m ()
forall {a}. Unparse a => Packet a -> m ()
tx Packet (Packet (Packet Packet))
request
		in m () -> m (Packet, Addr) -> m (Packet, Addr)
forall {r :: * -> *} {m :: * -> *} {a} {b}.
(RefIO r m, ForkIO m, DelayIO m) =>
m a -> m b -> m b
solicit m ()
req ((Addr -> Packet -> Bool) -> m (Packet, Addr)
forall {a}. Parse a => (Addr -> a -> Bool) -> m (a, Addr)
rx (Word32 -> Addr -> Addr -> Packet -> Bool
forall {a}. Eq a => Word32 -> a -> a -> Packet -> Bool
isAck Word32
xid Addr
serverMAC))
     [Char] -> m ()
debug ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Ack " -- ++show ack
     let ip :: Addr
ip = Packet -> Addr
yiaddr Packet
ack
	 Options [Option]
os = Packet -> Options
options Packet
ack
         router :: Maybe Addr
router = [Addr] -> Maybe Addr
forall a. [a] -> Maybe a
listToMaybe [Addr
r|Routers [Addr]
rs<-[Option]
os,Addr
r<-[Addr]
rs]
	 dm :: Addr
dm = Addr -> Addr
IP.defaultNetmask Addr
ip
	 netmask :: Addr
netmask = Addr -> Maybe Addr -> Addr
forall a. a -> Maybe a -> a
fromMaybe Addr
dm (Maybe Addr -> Addr) -> Maybe Addr -> Addr
forall a b. (a -> b) -> a -> b
$ [Addr] -> Maybe Addr
forall a. [a] -> Maybe a
listToMaybe [Addr
m|SubnetMask Addr
m<-[Option]
os]
	 net :: (Addr, Maybe Addr, Addr)
net = (Addr
ip,Maybe Addr
router,Addr
netmask)
     --debug $ show net
     (Addr, Maybe Addr, Addr) -> m (Addr, Maybe Addr, Addr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Addr, Maybe Addr, Addr)
net
  where
    debug :: [Char] -> m ()
debug = [Char] -> m ()
putStrLn ([Char] -> m ()) -> ([Char] -> [Char]) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"DHCP init: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

    mac :: Addr
mac = Interface m (Packet InPacket) (Packet OutPacket) -> Addr
forall (m :: * -> *) i o. Interface m i o -> Addr
Eth.myMAC Interface m (Packet InPacket) (Packet OutPacket)
eth

    tx :: Packet a -> m ()
tx Packet a
p = Interface m (Packet InPacket) (Packet OutPacket)
-> Packet OutPacket -> m ()
forall {m :: * -> *} {i} {o}. Interface m i o -> o -> m ()
Eth.tx Interface m (Packet InPacket) (Packet OutPacket)
eth ((a -> OutPacket) -> Packet a -> Packet OutPacket
forall a b. (a -> b) -> Packet a -> Packet b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> OutPacket
forall {a}. Unparse a => a -> OutPacket
doUnparse Packet a
p)

    rx :: (Addr -> a -> Bool) -> m (a, Addr)
rx Addr -> a -> Bool
expected =
        do Packet InPacket
ep <- Interface m (Packet InPacket) (Packet OutPacket)
-> m (Packet InPacket)
forall {m :: * -> *} {i} {o}. Interface m i o -> m i
Eth.rx Interface m (Packet InPacket) (Packet OutPacket)
eth
	   if Packet InPacket -> PacketType
forall content. Packet content -> PacketType
Eth.packType Packet InPacket
epPacketType -> PacketType -> Bool
forall a. Eq a => a -> a -> Bool
/=PacketType
Eth.IPv4
	      then [Char] -> m (a, Addr)
again [Char]
"" --"Eth type IPv4"
	      else [Char]
-> Packet InPacket
-> (Packet InPacket -> m (a, Addr))
-> m (a, Addr)
forall {a} {f :: * -> *}.
(Parse a, Container f) =>
[Char] -> f InPacket -> (a -> m (a, Addr)) -> m (a, Addr)
try [Char]
"IP" Packet InPacket
ep ((Packet InPacket -> m (a, Addr)) -> m (a, Addr))
-> (Packet InPacket -> m (a, Addr)) -> m (a, Addr)
forall a b. (a -> b) -> a -> b
$ \ Packet InPacket
ip ->
		   if Packet InPacket -> Protocol
forall content. Packet content -> Protocol
IP.protocol Packet InPacket
ipProtocol -> Protocol -> Bool
forall a. Eq a => a -> a -> Bool
/=Protocol
IP.UDP
		   then [Char] -> m (a, Addr)
again [Char]
"protocol UDP"
		   else [Char]
-> Packet InPacket
-> (Packet InPacket -> m (a, Addr))
-> m (a, Addr)
forall {a} {f :: * -> *}.
(Parse a, Container f) =>
[Char] -> f InPacket -> (a -> m (a, Addr)) -> m (a, Addr)
try [Char]
"UDP" Packet InPacket
ip ((Packet InPacket -> m (a, Addr)) -> m (a, Addr))
-> (Packet InPacket -> m (a, Addr)) -> m (a, Addr)
forall a b. (a -> b) -> a -> b
$ \ Packet InPacket
udp ->
		        if Packet InPacket -> Port
forall content. Packet content -> Port
UDP.sourcePort Packet InPacket
udpPort -> Port -> Bool
forall a. Eq a => a -> a -> Bool
/=Port
serverPort Bool -> Bool -> Bool
||
			   Packet InPacket -> Port
forall content. Packet content -> Port
UDP.destPort Packet InPacket
udpPort -> Port -> Bool
forall a. Eq a => a -> a -> Bool
/=Port
clientPort
			then [Char] -> m (a, Addr)
again [Char]
"DHCP ports"
			else [Char] -> Packet InPacket -> (a -> m (a, Addr)) -> m (a, Addr)
forall {a} {f :: * -> *}.
(Parse a, Container f) =>
[Char] -> f InPacket -> (a -> m (a, Addr)) -> m (a, Addr)
try [Char]
"DHCP" Packet InPacket
udp ((a -> m (a, Addr)) -> m (a, Addr))
-> (a -> m (a, Addr)) -> m (a, Addr)
forall a b. (a -> b) -> a -> b
$ \ a
dhcp ->
			     a -> Addr -> m (a, Addr)
cont a
dhcp (Packet InPacket -> Addr
forall content. Packet content -> Addr
Eth.source Packet InPacket
ep)
      where try :: [Char] -> f InPacket -> (a -> m (a, Addr)) -> m (a, Addr)
try [Char]
msg = ((a -> m (a, Addr)) -> Maybe a -> m (a, Addr))
-> Maybe a -> (a -> m (a, Addr)) -> m (a, Addr)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (m (a, Addr) -> (a -> m (a, Addr)) -> Maybe a -> m (a, Addr)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> m (a, Addr)
again [Char]
msg)) (Maybe a -> (a -> m (a, Addr)) -> m (a, Addr))
-> (f InPacket -> Maybe a)
-> f InPacket
-> (a -> m (a, Addr))
-> m (a, Addr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InPacket -> Maybe a
forall {a}. Parse a => InPacket -> Maybe a
doParse (InPacket -> Maybe a)
-> (f InPacket -> InPacket) -> f InPacket -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f InPacket -> InPacket
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents
            again :: [Char] -> m (a, Addr)
again [Char]
msg = do Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
msg) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
debug ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"not "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
msg
			   (Addr -> a -> Bool) -> m (a, Addr)
rx Addr -> a -> Bool
expected
            cont :: a -> Addr -> m (a, Addr)
cont a
p Addr
sMAC =
		if Addr -> a -> Bool
expected Addr
sMAC a
p
		then (a, Addr) -> m (a, Addr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
p,Addr
sMAC)
		else do [Char] -> m ()
debug [Char]
"unexpected DHCP packet"
			(Addr -> a -> Bool) -> m (a, Addr)
rx Addr -> a -> Bool
expected

    isAck :: Word32 -> a -> a -> Packet -> Bool
isAck Word32
uid a
sMac a
sMac' Packet
p =
        Packet -> Operation
opcode Packet
pOperation -> Operation -> Bool
forall a. Eq a => a -> a -> Bool
==Operation
BootReply Bool -> Bool -> Bool
&& Bool
ack Bool -> Bool -> Bool
&& a
sMac'a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
sMac Bool -> Bool -> Bool
&& Packet -> Word32
xid Packet
p Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
uid
      where
	Options [Option]
os = Packet -> Options
options Packet
p
	ack :: Bool
ack = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [()|MessageType MessageType
Ack<-[Option]
os]

    isOffer :: Word32 -> p -> Packet -> Bool
isOffer Word32
uid p
_ Packet
p = Packet -> Operation
opcode Packet
pOperation -> Operation -> Bool
forall a. Eq a => a -> a -> Bool
==Operation
BootReply Bool -> Bool -> Bool
&& Bool
offer Bool -> Bool -> Bool
&& Packet -> Word32
xid Packet
p Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
uid
      where
	Options [Option]
os = Packet -> Options
options Packet
p
	offer :: Bool
offer = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [()|MessageType MessageType
Offer<-[Option]
os]

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

    dhcpDiscover :: Word32 -> Packet (Packet (Packet Packet))
dhcpDiscover Word32
uid = Packet Packet -> Packet (Packet (Packet Packet))
forall {content}. content -> Packet (Packet content)
bcastIP (Packet -> Packet Packet
forall {content}. content -> Packet content
dhcpUDP Packet
discover)
      where
        discover :: Packet
discover = (Addr -> Packet
template Addr
mac){xid=uid,
				  options=Options [MessageType Discover]}

    dhcpRequest :: Word32 -> Addr -> Addr -> Addr -> Packet (Packet (Packet Packet))
dhcpRequest Word32
uid Addr
sIP Addr
sMAC Addr
myIP =
        Addr
-> Addr -> Addr -> Packet Packet -> Packet (Packet (Packet Packet))
forall {content}.
Addr -> Addr -> Addr -> content -> Packet (Packet content)
ucastIP Addr
myIP Addr
sIP Addr
sMAC (Packet -> Packet Packet
forall {content}. content -> Packet content
dhcpUDP Packet
request)
      where
        request :: Packet
request = (Addr -> Packet
template Addr
mac){xid=uid,
				 options=Options [MessageType Request,
						  ServerIdentifier sIP,
						  RequestedIPAddress myIP]}

    dhcpUDP :: content -> Packet content
dhcpUDP content
p =  Port -> Port -> content -> Packet content
forall {content}. Port -> Port -> content -> Packet content
UDP.template Port
clientPort Port
serverPort content
p

    bcastIP :: content -> Packet (Packet content)
bcastIP content
p = Packet content -> Packet (Packet content)
forall {content}. content -> Packet content
bcastEth (Protocol -> Addr -> Addr -> content -> Packet content
forall {content}.
Protocol -> Addr -> Addr -> content -> Packet content
IP.template Protocol
IP.UDP Addr
z Addr
bcast content
p)
      where
        z :: Addr
z     = Word8 -> Word8 -> Word8 -> Word8 -> Addr
IP.Addr Word8
0 Word8
0 Word8
0 Word8
0
	bcast :: Addr
bcast = Word8 -> Word8 -> Word8 -> Word8 -> Addr
IP.Addr Word8
255 Word8
255 Word8
255 Word8
255

    bcastEth :: content -> Packet content
bcastEth content
p = Addr -> Addr -> PacketType -> content -> Packet content
forall content.
Addr -> Addr -> PacketType -> content -> Packet content
Eth.Packet Addr
Eth.broadcastAddr Addr
mac PacketType
Eth.IPv4 content
p

    ucastIP :: Addr -> Addr -> Addr -> content -> Packet (Packet content)
ucastIP Addr
srcIP Addr
dstIP Addr
dstMAC content
p =
      Addr -> Packet content -> Packet (Packet content)
forall {content}. Addr -> content -> Packet content
ucastEth Addr
dstMAC (Protocol -> Addr -> Addr -> content -> Packet content
forall {content}.
Protocol -> Addr -> Addr -> content -> Packet content
IP.template Protocol
IP.UDP Addr
srcIP Addr
dstIP content
p)

    ucastEth :: Addr -> content -> Packet content
ucastEth Addr
dst content
p = Addr -> Addr -> PacketType -> content -> Packet content
forall content.
Addr -> Addr -> PacketType -> content -> Packet content
Eth.Packet Addr
dst Addr
mac PacketType
Eth.IPv4 content
p

-- Nice enough to move to Net.Utils?
solicit :: m a -> m b -> m b
solicit m a
req = Int -> m a -> m b -> m b
forall {m :: * -> *} {r :: * -> *} {a} {b}.
(RefIO r m, ForkIO m, DelayIO m) =>
Int -> m a -> m b -> m b
solicit' Int
3000000 m a
req -- microseconds

solicit' :: Int -> m a -> m b -> m b
solicit' Int
timeout m a
request m b
response =
  do r Bool
waiting <- Bool -> m (r Bool)
forall a. a -> m (r a)
forall (r :: * -> *) (io :: * -> *) a. RefIO r io => a -> io (r a)
newRef Bool
True
     m () -> m ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ m Bool -> m () -> m ()
forall {m :: * -> *} {a}. Monad m => m Bool -> m a -> m ()
whileM (r Bool -> m Bool
forall a. r a -> m a
forall (r :: * -> *) (io :: * -> *) a. RefIO r io => r a -> io a
readRef r Bool
waiting) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
	    do m a
request
	       Int -> m ()
forall (io :: * -> *). DelayIO io => Int -> io ()
delay Int
timeout
     b
r <- m b
response
     r Bool -> Bool -> m ()
forall a. r a -> a -> m ()
forall (r :: * -> *) (io :: * -> *) a.
RefIO r io =>
r a -> a -> io ()
writeRef r Bool
waiting Bool
False
     b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r