asif 3.1.0 → 3.2.0

raw patch · 23 files changed

+1072/−204 lines, 23 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• app/App/Commands.hs +13/−7
• app/App/Commands/Dump.hs +30/−120
• app/App/Commands/DumpBitmap.hs +58/−0
• app/App/Commands/DumpOnly.hs +87/−0
• app/App/Commands/EncodeFiles.hs +1/−1
• app/App/Commands/ExtractFiles.hs +1/−1
• app/App/Commands/ExtractSegments.hs +1/−1
• app/App/Commands/Ls.hs +96/−0
• app/App/Commands/Options/Type.hs +19/−0
• app/App/Dump.hs +155/−0
• asif.cabal +12/−1
• src/Arbor/File/Format/Asif/ByteString/Builder.hs +25/−25
• src/Arbor/File/Format/Asif/Extract.hs +14/−14
• src/Arbor/File/Format/Asif/Format.hs +13/−23
• src/Arbor/File/Format/Asif/Format/SegmentValue.hs +150/−0
• src/Arbor/File/Format/Asif/Format/Text.hs +54/−0
• src/Arbor/File/Format/Asif/Format/Type.hs +28/−0
• src/Arbor/File/Format/Asif/List.hs +6/−0
• src/Arbor/File/Format/Asif/Segment.hs +13/−4
• src/Arbor/File/Format/Asif/Type.hs +7/−7
• test/Arbor/File/Format/Asif/Format/SegmentValueSpec.hs +141/−0
• test/Arbor/File/Format/Asif/Format/TextSpec.hs +140/−0
• test/Arbor/TestUtils.hs +8/−0

@@ -2,17 +2,23 @@   ( globalOptions   ) where -import App.Commands.Dump-import App.Commands.EncodeFiles-import App.Commands.ExtractFiles-import App.Commands.ExtractSegments-import Data.Monoid                  ((<>))-import Options.Applicative+import           App.Commands.Dump+import           App.Commands.DumpBitmap+import           App.Commands.DumpOnly+import           App.Commands.EncodeFiles+import           App.Commands.ExtractFiles+import           App.Commands.ExtractSegments+import           App.Commands.Ls+import           Data.Monoid                  ((<>))+import           Options.Applicative  globalOptions :: Parser (IO ())-globalOptions = subparser+globalOptions = hsubparser   (   command "dump"                (info commandDump               idm)+  <>  command "dump-only"           (info commandDumpOnly           idm)+  <>  command "dump-bitmap"         (info commandDumpBitmap         idm)   <>  command "encode-files"        (info commandEncodeFiles        idm)   <>  command "extract-files"       (info commandExtractFiles       idm)   <>  command "extract-segments"    (info commandExtractSegments    idm)+  <>  command "ls"                  (info commandLs                 idm)   )

@@ -5,41 +5,26 @@  module App.Commands.Dump where -import App.Commands.Options.Type-import Arbor.File.Format.Asif.Data.Ip+import App.Commands.Options.Type      (DumpOptions (DumpOptions))+import App.Dump import Arbor.File.Format.Asif.IO 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, runResourceT)-import Data.Char                       (isPrint)+import Control.Monad.IO.Class         (liftIO)+import Control.Monad.Trans.Resource   (MonadResource, runResourceT) import Data.Generics.Product.Any-import Data.List import Data.Maybe-import Data.Monoid                     ((<>))-import Data.Thyme.Clock-import Data.Thyme.Clock.POSIX          (POSIXTime)-import Data.Thyme.Format               (formatTime)-import Data.Thyme.Time.Core-import Data.Word-import HaskellWorks.Data.Bits.BitShow-import Numeric                         (showHex)+import Data.Monoid                    ((<>))+import Data.Text                      (Text) import Options.Applicative-import System.Locale                   (defaultTimeLocale, iso8601DateFormat) -import qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS-import qualified Arbor.File.Format.Asif.Format          as F-import qualified Data.Attoparsec.ByteString             as AP-import qualified Data.Binary                            as G-import qualified Data.Binary.Get                        as G-import qualified Data.ByteString                        as BS-import qualified Data.ByteString.Lazy                   as LBS-import qualified Data.ByteString.Lazy.Char8             as LBSC-import qualified Data.Text                              as T-import qualified Data.Text.Encoding                     as T-import qualified System.IO                              as IO+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Lazy       as LBS+import qualified Data.Set                   as S+import qualified Data.Text                  as T+import qualified System.IO                  as IO  {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} {-# ANN module ("HLint: ignore Redundant do"        :: String) #-}@@ -58,25 +43,30 @@       <>  value "-"       <>  help "Output file"       )+  <*> many+      ( option auto+        (   long "without-segment"+        <>  metavar "SEGMENT_ID"+        <>  help "Output file"+        )+      )+  <*> many+      ( strOption+        (   long "without-filename"+        <>  metavar "FILE"+        <>  help "Output file"+        )+      )  commandDump :: Parser (IO ()) commandDump = runResourceT . runDump <$> parseDumpOptions -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)- runDump :: MonadResource m => DumpOptions -> m () runDump opt = do   (_, hIn)  <- openFileOrStd (opt ^. the @"source") IO.ReadMode   (_, hOut) <- openFileOrStd (opt ^. the @"target") IO.WriteMode+  let dumpWithoutSegments  = opt ^. the @"withoutSegments"             & S.fromList :: S.Set Int+  let dumpWithoutFilenames = opt ^. the @"withoutFilenames" <&> T.pack & S.fromList :: S.Set Text    contents <- liftIO $ LBS.hGetContents hIn @@ -89,87 +79,7 @@       let namedSegments = zip filenames segments        forM_ (zip [0..] namedSegments) $ \(i :: Int, (filename, segment)) -> do-        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"))-          _ ->-            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 ""+        unless (S.member filename dumpWithoutFilenames || S.member i dumpWithoutSegments) $ do+          dumpSegment hOut i filename segment    where magic = AP.string "seg:" *> (BS.pack <$> many AP.anyWord8) AP.<?> "\"seg:????\""

@@ -0,0 +1,58 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.DumpBitmap+  ( commandDumpBitmap+  ) where++import App.Commands.Options.Type+import App.Dump+import Arbor.File.Format.Asif.Data.Ip+import Arbor.File.Format.Asif.IO+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class         (liftIO)+import Control.Monad.Trans.Resource   (MonadResource, runResourceT)+import Data.Generics.Product.Any+import Data.Monoid                    ((<>))+import Options.Applicative++import qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS+import qualified Data.Binary.Get                        as G+import qualified Data.ByteString.Lazy                   as LBS+import qualified System.IO                              as IO++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++parseDumpBitmapOptions :: Parser DumpBitmapOptions+parseDumpBitmapOptions = DumpBitmapOptions+  <$> strOption+      (   long "source"+      <>  metavar "FILE"+      <>  value "-"+      <>  help "Input file"+      )+  <*> strOption+      (   long "target"+      <>  metavar "FILE"+      <>  value "-"+      <>  help "Output file"+      )++commandDumpBitmap :: Parser (IO ())+commandDumpBitmap = runResourceT . runDump <$> parseDumpBitmapOptions++runDump :: MonadResource m => DumpBitmapOptions -> m ()+runDump opt = do+  (_, hIn)  <- openFileOrStd (opt ^. the @"source") IO.ReadMode+  (_, hOut) <- openFileOrStd (opt ^. the @"target") IO.WriteMode++  contents <- liftIO $ LBS.hGetContents hIn++  forM_ (zip [0..] (G.runGet G.getWord64le <$> LBS.chunkBy 8 contents)) $ \(idx, w64) ->+    forM_ (word64ToList idx w64 []) $ \w32 -> do+      let ipString = w32 & word32ToIpv4 & ipv4ToString+      liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (16 - length ipString) ' ' <> "(" <> show w32 <> ")"

@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.DumpOnly+  ( commandDumpOnly+  ) where++import App.Commands.Options.Type      (DumpOnlyOptions (DumpOnlyOptions))+import App.Dump+import Arbor.File.Format.Asif.IO+import Arbor.File.Format.Asif.Segment+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class         (liftIO)+import Control.Monad.Trans.Resource   (MonadResource, runResourceT)+import Data.Generics.Product.Any+import Data.Maybe+import Data.Monoid                    ((<>))+import Data.Text                      (Text)+import Options.Applicative++import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Lazy       as LBS+import qualified Data.Set                   as S+import qualified Data.Text                  as T+import qualified System.IO                  as IO++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++parseDumpOnlyOptions :: Parser DumpOnlyOptions+parseDumpOnlyOptions = DumpOnlyOptions+  <$> strOption+      (   long "source"+      <>  metavar "FILE"+      <>  value "-"+      <>  help "Input file"+      )+  <*> strOption+      (   long "target"+      <>  metavar "FILE"+      <>  value "-"+      <>  help "Output file"+      )+  <*> many+      ( option auto+        (   long "segment"+        <>  metavar "SEGMENT_ID"+        <>  help "Output file"+        )+      )+  <*> many+      ( strOption+        (   long "filename"+        <>  metavar "FILE"+        <>  help "Output file"+        )+      )++commandDumpOnly :: Parser (IO ())+commandDumpOnly = runResourceT . runDump <$> parseDumpOnlyOptions++runDump :: MonadResource m => DumpOnlyOptions -> m ()+runDump opt = do+  (_, hIn)  <- openFileOrStd (opt ^. the @"source") IO.ReadMode+  (_, hOut) <- openFileOrStd (opt ^. the @"target") IO.WriteMode+  let dumpSegments  = opt ^. the @"segments"             & S.fromList :: S.Set Int+  let dumpFilenames = opt ^. the @"filenames" <&> T.pack & S.fromList :: S.Set Text++  contents <- liftIO $ LBS.hGetContents hIn++  case extractSegments magic contents of+    Left errorMessage -> do+      liftIO $ IO.hPutStrLn IO.stderr $ "Error occured: " <> errorMessage+      return ()+    Right segments -> do+      let filenames = fromMaybe "" . (^. the @"meta" . the @"filename") <$> segments+      let namedSegments = zip filenames segments++      forM_ (zip [0..] namedSegments) $ \(i :: Int, (filename, segment)) -> do+        when (S.member filename dumpFilenames || S.member i dumpSegments) $ do+          dumpSegment hOut i filename segment++  where magic = AP.string "seg:" *> (BS.pack <$> many AP.anyWord8) AP.<?> "\"seg:????\""

@@ -4,7 +4,7 @@  module App.Commands.EncodeFiles where -import App.Commands.Options.Type+import App.Commands.Options.Type                 (EncodeFilesOptions (EncodeFilesOptions)) import Arbor.File.Format.Asif.ByteString.Builder import Arbor.File.Format.Asif.IO import Conduit

@@ -4,7 +4,7 @@  module App.Commands.ExtractFiles where -import App.Commands.Options.Type+import App.Commands.Options.Type      (ExtractFilesOptions (ExtractFilesOptions)) import Arbor.File.Format.Asif.IO import Arbor.File.Format.Asif.Segment import Control.Lens

@@ -4,7 +4,7 @@  module App.Commands.ExtractSegments where -import App.Commands.Options.Type+import App.Commands.Options.Type      (ExtractSegmentsOptions (ExtractSegmentsOptions)) import Arbor.File.Format.Asif.IO import Arbor.File.Format.Asif.Segment import Control.Lens

@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.Ls+  ( commandLs+  ) where++import App.Commands.Options.Type      (LsOptions (LsOptions))+import Arbor.File.Format.Asif.IO+import Arbor.File.Format.Asif.Segment hiding (meta)+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class         (liftIO)+import Control.Monad.Trans.Resource   (MonadResource, runResourceT)+import Data.Generics.Product.Any+import Data.Maybe+import Data.Monoid                    ((<>))+import Data.Thyme.Clock.POSIX         (POSIXTime)+import Data.Thyme.Time.Core+import Options.Applicative++import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Lazy       as LBS+import qualified Data.Text                  as T+import qualified System.IO                  as IO++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++parseLsOptions :: Parser LsOptions+parseLsOptions = LsOptions+  <$> strOption+      (   long "source"+      <>  metavar "FILE"+      <>  value "-"+      <>  help "Input file"+      )+  <*> strOption+      (   long "target"+      <>  metavar "FILE"+      <>  value "-"+      <>  help "Output file"+      )++commandLs :: Parser (IO ())+commandLs = runResourceT . runDump <$> parseLsOptions++runDump :: MonadResource m => LsOptions -> m ()+runDump opt = do+  (_, hIn)  <- openFileOrStd (opt ^. the @"source") IO.ReadMode+  (_, hOut) <- openFileOrStd (opt ^. the @"target") IO.WriteMode++  contents <- liftIO $ LBS.hGetContents hIn++  case extractSegments magic contents of+    Left errorMessage -> do+      liftIO $ IO.hPutStrLn IO.stderr $ "Error occured: " <> errorMessage+      return ()+    Right segments -> do+      let filenames = fromMaybe "" . (^. the @"meta" . the @"filename") <$> segments+      let namedSegments = zip filenames segments++      forM_ (zip [0..] namedSegments) $ \(i :: Int, (filename, segment)) -> do+        let meta = segment ^. the @"meta"++        liftIO $ IO.hPutStrLn hOut $ mempty+          <> (show i & trimPadLeft 4)+          <> " " <> (meta     ^. the @"createTime" <&> showPosixSeconds & fromMaybe ""  & trimPadLeft   19)+          <> " " <> (meta     ^. the @"format"     <&> show             & fromMaybe ""  & trimPadRight  20)+          <> " " <> (segment  ^. the @"payload"    &   showLbsLength                    & trimPadLeft   12)+          <> " " <> T.unpack filename++  where magic = AP.string "seg:" *> (BS.pack <$> many AP.anyWord8) AP.<?> "\"seg:????\""++showLbsLength :: LBS.ByteString -> String+showLbsLength = show . LBS.length++showPosixSeconds :: POSIXTime -> String+showPosixSeconds t = take 19 (show (posixSecondsToUTCTime t))++trimPadLeft :: Int -> String -> String+trimPadLeft n s+  | len < n   = replicate (n - len) ' ' <> s+  | len == n  = s+  | otherwise = '<':reverse (take (n - 1) (reverse s))+  where len = length s++trimPadRight :: Int -> String -> String+trimPadRight n s+  | len < n   = s <> replicate (n - len) ' '+  | len == n  = s+  | otherwise = take (n - 1) s <> ">"+  where len = length s

@@ -22,6 +22,25 @@   } deriving (Eq, Show, Generic)  data DumpOptions = DumpOptions+  { source           :: FilePath+  , target           :: FilePath+  , withoutSegments  :: [Int]+  , withoutFilenames :: [FilePath]+  } deriving (Eq, Show, Generic)++data DumpOnlyOptions = DumpOnlyOptions+  { source    :: FilePath+  , target    :: FilePath+  , segments  :: [Int]+  , filenames :: [FilePath]+  } deriving (Eq, Show, Generic)++data DumpBitmapOptions = DumpBitmapOptions+  { source :: FilePath+  , target :: FilePath+  } deriving (Eq, Show, Generic)++data LsOptions = LsOptions   { source :: FilePath   , target :: FilePath   } deriving (Eq, Show, Generic)

@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Dump+  ( dumpSegment+  , word64ToList+  ) where++import Arbor.File.Format.Asif.Data.Ip+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 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.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 qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS+import qualified Arbor.File.Format.Asif.Format          as F+import qualified Data.Binary                            as G+import qualified Data.Binary.Get                        as G+import qualified Data.Bits                              as B+import qualified Data.ByteString.Lazy                   as LBS+import qualified Data.ByteString.Lazy.Char8             as LBSC+import qualified Data.Text                              as T+import qualified Data.Text.Encoding                     as T+import qualified System.IO                              as IO++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++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)+  where p  = B.countTrailingZeros w+        hi = o .<. 6+        ip = fromIntegral (p .|. hi)+        b  = 1 .<. fromIntegral p++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 <> " ===="++        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 <> ")"+          _ ->+            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 ""

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           asif-version:        3.1.0+version:        3.2.0 description:    Please see the README on Github at <https://github.com/packetloop/asif#readme> category:       Services homepage:       https://github.com/packetloop/asif#readme@@ -63,6 +63,7 @@       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@@ -70,6 +71,9 @@       Arbor.File.Format.Asif.Type       Arbor.File.Format.Asif.Whatever   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@@ -111,10 +115,14 @@   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   default-language: Haskell2010 @@ -156,7 +164,10 @@   other-modules:       Arbor.File.Format.Asif.ByteString.BuilderSpec       Arbor.File.Format.Asif.Data.IpSpec+      Arbor.File.Format.Asif.Format.SegmentValueSpec+      Arbor.File.Format.Asif.Format.TextSpec       Arbor.File.Format.AsifSpec+      Arbor.TestUtils       Gen.Feed       TestApp   default-language: Haskell2010

@@ -10,32 +10,32 @@   , magicLength   ) where -import Arbor.File.Format.Asif.Whatever-import Conduit-import Control.Lens-import Control.Monad-import Data.Bits-import Data.ByteString.Builder-import Data.Generics.Product.Any-import Data.Int-import Data.Maybe-import Data.Monoid                     ((<>))-import Data.String-import Data.Thyme.Clock-import Data.Thyme.Clock.POSIX          (POSIXTime, getPOSIXTime)-import Data.Word+import           Arbor.File.Format.Asif.Whatever+import           Conduit+import           Control.Lens+import           Control.Monad+import           Data.Bits+import           Data.ByteString.Builder+import           Data.Generics.Product.Any+import           Data.Int+import           Data.Maybe+import           Data.Monoid                        ((<>))+import           Data.String+import           Data.Thyme.Clock+import           Data.Thyme.Clock.POSIX             (POSIXTime, getPOSIXTime)+import           Data.Word -import qualified Arbor.File.Format.Asif.Format as F-import qualified Arbor.File.Format.Asif.IO     as IO-import qualified Arbor.File.Format.Asif.Type   as Z-import qualified Data.ByteString               as BS-import qualified Data.ByteString.Builder       as B-import qualified Data.ByteString.Lazy          as LBS-import qualified Data.ByteString.Lazy.Char8    as LC8-import qualified Data.Conduit.List             as CL-import qualified Data.Text.Encoding            as T-import qualified GHC.IO.Handle                 as IO-import qualified System.IO.Temp                as IO+import qualified Arbor.File.Format.Asif.Format.Type as F+import qualified Arbor.File.Format.Asif.IO          as IO+import qualified Arbor.File.Format.Asif.Type        as Z+import qualified Data.ByteString                    as BS+import qualified Data.ByteString.Builder            as B+import qualified Data.ByteString.Lazy               as LBS+import qualified Data.ByteString.Lazy.Char8         as LC8+import qualified Data.Conduit.List                  as CL+import qualified Data.Text.Encoding                 as T+import qualified GHC.IO.Handle                      as IO+import qualified System.IO.Temp                     as IO  makeMagic :: String -> Builder makeMagic c = B.lazyByteString (magicString c)

@@ -13,21 +13,21 @@   , vectorUnboxed   ) where -import Arbor.File.Format.Asif.Format   (Format)-import Arbor.File.Format.Asif.Whatever-import Control.Lens-import Data.Binary.Get-import Data.List                       hiding (map)-import Data.Text                       (Text)-import Data.Text.Encoding              (decodeUtf8')-import Data.Text.Encoding.Error-import Prelude                         hiding (map)+import           Arbor.File.Format.Asif.Format.Type (Format)+import           Arbor.File.Format.Asif.Whatever+import           Control.Lens+import           Data.Binary.Get+import           Data.List                          hiding (map)+import           Data.Text                          (Text)+import           Data.Text.Encoding                 (decodeUtf8')+import           Data.Text.Encoding.Error+import           Prelude                            hiding (map) -import qualified Data.Binary.Get      as G-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Map.Strict      as M-import qualified Data.Vector          as V-import qualified Data.Vector.Unboxed  as VU+import qualified Data.Binary.Get                    as G+import qualified Data.ByteString.Lazy               as LBS+import qualified Data.Map.Strict                    as M+import qualified Data.Vector                        as V+import qualified Data.Vector.Unboxed                as VU  vectorBoxed :: Get a -> LBS.ByteString -> V.Vector a vectorBoxed g = V.unfoldr step

@@ -1,26 +1,16 @@-{-# LANGUAGE DeriveGeneric #-}+module Arbor.File.Format.Asif.Format+  ( module X+  , SegmentValue (..)+  , segmentValues+  , extractValues+  )+where -module Arbor.File.Format.Asif.Format where+import           Arbor.File.Format.Asif.Format.Type         as X -import GHC.Generics+import           Arbor.File.Format.Asif.Format.SegmentValue+import           Arbor.File.Format.Asif.Segment+import           Data.ByteString.Lazy                       as LBS -data Format-  = Binary-  | BitString-  | Char-  | Int8-  | Int16LE-  | Int32LE-  | Int64LE-  | Ipv4-  | Ipv6-  | Repeat Word Format-  | StringZ-  | Text-  | TimeMicros64LE-  | TimeMillis64LE-  | Word8-  | Word16LE-  | Word32LE-  | Word64LE-  deriving (Eq, Read, Show, Generic)+extractValues :: (SegmentValue -> a) -> Segment LBS.ByteString -> [a]+extractValues f s = f <$> segmentValues s

@@ -0,0 +1,150 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module Arbor.File.Format.Asif.Format.SegmentValue+where++import qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS+import           Arbor.File.Format.Asif.Data.Ip+import qualified Arbor.File.Format.Asif.Format.Type     as F+import           Arbor.File.Format.Asif.List            as L+import           Arbor.File.Format.Asif.Segment+import           Arbor.File.Format.Asif.Whatever+import           Control.Lens+import qualified Data.Binary                            as G+import qualified Data.Binary.Get                        as G+import qualified Data.ByteString.Lazy                   as LBS+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)++data SegmentValue+  = SString LBS.ByteString+  | SChar Char+  | STime UTCTime+  | SIpv4 IPv4+  | SIpv6 IPv6+  | SInt64 Int64+  | SInt32 Int32+  | SInt16 Int16+  | SInt8 Int8+  | SWord64 Word64+  | SWord32 Word32+  | SWord16 Word16+  | SWord8 Word8+  | SText LBS.ByteString+  | SBitString LBS.ByteString+  | SBitmap LBS.ByteString+  | SBinary LBS.ByteString+  | SList [SegmentValue]+  | 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)++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))+  in LBS.chunkBy n bs <&> getValue++getRawValue :: F.Format -> LBS.ByteString -> [SegmentValue]+getRawValue format bs =+  case format of+    F.StringZ ->+      if LBS.null bs+        then []+        else init (LBS.split 0 bs) <&> SString++    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)++    F.TimeMicros64LE -> whenNonEmpty bs $+      let toTime ms = ms ^. from microseconds & posixSecondsToUTCTime+      in bs & getValues 8 G.getInt64le <&> (STime . toTime)++    F.Ipv4 -> whenNonEmpty bs $+      bs & getValues 4 G.getWord32le <&> (SIpv4 . word32ToIpv4)++    F.Ipv6 -> whenNonEmpty bs $+      bs & getValues 16 getWord32x4 <&> (SIpv6 . word32x4ToIpv6)++    F.Int64LE -> whenNonEmpty bs $+      bs & getValues 8 G.getInt64le <&> SInt64++    F.Int32LE -> whenNonEmpty bs $+      bs & getValues 4 G.getInt32le <&> SInt32++    F.Int16LE -> whenNonEmpty bs $+      bs & getValues 2 G.getInt16le <&> SInt16++    F.Int8 -> whenNonEmpty bs $+      bs & getValues 1 G.getInt8 <&> SInt8++    F.Word64LE -> whenNonEmpty bs $+      bs & getValues 8 G.getWord64le <&> SWord64++    F.Word32LE -> whenNonEmpty bs $+      bs & getValues 4 G.getWord32le <&> SWord32++    F.Word16LE -> whenNonEmpty bs $+      bs & getValues 2 G.getWord16le <&> SWord16++    F.Word8 -> whenNonEmpty bs $+      bs & getValues 1 G.getWord8 <&> SWord8++    F.Text ->+      [SText bs]++    F.Repeat n fmt@F.Text -> whenNonEmpty bs $+      LBS.chunkBy (fromIntegral n) bs >>= getRawValue fmt++    F.BitString ->+      [SBitString bs]++    F.Repeat n fmt@F.BitString -> whenNonEmpty bs $+      LBS.chunkBy (fromIntegral n) bs >>= getRawValue fmt++    F.Binary ->+      [SBinary bs]++    F.Repeat n fmt@F.Binary -> whenNonEmpty bs $+      LBS.chunkBy (fromIntegral n) bs >>= getRawValue fmt++    F.Bitmap ->+      [SBitmap bs]++    F.Repeat n fmt@F.Bitmap -> whenNonEmpty bs $+      LBS.chunkBy (fromIntegral n) bs >>= getRawValue fmt++    F.Repeat n fmt -> whenNonEmpty bs $+      getRawValue fmt bs & L.chunksOf (fromIntegral n) <&> SList++whenNonEmpty :: LBSC.ByteString -> [a] -> [a]+whenNonEmpty bs f =+  if LBS.null bs then [] else f++segmentValues :: Segment LBS.ByteString -> [SegmentValue]+segmentValues segment =+  case segment ^. the @"meta" . the @"format" of+    Just (Known format) -> getRawValue format (segment ^. the @"payload")+    Just (Unknown txt)  -> [SUnknown txt (segment ^. the @"payload")]+    Nothing             -> []+

@@ -0,0 +1,54 @@+{-# LANGUAGE LambdaCase #-}+module Arbor.File.Format.Asif.Format.Text+( segmentValueToText+)+where++import qualified Arbor.File.Format.Asif.ByteString.Lazy     as LBS+import           Arbor.File.Format.Asif.Data.Ip+import           Arbor.File.Format.Asif.Format.SegmentValue+import           Control.Lens+import qualified Data.ByteString.Lazy                       as LBS+import qualified Data.List                                  as L+import           Data.Text                                  (Text)+import qualified Data.Text                                  as T+import qualified Data.Text.Encoding                         as T+import           HaskellWorks.Data.Bits.BitShow             (bitShow)+import           Numeric                                    (showHex)++segmentValueToText :: SegmentValue -> Text+segmentValueToText = \case+  SString v -> T.decodeUtf8 (LBS.toStrict v)+  SChar v -> T.singleton v+  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++  SInt64 v -> T.pack $ show v+  SInt32 v -> T.pack $ show v+  SInt16 v -> T.pack $ show v+  SInt8  v -> T.pack $ show v++  SWord64 v -> T.pack $ show v+  SWord32 v -> T.pack $ show v+  SWord16 v -> T.pack $ show v+  SWord8  v -> T.pack $ show v++  SText v -> T.decodeUtf8 (LBS.toStrict v)++  SBitString v  -> T.pack $ bitShow v+  SBitmap v     -> T.pack $ bitShow v+  SBinary v     -> LBS.chunkBy 4 v <&> toHex & L.intersperse " " & mconcat++  SList vs -> vs <&> segmentValueToText & T.intercalate ","++  SUnknown _ v -> LBS.chunkBy 4 v <&> toHex & L.intersperse " " & mconcat+++toHex :: LBS.ByteString -> Text+toHex bs =+  T.pack $ mconcat (L.reverse . L.take 2 . L.reverse . ('0':) . flip showHex "" <$> LBS.unpack bs)

@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveGeneric #-}++module Arbor.File.Format.Asif.Format.Type+where++import           GHC.Generics++data Format+  = Binary+  | Bitmap+  | BitString+  | Char+  | Int8+  | Int16LE+  | Int32LE+  | Int64LE+  | Ipv4+  | Ipv6+  | Repeat Word Format+  | StringZ+  | Text+  | TimeMicros64LE+  | TimeMillis64LE+  | Word8+  | Word16LE+  | Word32LE+  | Word64LE+  deriving (Eq, Read, Show, Generic)

@@ -0,0 +1,6 @@+module Arbor.File.Format.Asif.List where++import           Data.List++chunksOf :: Int -> [a] -> [[a]]+chunksOf n = takeWhile (not . null) . unfoldr (Just . splitAt n)

@@ -6,6 +6,8 @@   , mkDefaultSegment   , extractSegments   , extractNamedSegments+  , extractHeader+  , extractSegmentByteStringsWithHeader   , segmentNamed   ) where @@ -34,7 +36,8 @@  extractSegments :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String [Z.Segment LBS.ByteString] extractSegments magicParser bs = do-  bss <- extractSegmentByteStrings magicParser bs+  header <- extractHeader magicParser bs+  bss <- extractSegmentByteStringsWithHeader bs header   case bss of     (as:_) -> if ".asif/filenames\0" `LBS.isPrefixOf` as       then do@@ -57,10 +60,16 @@   let filenames = fromMaybe "" . (^. the @"meta" . the @"filename") <$> segments   return $ M.fromList $ zip filenames segments +extractHeader :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String [(Int, Int)]+extractHeader magicParser bs = case runGetOrFail (getHeader magicParser) bs of+  Left (_, _, err)     -> Left err+  Right (_, _, header) -> Right header+ extractSegmentByteStrings :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String [LBS.ByteString]-extractSegmentByteStrings magicParser bs = case runGetOrFail (getHeader magicParser) bs of-  Left (_, _, err) -> Left err-  Right (_, _, header) -> do+extractSegmentByteStrings magicParser bs = extractHeader magicParser bs >>= extractSegmentByteStringsWithHeader bs++extractSegmentByteStringsWithHeader :: LBS.ByteString -> [(Int, Int)] -> Either String [LBS.ByteString]+extractSegmentByteStringsWithHeader bs header = do     let segs = fmap (\(o, l) -> LBS.take (fromIntegral l) $ LBS.drop (fromIntegral o) bs) header     forM_ (zip segs header) $ \(seg, (_, len)) ->       when (LC8.length seg /= fromIntegral len) $

@@ -2,13 +2,13 @@  module Arbor.File.Format.Asif.Type where -import Arbor.File.Format.Asif.Format   (Format)-import Arbor.File.Format.Asif.Maybe-import Arbor.File.Format.Asif.Whatever-import Data.Semigroup                  (Semigroup, (<>))-import Data.Text                       (Text)-import Data.Thyme.Clock.POSIX          (POSIXTime)-import GHC.Generics+import           Arbor.File.Format.Asif.Format.Type (Format)+import           Arbor.File.Format.Asif.Maybe+import           Arbor.File.Format.Asif.Whatever+import           Data.Semigroup                     (Semigroup, (<>))+import           Data.Text                          (Text)+import           Data.Thyme.Clock.POSIX             (POSIXTime)+import           GHC.Generics  data SegmentMeta = SegmentMeta   { createTime :: Maybe POSIXTime

@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Arbor.File.Format.Asif.Format.SegmentValueSpec+  ( spec+  ) where++import           Arbor.File.Format.Asif.Data.Ip+import           Arbor.File.Format.Asif.Format   as F+import           Arbor.File.Format.Asif.Type+import           Arbor.File.Format.Asif.Whatever+import           Control.Lens+import qualified Data.List                       as L+import           Data.Semigroup                  ((<>))+import           Data.Thyme.Time.Core++import qualified Data.ByteString.Builder         as BB+import qualified Data.ByteString.Lazy            as LBS+import qualified Data.ByteString.Lazy.Char8      as LC8++import           Arbor.TestUtils+import           HaskellWorks.Hspec.Hedgehog+import           Hedgehog+import           Test.Hspec++import qualified Hedgehog.Gen                    as Gen+import qualified Hedgehog.Range                  as Range++{-# ANN module ("HLint: ignore Redundant do"  :: String) #-}++spec :: Spec+spec = describe "Arbor.File.Format.Asif.Format.RawValueSpec" $ do+  it "should parse strings" $ require $ property $ do+    bs <- forAll $ Gen.list (Range.linear 0 20) (genLazyBS (Range.linear 0 512) Gen.alphaNum)+    let body = mconcat $ (<> "\0") <$> bs+    let seg = segment body $ metaFormat (Known F.StringZ)+    segmentValues seg === fmap SString bs++  it "should parse chars" $ require $ property $ do+    bs <- forAll $ genLazyBS (Range.linear 0 512) Gen.latin1+    let expected = LC8.unpack bs <&> SChar+    let seg = segment bs $ metaFormat (Known F.Char)+    segmentValues seg === expected++  it "should parse time (micros)" $ require $ property $ do+    ts <- forAll $ Gen.list (Range.linear 0 20) (Gen.int64 (Range.linear 0 maxBound))+    let body = ts <&> BB.int64LE & mconcat & BB.toLazyByteString+    let times = ts ^.. each . from microseconds . to posixSecondsToUTCTime+    let seg = segment body $ metaFormat (Known F.TimeMicros64LE)+    segmentValues seg === fmap STime times++  it "should parse time (millis)" $ require $ property $ do+    ts <- forAll $ Gen.list (Range.linear 0 20) (Gen.int64 (Range.linear 0 maxBound) <&> (`div` 1000))+    let body = ts <&> BB.int64LE & mconcat & BB.toLazyByteString+    let times = ts ^.. each . to (*1000) . from microseconds . to posixSecondsToUTCTime+    let seg = segment body $ metaFormat (Known F.TimeMillis64LE)+    segmentValues seg === fmap STime times++  it "should parse int64" $ require $ property $ do+    testMany F.Int64LE SInt64 BB.int64LE (Gen.int64 (Range.linear 0 maxBound))++  it "should parse int32" $ require $ property $ do+    testMany F.Int32LE SInt32 BB.int32LE (Gen.int32 (Range.linear 0 maxBound))++  it "should parse int16" $ require $ property $ do+    testMany F.Int16LE SInt16 BB.int16LE (Gen.int16 (Range.linear 0 maxBound))++  it "should parse int8" $ require $ property $ do+    testMany F.Int8 SInt8 BB.int8 (Gen.int8 (Range.linear 0 maxBound))++  it "should parse word64" $ require $ property $ do+    testMany F.Word64LE SWord64 BB.word64LE (Gen.word64 (Range.linear 0 maxBound))++  it "should parse word32" $ require $ property $ do+    testMany F.Word32LE SWord32 BB.word32LE (Gen.word32 (Range.linear 0 maxBound))++  it "should parse word16" $ require $ property $ do+    testMany F.Word16LE SWord16 BB.word16LE (Gen.word16 (Range.linear 0 maxBound))++  it "should parse word8" $ require $ property $ do+    testMany F.Word8 SWord8 BB.word8 (Gen.word8 (Range.linear 0 maxBound))++  it "should parse BitString" $ require $ property $+    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict+    in testOne F.BitString SBitString BB.lazyByteString gen++  it "should parse Binary" $ require $ property $+    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict+    in testOne F.Binary SBinary BB.lazyByteString gen++  it "should parse Bitmap" $ require $ property $+    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict+    in testOne F.Bitmap SBitmap BB.lazyByteString gen++  it "should parse repeated BitString" $ require $ property $ do+    n <- forAll $ Gen.int (Range.linear 1 32)+    vs <- forAll $ Gen.list (Range.linear 0 20) (Gen.bytes (Range.singleton n) <&> LBS.fromStrict)+    let seg = segment (mconcat vs) $ metaFormat (Known (Repeat (fromIntegral n) F.BitString))+    segmentValues seg === fmap SBitString vs++  it  "should parse repeated chars" $ require $ property $ do+    n <- forAll $ Gen.int (Range.linear 1 32)+    vs <- forAll $ Gen.list (Range.linear 0 20) (Gen.string (Range.singleton n) Gen.alphaNum)+    let seg = segment (LC8.pack $ mconcat vs) $ metaFormat (Known (Repeat (fromIntegral n) F.Char))+    segmentValues seg === fmap (SList . fmap SChar) vs++  it "should parse repeated ips" $ require $ property $ do+    n <- forAll $ Gen.int (Range.linear 1 32)+    k <- forAll $ Gen.int (Range.linear 0 20)+    vs <- forAll $ Gen.list (Range.singleton (n*k)) (Gen.word32 Range.linearBounded)+    let body = vs <&> BB.word32LE & mconcat & BB.toLazyByteString+    let seg = segment body $ metaFormat (Known (Repeat (fromIntegral n) F.Ipv4))+    let expected = vs <&> (SIpv4 . word32ToIpv4) & chunksOf n <&> SList+    segmentValues seg === expected++genLazyBS :: MonadGen m => Range Int -> m Char -> m LBS.ByteString+genLazyBS rng gen = Gen.utf8 rng gen <&> LBS.fromStrict++testOne :: (Monad m, Show a)+        => Format+        -> (a -> SegmentValue)+        -> (a -> BB.Builder)+        -> Gen a+        -> PropertyT m ()+testOne fmt wrap put gen = do+  v <- forAll gen+  let body = put v & BB.toLazyByteString+  let seg = segment body $ metaFormat (Known fmt)+  segmentValues seg === [wrap v]++testMany :: (Monad m, Show a)+          => Format+          -> (a -> SegmentValue)+          -> (a -> BB.Builder)+          -> Gen a+          -> PropertyT m ()+testMany fmt wrap put gen = do+  vs <- forAll $ Gen.list (Range.linear 0 20) gen+  let body = vs <&> put & mconcat & BB.toLazyByteString+  let seg = segment body $ metaFormat (Known fmt)+  segmentValues seg === fmap wrap vs

@@ -0,0 +1,140 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Arbor.File.Format.Asif.Format.TextSpec+  ( spec+  ) where++import           Arbor.File.Format.Asif.Data.Ip+import           Arbor.File.Format.Asif.Format      as F+import           Arbor.File.Format.Asif.Format.Text as F+import           Arbor.File.Format.Asif.Type+import           Arbor.File.Format.Asif.Whatever+import           Control.Lens+import qualified Data.List                          as L+import           Data.Semigroup                     ((<>))+import           Data.Thyme.Time.Core+import           HaskellWorks.Data.Bits.BitShow     (bitShow)++import qualified Data.ByteString.Builder            as BB+import qualified Data.ByteString.Lazy               as LBS+import qualified Data.ByteString.Lazy.Char8         as LC8+import qualified Data.Text                          as T+import qualified Data.Text.Encoding                 as T++import           Arbor.TestUtils+import           HaskellWorks.Hspec.Hedgehog+import           Hedgehog+import           Test.Hspec+++import qualified Hedgehog.Gen                       as Gen+import qualified Hedgehog.Range                     as Range++{-# ANN module ("HLint: ignore Redundant do"  :: String) #-}++spec :: Spec+spec = describe "Arbor.File.Format.Asif.Format.TextSpec" $ do+  it "should parse strings" $ require $ property $ do+    ts <- forAll $ Gen.list (Range.linear 0 20) (Gen.text (Range.linear 0 512) Gen.alphaNum)+    let body = ts <&> T.encodeUtf8 <&> (<> "\0") & mconcat & LBS.fromStrict+    let seg = segment body $ metaFormat (Known F.StringZ)+    F.extractValues F.segmentValueToText seg === ts++  it "should parse chars" $ require $ property $ do+    txt <- forAll $ Gen.text (Range.linear 0 512) Gen.alphaNum+    let expected = T.unpack txt <&> T.singleton+    let body = txt & T.encodeUtf8 & LBS.fromStrict+    let seg = segment body $ metaFormat (Known F.Char)+    F.extractValues F.segmentValueToText seg === expected++  it "should parse time (micros)" $ require $ property $ do+    ts <- forAll $ Gen.list (Range.linear 0 20) (Gen.int64 (Range.linear 0 maxBound))+    let body = ts <&> BB.int64LE & mconcat & BB.toLazyByteString+    let times = ts ^.. each . from microseconds . to posixSecondsToUTCTime+    let seg = segment body $ metaFormat (Known F.TimeMicros64LE)+    F.extractValues F.segmentValueToText seg === (T.pack . show <$> times)++  it "should parse time (millis)" $ require $ property $ do+    ts <- forAll $ Gen.list (Range.linear 0 20) (Gen.int64 (Range.linear 0 (maxBound `div` 1000)))+    let body = ts <&> BB.int64LE & mconcat & BB.toLazyByteString+    let times = ts ^.. each . to (*1000) . from microseconds . to posixSecondsToUTCTime+    let seg = segment body $ metaFormat (Known F.TimeMillis64LE)+    F.extractValues F.segmentValueToText seg === (T.pack . show <$> times)++  it "should parse int64" $ require $ property $ do+    testMany F.Int64LE (T.pack . show) BB.int64LE (Gen.int64 (Range.linear 0 maxBound))++  it "should parse int32" $ require $ property $ do+    testMany F.Int32LE (T.pack . show) BB.int32LE (Gen.int32 (Range.linear 0 maxBound))++  it "should parse int16" $ require $ property $ do+    testMany F.Int16LE (T.pack . show) BB.int16LE (Gen.int16 (Range.linear 0 maxBound))++  it "should parse int8" $ require $ property $ do+    testMany F.Int8 (T.pack . show) BB.int8 (Gen.int8 (Range.linear 0 maxBound))++  it "should parse Word64" $ require $ property $ do+    testMany F.Word64LE (T.pack . show) BB.word64LE (Gen.word64 (Range.linear 0 maxBound))++  it "should parse Word32" $ require $ property $ do+    testMany F.Word32LE (T.pack . show) BB.word32LE (Gen.word32 (Range.linear 0 maxBound))++  it "should parse Word16" $ require $ property $ do+    testMany F.Word16LE (T.pack . show) BB.word16LE (Gen.word16 (Range.linear 0 maxBound))++  it "should parse Word8" $ require $ property $ do+    testMany F.Word8 (T.pack . show) BB.word8 (Gen.word8 (Range.linear 0 maxBound))++  it "should parse BitString" $ require $ property $+    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict+    in testOne F.BitString (T.pack . bitShow) BB.lazyByteString gen++  it "should parse Bitmap" $ require $ property $+    let gen = Gen.bytes (Range.linear 0 256) <&> LBS.fromStrict+    in testOne F.Bitmap (T.pack . bitShow) BB.lazyByteString gen++  it "should parse repeated BitString" $ require $ property $ do+    n <- forAll $ Gen.int (Range.linear 1 32)+    vs <- forAll $ Gen.list (Range.linear 0 20) (Gen.bytes (Range.singleton n) <&> LBS.fromStrict)+    let seg = segment (mconcat vs) $ metaFormat (Known (Repeat (fromIntegral n) F.BitString))+    F.extractValues F.segmentValueToText seg === fmap (T.pack . bitShow) vs++  it  "should parse repeated chars" $ require $ property $ do+    n <- forAll $ Gen.int (Range.linear 1 32)+    vs <- forAll $ Gen.list (Range.linear 0 20) (Gen.string (Range.singleton n) Gen.alphaNum)+    let seg = segment (LC8.pack $ mconcat vs) $ metaFormat (Known (Repeat (fromIntegral n) F.Char))+    F.extractValues F.segmentValueToText seg === fmap (T.pack . L.intersperse ',') vs++  it "should parse repeated ips" $ require $ property $ do+    n <- forAll $ Gen.int (Range.linear 1 32)+    k <- forAll $ Gen.int (Range.linear 0 20)+    vs <- forAll $ Gen.list (Range.singleton (n*k)) (Gen.word32 Range.linearBounded)+    let body = vs <&> BB.word32LE & mconcat & BB.toLazyByteString+    let seg = segment body $ metaFormat (Known (Repeat (fromIntegral n) F.Ipv4))+    let expected = vs <&> (ipv4ToString . word32ToIpv4) & chunksOf n <&> (T.pack . L.intercalate ",")+    F.extractValues F.segmentValueToText seg === expected++testMany :: (Monad m, Show a)+          => Format+          -> (a -> T.Text)+          -> (a -> BB.Builder)+          -> Gen a+          -> PropertyT m ()+testMany fmt wrap put gen = do+  vs <- forAll $ Gen.list (Range.linear 0 20) gen+  let body = vs <&> put & mconcat & BB.toLazyByteString+  let seg = segment body $ metaFormat (Known fmt)+  F.extractValues F.segmentValueToText seg === fmap wrap vs++testOne :: (Monad m, Show a)+        => Format+        -> (a -> T.Text)+        -> (a -> BB.Builder)+        -> Gen a+        -> PropertyT m ()+testOne fmt wrap put gen = do+  v <- forAll gen+  let body = put v & BB.toLazyByteString+  let seg = segment body $ metaFormat (Known fmt)+  F.extractValues F.segmentValueToText seg === [wrap v]

@@ -0,0 +1,8 @@+module Arbor.TestUtils+where++import qualified Data.List as L++chunksOf :: Int -> [a] -> [[a]]+chunksOf n = L.takeWhile (not . L.null) . L.unfoldr (Just . L.splitAt n)+