module Hans.IP4.Dhcp.Packet
(
RequestMessage(..)
, Request(..)
, Discover(..)
, ServerSettings(..)
, ReplyMessage(..)
, Ack(..)
, Offer(..)
, Dhcp4Message(..)
, Xid(..)
, requestToAck
, discoverToOffer
, mkDiscover
, offerToRequest
, requestToMessage
, ackToMessage
, offerToMessage
, discoverToMessage
, parseDhcpMessage
, getDhcp4Message
, putDhcp4Message
) where
import Hans.Ethernet (Mac)
import Hans.IP4.Dhcp.Codec
import Hans.IP4.Dhcp.Options
import Hans.IP4.Packet (IP4(..),pattern WildcardIP4)
import qualified Control.Applicative as A
import Control.Monad (unless)
import Data.Bits (testBit,bit)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Maybe (mapMaybe)
import Data.Serialize.Get
(Get,getByteString,isolate,remaining,label,skip)
import Data.Serialize.Put (Put,putByteString)
import Data.Word (Word8,Word16,Word32)
import Numeric (showHex)
data ServerSettings = Settings
{ staticServerAddr :: !IP4
, staticTimeOffset :: !Word32
, staticClientAddr :: !IP4
, staticLeaseTime :: !Word32
, staticSubnet :: !SubnetMask
, staticBroadcast :: !IP4
, staticRouters :: [IP4]
, staticDomainName :: String
, staticDNS :: [IP4]
} deriving (Show)
data RequestMessage = RequestMessage !Request
| DiscoverMessage !Discover
deriving (Show)
data ReplyMessage = AckMessage !Ack
| OfferMessage !Offer
deriving (Show)
data Request = Request
{ requestXid :: !Xid
, requestBroadcast :: Bool
, requestServerAddr :: !IP4
, requestClientHardwareAddress :: !Mac
, requestParameters :: [Dhcp4OptionTag]
, requestAddress :: Maybe IP4
} deriving (Show)
data Discover = Discover
{ discoverXid :: !Xid
, discoverBroadcast :: Bool
, discoverClientHardwareAddr :: !Mac
, discoverParameters :: [Dhcp4OptionTag]
} deriving (Show)
data Ack = Ack
{ ackHops :: !Word8
, ackXid :: !Xid
, ackYourAddr :: !IP4
, ackServerAddr :: !IP4
, ackRelayAddr :: !IP4
, ackClientHardwareAddr :: !Mac
, ackLeaseTime :: !Word32
, ackOptions :: [Dhcp4Option]
} deriving (Show)
data Offer = Offer
{ offerHops :: !Word8
, offerXid :: !Xid
, offerYourAddr :: !IP4
, offerServerAddr :: !IP4
, offerRelayAddr :: !IP4
, offerClientHardwareAddr :: !Mac
, offerOptions :: [Dhcp4Option]
} deriving (Show)
requestToAck :: ServerSettings
-> Request
-> Ack
requestToAck settings request = Ack
{ ackHops = 1
, ackXid = requestXid request
, ackYourAddr = staticClientAddr settings
, ackServerAddr = staticServerAddr settings
, ackRelayAddr = staticServerAddr settings
, ackClientHardwareAddr = requestClientHardwareAddress request
, ackLeaseTime = staticLeaseTime settings
, ackOptions = mapMaybe lookupOption (requestParameters request)
}
where
lookupOption tag = case tag of
OptTagSubnetMask
-> Just (OptSubnetMask (staticSubnet settings))
OptTagBroadcastAddress
-> Just (OptBroadcastAddress (staticBroadcast settings))
OptTagTimeOffset
-> Just (OptTimeOffset (staticTimeOffset settings))
OptTagRouters
-> Just (OptRouters (staticRouters settings))
OptTagDomainName
-> Just (OptDomainName (NVTAsciiString (staticDomainName settings)))
OptTagNameServers
-> Just (OptNameServers (staticDNS settings))
_ -> Nothing
discoverToOffer :: ServerSettings
-> Discover
-> Offer
discoverToOffer settings discover = Offer
{ offerHops = 1
, offerXid = discoverXid discover
, offerYourAddr = staticClientAddr settings
, offerServerAddr = staticServerAddr settings
, offerRelayAddr = staticServerAddr settings
, offerClientHardwareAddr = discoverClientHardwareAddr discover
, offerOptions = mapMaybe lookupOption (discoverParameters discover)
}
where
lookupOption tag = case tag of
OptTagSubnetMask
-> Just (OptSubnetMask (staticSubnet settings))
OptTagBroadcastAddress
-> Just (OptBroadcastAddress (staticBroadcast settings))
OptTagTimeOffset
-> Just (OptTimeOffset (staticTimeOffset settings))
OptTagRouters
-> Just (OptRouters (staticRouters settings))
OptTagDomainName
-> Just (OptDomainName (NVTAsciiString (staticDomainName settings)))
OptTagNameServers
-> Just (OptNameServers (staticDNS settings))
_ -> Nothing
data Dhcp4Message = Dhcp4Message
{ dhcp4Op :: Dhcp4Op
, dhcp4Hops :: !Word8
, dhcp4Xid :: !Xid
, dhcp4Secs :: !Word16
, dhcp4Broadcast :: Bool
, dhcp4ClientAddr :: !IP4
, dhcp4YourAddr :: !IP4
, dhcp4ServerAddr :: !IP4
, dhcp4RelayAddr :: !IP4
, dhcp4ClientHardwareAddr :: !Mac
, dhcp4ServerHostname :: String
, dhcp4BootFilename :: String
, dhcp4Options :: [Dhcp4Option]
} deriving (Eq,Show)
getDhcp4Message :: Get Dhcp4Message
getDhcp4Message =
do op <- getAtom
hwtype <- getAtom
len <- getAtom
unless (len == hardwareTypeAddressLength hwtype)
(fail "Hardware address length does not match hardware type.")
hops <- label "hops" getAtom
xid <- label "xid" getAtom
secs <- label "secs" getAtom
flags <- label "flags" getAtom
ciaddr <- label "ciaddr" getAtom
yiaddr <- label "yiaddr" getAtom
siaddr <- label "siaddr" getAtom
giaddr <- label "giaddr" getAtom
chaddr <- label "chaddr" $ isolate 16 $ getAtom A.<* (skip =<< remaining)
snameBytes <- label "sname field" (getByteString 64)
fileBytes <- label "file field" (getByteString 128)
(sname, file, opts) <- getDhcp4Options snameBytes fileBytes
return $! Dhcp4Message
{ dhcp4Op = op
, dhcp4Hops = hops
, dhcp4Xid = xid
, dhcp4Secs = secs
, dhcp4Broadcast = broadcastFlag flags
, dhcp4ClientAddr = ciaddr
, dhcp4YourAddr = yiaddr
, dhcp4ServerAddr = siaddr
, dhcp4RelayAddr = giaddr
, dhcp4ClientHardwareAddr = chaddr
, dhcp4ServerHostname = sname
, dhcp4BootFilename = file
, dhcp4Options = opts
}
putDhcp4Message :: Dhcp4Message -> Put
putDhcp4Message dhcp =
do putAtom (dhcp4Op dhcp)
let hwType = Ethernet
putAtom hwType
putAtom (hardwareTypeAddressLength hwType)
putAtom (dhcp4Hops dhcp)
putAtom (dhcp4Xid dhcp)
putAtom (dhcp4Secs dhcp)
putAtom Flags { broadcastFlag = dhcp4Broadcast dhcp }
putAtom (dhcp4ClientAddr dhcp)
putAtom (dhcp4YourAddr dhcp)
putAtom (dhcp4ServerAddr dhcp)
putAtom (dhcp4RelayAddr dhcp)
putAtom (dhcp4ClientHardwareAddr dhcp)
putByteString $ BS.replicate (16
fromIntegral (hardwareTypeAddressLength hwType)) 0
putPaddedByteString 64 (BS8.pack (dhcp4ServerHostname dhcp))
putPaddedByteString 128 (BS8.pack (dhcp4BootFilename dhcp))
putDhcp4Options (dhcp4Options dhcp)
newtype Xid = Xid Word32
deriving (Eq, Show)
instance CodecAtom Xid where
getAtom =
do w <- getAtom
return (Xid w)
putAtom (Xid xid) =
putAtom xid
atomSize _ =
atomSize (0 :: Word32)
data Dhcp4Op = BootRequest
| BootReply
deriving (Eq,Show)
instance CodecAtom Dhcp4Op where
getAtom = do
b <- getAtom
case b :: Word8 of
1 -> return BootRequest
2 -> return BootReply
_ -> fail ("Unknown DHCP op 0x" ++ showHex b "")
putAtom BootRequest = putAtom (0x1 :: Word8)
putAtom BootReply = putAtom (0x2 :: Word8)
atomSize _ = atomSize (0 :: Word8)
data HardwareType = Ethernet
deriving (Eq, Show)
instance CodecAtom HardwareType where
getAtom =
do b <- getAtom
case b :: Word8 of
1 -> return Ethernet
_ -> fail ("Unsupported hardware type 0x" ++ showHex b "")
putAtom Ethernet = putAtom (1 :: Word8)
atomSize _ = atomSize (1 :: Word8)
hardwareTypeAddressLength :: HardwareType -> Word8
hardwareTypeAddressLength Ethernet = 6
data Flags = Flags { broadcastFlag :: Bool
} deriving (Show, Eq)
instance CodecAtom Flags where
getAtom =
do b <- getAtom
return Flags { broadcastFlag = testBit (b :: Word16) 15 }
putAtom flags = putAtom $ if broadcastFlag flags then bit 15 :: Word16
else 0
atomSize _ = atomSize (0 :: Word16)
putPaddedByteString :: Int -> BS.ByteString -> Put
putPaddedByteString n bs =
do putByteString $ BS.take n bs
putByteString $ BS.replicate (n BS.length bs) 0
selectKnownTags :: [OptionTagOrError] -> [Dhcp4OptionTag]
selectKnownTags = mapMaybe aux
where
aux (KnownTag t) = Just t
aux _ = Nothing
parseDhcpMessage :: Dhcp4Message -> Maybe (Either RequestMessage ReplyMessage)
parseDhcpMessage msg =
do messageType <- lookupMessageType (dhcp4Options msg)
case dhcp4Op msg of
BootRequest -> Left `fmap` case messageType of
Dhcp4Request -> RequestMessage `fmap`
do params <- lookupParams (dhcp4Options msg)
let params' = selectKnownTags params
let addr = lookupRequestAddr (dhcp4Options msg)
return $! Request
{ requestXid = dhcp4Xid msg
, requestBroadcast = dhcp4Broadcast msg
, requestServerAddr = dhcp4ServerAddr msg
, requestClientHardwareAddress = dhcp4ClientHardwareAddr msg
, requestParameters = params'
, requestAddress = addr
}
Dhcp4Discover -> DiscoverMessage `fmap`
do params <- lookupParams (dhcp4Options msg)
let params' = selectKnownTags params
return $! Discover
{ discoverXid = dhcp4Xid msg
, discoverBroadcast = dhcp4Broadcast msg
, discoverClientHardwareAddr = dhcp4ClientHardwareAddr msg
, discoverParameters = params'
}
_ -> Nothing
BootReply -> Right `fmap` case messageType of
Dhcp4Ack -> AckMessage `fmap`
do leaseTime <- lookupLeaseTime (dhcp4Options msg)
return Ack
{ ackHops = dhcp4Hops msg
, ackXid = dhcp4Xid msg
, ackYourAddr = dhcp4YourAddr msg
, ackServerAddr = dhcp4ServerAddr msg
, ackRelayAddr = dhcp4RelayAddr msg
, ackClientHardwareAddr = dhcp4ClientHardwareAddr msg
, ackLeaseTime = leaseTime
, ackOptions = dhcp4Options msg
}
Dhcp4Offer -> return $! OfferMessage Offer
{ offerHops = dhcp4Hops msg
, offerXid = dhcp4Xid msg
, offerYourAddr = dhcp4YourAddr msg
, offerServerAddr = getOfferServerAddr (dhcp4ServerAddr msg) (dhcp4Options msg)
, offerRelayAddr = dhcp4RelayAddr msg
, offerClientHardwareAddr = dhcp4ClientHardwareAddr msg
, offerOptions = dhcp4Options msg
}
_ -> Nothing
getOfferServerAddr :: IP4 -> [Dhcp4Option] -> IP4
getOfferServerAddr = foldr check
where
check (OptServerIdentifier ip) _ = ip
check _ def = def
discoverToMessage :: Discover -> Dhcp4Message
discoverToMessage discover = Dhcp4Message
{ dhcp4Op = BootRequest
, dhcp4Hops = 0
, dhcp4Xid = discoverXid discover
, dhcp4Secs = 0
, dhcp4Broadcast = False
, dhcp4ClientAddr = WildcardIP4
, dhcp4YourAddr = WildcardIP4
, dhcp4ServerAddr = WildcardIP4
, dhcp4RelayAddr = WildcardIP4
, dhcp4ClientHardwareAddr = discoverClientHardwareAddr discover
, dhcp4ServerHostname = ""
, dhcp4BootFilename = ""
, dhcp4Options = [ OptMessageType Dhcp4Discover
, OptParameterRequestList
$ map KnownTag
$ discoverParameters discover
]
}
ackToMessage :: Ack -> Dhcp4Message
ackToMessage ack = Dhcp4Message
{ dhcp4Op = BootReply
, dhcp4Hops = ackHops ack
, dhcp4Xid = ackXid ack
, dhcp4Secs = 0
, dhcp4Broadcast = False
, dhcp4ClientAddr = WildcardIP4
, dhcp4YourAddr = ackYourAddr ack
, dhcp4ServerAddr = ackServerAddr ack
, dhcp4RelayAddr = ackRelayAddr ack
, dhcp4ClientHardwareAddr = ackClientHardwareAddr ack
, dhcp4ServerHostname = ""
, dhcp4BootFilename = ""
, dhcp4Options = OptMessageType Dhcp4Ack
: OptServerIdentifier (ackServerAddr ack)
: OptIPAddressLeaseTime (ackLeaseTime ack)
: ackOptions ack
}
offerToMessage :: Offer -> Dhcp4Message
offerToMessage offer = Dhcp4Message
{ dhcp4Op = BootReply
, dhcp4Hops = offerHops offer
, dhcp4Xid = offerXid offer
, dhcp4Secs = 0
, dhcp4Broadcast = False
, dhcp4ClientAddr = WildcardIP4
, dhcp4YourAddr = offerYourAddr offer
, dhcp4ServerAddr = offerServerAddr offer
, dhcp4RelayAddr = offerRelayAddr offer
, dhcp4ClientHardwareAddr = offerClientHardwareAddr offer
, dhcp4ServerHostname = ""
, dhcp4BootFilename = ""
, dhcp4Options = OptMessageType Dhcp4Offer
: OptServerIdentifier (offerServerAddr offer)
: offerOptions offer
}
requestToMessage :: Request -> Dhcp4Message
requestToMessage request = Dhcp4Message
{ dhcp4Op = BootRequest
, dhcp4Hops = 0
, dhcp4Xid = requestXid request
, dhcp4Secs = 0
, dhcp4Broadcast = requestBroadcast request
, dhcp4ClientAddr = WildcardIP4
, dhcp4YourAddr = WildcardIP4
, dhcp4ServerAddr = WildcardIP4
, dhcp4RelayAddr = WildcardIP4
, dhcp4ClientHardwareAddr = requestClientHardwareAddress request
, dhcp4ServerHostname = ""
, dhcp4BootFilename = ""
, dhcp4Options = [ OptMessageType Dhcp4Request
, OptServerIdentifier (requestServerAddr request)
, OptParameterRequestList
$ map KnownTag
$ requestParameters request
] ++ maybe [] (\x -> [OptRequestIPAddress x])
(requestAddress request)
}
mkDiscover :: Xid
-> Mac
-> Discover
mkDiscover xid mac = Discover
{ discoverXid = xid
, discoverBroadcast = False
, discoverClientHardwareAddr = mac
, discoverParameters = [ OptTagSubnetMask
, OptTagBroadcastAddress
, OptTagTimeOffset
, OptTagRouters
, OptTagDomainName
, OptTagNameServers
, OptTagHostName
]
}
offerToRequest :: Offer
-> Request
offerToRequest offer = Request
{ requestXid = offerXid offer
, requestBroadcast = False
, requestServerAddr = offerServerAddr offer
, requestClientHardwareAddress = offerClientHardwareAddr offer
, requestParameters = [ OptTagSubnetMask
, OptTagBroadcastAddress
, OptTagTimeOffset
, OptTagRouters
, OptTagDomainName
, OptTagNameServers
, OptTagHostName
]
, requestAddress = Just (offerYourAddr offer)
}