module Hans.IP4.Dhcp.Options where
import Hans.IP4.Dhcp.Codec
import Hans.IP4.Packet (IP4,IP4Mask)
import qualified Control.Applicative as A
import Control.Monad (unless)
import Data.Maybe (fromMaybe)
import Data.Foldable (traverse_)
import qualified Data.Traversable as T
import Data.Word (Word8, Word16, Word32)
import Data.Serialize.Get
import Data.Serialize.Put
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Numeric (showHex)
data MagicCookie = MagicCookie
dhcp4MagicCookie :: Word32
dhcp4MagicCookie = 0x63825363
instance CodecAtom MagicCookie where
getAtom = do cookie <- getAtom
unless (cookie == dhcp4MagicCookie)
(fail "Incorrect magic cookie.")
return MagicCookie
putAtom MagicCookie = putAtom dhcp4MagicCookie
atomSize MagicCookie = atomSize dhcp4MagicCookie
data Dhcp4Option
= OptSubnetMask SubnetMask
| OptTimeOffset Word32
| OptRouters [IP4]
| OptTimeServers [IP4]
| OptIEN116NameServers [IP4]
| OptNameServers [IP4]
| OptLogServers [IP4]
| OptCookieServers [IP4]
| OptLPRServers [IP4]
| OptImpressServers [IP4]
| OptResourceLocationServers [IP4]
| OptHostName NVTAsciiString
| OptBootFileSize Word16
| OptMeritDumpFile NVTAsciiString
| OptDomainName NVTAsciiString
| OptSwapServer IP4
| OptRootPath NVTAsciiString
| OptExtensionsPath NVTAsciiString
| OptEnableIPForwarding Bool
| OptEnableNonLocalSourceRouting Bool
| OptPolicyFilters [IP4Mask]
| OptMaximumDatagramReassemblySize Word16
| OptDefaultTTL Word8
| OptPathMTUAgingTimeout Word32
| OptPathMTUPlateauTable [Word16]
| OptInterfaceMTU Word16
| OptAllSubnetsAreLocal Bool
| OptBroadcastAddress IP4
| OptPerformMaskDiscovery Bool
| OptShouldSupplyMasks Bool
| OptShouldPerformRouterDiscovery Bool
| OptRouterSolicitationAddress IP4
| OptStaticRoutes [(IP4,IP4)]
| OptShouldNegotiateArpTrailers Bool
| OptArpCacheTimeout Word32
| OptUseRFC1042EthernetEncapsulation Bool
| OptTcpDefaultTTL Word8
| OptTcpKeepaliveInterval Word32
| OptTcpKeepaliveUseGarbage Bool
| OptNisDomainName NVTAsciiString
| OptNisServers [IP4]
| OptNtpServers [IP4]
| OptVendorSpecific ByteString
| OptNetBiosNameServers [IP4]
| OptNetBiosDistributionServers [IP4]
| OptNetBiosNodeType NetBiosNodeType
| OptNetBiosScope NVTAsciiString
| OptXWindowsFontServer [IP4]
| OptXWindowsDisplayManagers [IP4]
| OptNisPlusDomain NVTAsciiString
| OptNisPlusServers [IP4]
| OptSmtpServers [IP4]
| OptPopServers [IP4]
| OptNntpServers [IP4]
| OptWwwServers [IP4]
| OptFingerServers [IP4]
| OptIrcServers [IP4]
| OptStreetTalkServers [IP4]
| OptStreetTalkDirectoryAssistanceServers [IP4]
| OptFQDN NVTAsciiString
| OptRequestIPAddress IP4
| OptIPAddressLeaseTime Word32
| OptOverload OverloadOption
| OptTftpServer NVTAsciiString
| OptBootfileName NVTAsciiString
| OptMessageType Dhcp4MessageType
| OptServerIdentifier IP4
| OptParameterRequestList [OptionTagOrError]
| OptErrorMessage NVTAsciiString
| OptMaxDHCPMessageSize Word16
| OptRenewalTime Word32
| OptRebindingTime Word32
| OptVendorClass NVTAsciiString
| OptClientIdentifier ByteString
| OptNetWareDomainName NVTAsciiString
| OptNetWareInfo ByteString
| OptAutoconfiguration Bool
deriving (Show,Eq)
getDhcp4Option :: Get (Either ControlTag Dhcp4Option)
getDhcp4Option = do
mb_tag <- getOptionTag
case mb_tag of
UnknownTag t -> do xs <- getBytes =<< remaining
fail ("getDhcp4Option failed tag (" ++ show t ++ ") " ++ show xs)
KnownTag tag -> do
let r con = (Right . con) `fmap` getOption
case tag of
OptTagPad -> A.pure (Left ControlPad)
OptTagEnd -> A.pure (Left ControlEnd)
OptTagSubnetMask -> r OptSubnetMask
OptTagTimeOffset -> r OptTimeOffset
OptTagRouters -> r OptRouters
OptTagTimeServers -> r OptTimeServers
OptTagIEN116NameServers -> r OptIEN116NameServers
OptTagNameServers -> r OptNameServers
OptTagLogServers -> r OptLogServers
OptTagCookieServers -> r OptCookieServers
OptTagLPRServers -> r OptLPRServers
OptTagImpressServers -> r OptImpressServers
OptTagResourceLocationServers -> r OptResourceLocationServers
OptTagHostName -> r OptHostName
OptTagBootFileSize -> r OptBootFileSize
OptTagMeritDumpFile -> r OptMeritDumpFile
OptTagDomainName -> r OptDomainName
OptTagSwapServer -> r OptSwapServer
OptTagRootPath -> r OptRootPath
OptTagExtensionsPath -> r OptExtensionsPath
OptTagEnableIPForwarding -> r OptEnableIPForwarding
OptTagEnableNonLocalSourceRouting -> r OptEnableNonLocalSourceRouting
OptTagPolicyFilters -> r OptPolicyFilters
OptTagMaximumDatagramReassemblySize -> r OptMaximumDatagramReassemblySize
OptTagDefaultTTL -> r OptDefaultTTL
OptTagPathMTUAgingTimeout -> r OptPathMTUAgingTimeout
OptTagPathMTUPlateauTable -> r OptPathMTUPlateauTable
OptTagInterfaceMTU -> r OptInterfaceMTU
OptTagAllSubnetsAreLocal -> r OptAllSubnetsAreLocal
OptTagBroadcastAddress -> r OptBroadcastAddress
OptTagPerformMaskDiscovery -> r OptPerformMaskDiscovery
OptTagShouldSupplyMasks -> r OptShouldSupplyMasks
OptTagShouldPerformRouterDiscovery -> r OptShouldPerformRouterDiscovery
OptTagRouterSolicitationAddress -> r OptRouterSolicitationAddress
OptTagStaticRoutes -> r OptStaticRoutes
OptTagShouldNegotiateArpTrailers -> r OptShouldNegotiateArpTrailers
OptTagArpCacheTimeout -> r OptArpCacheTimeout
OptTagUseRFC1042EthernetEncapsulation -> r OptUseRFC1042EthernetEncapsulation
OptTagTcpDefaultTTL -> r OptTcpDefaultTTL
OptTagTcpKeepaliveInterval -> r OptTcpKeepaliveInterval
OptTagTcpKeepaliveUseGarbage -> r OptTcpKeepaliveUseGarbage
OptTagNisDomainName -> r OptNisDomainName
OptTagNisServers -> r OptNisServers
OptTagNtpServers -> r OptNtpServers
OptTagVendorSpecific -> r OptVendorSpecific
OptTagNetBiosNameServers -> r OptNetBiosNameServers
OptTagNetBiosDistributionServers -> r OptNetBiosDistributionServers
OptTagNetBiosNodeType -> r OptNetBiosNodeType
OptTagNetBiosScope -> r OptNetBiosScope
OptTagXWindowsFontServer -> r OptXWindowsFontServer
OptTagXWindowsDisplayManagers -> r OptXWindowsDisplayManagers
OptTagNisPlusDomain -> r OptNisPlusDomain
OptTagNisPlusServers -> r OptNisPlusServers
OptTagSmtpServers -> r OptSmtpServers
OptTagPopServers -> r OptPopServers
OptTagNntpServers -> r OptNntpServers
OptTagWwwServers -> r OptWwwServers
OptTagFingerServers -> r OptFingerServers
OptTagIrcServers -> r OptIrcServers
OptTagStreetTalkServers -> r OptStreetTalkServers
OptTagStreetTalkDirectoryAssistanceServers -> r OptStreetTalkDirectoryAssistanceServers
OptTagFQDN -> r OptFQDN
OptTagRequestIPAddress -> r OptRequestIPAddress
OptTagIPAddressLeaseTime -> r OptIPAddressLeaseTime
OptTagOverload -> r OptOverload
OptTagTftpServer -> r OptTftpServer
OptTagBootfileName -> r OptBootfileName
OptTagMessageType -> r OptMessageType
OptTagServerIdentifier -> r OptServerIdentifier
OptTagParameterRequestList -> r OptParameterRequestList
OptTagErrorMessage -> r OptErrorMessage
OptTagMaxDHCPMessageSize -> r OptMaxDHCPMessageSize
OptTagRenewalTime -> r OptRenewalTime
OptTagRebindingTime -> r OptRebindingTime
OptTagVendorClass -> r OptVendorClass
OptTagClientIdentifier -> r OptClientIdentifier
OptTagNetWareDomainName -> r OptNetWareDomainName
OptTagNetWareInfo -> r OptNetWareInfo
OptTagAutoconfiguration -> r OptAutoconfiguration
putDhcp4Option :: Dhcp4Option -> Put
putDhcp4Option opt =
let p tag val = do putAtom (KnownTag tag); putOption val in
case opt of
OptSubnetMask mask -> p OptTagSubnetMask mask
OptTimeOffset offset -> p OptTagTimeOffset offset
OptRouters routers -> p OptTagRouters routers
OptTimeServers servers -> p OptTagTimeServers servers
OptIEN116NameServers servers -> p OptTagIEN116NameServers servers
OptNameServers servers -> p OptTagNameServers servers
OptLogServers servers -> p OptTagLogServers servers
OptCookieServers servers -> p OptTagCookieServers servers
OptLPRServers servers -> p OptTagLPRServers servers
OptImpressServers servers -> p OptTagImpressServers servers
OptResourceLocationServers servers -> p OptTagResourceLocationServers servers
OptHostName hostname -> p OptTagHostName hostname
OptBootFileSize sz -> p OptTagBootFileSize sz
OptMeritDumpFile file -> p OptTagMeritDumpFile file
OptDomainName domainname -> p OptTagDomainName domainname
OptSwapServer server -> p OptTagSwapServer server
OptRootPath path -> p OptTagRootPath path
OptExtensionsPath path -> p OptTagExtensionsPath path
OptEnableIPForwarding enabled -> p OptTagEnableIPForwarding enabled
OptEnableNonLocalSourceRouting enab -> p OptTagEnableNonLocalSourceRouting enab
OptPolicyFilters filters -> p OptTagPolicyFilters filters
OptMaximumDatagramReassemblySize n -> p OptTagMaximumDatagramReassemblySize n
OptDefaultTTL ttl -> p OptTagDefaultTTL ttl
OptPathMTUAgingTimeout timeout -> p OptTagPathMTUAgingTimeout timeout
OptPathMTUPlateauTable mtus -> p OptTagPathMTUPlateauTable mtus
OptInterfaceMTU mtu -> p OptTagInterfaceMTU mtu
OptAllSubnetsAreLocal arelocal -> p OptTagAllSubnetsAreLocal arelocal
OptBroadcastAddress addr -> p OptTagBroadcastAddress addr
OptPerformMaskDiscovery perform -> p OptTagPerformMaskDiscovery perform
OptShouldSupplyMasks should -> p OptTagShouldSupplyMasks should
OptShouldPerformRouterDiscovery b -> p OptTagShouldPerformRouterDiscovery b
OptRouterSolicitationAddress addr -> p OptTagRouterSolicitationAddress addr
OptStaticRoutes routes -> p OptTagStaticRoutes routes
OptShouldNegotiateArpTrailers b -> p OptTagShouldNegotiateArpTrailers b
OptArpCacheTimeout timeout -> p OptTagArpCacheTimeout timeout
OptUseRFC1042EthernetEncapsulation b-> p OptTagUseRFC1042EthernetEncapsulation b
OptTcpDefaultTTL ttl -> p OptTagTcpDefaultTTL ttl
OptTcpKeepaliveInterval interval -> p OptTagTcpKeepaliveInterval interval
OptTcpKeepaliveUseGarbage use -> p OptTagTcpKeepaliveUseGarbage use
OptNisDomainName domainname -> p OptTagNisDomainName domainname
OptNisServers servers -> p OptTagNisServers servers
OptNtpServers servers -> p OptTagNtpServers servers
OptVendorSpecific bs -> p OptTagVendorSpecific bs
OptNetBiosNameServers servers -> p OptTagNetBiosNameServers servers
OptNetBiosDistributionServers srvs -> p OptTagNetBiosDistributionServers srvs
OptNetBiosNodeType node -> p OptTagNetBiosNodeType node
OptNetBiosScope scope -> p OptTagNetBiosScope scope
OptXWindowsFontServer servers -> p OptTagXWindowsFontServer servers
OptXWindowsDisplayManagers servers -> p OptTagXWindowsDisplayManagers servers
OptNisPlusDomain domain -> p OptTagNisPlusDomain domain
OptNisPlusServers servers -> p OptTagNisPlusServers servers
OptSmtpServers servers -> p OptTagSmtpServers servers
OptPopServers servers -> p OptTagPopServers servers
OptNntpServers servers -> p OptTagNntpServers servers
OptWwwServers servers -> p OptTagWwwServers servers
OptFingerServers servers -> p OptTagFingerServers servers
OptIrcServers servers -> p OptTagIrcServers servers
OptStreetTalkServers servers -> p OptTagStreetTalkServers servers
OptStreetTalkDirectoryAssistanceServers servers -> p OptTagStreetTalkDirectoryAssistanceServers servers
OptFQDN fqdn -> p OptTagFQDN fqdn
OptRequestIPAddress addr -> p OptTagRequestIPAddress addr
OptIPAddressLeaseTime time -> p OptTagIPAddressLeaseTime time
OptOverload overload -> p OptTagOverload overload
OptTftpServer server -> p OptTagTftpServer server
OptBootfileName filename -> p OptTagBootfileName filename
OptMessageType t -> p OptTagMessageType t
OptServerIdentifier server -> p OptTagServerIdentifier server
OptParameterRequestList ps -> p OptTagParameterRequestList ps
OptErrorMessage msg -> p OptTagErrorMessage msg
OptMaxDHCPMessageSize maxsz -> p OptTagMaxDHCPMessageSize maxsz
OptRenewalTime time -> p OptTagRenewalTime time
OptRebindingTime time -> p OptTagRebindingTime time
OptVendorClass str -> p OptTagVendorClass str
OptClientIdentifier client -> p OptTagClientIdentifier client
OptNetWareDomainName name -> p OptTagNetWareDomainName name
OptNetWareInfo info -> p OptTagNetWareInfo info
OptAutoconfiguration autoconf -> p OptTagAutoconfiguration autoconf
data Dhcp4MessageType
= Dhcp4Discover
| Dhcp4Offer
| Dhcp4Request
| Dhcp4Decline
| Dhcp4Ack
| Dhcp4Nak
| Dhcp4Release
| Dhcp4Inform
deriving (Eq,Show)
instance Option Dhcp4MessageType where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance CodecAtom Dhcp4MessageType where
getAtom = do
b <- getAtom
case b :: Word8 of
1 -> return Dhcp4Discover
2 -> return Dhcp4Offer
3 -> return Dhcp4Request
4 -> return Dhcp4Decline
5 -> return Dhcp4Ack
6 -> return Dhcp4Nak
7 -> return Dhcp4Release
8 -> return Dhcp4Inform
_ -> fail ("Unknown DHCP Message Type 0x" ++ showHex b "")
putAtom t = putAtom $ case t of
Dhcp4Discover -> 1 :: Word8
Dhcp4Offer -> 2
Dhcp4Request -> 3
Dhcp4Decline -> 4
Dhcp4Ack -> 5
Dhcp4Nak -> 6
Dhcp4Release -> 7
Dhcp4Inform -> 8
atomSize _ = 1
data ControlTag
= ControlPad
| ControlEnd
deriving (Eq, Show)
putControlOption :: ControlTag -> Put
putControlOption opt = case opt of
ControlPad -> putAtom (KnownTag OptTagPad)
ControlEnd -> putAtom (KnownTag OptTagEnd)
data Dhcp4OptionTag
= OptTagPad
| OptTagEnd
| OptTagSubnetMask
| OptTagTimeOffset
| OptTagRouters
| OptTagTimeServers
| OptTagIEN116NameServers
| OptTagNameServers
| OptTagLogServers
| OptTagCookieServers
| OptTagLPRServers
| OptTagImpressServers
| OptTagResourceLocationServers
| OptTagHostName
| OptTagBootFileSize
| OptTagMeritDumpFile
| OptTagDomainName
| OptTagSwapServer
| OptTagRootPath
| OptTagExtensionsPath
| OptTagEnableIPForwarding
| OptTagEnableNonLocalSourceRouting
| OptTagPolicyFilters
| OptTagMaximumDatagramReassemblySize
| OptTagDefaultTTL
| OptTagPathMTUAgingTimeout
| OptTagPathMTUPlateauTable
| OptTagInterfaceMTU
| OptTagAllSubnetsAreLocal
| OptTagBroadcastAddress
| OptTagPerformMaskDiscovery
| OptTagShouldSupplyMasks
| OptTagShouldPerformRouterDiscovery
| OptTagRouterSolicitationAddress
| OptTagStaticRoutes
| OptTagShouldNegotiateArpTrailers
| OptTagArpCacheTimeout
| OptTagUseRFC1042EthernetEncapsulation
| OptTagTcpDefaultTTL
| OptTagTcpKeepaliveInterval
| OptTagTcpKeepaliveUseGarbage
| OptTagNisDomainName
| OptTagNisServers
| OptTagNtpServers
| OptTagVendorSpecific
| OptTagNetBiosNameServers
| OptTagNetBiosDistributionServers
| OptTagNetBiosNodeType
| OptTagNetBiosScope
| OptTagXWindowsFontServer
| OptTagXWindowsDisplayManagers
| OptTagNisPlusDomain
| OptTagNisPlusServers
| OptTagSmtpServers
| OptTagPopServers
| OptTagNntpServers
| OptTagWwwServers
| OptTagFingerServers
| OptTagIrcServers
| OptTagStreetTalkServers
| OptTagStreetTalkDirectoryAssistanceServers
| OptTagFQDN
| OptTagRequestIPAddress
| OptTagIPAddressLeaseTime
| OptTagOverload
| OptTagTftpServer
| OptTagBootfileName
| OptTagMessageType
| OptTagServerIdentifier
| OptTagParameterRequestList
| OptTagErrorMessage
| OptTagMaxDHCPMessageSize
| OptTagRenewalTime
| OptTagRebindingTime
| OptTagVendorClass
| OptTagClientIdentifier
| OptTagNetWareDomainName
| OptTagNetWareInfo
| OptTagAutoconfiguration
deriving (Show,Eq)
data OptionTagOrError = UnknownTag Word8 | KnownTag Dhcp4OptionTag
deriving (Show,Eq)
getOptionTag :: Get OptionTagOrError
getOptionTag = f =<< getWord8
where
r = return . KnownTag
f 0 = r OptTagPad
f 1 = r OptTagSubnetMask
f 2 = r OptTagTimeOffset
f 3 = r OptTagRouters
f 4 = r OptTagTimeServers
f 5 = r OptTagIEN116NameServers
f 6 = r OptTagNameServers
f 7 = r OptTagLogServers
f 8 = r OptTagCookieServers
f 9 = r OptTagLPRServers
f 10 = r OptTagImpressServers
f 11 = r OptTagResourceLocationServers
f 12 = r OptTagHostName
f 13 = r OptTagBootFileSize
f 14 = r OptTagMeritDumpFile
f 15 = r OptTagDomainName
f 16 = r OptTagSwapServer
f 17 = r OptTagRootPath
f 18 = r OptTagExtensionsPath
f 19 = r OptTagEnableIPForwarding
f 20 = r OptTagEnableNonLocalSourceRouting
f 21 = r OptTagPolicyFilters
f 22 = r OptTagMaximumDatagramReassemblySize
f 23 = r OptTagDefaultTTL
f 24 = r OptTagPathMTUAgingTimeout
f 25 = r OptTagPathMTUPlateauTable
f 26 = r OptTagInterfaceMTU
f 27 = r OptTagAllSubnetsAreLocal
f 28 = r OptTagBroadcastAddress
f 29 = r OptTagPerformMaskDiscovery
f 30 = r OptTagShouldSupplyMasks
f 31 = r OptTagShouldPerformRouterDiscovery
f 32 = r OptTagRouterSolicitationAddress
f 33 = r OptTagStaticRoutes
f 34 = r OptTagShouldNegotiateArpTrailers
f 35 = r OptTagArpCacheTimeout
f 36 = r OptTagUseRFC1042EthernetEncapsulation
f 37 = r OptTagTcpDefaultTTL
f 38 = r OptTagTcpKeepaliveInterval
f 39 = r OptTagTcpKeepaliveUseGarbage
f 40 = r OptTagNisDomainName
f 41 = r OptTagNisServers
f 42 = r OptTagNtpServers
f 43 = r OptTagVendorSpecific
f 44 = r OptTagNetBiosNameServers
f 45 = r OptTagNetBiosDistributionServers
f 46 = r OptTagNetBiosNodeType
f 47 = r OptTagNetBiosScope
f 48 = r OptTagXWindowsFontServer
f 49 = r OptTagXWindowsDisplayManagers
f 50 = r OptTagRequestIPAddress
f 51 = r OptTagIPAddressLeaseTime
f 52 = r OptTagOverload
f 53 = r OptTagMessageType
f 54 = r OptTagServerIdentifier
f 55 = r OptTagParameterRequestList
f 56 = r OptTagErrorMessage
f 57 = r OptTagMaxDHCPMessageSize
f 58 = r OptTagRenewalTime
f 59 = r OptTagRebindingTime
f 60 = r OptTagVendorClass
f 61 = r OptTagClientIdentifier
f 62 = r OptTagNetWareDomainName
f 63 = r OptTagNetWareInfo
f 64 = r OptTagNisPlusDomain
f 65 = r OptTagNisPlusServers
f 66 = r OptTagTftpServer
f 67 = r OptTagBootfileName
f 69 = r OptTagSmtpServers
f 70 = r OptTagPopServers
f 71 = r OptTagNntpServers
f 72 = r OptTagWwwServers
f 73 = r OptTagFingerServers
f 74 = r OptTagIrcServers
f 75 = r OptTagStreetTalkServers
f 76 = r OptTagStreetTalkDirectoryAssistanceServers
f 81 = r OptTagFQDN
f 116 = r OptTagAutoconfiguration
f 255 = r OptTagEnd
f t = return (UnknownTag t)
putOptionTag :: OptionTagOrError -> Put
putOptionTag (UnknownTag t) = putAtom t
putOptionTag (KnownTag t) = putAtom (f t)
where
f :: Dhcp4OptionTag -> Word8
f OptTagPad = 0
f OptTagEnd = 255
f OptTagSubnetMask = 1
f OptTagTimeOffset = 2
f OptTagRouters = 3
f OptTagTimeServers = 4
f OptTagIEN116NameServers = 5
f OptTagNameServers = 6
f OptTagLogServers = 7
f OptTagCookieServers = 8
f OptTagLPRServers = 9
f OptTagImpressServers = 10
f OptTagResourceLocationServers = 11
f OptTagHostName = 12
f OptTagBootFileSize = 13
f OptTagMeritDumpFile = 14
f OptTagDomainName = 15
f OptTagSwapServer = 16
f OptTagRootPath = 17
f OptTagExtensionsPath = 18
f OptTagEnableIPForwarding = 19
f OptTagEnableNonLocalSourceRouting = 20
f OptTagPolicyFilters = 21
f OptTagMaximumDatagramReassemblySize = 22
f OptTagDefaultTTL = 23
f OptTagPathMTUAgingTimeout = 24
f OptTagPathMTUPlateauTable = 25
f OptTagInterfaceMTU = 26
f OptTagAllSubnetsAreLocal = 27
f OptTagBroadcastAddress = 28
f OptTagPerformMaskDiscovery = 29
f OptTagShouldSupplyMasks = 30
f OptTagShouldPerformRouterDiscovery = 31
f OptTagRouterSolicitationAddress = 32
f OptTagStaticRoutes = 33
f OptTagShouldNegotiateArpTrailers = 34
f OptTagArpCacheTimeout = 35
f OptTagUseRFC1042EthernetEncapsulation = 36
f OptTagTcpDefaultTTL = 37
f OptTagTcpKeepaliveInterval = 38
f OptTagTcpKeepaliveUseGarbage = 39
f OptTagNisDomainName = 40
f OptTagNisServers = 41
f OptTagNtpServers = 42
f OptTagVendorSpecific = 43
f OptTagNetBiosNameServers = 44
f OptTagNetBiosDistributionServers = 45
f OptTagNetBiosNodeType = 46
f OptTagNetBiosScope = 47
f OptTagXWindowsFontServer = 48
f OptTagXWindowsDisplayManagers = 49
f OptTagRequestIPAddress = 50
f OptTagIPAddressLeaseTime = 51
f OptTagOverload = 52
f OptTagMessageType = 53
f OptTagServerIdentifier = 54
f OptTagParameterRequestList = 55
f OptTagErrorMessage = 56
f OptTagMaxDHCPMessageSize = 57
f OptTagRenewalTime = 58
f OptTagRebindingTime = 59
f OptTagVendorClass = 60
f OptTagClientIdentifier = 61
f OptTagNetWareDomainName = 62
f OptTagNetWareInfo = 63
f OptTagNisPlusDomain = 64
f OptTagNisPlusServers = 65
f OptTagTftpServer = 66
f OptTagBootfileName = 67
f OptTagSmtpServers = 69
f OptTagPopServers = 70
f OptTagNntpServers = 71
f OptTagWwwServers = 72
f OptTagFingerServers = 73
f OptTagIrcServers = 74
f OptTagStreetTalkServers = 75
f OptTagStreetTalkDirectoryAssistanceServers = 76
f OptTagFQDN = 81
f OptTagAutoconfiguration = 116
data NetBiosNodeType
= BNode
| PNode
| MNode
| HNode
deriving (Show,Eq)
instance Option NetBiosNodeType where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance CodecAtom NetBiosNodeType where
getAtom = do
b <- getAtom
case b :: Word8 of
0x1 -> return BNode
0x2 -> return PNode
0x4 -> return MNode
0x8 -> return HNode
_ -> fail "Unknown NetBIOS node type"
putAtom t = putAtom $ case t of
BNode -> 0x1 :: Word8
PNode -> 0x2
MNode -> 0x4
HNode -> 0x8
atomSize _ = 1
data OverloadOption
= UsedFileField
| UsedSNameField
| UsedBothFields
deriving (Show, Eq)
instance Option OverloadOption where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance CodecAtom OverloadOption where
getAtom = do b <- getAtom
case b :: Word8 of
1 -> return UsedFileField
2 -> return UsedSNameField
3 -> return UsedBothFields
_ -> fail ("Bad overload value 0x" ++ showHex b "")
putAtom t = putAtom $ case t of
UsedFileField -> 1 :: Word8
UsedSNameField -> 2
UsedBothFields -> 3
atomSize _ = atomSize (undefined :: Word8)
getDhcp4Options :: ByteString -> ByteString
-> Get (String, String, [Dhcp4Option])
getDhcp4Options sname file = do
MagicCookie <- getAtom
options0 <- remainingAsOptions
case lookupOverload options0 of
Nothing -> return (nullTerminated sname, nullTerminated file, options0)
Just UsedFileField -> do
options1 <- localParse file remainingAsOptions
let options = options0 ++ options1
NVTAsciiString fileString
= fromMaybe (NVTAsciiString "") (lookupFile options)
return (nullTerminated sname, fileString, options)
Just UsedSNameField -> do
options1 <- localParse sname remainingAsOptions
let options = options0 ++ options1
NVTAsciiString snameString
= fromMaybe (NVTAsciiString "") (lookupSname options)
return (snameString, nullTerminated file, options)
Just UsedBothFields -> do
options1 <- localParse file remainingAsOptions
options2 <- localParse sname remainingAsOptions
let options = options0 ++ options1 ++ options2
NVTAsciiString snameString
= fromMaybe (NVTAsciiString "") (lookupSname options)
NVTAsciiString fileString
= fromMaybe (NVTAsciiString "") (lookupFile options)
return (snameString, fileString, options)
where
remainingAsOptions = scrubControls =<< repeatedly getDhcp4Option
localParse bs m = case runGet m bs of
Right x -> return x
Left err -> fail err
putDhcp4Options :: [Dhcp4Option] -> Put
putDhcp4Options opts =
do putAtom MagicCookie
traverse_ putDhcp4Option opts
putControlOption ControlEnd
scrubControls :: (A.Applicative m, Monad m)
=> [Either ControlTag Dhcp4Option] -> m [Dhcp4Option]
scrubControls [] =
fail "No END option found"
scrubControls (Left ControlPad : xs) =
scrubControls xs
scrubControls (Left ControlEnd : xs) =
do traverse_ eatPad xs
return []
scrubControls (Right o : xs) =
do os <- scrubControls xs
return (o:os)
eatPad :: Monad m => Either ControlTag Dhcp4Option -> m ()
eatPad (Left ControlPad) = return ()
eatPad _ = fail "Unexpected option after END option"
replicateA :: A.Applicative f => Int -> f a -> f [a]
replicateA n f = T.sequenceA (replicate n f)
repeatedly :: Get a -> Get [a]
repeatedly m = go []
where
go acc =
do done <- isEmpty
if done then return (reverse acc)
else do a <- m
go (a:acc)
nullTerminated :: ByteString -> String
nullTerminated = takeWhile (/= '\NUL') . BS8.unpack
lookupOverload :: [Dhcp4Option] -> Maybe OverloadOption
lookupOverload = foldr f Nothing
where f (OptOverload o) _ = Just o
f _ a = a
lookupFile :: [Dhcp4Option] -> Maybe NVTAsciiString
lookupFile = foldr f Nothing
where f (OptBootfileName fn) _ = Just fn
f _ a = a
lookupSname :: [Dhcp4Option] -> Maybe NVTAsciiString
lookupSname = foldr f Nothing
where f (OptTftpServer n) _ = Just n
f _ a = a
lookupParams :: [Dhcp4Option] -> Maybe [OptionTagOrError]
lookupParams = foldr f Nothing
where f (OptParameterRequestList n) _ = Just n
f _ a = a
lookupMessageType :: [Dhcp4Option] -> Maybe Dhcp4MessageType
lookupMessageType = foldr f Nothing
where f (OptMessageType n) _ = Just n
f _ a = a
lookupRequestAddr :: [Dhcp4Option] -> Maybe IP4
lookupRequestAddr = foldr f Nothing
where f (OptRequestIPAddress n) _ = Just n
f _ a = a
lookupLeaseTime :: [Dhcp4Option] -> Maybe Word32
lookupLeaseTime = foldr f Nothing
where f (OptIPAddressLeaseTime t) _ = Just t
f _ a = a
class Option a where
getOption :: Get a
putOption :: a -> Put
instance CodecAtom a => Option [a] where
getOption = do
let (n, m) = getRecord
len <- getLen
let (count, remainder) = divMod len n
unless (remainder == 0) (fail ("Length was not a multiple of " ++ show n))
unless (count > 0) (fail "Minimum length not met")
replicateA count $ label "List of fixed-length values" $ isolate n m
putOption xs = do putLen (atomSize (head xs) * length xs)
traverse_ putAtom xs
instance (CodecAtom a, CodecAtom b) => Option (a,b) where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance Option Bool where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance Option Word8 where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance Option Word16 where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance Option Word32 where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance Option IP4 where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance Option SubnetMask where
getOption = defaultFixedGetOption
putOption = defaultFixedPutOption
instance Option ByteString where
getOption = do len <- getLen
getByteString len
putOption bs = do putLen (BS.length bs)
putByteString bs
defaultFixedGetOption :: CodecAtom a => Get a
defaultFixedGetOption = fixedLen n m
where (n,m) = getRecord
defaultFixedPutOption :: CodecAtom a => a -> Put
defaultFixedPutOption x = do
putLen (atomSize x)
putAtom x
fixedLen :: Int -> Get a -> Get a
fixedLen expectedLen m = do
len <- getLen
unless (len == expectedLen) (fail "Bad length on \"fixed-length\" option.")
label "Fixed length field" (isolate expectedLen m)
getRecord :: CodecAtom a => (Int, Get a)
getRecord = (atomSize undef, m)
where
(undef, m) = (undefined, getAtom) :: CodecAtom a => (a, Get a)
instance CodecAtom OptionTagOrError where
getAtom = getOptionTag
putAtom x = putOptionTag x
atomSize _ = 1
newtype NVTAsciiString = NVTAsciiString String
deriving (Eq, Show)
instance Option NVTAsciiString where
getOption = do len <- getLen
bs <- getByteString len
return (NVTAsciiString (nullTerminated bs))
putOption (NVTAsciiString str) = do
putLen (length str)
putByteString (BS8.pack str)
getLen :: Get Int
getLen = fromIntegral `fmap` getWord8
putLen :: Int -> Put
putLen n = putWord8 (fromIntegral n)