asif 5.0.0 → 5.0.1

raw patch · 6 files changed

+394/−249 lines, 6 filesdep −iproutePVP ok

version bump matches the API change (PVP)

Dependencies removed: iproute

API changes (from Hackage documentation)

Files

• app/App/Dump.hs +141/−109
• asif.cabal +72/−110
• src/Arbor/File/Format/Asif/Format/Decoder.hs +48/−0
• src/Arbor/File/Format/Asif/Format/SegmentValue.hs +8/−27
• src/Arbor/File/Format/Asif/Write.hs +93/−3
• test/Arbor/File/Format/Asif/WriteSpec.hs +32/−0

@@ -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 ""

@@ -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 <https://github.com/packetloop/asif#readme> 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

@@ -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

@@ -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

@@ -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)  ------------------------------------------------------------------------------- 

@@ -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)