diff --git a/doctest/DoctestDriver.hs b/doctest/DoctestDriver.hs new file mode 100644 --- /dev/null +++ b/doctest/DoctestDriver.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} + +#if MIN_VERSION_GLASGOW_HASKELL(8,4,4,0) +{-# OPTIONS_GHC -F -pgmF doctest-discover #-} +#else +module Main where + +import qualified System.IO as IO + +main :: IO () +main = IO.putStrLn "WARNING: doctest will not run on GHC versions earlier than 8.4.4" +#endif diff --git a/hw-ip.cabal b/hw-ip.cabal --- a/hw-ip.cabal +++ b/hw-ip.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hw-ip -version: 2.4.0.1 +version: 2.4.1.0 license: BSD-3-Clause license-file: LICENSE copyright: 2018-2019 John Ky, David Turnbull, Jian Wan @@ -22,28 +22,36 @@ type: git location: https://github.com/haskell-works/hw-ip -common base { build-depends: base >= 4 && < 5 } +common base { build-depends: base >= 4 && < 5 } -common appar { build-depends: appar >= 0.1.8 && < 0.2 } -common binary { build-depends: binary >= 0.8 && < 0.9 } -common bytestring { build-depends: bytestring >= 0.10.6 && < 0.11 } -common containers { build-depends: containers >= 0.5 && < 0.7 } -common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 1.3 } -common hedgehog { build-depends: hedgehog >= 0.6 && < 1.1 } -common hspec { build-depends: hspec >= 2.4.4 && < 2.8 } -common hw-bits { build-depends: hw-bits >= 0.7 && < 0.8 } -common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.2 && < 0.2 } -common iproute { build-depends: iproute >= 1.7.3 && < 1.8 } -common lens { build-depends: lens >= 4 && < 5 } -common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.16 } -common text { build-depends: text >= 1.2.3.1 && < 1.3 } +common appar { build-depends: appar >= 0.1.8 && < 0.2 } +common binary { build-depends: binary >= 0.8 && < 0.9 } +common bytestring { build-depends: bytestring >= 0.10.6 && < 0.11 } +common containers { build-depends: containers >= 0.5 && < 0.7 } +common doctest { build-depends: doctest >= 0.16.2 && < 0.17 } +common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 } +common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 1.3 } +common hedgehog { build-depends: hedgehog >= 0.6 && < 1.1 } +common hspec { build-depends: hspec >= 2.4.4 && < 2.8 } +common hw-bits { build-depends: hw-bits >= 0.7 && < 0.8 } +common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.2 && < 0.2 } +common iproute { build-depends: iproute >= 1.7.3 && < 1.8 } +common lens { build-depends: lens >= 4 && < 5 } +common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.16 } +common text { build-depends: text >= 1.2.3.1 && < 1.3 } -common semigroups { if impl(ghc < 8 ) { build-depends: semigroups >= 0.16 && < 0.19 } } +common semigroups { if impl(ghc < 8 ) { build-depends: semigroups >= 0.16 && < 0.19 } } common config default-language: Haskell2010 ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints +common hw-ip + build-depends: hw-ip + +common hw-ip-gen + build-depends: hw-ip-gen + library import: base, config , appar @@ -71,6 +79,7 @@ , binary , bytestring , generic-lens + , hw-ip , lens , optparse-applicative , semigroups @@ -82,16 +91,15 @@ main-is: Main.hs hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: hw-ip library hw-ip-gen import: base, config , hedgehog , hw-bits + , hw-ip , text exposed-modules: HaskellWorks.Data.Network.Gen hs-source-dirs: gen - build-depends: hw-ip test-suite hw-ip-test import: base, config @@ -101,6 +109,8 @@ , hspec , hw-bits , hw-hspec-hedgehog + , hw-ip + , hw-ip-gen , text other-modules: HaskellWorks.Data.Network.IpBlockSpec HaskellWorks.Data.Network.IpSpec @@ -112,5 +122,16 @@ main-is: Spec.hs hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: hw-ip, hw-ip-gen build-tool-depends: hspec-discover:hspec-discover + +test-suite doctest + import: base, config + , doctest + , doctest-discover + , hw-ip + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: DoctestDriver.hs + HS-Source-Dirs: doctest + build-tool-depends: doctest-discover:doctest-discover diff --git a/src/HaskellWorks/Data/Network/Ip/Ipv6.hs b/src/HaskellWorks/Data/Network/Ip/Ipv6.hs --- a/src/HaskellWorks/Data/Network/Ip/Ipv6.hs +++ b/src/HaskellWorks/Data/Network/Ip/Ipv6.hs @@ -13,6 +13,8 @@ , Unaligned, Canonical , fromIpv4 , fromIpv4Block + , isIpv4Block + , toIpv4Block , fromV4 , parseIpBlock , masksIp @@ -48,6 +50,7 @@ import qualified HaskellWorks.Data.Network.Ip.Internal.Appar as I import qualified HaskellWorks.Data.Network.Ip.Ipv4 as V4 import qualified HaskellWorks.Data.Network.Ip.Word128 as W +import qualified Text.Appar.String as AP newtype IpAddress = IpAddress W.Word128 deriving (Enum, Eq, Ord, Bounded, Generic, SafeEnum) @@ -56,11 +59,17 @@ instance Read IpAddress where readsPrec :: Int -> String -> [(IpAddress, String)] - readsPrec _ s = + readsPrec p s = case readMaybe s :: Maybe D.IPv6 of Just ip -> [(IpAddress (D.toHostAddress6 ip), "")] - Nothing -> [] + Nothing -> I.readsPrecOnParser (AP.try parse6052IpAddress) p s +-- Data.IP doesn't support this encoding, so we have to do it ourselves. It's pretty unambiguous. +parse6052IpAddress :: AP.Parser IpAddress +parse6052IpAddress = do + _ <- AP.string "::ffff:" + fromIpv4 <$> V4.parseIpAddress + newtype IpNetMask = IpNetMask { word :: Word8 } deriving (Enum, Eq, Ord, Show, Generic) @@ -165,6 +174,18 @@ fromIpv4 :: V4.IpAddress -> IpAddress fromIpv4 (V4.IpAddress w32) = IpAddress (0, 0, 0xFFFF, w32) + +isIpv4Block :: IpBlock v -> Bool +isIpv4Block (IpBlock (IpAddress (a, b, c, _)) _) = a == 0 && b == 0 && c == 0xffff + +toIpv4Block :: IpBlock v -> Maybe (V4.IpBlock v) +toIpv4Block b@(IpBlock (IpAddress (_, _, _, d)) (IpNetMask m)) + | isIpv4Block b = + let v4Addr = V4.IpAddress d + v4Mask = V4.IpNetMask (m - 96) + in pure $ V4.IpBlock v4Addr v4Mask + | otherwise = Nothing + canonicaliseIpBlock :: IpBlock v -> IpBlock Canonical canonicaliseIpBlock (IpBlock (IpAddress w) (IpNetMask m)) diff --git a/test/HaskellWorks/Data/Network/Ipv6Spec.hs b/test/HaskellWorks/Data/Network/Ipv6Spec.hs --- a/test/HaskellWorks/Data/Network/Ipv6Spec.hs +++ b/test/HaskellWorks/Data/Network/Ipv6Spec.hs @@ -113,3 +113,15 @@ it "::100 - ::200" $ requireTest $ do V6.rangeToBlocksDL (R.Range (V6.IpAddress 0x100) (V6.IpAddress 0x200)) [] === [ V6.IpBlock (V6.IpAddress 0x100) (V6.IpNetMask 120) , V6.IpBlock (V6.IpAddress 0x200) (V6.IpNetMask 128)] + + describe "should handle 4-in-6 encoding" $ do + it "::ffff:10.43.52.11/128" $ requireTest $ do + read "::ffff:10.43.52.11/128" === V6.IpBlock @Unaligned (V6.IpAddress (0,0,0xffff,0x0a2b340b)) (V6.IpNetMask 128) + + describe "should be able to detect 4-in-6 encoded addresses" $ do + it "::ffff:10.43.52.11/128" $ requireTest $ do + V6.isIpv4Block (read "::ffff:10.43.52.11/128" :: V6.IpBlock Unaligned) === True + + describe "should be able to convert 4-in-6 encoded addresses to ipv4" $ do + it "::ffff:10.43.52.11/128" $ requireTest $ do + V6.toIpv4Block (read "::ffff:10.43.52.11/128") === Just (V4.IpBlock @Unaligned (V4.IpAddress 0x0a2b340b) (V4.IpNetMask 32))