module Hans.Message.Dhcp4Options where

import Control.Monad (unless)
import Control.Applicative
import Data.Maybe (fromMaybe)
import Data.Foldable (traverse_)
import Data.Traversable (sequenceA)
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)

import Hans.Address.IP4 (IP4,IP4Mask)
import Hans.Message.Dhcp4Codec

-----------------------------------------------------------------------
-- 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 <$> getOption
      case tag of
        OptTagPad                           -> Left <$> pure ControlPad
        OptTagEnd                           -> Left <$> pure 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 = 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 = putAtom MagicCookie
                    *> traverse_ putDhcp4Option opts
                    *> putControlOption ControlEnd

scrubControls :: (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)            = []    <$  traverse_ eatPad xs
scrubControls (Right o : xs)                    = (o :) <$> scrubControls xs

-- | '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 :: Applicative f => Int -> f a -> f [a]
replicateA n f = sequenceA (replicate n f)

repeatedly :: Get a -> Get [a]
repeatedly m = do
  done <- isEmpty
  if done then return []
          else (:) <$> m <*> repeatedly m

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 <$> getWord8

putLen :: Int -> Put
putLen n = putWord8 $ fromIntegral n