diff --git a/app/App/Dump.hs b/app/App/Dump.hs --- a/app/App/Dump.hs +++ b/app/App/Dump.hs @@ -9,27 +9,26 @@ ) where import Arbor.File.Format.Asif.Data.Ip +import Arbor.File.Format.Asif.Format.Decoder as D import Arbor.File.Format.Asif.Segment import Arbor.File.Format.Asif.Whatever import Control.Lens import Control.Monad -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (MonadResource) -import Data.Char (isPrint) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Resource (MonadResource) +import Data.Char (isPrint) import Data.Generics.Product.Any import Data.List -import Data.Monoid ((<>)) -import Data.Text (Text) -import Data.Thyme.Clock -import Data.Thyme.Clock.POSIX (POSIXTime) -import Data.Thyme.Format (formatTime) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Thyme.Format (formatTime) import Data.Thyme.Time.Core import Data.Word import HaskellWorks.Data.Bits.BitShow import HaskellWorks.Data.Bits.BitWise -import Numeric (showHex) -import System.IO (Handle) -import System.Locale (defaultTimeLocale, iso8601DateFormat) +import Numeric (showHex) +import System.IO (Handle) +import System.Locale (defaultTimeLocale, iso8601DateFormat) import qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS import qualified Arbor.File.Format.Asif.Format as F @@ -40,6 +39,8 @@ import qualified Data.ByteString.Lazy.Char8 as LBSC import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6 import qualified System.IO as IO {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} @@ -48,14 +49,6 @@ showTime :: FormatTime t => t -> String showTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S %Z")) -getWord32x4 :: G.Get (Word32, Word32, Word32, Word32) -getWord32x4 = do - a <- G.getWord32be - b <- G.getWord32be - c <- G.getWord32be - d <- G.getWord32be - return (a, b, c, d) - word64ToList :: Int -> Word64 -> [Word32] -> [Word32] word64ToList _ 0 = id word64ToList o w = (ip:) . word64ToList o (w .&. comp b) @@ -66,94 +59,133 @@ dumpSegment :: MonadResource m => Handle -> Int -> Text -> Segment LBS.ByteString -> m () dumpSegment hOut i filename segment = do - if T.null filename - then liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] ====" - else liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] " <> T.unpack filename <> " ====" + if T.null filename + then liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] ====" + else liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] " <> T.unpack filename <> " ====" - case segment ^. the @"meta" . the @"format" of - Just (Known F.StringZ) -> do - when (LBS.length (segment ^. the @"payload") > 0) $ - forM_ (init (LBS.split 0 (segment ^. the @"payload"))) $ \bs -> - liftIO $ IO.hPutStrLn hOut $ T.unpack (T.decodeUtf8 (LBS.toStrict bs)) - Just (Known (F.Repeat n F.Char)) -> - forM_ (LBS.chunkBy (fromIntegral n) (segment ^. the @"payload")) $ \bs -> - liftIO $ IO.hPutStrLn hOut $ T.unpack (T.decodeUtf8 (LBS.toStrict bs)) - Just (Known F.TimeMillis64LE) -> - forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0)) - let t :: POSIXTime = (w * 1000) ^. from microseconds - liftIO $ IO.hPutStrLn hOut $ showTime (posixSecondsToUTCTime t) <> " (" <> show w <> " ms)" - Just (Known F.TimeMicros64LE) -> - forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0)) - let t :: POSIXTime = w ^. from microseconds - liftIO $ IO.hPutStrLn hOut $ showTime (posixSecondsToUTCTime t) <> " (" <> show w <> " µs)" - Just (Known F.Ipv4) -> - forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getWord32le (LBS.take 8 (bs <> LBS.replicate 4 0)) - let ipString = w & word32ToIpv4 & ipv4ToString - liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (16 - length ipString) ' ' <> "(" <> show w <> ")" - Just (Known F.Ipv6) -> - forM_ (LBS.chunkBy 16 (segment ^. the @"payload")) $ \bs -> do - let (a, b, c, d) = G.runGet getWord32x4 (LBS.take 16 (bs <> LBS.replicate 16 0)) - if a == 0 && b == 0 && c == 0xFFFF - then do - let ipString = d & word32ToIpv4 & ipv4ToString - liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show d <> ")" - else do - let ipString = word32x4ToIpv6 (a, b, c, d) & ipv6ToString - liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show (a, b, c, d) <> ")" - Just (Known F.Int64LE) -> - forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Int32LE) -> - forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getInt32le (LBS.take 4 (bs <> LBS.replicate 4 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Int16LE) -> - forM_ (LBS.chunkBy 2 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getInt16le (LBS.take 2 (bs <> LBS.replicate 2 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Int8) -> - forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getInt8 (LBS.take 1 (bs <> LBS.replicate 1 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Word64LE) -> - forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getWord64le (LBS.take 8 (bs <> LBS.replicate 8 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Word32LE) -> - forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getWord32le (LBS.take 4 (bs <> LBS.replicate 4 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Word16LE) -> - forM_ (LBS.chunkBy 2 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getWord16le (LBS.take 2 (bs <> LBS.replicate 2 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Word8) -> - forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do - let w = G.runGet G.getWord8 (LBS.take 1 (bs <> LBS.replicate 1 0)) - liftIO $ IO.hPrint hOut w - Just (Known F.Text) -> - liftIO $ LBSC.hPutStrLn hOut (segment ^. the @"payload") - Just (Known F.BitString) -> - liftIO $ IO.hPutStrLn hOut (bitShow (segment ^. the @"payload")) - Just (Known F.Bitmap) -> - forM_ (zip [0..] (G.runGet G.getWord64le <$> LBS.chunkBy 8 (segment ^. the @"payload"))) $ \(idx, w64) -> - forM_ (word64ToList idx w64 []) $ \w32 -> do - let ipString = w32 & word32ToIpv4 & ipv4ToString - liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (16 - length ipString) ' ' <> "(" <> show w32 <> ")" - Just (Known F.Bool) -> - forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do - let w :: Bool = G.runGet G.get (LBS.take 1 (bs <> LBS.replicate 1 0)) - liftIO $ IO.hPrint hOut w - _ -> - forM_ (zip (LBS.chunkBy 16 (segment ^. the @"payload")) [0 :: Int, 16..]) $ \(bs, j) -> do - let bytes = mconcat (intersperse " " (reverse . take 2 . reverse . ('0':) . flip showHex "" <$> LBS.unpack bs)) - liftIO $ IO.hPutStr hOut $ reverse $ take 8 $ reverse $ ("0000000" ++) $ showHex j "" - liftIO $ IO.hPutStr hOut " " - liftIO $ IO.hPutStr hOut $ bytes <> replicate (47 - length bytes) ' ' - liftIO $ IO.hPutStr hOut " " - liftIO $ IO.hPutStr hOut $ (\c -> if isPrint c then c else '.') <$> LBSC.unpack bs - liftIO $ IO.hPutStrLn hOut "" + case segment ^. the @"meta" . the @"format" of + Just (Known F.StringZ) -> do + when (LBS.length (segment ^. the @"payload") > 0) $ + forM_ (init (LBS.split 0 (segment ^. the @"payload"))) $ \bs -> + liftIO $ IO.hPutStrLn hOut $ T.unpack (T.decodeUtf8 (LBS.toStrict bs)) + + Just (Known (F.Repeat n F.Char)) -> + forM_ (LBS.chunkBy (fromIntegral n) (segment ^. the @"payload")) $ \bs -> + liftIO $ IO.hPutStrLn hOut $ T.unpack (T.decodeUtf8 (LBS.toStrict bs)) + + Just (Known F.TimeMillis64LE) -> + forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do + let t = G.runGet D.getTimeMillis (LBS.take 8 (bs <> LBS.replicate 8 0)) + let ms = t & utcTimeToPOSIXSeconds & toMicroseconds & (`div` 1000) + liftIO $ IO.hPutStrLn hOut $ showTime t <> " (" <> show ms <> " ms)" + + Just (Known F.TimeMicros64LE) -> + forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do + let t = G.runGet D.getTimeMicros (LBS.take 8 (bs <> LBS.replicate 8 0)) + let micros = t & utcTimeToPOSIXSeconds & toMicroseconds + liftIO $ IO.hPutStrLn hOut $ showTime t <> " (" <> show micros <> " µs)" + + Just (Known F.Ipv4) -> + forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet D.getIpv4 (LBS.take 4 (bs <> LBS.replicate 4 0)) + let ipString = w & ipv4ToString + liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (16 - length ipString) ' ' <> "(" <> show w <> ")" + + Just (Known F.Ipv6) -> + forM_ (LBS.chunkBy 16 (segment ^. the @"payload")) $ \bs -> do + let ip6@(IP6.IpAddress (a,b,c,d)) = G.runGet D.getIpv6 (LBS.take 16 (bs <> LBS.replicate 16 0)) + let ipString = ipv6toStringCollapseV4 ip6 + let raw = case isIpv4 ip6 of + Just (IP4.IpAddress w32) -> "(" <> show w32 <> ")" + Nothing -> "(" <> show (a, b, c, d) <> ")" + liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> raw + + Just (Known F.Ipv4Block) -> + forM_ (LBS.chunkBy 5 (segment ^. the @"payload")) $ \bs -> do + let block@(IP4.IpBlock ip mask) = G.runGet D.getIpv4Block (LBS.take 5 (bs <> LBS.replicate 5 0)) + let IP4.IpAddress ipw = ip + let IP4.IpNetMask maskw = mask + let ipString = block & ipv4CidrToString + liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show (ipw, maskw) <> ")" + + Just (Known F.Ipv6Block) -> + forM_ (LBS.chunkBy 17 (segment ^. the @"payload")) $ \bs -> do + let block@(IP6.IpBlock ip mask) = G.runGet D.getIpv6Block (LBS.take 17 (bs <> LBS.replicate 17 0)) + let IP6.IpAddress ipw = ip + let IP6.IpNetMask maskw = mask + let ipString = block & ipv6CidrToStringCollapseV4 + liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show (ipw, maskw) <> ")" + + Just (Known F.Int64LE) -> + forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Int32LE) -> + forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getInt32le (LBS.take 4 (bs <> LBS.replicate 4 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Int16LE) -> + forM_ (LBS.chunkBy 2 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getInt16le (LBS.take 2 (bs <> LBS.replicate 2 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Int8) -> + forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getInt8 (LBS.take 1 (bs <> LBS.replicate 1 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Word64LE) -> + forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getWord64le (LBS.take 8 (bs <> LBS.replicate 8 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Word32LE) -> + forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getWord32le (LBS.take 4 (bs <> LBS.replicate 4 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Word16LE) -> + forM_ (LBS.chunkBy 2 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getWord16le (LBS.take 2 (bs <> LBS.replicate 2 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Word8) -> + forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do + let w = G.runGet G.getWord8 (LBS.take 1 (bs <> LBS.replicate 1 0)) + liftIO $ IO.hPrint hOut w + + Just (Known F.Text) -> + liftIO $ LBSC.hPutStrLn hOut (segment ^. the @"payload") + + Just (Known F.BitString) -> + liftIO $ IO.hPutStrLn hOut (bitShow (segment ^. the @"payload")) + + Just (Known F.Bitmap) -> + forM_ (zip [0..] (G.runGet G.getWord64le <$> LBS.chunkBy 8 (segment ^. the @"payload"))) $ \(idx, w64) -> + forM_ (word64ToList idx w64 []) $ \w32 -> do + let ipString = w32 & word32ToIpv4 & ipv4ToString + liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (16 - length ipString) ' ' <> "(" <> show w32 <> ")" + + Just (Known F.Bool) -> + forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do + let w :: Bool = G.runGet G.get (LBS.take 1 (bs <> LBS.replicate 1 0)) + liftIO $ IO.hPrint hOut w + + -- WARNING: Don't put a true catch-all (_ -> ...) case here + -- it means we miss this function when new formats get added. + Just (Known F.Binary) -> catchAll + Just (Known F.Char) -> catchAll + Just (Known (F.Repeat _ _)) -> catchAll + Just (Unknown _) -> catchAll + Nothing -> catchAll + where + catchAll = forM_ (zip (LBS.chunkBy 16 (segment ^. the @"payload")) [0 :: Int, 16..]) $ \(bs, j) -> do + let bytes = mconcat (intersperse " " (reverse . take 2 . reverse . ('0':) . flip showHex "" <$> LBS.unpack bs)) + liftIO $ IO.hPutStr hOut $ reverse $ take 8 $ reverse $ ("0000000" ++) $ showHex j "" + liftIO $ IO.hPutStr hOut " " + liftIO $ IO.hPutStr hOut $ bytes <> replicate (47 - length bytes) ' ' + liftIO $ IO.hPutStr hOut " " + liftIO $ IO.hPutStr hOut $ (\c -> if isPrint c then c else '.') <$> LBSC.unpack bs + liftIO $ IO.hPutStrLn hOut "" diff --git a/asif.cabal b/asif.cabal --- a/asif.cabal +++ b/asif.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.2 name: asif -version: 5.0.0 +version: 5.0.1 description: Library for creating and querying segmented feeds. Please see synopsis: Library for creating and querying segmented feeds category: Services @@ -11,7 +12,6 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 extra-source-files: ChangeLog.md README.md @@ -20,36 +20,9 @@ type: git location: https://github.com/packetloop/asif -library - exposed-modules: - Arbor.File.Format.Asif - Arbor.File.Format.Asif.ByIndex - Arbor.File.Format.Asif.ByteString - Arbor.File.Format.Asif.ByteString.Builder - Arbor.File.Format.Asif.ByteString.Lazy - Arbor.File.Format.Asif.Data.Ip - Arbor.File.Format.Asif.Data.Read - Arbor.File.Format.Asif.Extract - Arbor.File.Format.Asif.Format - Arbor.File.Format.Asif.Format.Text - Arbor.File.Format.Asif.Get - Arbor.File.Format.Asif.IO - Arbor.File.Format.Asif.Lookup - Arbor.File.Format.Asif.Segment - Arbor.File.Format.Asif.Type - Arbor.File.Format.Asif.Whatever - Arbor.File.Format.Asif.Write - other-modules: - Arbor.File.Format.Asif.Format.SegmentValue - Arbor.File.Format.Asif.Format.Type - Arbor.File.Format.Asif.List - Arbor.File.Format.Asif.Maybe - Arbor.File.Format.Asif.Text - Paths_asif - hs-source-dirs: - src - default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints +common common-deps + default-language: Haskell2010 + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -msse4.2 build-depends: attoparsec , base >=4.7 && <5 @@ -66,7 +39,6 @@ , generic-lens , hw-bits , hw-ip - , iproute , lens , network , old-locale @@ -77,107 +49,97 @@ , thyme , transformers , vector + + +library + import: common-deps + exposed-modules: + Arbor.File.Format.Asif + Arbor.File.Format.Asif.ByIndex + Arbor.File.Format.Asif.ByteString + Arbor.File.Format.Asif.ByteString.Builder + Arbor.File.Format.Asif.ByteString.Lazy + Arbor.File.Format.Asif.Data.Ip + Arbor.File.Format.Asif.Data.Read + Arbor.File.Format.Asif.Extract + Arbor.File.Format.Asif.Format + Arbor.File.Format.Asif.Format.Text + Arbor.File.Format.Asif.Get + Arbor.File.Format.Asif.IO + Arbor.File.Format.Asif.Lookup + Arbor.File.Format.Asif.Segment + Arbor.File.Format.Asif.Type + Arbor.File.Format.Asif.Whatever + Arbor.File.Format.Asif.Write + Arbor.File.Format.Asif.Format.Decoder + other-modules: + Arbor.File.Format.Asif.Format.SegmentValue + Arbor.File.Format.Asif.Format.Type + Arbor.File.Format.Asif.List + Arbor.File.Format.Asif.Maybe + Arbor.File.Format.Asif.Text + Paths_asif + autogen-modules: + Paths_asif + hs-source-dirs: + src + default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints default-language: Haskell2010 executable asif + import: common-deps main-is: Main.hs other-modules: - App.Commands - App.Commands.Dump - App.Commands.DumpBitmap - App.Commands.DumpOnly - App.Commands.EncodeFiles - App.Commands.ExtractFiles - App.Commands.ExtractSegments - App.Commands.Ls - App.Commands.Options.Type - App.Dump - App.IO - Paths_asif + App.Commands + App.Commands.Dump + App.Commands.DumpBitmap + App.Commands.DumpOnly + App.Commands.EncodeFiles + App.Commands.ExtractFiles + App.Commands.ExtractSegments + App.Commands.Ls + App.Commands.Options.Type + App.Dump + App.IO + Paths_asif + autogen-modules: + Paths_asif hs-source-dirs: - app + app default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -O2 -msse4.2 build-depends: asif - , attoparsec - , base >=4.7 && <5 - , binary - , bytestring - , conduit - , conduit-combinators - , conduit-extra - , containers - , cpu , directory - , either - , exceptions - , foldl - , generic-lens - , hw-bits - , hw-ip - , iproute - , lens - , network - , old-locale , optparse-applicative - , profunctors - , resourcet - , temporary-resourcet - , text - , thyme - , transformers - , vector default-language: Haskell2010 test-suite asif-test + import: common-deps type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Arbor.File.Format.Asif.ByteString.BuilderSpec - Arbor.File.Format.Asif.Data.IpSpec - Arbor.File.Format.Asif.ExtractSpec - Arbor.File.Format.Asif.Format.SegmentValueSpec - Arbor.File.Format.Asif.Format.TextSpec - Arbor.File.Format.Asif.WriteSpec - Arbor.File.Format.AsifSpec - Arbor.TestUtils - Gen.Feed - TestApp - Paths_asif + Arbor.File.Format.Asif.ByteString.BuilderSpec + Arbor.File.Format.Asif.Data.IpSpec + Arbor.File.Format.Asif.ExtractSpec + Arbor.File.Format.Asif.Format.SegmentValueSpec + Arbor.File.Format.Asif.Format.TextSpec + Arbor.File.Format.Asif.WriteSpec + Arbor.File.Format.AsifSpec + Arbor.TestUtils + Gen.Feed + TestApp + Paths_asif + autogen-modules: + Paths_asif hs-source-dirs: - test + test default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: asif - , attoparsec - , base >=4.7 && <5 - , binary - , bytestring - , conduit - , conduit-combinators - , conduit-extra - , containers - , cpu - , either - , exceptions - , foldl - , generic-lens , hedgehog , hspec - , hw-bits , hw-hspec-hedgehog - , hw-ip - , iproute - , lens - , network - , old-locale - , profunctors - , resourcet - , temporary-resourcet - , text - , thyme - , transformers - , vector default-language: Haskell2010 diff --git a/src/Arbor/File/Format/Asif/Format/Decoder.hs b/src/Arbor/File/Format/Asif/Format/Decoder.hs new file mode 100644 --- /dev/null +++ b/src/Arbor/File/Format/Asif/Format/Decoder.hs @@ -0,0 +1,48 @@ +module Arbor.File.Format.Asif.Format.Decoder where + +import Arbor.File.Format.Asif.Data.Ip +import Control.Lens +import Data.Thyme.Time.Core +import Data.Word (Word32) +import HaskellWorks.Data.Network.Ip.Validity (Canonical) + +import qualified Data.Binary.Get as G +import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4 +import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6 + +getWord32x4 :: G.Get (Word32, Word32, Word32, Word32) +getWord32x4 = do + a <- G.getWord32be + b <- G.getWord32be + c <- G.getWord32be + d <- G.getWord32be + return (a, b, c, d) + +getBool :: G.Get Bool +getBool = G.getWord8 <&> (/= 0) + +getIpv4 :: G.Get IP4.IpAddress +getIpv4 = G.getWord32le <&> word32ToIpv4 + +getIpv6 :: G.Get IP6.IpAddress +getIpv6 = getWord32x4 <&> word32x4ToIpv6 + +getIpv4Block :: G.Get (IP4.IpBlock Canonical) +getIpv4Block = + let toIpBlock w32 w8 = IP4.IpBlock (IP4.IpAddress w32) (IP4.IpNetMask w8) + in toIpBlock <$> G.getWord32le <*> G.getWord8 + +getIpv6Block :: G.Get (IP6.IpBlock Canonical) +getIpv6Block = + let toIpBlock w128 w8 = IP6.IpBlock (IP6.IpAddress w128) (IP6.IpNetMask w8) + in toIpBlock <$> getWord32x4 <*> G.getWord8 + +getTimeMillis :: G.Get UTCTime +getTimeMillis = + let toTime ms = (ms * 1000) ^. from microseconds & posixSecondsToUTCTime + in G.getInt64le <&> toTime + +getTimeMicros :: G.Get UTCTime +getTimeMicros = + let toTime ms = ms ^. from microseconds & posixSecondsToUTCTime + in G.getInt64le <&> toTime 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 @@ -7,7 +7,7 @@ where import qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS -import Arbor.File.Format.Asif.Data.Ip +import Arbor.File.Format.Asif.Format.Decoder as D import qualified Arbor.File.Format.Asif.Format.Type as F import Arbor.File.Format.Asif.List as L import Arbor.File.Format.Asif.Segment @@ -53,20 +53,6 @@ | SUnknown T.Text LBS.ByteString deriving (Show, Eq, Generic) -getWord32x4 :: G.Get (Word32, Word32, Word32, Word32) -getWord32x4 = do - a <- G.getWord32be - b <- G.getWord32be - c <- G.getWord32be - 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)) @@ -81,33 +67,28 @@ else init (LBS.split 0 bs) <&> SString F.Bool -> whenNonEmpty bs $ - let toBool = (/=) 0 - in bs & getValues 1 G.getWord8 <&> (SBool . toBool) + bs & getValues 1 D.getBool <&> SBool F.Char -> whenNonEmpty bs $ LBSC.unpack bs <&> SChar F.TimeMillis64LE -> whenNonEmpty bs $ - let toTime ms = (ms * 1000) ^. from microseconds & posixSecondsToUTCTime - in bs & getValues 8 G.getInt64le <&> (STime . toTime) + bs & getValues 8 D.getTimeMillis <&> STime F.TimeMicros64LE -> whenNonEmpty bs $ - let toTime ms = ms ^. from microseconds & posixSecondsToUTCTime - in bs & getValues 8 G.getInt64le <&> (STime . toTime) + bs & getValues 8 D.getTimeMicros <&> STime F.Ipv4 -> whenNonEmpty bs $ - bs & getValues 4 G.getWord32le <&> (SIpv4 . word32ToIpv4) + bs & getValues 4 D.getIpv4 <&> SIpv4 F.Ipv6 -> whenNonEmpty bs $ - bs & getValues 16 getWord32x4 <&> (SIpv6 . word32x4ToIpv6) + bs & getValues 16 D.getIpv6 <&> SIpv6 F.Ipv4Block -> whenNonEmpty bs $ - let toIpBlock (w32,w8) = IP4.IpBlock (IP4.IpAddress w32) (IP4.IpNetMask w8) - in bs & getValues 5 getWord40 <&> (SIpv4Block . toIpBlock) + bs & getValues 5 D.getIpv4Block <&> SIpv4Block F.Ipv6Block -> whenNonEmpty bs $ - let toIpBlock (w128,w8) = IP6.IpBlock (IP6.IpAddress w128) (IP6.IpNetMask w8) - in bs & getValues 17 getWord136 <&> (SIpv6Block . toIpBlock) + bs & getValues 17 D.getIpv6Block <&> SIpv6Block F.Int64LE -> whenNonEmpty bs $ bs & getValues 8 G.getInt64le <&> SInt64 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 @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} - - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module: Arbor.File.Format.Asif.Write -- @@ -19,6 +19,7 @@ -- $segments , lazyByteStringSegment , nullTerminatedStringSegment + , fixedLengthAsciiSegment , textSegment , asciiSegment , boolSegment @@ -36,6 +37,12 @@ , ipv6BlockSegment , utcTimeMicrosSegment + -- * Lookup segments + , lookupSegment + , word16LookupSegment + , word32LookupSegment + , word64LookupSegment + -- * Utility functions -- $helper , genericInitial @@ -72,6 +79,8 @@ 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.Map.Strict as Map +import qualified Data.Foldable as Foldable import qualified Data.Thyme.Clock.POSIX as TY import qualified Data.Thyme.Time.Core as TY @@ -131,7 +140,6 @@ segments <- lift $ foldM fld foldable segmentsC asifType mTimestamp segments ----- -- $segments -- -- Use these to build 'FoldM's for the types you want to encode. @@ -164,6 +172,12 @@ asciiSegment :: MonadResource m => (a -> Char) -> T.Text -> FoldM m a [Segment Handle] asciiSegment = genericFold BB.char8 (Known F.Char) +fixedLengthAsciiSegment :: MonadResource m => (a -> T.Text) -> T.Text -> Word -> FoldM m a [Segment Handle] +fixedLengthAsciiSegment f name len = + genericFold (Foldable.foldMap BB.char8 . T.unpack) (Known (F.Repeat len F.Char)) (ensureLength . f) name + where + ensureLength = T.take (fromIntegral len) . T.justifyLeft 2 ' ' + ----- -- | Build a segment of 'Bool's, encoded as 'Word8's, where False == 0, and True == 1 @@ -243,6 +257,82 @@ where fromTime :: TY.UTCTime -> Int64 fromTime = view (TY.posixTime . TY.microseconds) + +-- | Creates a lookup segment where index keys are 'Word16' +-- Missing values are represented by 'maxBound :: Word16' +-- +-- @ +-- word16LookupSegment name f = lookupSegment name f (Known F.Word16LE) BB.word16LE +-- @ +word16LookupSegment :: (MonadResource m, Ord b) + => T.Text + -> (a -> Maybe b) + -> FoldM m b [Segment Handle] + -> FoldM m a [Segment Handle] +word16LookupSegment name f = lookupSegment name f (Known F.Word16LE) BB.word16LE + +-- | Creates a lookup segment where index keys are 'Word32' +-- Missing values are represented by 'maxBound :: Word32' +-- +-- @ +-- word32LookupSegment name f = lookupSegment name f (Known F.Word32LE) BB.word32LE +-- @ +word32LookupSegment :: (MonadResource m, Ord b) + => T.Text + -> (a -> Maybe b) + -> FoldM m b [Segment Handle] + -> FoldM m a [Segment Handle] +word32LookupSegment name f = lookupSegment name f (Known F.Word32LE) BB.word32LE + +-- | Creates a lookup segment where index keys are 'Word64' +-- Missing values are represented by 'maxBound :: Word64' +-- +-- @ +-- word64LookupSegment name f = lookupSegment name f (Known F.Word64LE) BB.word64LE +-- @ +word64LookupSegment :: (MonadResource m, Ord b) + => T.Text + -> (a -> Maybe b) + -> FoldM m b [Segment Handle] + -> FoldM m a [Segment Handle] +word64LookupSegment name f = lookupSegment name f (Known F.Word64LE) BB.word64LE + +-- | Creates a lookup segment for every input into a value in an "inner" dictionary segment. +-- Missing values are represented as 'maxBound' for the key type. +lookupSegment :: (MonadResource m, Ord b, Eq i, Num i, Bounded i) + => T.Text -- ^ Lookup segment name + -> (a -> Maybe b) -- ^ Extract "dictionary" value + -> Whatever F.Format -- ^ Format of lookup segment + -> (i -> BB.Builder) -- ^ Write a lookup value + -> FoldM m b [Segment Handle] -- ^ A fold that represents a dictionary segment + -> FoldM m a [Segment Handle] +lookupSegment name f fmt enc (FoldM rstep rinit rextract) = + FoldM lstep linit lextract + where + linit = do + (_, _, h) <- openTempFile Nothing (T.unpack name) + rx <- rinit + pure (h, Map.empty, 0, rx) + + lstep (h, m, c, rx) a = + case f a of + Nothing -> do + liftIO $ BB.hPutBuilder h $ enc maxBound + pure (h, m, c, rx) + Just b -> do + let (v, c', m') = updateMap b c m + liftIO $ BB.hPutBuilder h $ enc v + -- only push value to the dictionary fold if the map has been updated + -- so that the dictionary segment would only have unique values + rx' <- if c' == c then pure rx else rstep rx b + pure (h, m', c', rx') + + lextract (h, _, _, rx) = do + rres <- rextract rx + pure $ [ segment h $ metaFilename name <> metaFormat fmt] <> rres + + updateMap k c m = + maybe (c, c+1, Map.insert k c m) (, c, m) (Map.lookup k m) ------------------------------------------------------------------------------- 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,10 +4,13 @@ import Arbor.File.Format.Asif.Format import Arbor.File.Format.Asif.Segment import Arbor.File.Format.Asif.Write +import Control.Lens import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Resource import Data.Int +import Data.List (elemIndex, nub) +import Data.Maybe (catMaybes, fromMaybe) import Data.Semigroup ((<>)) import Data.Word import HaskellWorks.Data.Network.Ip.Validity (Canonical) @@ -30,7 +33,9 @@ import qualified System.IO as IO +import Debug.Trace + {-# ANN module ("HLint: ignore Redundant do" :: String) #-} spec :: Spec @@ -253,6 +258,33 @@ [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) [SText . T.encodeUtf8 . T.concat $ T.fromStrict <$> lst] === seg + + it "should write and read back a lookup segment" $ require $ property $ do + let pairGen = (,) <$> genIpv4 <*> G.maybe (G.element ["US", "KZ", "AU"]) + pairs <- forAll $ G.list (R.linear 1 100) pairGen + + let countriesFold = nullTerminatedStringSegment id "countries" + let countriesLookup = word16LookupSegment "ip-to-countries" snd countriesFold + + let resFold = ipv4Segment fst "ip" <> countriesLookup + + content <- asifContent "ipct" Nothing resFold pairs + + let Right segments = extractSegments (AP.string "seg:ipct") content + + [names, times, types, ips, lkp, dict] <- forAll $ pure (segmentValues <$> segments) + + let expectedVals = pairs ^.. each . _2 . _Just & nub + let expectedLkpVals = pairs ^.. each . _2 . to (\x -> x >>= flip elemIndex expectedVals) . to (fromMaybe maxBound) + + expectedDict <- forAll . pure $ + expectedVals <&> (SString . T.encodeUtf8 . T.fromStrict) + + expectedLkp <- forAll . pure $ + expectedLkpVals <&> (SWord16 . fromIntegral) + + dict === expectedDict + lkp === expectedLkp genTriple :: MonadGen m => m (Int64, Word16, T.Text)