diff --git a/asif.cabal b/asif.cabal --- a/asif.cabal +++ b/asif.cabal @@ -1,5 +1,5 @@ name: asif -version: 4.1.0 +version: 5.0.0 description: Library for creating and querying segmented feeds. Please see synopsis: Library for creating and querying segmented feeds category: Services diff --git a/src/Arbor/File/Format/Asif/Data/Ip.hs b/src/Arbor/File/Format/Asif/Data/Ip.hs --- a/src/Arbor/File/Format/Asif/Data/Ip.hs +++ b/src/Arbor/File/Format/Asif/Data/Ip.hs @@ -2,7 +2,12 @@ ( stringToIpv4 , stringToIpv6 , ipv4ToString + , ipv4CidrToString + , isIpv4 , ipv6ToString + , ipv6toStringCollapseV4 + , ipv6CidrToString + , ipv6CidrToStringCollapseV4 , word32ToIpv4 , word32x4ToIpv6 , ipv4ToWord32 @@ -11,36 +16,64 @@ ) where import Arbor.File.Format.Asif.Data.Read -import Data.IP +import Control.Lens ((&)) import Data.Word -import System.Endian import Text.Read -stringToIpv4 :: String -> Maybe IPv4 +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6 + +stringToIpv4 :: String -> Maybe IP4.IpAddress stringToIpv4 str = if '.' `elem` str then readMaybe str else word32ToIpv4 <$> stringToAnyDigits str -stringToIpv6 :: String -> Maybe IPv6 +stringToIpv6 :: String -> Maybe IP6.IpAddress stringToIpv6 = readMaybe -ipv4ToString :: IPv4 -> String -ipv4ToString = show +ipv4ToString :: IP4.IpAddress -> String +ipv4ToString = IP4.showIpAddress -ipv6ToString :: IPv6 -> String -ipv6ToString = show +ipv4CidrToString :: IP4.IpBlock v -> String +ipv4CidrToString = show -word32ToIpv4 :: Word32 -> IPv4 -word32ToIpv4 = fromHostAddress . toBE32 +isIpv4 :: IP6.IpAddress -> Maybe IP4.IpAddress +isIpv4 ip = + let (a, b, c, d) = ipv6ToWord32x4 ip + in if a == 0 && b == 0 && c == 0xFFFF + then Just $ IP4.IpAddress d + else Nothing -word32x4ToIpv6 :: (Word32, Word32, Word32, Word32) -> IPv6 -word32x4ToIpv6 = fromHostAddress6 +ipv6ToString :: IP6.IpAddress -> String +ipv6ToString = IP6.showIpAddress -ipv4ToWord32 :: IPv4 -> Word32 -ipv4ToWord32 = fromBE32 . toHostAddress +ipv6toStringCollapseV4 :: IP6.IpAddress -> String +ipv6toStringCollapseV4 ip + = case isIpv4 ip of + Just d -> d & ipv4ToString + _ -> ip & ipv6ToString -ipv6ToWord32x4 :: IPv6 -> (Word32, Word32, Word32, Word32) -ipv6ToWord32x4 = toHostAddress6 +ipv6CidrToString :: IP6.IpBlock v -> String +ipv6CidrToString = show -ipv4ToIpv6 :: IPv4 -> IPv6 -ipv4ToIpv6 = ipv4ToIPv6 +ipv6CidrToStringCollapseV4 :: IP6.IpBlock v -> String +ipv6CidrToStringCollapseV4 block = + let IP6.IpBlock ip (IP6.IpNetMask m) = block + in case isIpv4 ip of + Just d -> ipv4CidrToString $ IP4.IpBlock d (IP4.IpNetMask m) + Nothing -> ipv6CidrToString block + +word32ToIpv4 :: Word32 -> IP4.IpAddress +word32ToIpv4 = IP4.IpAddress + +word32x4ToIpv6 :: (Word32, Word32, Word32, Word32) -> IP6.IpAddress +word32x4ToIpv6 = IP6.IpAddress + +ipv4ToWord32 :: IP4.IpAddress -> Word32 +ipv4ToWord32 = IP4.word + +ipv6ToWord32x4 :: IP6.IpAddress -> (Word32, Word32, Word32, Word32) +ipv6ToWord32x4 (IP6.IpAddress w128) = w128 + +ipv4ToIpv6 :: IP4.IpAddress -> IP6.IpAddress +ipv4ToIpv6 = IP6.fromIpv4 diff --git a/src/Arbor/File/Format/Asif/Format/SegmentValue.hs b/src/Arbor/File/Format/Asif/Format/SegmentValue.hs --- a/src/Arbor/File/Format/Asif/Format/SegmentValue.hs +++ b/src/Arbor/File/Format/Asif/Format/SegmentValue.hs @@ -19,20 +19,24 @@ import qualified Data.ByteString.Lazy.Char8 as LBSC import Data.Generics.Product.Any import Data.Int -import Data.IP import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Thyme.Time.Core import Data.Word import GHC.Generics (Generic) +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6 +import HaskellWorks.Data.Network.Ip.Validity data SegmentValue = SString LBS.ByteString | SBool Bool | SChar Char | STime UTCTime - | SIpv4 IPv4 - | SIpv6 IPv6 + | SIpv4 IP4.IpAddress + | SIpv6 IP6.IpAddress + | SIpv4Block (IP4.IpBlock Canonical) + | SIpv6Block (IP6.IpBlock Canonical) | SInt64 Int64 | SInt32 Int32 | SInt16 Int16 @@ -57,6 +61,12 @@ d <- G.getWord32be return (a, b, c, d) +getWord40 :: G.Get (Word32, Word8) +getWord40 = (,) <$> G.getWord32le <*> G.getWord8 + +getWord136 :: G.Get ((Word32, Word32, Word32, Word32), Word8) +getWord136 = (,) <$> getWord32x4 <*> G.getWord8 + getValues :: Int64 -> G.Get a -> LBSC.ByteString -> [a] getValues n f bs = let getValue bs' = G.runGet f (LBS.take n (bs' <> LBS.replicate n 0)) @@ -90,6 +100,14 @@ F.Ipv6 -> whenNonEmpty bs $ bs & getValues 16 getWord32x4 <&> (SIpv6 . word32x4ToIpv6) + + F.Ipv4Block -> whenNonEmpty bs $ + let toIpBlock (w32,w8) = IP4.IpBlock (IP4.IpAddress w32) (IP4.IpNetMask w8) + in bs & getValues 5 getWord40 <&> (SIpv4Block . toIpBlock) + + F.Ipv6Block -> whenNonEmpty bs $ + let toIpBlock (w128,w8) = IP6.IpBlock (IP6.IpAddress w128) (IP6.IpNetMask w8) + in bs & getValues 17 getWord136 <&> (SIpv6Block . toIpBlock) F.Int64LE -> whenNonEmpty bs $ bs & getValues 8 G.getInt64le <&> SInt64 diff --git a/src/Arbor/File/Format/Asif/Format/Text.hs b/src/Arbor/File/Format/Asif/Format/Text.hs --- a/src/Arbor/File/Format/Asif/Format/Text.hs +++ b/src/Arbor/File/Format/Asif/Format/Text.hs @@ -24,10 +24,9 @@ STime v -> T.pack $ show v SIpv4 v -> T.pack $ ipv4ToString v - SIpv6 v -> - case ipv6ToWord32x4 v of - (a, b, c, d) | a == 0 && b == 0 && c == 0xFFFF -> d & word32ToIpv4 & ipv4ToString & T.pack - _ -> T.pack $ ipv6ToString v + SIpv6 v -> T.pack $ ipv6toStringCollapseV4 v + SIpv4Block v -> T.pack $ ipv4CidrToString v + SIpv6Block v -> T.pack $ ipv6CidrToStringCollapseV4 v SInt64 v -> T.pack $ show v SInt32 v -> T.pack $ show v @@ -48,7 +47,6 @@ SList vs -> vs <&> segmentValueToText & T.intercalate "," SUnknown _ v -> LBS.chunkBy 4 v <&> toHex & L.intersperse " " & mconcat - toHex :: LBS.ByteString -> Text toHex bs = diff --git a/src/Arbor/File/Format/Asif/Format/Type.hs b/src/Arbor/File/Format/Asif/Format/Type.hs --- a/src/Arbor/File/Format/Asif/Format/Type.hs +++ b/src/Arbor/File/Format/Asif/Format/Type.hs @@ -3,7 +3,7 @@ module Arbor.File.Format.Asif.Format.Type where -import GHC.Generics +import GHC.Generics data Format = Binary @@ -17,6 +17,8 @@ | Int64LE | Ipv4 | Ipv6 + | Ipv4Block + | Ipv6Block | Repeat Word Format | StringZ | Text diff --git a/src/Arbor/File/Format/Asif/Write.hs b/src/Arbor/File/Format/Asif/Write.hs --- a/src/Arbor/File/Format/Asif/Write.hs +++ b/src/Arbor/File/Format/Asif/Write.hs @@ -32,6 +32,8 @@ , int64Segment , ipv4Segment , ipv6Segment + , ipv4BlockSegment + , ipv6BlockSegment , utcTimeMicrosSegment -- * Utility functions @@ -56,18 +58,20 @@ import Data.Profunctor (lmap) import Data.Semigroup ((<>)) import Data.Word +import HaskellWorks.Data.Network.Ip.Validity (Canonical (..)) import System.IO (Handle, hFlush) import System.IO.Temp (openTempFile) -import qualified Arbor.File.Format.Asif.Format as F -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as LBS -import qualified Data.IP as IP -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TE +import qualified Arbor.File.Format.Asif.Format as F +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TE +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6 import qualified Data.Thyme.Clock.POSIX as TY import qualified Data.Thyme.Time.Core as TY @@ -206,18 +210,31 @@ ----- -- | Builds a segment of 'IPv4's. -ipv4Segment :: MonadResource m => (a -> IP.IPv4) -> T.Text -> FoldM m a [Segment Handle] +ipv4Segment :: MonadResource m => (a -> IP4.IpAddress) -> T.Text -> FoldM m a [Segment Handle] ipv4Segment f = genericFold BB.word32LE (Known F.Ipv4) (ipv4ToWord32 . f) -- | Builds a segment of 'IPv6's. -ipv6Segment :: MonadResource m => (a -> IP.IPv6) -> T.Text -> FoldM m a [Segment Handle] +ipv6Segment :: MonadResource m => (a -> IP6.IpAddress) -> T.Text -> FoldM m a [Segment Handle] ipv6Segment f = genericFold encoding (Known F.Ipv6) extract where -- I do not know why this is Big-Endian, when everything else is Little-Endian. encoding = Prelude.foldMap BB.word32BE extract = tupleToList . ipv6ToWord32x4 . f - tupleToList (w1,w2,w3,w4) = [w1,w2,w3,w4] +-- | Builds a segment of IPv4 CIDR blocks +ipv4BlockSegment :: MonadResource m => (a -> IP4.IpBlock Canonical) -> T.Text -> FoldM m a [Segment Handle] +ipv4BlockSegment = genericFold encoding (Known F.Ipv4Block) + where + encoding (IP4.IpBlock (IP4.IpAddress ip) (IP4.IpNetMask block)) = BB.word32LE ip <> BB.word8 block + +-- | Builds a segment of IPv6 CIDR blocks +ipv6BlockSegment :: MonadResource m => (a -> IP6.IpBlock Canonical) -> T.Text -> FoldM m a [Segment Handle] +ipv6BlockSegment = genericFold encoding (Known F.Ipv6Block) + where + encoding (IP6.IpBlock ip (IP6.IpNetMask block)) = + let extract = Prelude.foldMap BB.word32BE . tupleToList . ipv6ToWord32x4 + in extract ip <> BB.word8 block + ----- -- | Builds a segment of 'UTCTime's, accurate to microseconds. @@ -248,3 +265,10 @@ genericFold :: MonadResource m => (a -> BB.Builder) -> Whatever F.Format -> (b -> a) -> T.Text -> FoldM m b [Segment Handle] genericFold enc fmt f t = lmap f $ FoldM (genericStep enc) (genericInitial t) (genericExtract t fmt) + +------------------------------------------------------------------------------- + +-- Private + +tupleToList :: (a,a,a,a) -> [a] +tupleToList (w1,w2,w3,w4) = [w1,w2,w3,w4] diff --git a/test/Arbor/File/Format/Asif/WriteSpec.hs b/test/Arbor/File/Format/Asif/WriteSpec.hs --- a/test/Arbor/File/Format/Asif/WriteSpec.hs +++ b/test/Arbor/File/Format/Asif/WriteSpec.hs @@ -4,27 +4,29 @@ import Arbor.File.Format.Asif.Format import Arbor.File.Format.Asif.Segment import Arbor.File.Format.Asif.Write -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Resource import Data.Int -import Data.Semigroup ((<>)) +import Data.Semigroup ((<>)) import Data.Word -import System.IO.Temp (openBinaryTempFile) +import HaskellWorks.Data.Network.Ip.Validity (Canonical) +import System.IO.Temp (openBinaryTempFile) import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec -import qualified Data.Attoparsec.ByteString as AP -import qualified Data.ByteString.Lazy as LBS -import qualified Data.IP as IP -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.Encoding as T -import qualified Data.Thyme.Clock.POSIX as TY -import qualified Data.Thyme.Time.Core as TY -import qualified Hedgehog.Gen as G -import qualified Hedgehog.Range as R +import qualified Data.Attoparsec.ByteString as AP +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +import qualified Data.Thyme.Clock.POSIX as TY +import qualified Data.Thyme.Time.Core as TY +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6 +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R import qualified System.IO as IO @@ -169,7 +171,7 @@ ----- it "should write out and read back in a ipv4 segment" $ require $ property $ do - lst <- forAll $ G.list (R.linear 0 50) (word32ToIpv4 <$> G.word32 R.linearBounded) + lst <- forAll $ G.list (R.linear 0 50) genIpv4 lbs <- asifContent "wxyz" Nothing (ipv4Segment id "ipv4") lst @@ -188,6 +190,26 @@ (SIpv6 <$> lst) === seg + it "should write out and read back in a ipv4 block segment" $ require $ property $ do + lst <- forAll $ G.list (R.linear 0 50) genIpv4Block + + lbs <- asifContent "wxyz" Nothing (ipv4BlockSegment id "ipv4Block") lst + + let Right segments = extractSegments (AP.string "seg:wxyz") lbs + [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) + + (SIpv4Block <$> lst) === seg + + it "should write out and read back in a ipv6 block segment" $ require $ property $ do + lst <- forAll $ G.list (R.linear 0 50) genIpv6Block + + lbs <- asifContent "wxyz" Nothing (ipv6BlockSegment id "ipv6Block") lst + + let Right segments = extractSegments (AP.string "seg:wxyz") lbs + [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) + + (SIpv6Block <$> lst) === seg + ----- it "should write out and read back in a time segment" $ require $ property $ do @@ -240,13 +262,28 @@ <*> G.word16 R.linearBounded <*> genNonNullText -genIpv6 :: MonadGen m => m IP.IPv6 +genIpv4 :: MonadGen m => m IP4.IpAddress +genIpv4 = word32ToIpv4 <$> G.word32 R.linearBounded + +genIpv6 :: MonadGen m => m IP6.IpAddress genIpv6 = word32x4ToIpv6 <$> gen4 where gen4 :: MonadGen m => m (Word32, Word32, Word32, Word32) gen4 = let g = G.word32 R.linearBounded in (,,,) <$> g <*> g <*> g <*> g + +genIpv4Block :: MonadGen m => m (IP4.IpBlock Canonical) +genIpv4Block = do + ip <- genIpv4 + mask <- IP4.IpNetMask <$> G.word8 (R.linear 0 32) + pure . IP4.canonicaliseIpBlock $ IP4.IpBlock ip mask + +genIpv6Block :: MonadGen m => m (IP6.IpBlock Canonical) +genIpv6Block = do + ip <- genIpv6 + mask <- IP6.IpNetMask <$> G.word8 (R.linear 0 128) + pure . IP6.canonicaliseIpBlock $ IP6.IpBlock ip mask genNonNullText :: MonadGen m => m T.Text genNonNullText =