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) ----------------------------------------------------------------------- -- Magic constants ---------------------------------------------------- ----------------------------------------------------------------------- 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 ----------------------------------------------------------------------- -- DHCP option type and operations ------------------------------------ ----------------------------------------------------------------------- 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 -- RFC 4702 | 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 -- RFC 2242 | OptNetWareInfo ByteString -- RFC 2242 | OptAutoconfiguration Bool -- RFC 2563 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 ----------------------------------------------------------------------- -- Message Type type and operations ----------------------------------- ----------------------------------------------------------------------- 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 ----------------------------------------------------------------------- -- Control tag type and operations ------------------------------------ ----------------------------------------------------------------------- data ControlTag = ControlPad | ControlEnd deriving (Eq, Show) putControlOption :: ControlTag -> Put putControlOption opt = case opt of ControlPad -> putAtom (KnownTag OptTagPad) ControlEnd -> putAtom (KnownTag OptTagEnd) ----------------------------------------------------------------------- -- Option tag type and operations ------------------------------------- ----------------------------------------------------------------------- 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 ----------------------------------------------------------------------- -- NetBIOS node type and operations ----------------------------------- ----------------------------------------------------------------------- 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 ----------------------------------------------------------------------- -- Overload option type and operations -------------------------------- ----------------------------------------------------------------------- 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) ----------------------------------------------------------------------- -- Options list operations -------------------------------------------- ----------------------------------------------------------------------- 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 -- The file field MUST be interpreted for options before the sname field. -- RFC 2131, Section 4.1, Page 24 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' fails on any non 'ControlPad' option with an error message. 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 ----------------------------------------------------------------------- -- Protected parser and unparser monad -------------------------------- ----------------------------------------------------------------------- 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)