module Hans.Message.Dhcp4
(
RequestMessage(..)
, Request(..)
, Discover(..)
, ServerSettings(..)
, ReplyMessage(..)
, Ack(..)
, Offer(..)
, Dhcp4Message(..)
, Xid(..)
, requestToAck
, discoverToOffer
, mkDiscover
, offerToRequest
, requestToMessage
, ackToMessage
, offerToMessage
, discoverToMessage
, parseDhcpMessage
, getDhcp4Message
, putDhcp4Message
) where
import Hans.Address.IP4 (IP4(..))
import Hans.Address.Mac (Mac)
import Hans.Message.Dhcp4Codec
import Hans.Message.Dhcp4Options
import Hans.Utils (chunk)
import Control.Applicative ((<*), (<$>))
import Control.Monad (unless)
import Data.Bits (testBit,bit)
import Data.Maybe (mapMaybe)
import Data.Serialize.Get (Get, runGet, getByteString, isolate, remaining, label
, skip)
import Data.Serialize.Put (Put, runPut, putByteString)
import Data.Word (Word8,Word16,Word32)
import Numeric (showHex)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as L
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 :: BS.ByteString -> Either String Dhcp4Message
getDhcp4Message = runGet $ 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 <* (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 -> L.ByteString
putDhcp4Message dhcp = chunk $ runPut $ 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 = Xid <$> getAtom
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 = getAtom >>= \ b -> 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 :: Get Word16
return Flags { broadcastFlag = testBit b 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 <$> case messageType of
Dhcp4Request -> RequestMessage <$> 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 <$> 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 <$> case messageType of
Dhcp4Ack -> AckMessage <$> 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 -> OfferMessage <$> do
return Offer
{ offerHops = dhcp4Hops msg
, offerXid = dhcp4Xid msg
, offerYourAddr = dhcp4YourAddr msg
, offerServerAddr = dhcp4ServerAddr msg
, offerRelayAddr = dhcp4RelayAddr msg
, offerClientHardwareAddr = dhcp4ClientHardwareAddr msg
, offerOptions = dhcp4Options msg
}
_ -> Nothing
discoverToMessage :: Discover -> Dhcp4Message
discoverToMessage discover = Dhcp4Message
{ dhcp4Op = BootRequest
, dhcp4Hops = 0
, dhcp4Xid = discoverXid discover
, dhcp4Secs = 0
, dhcp4Broadcast = False
, dhcp4ClientAddr = IP4 0 0 0 0
, dhcp4YourAddr = IP4 0 0 0 0
, dhcp4ServerAddr = IP4 0 0 0 0
, dhcp4RelayAddr = IP4 0 0 0 0
, 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 = IP4 0 0 0 0
, 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 = IP4 0 0 0 0
, 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 = IP4 0 0 0 0
, dhcp4YourAddr = IP4 0 0 0 0
, dhcp4ServerAddr = IP4 0 0 0 0
, dhcp4RelayAddr = IP4 0 0 0 0
, 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)
}