diff --git a/app/App/Commands.hs b/app/App/Commands.hs --- a/app/App/Commands.hs +++ b/app/App/Commands.hs @@ -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) ) diff --git a/app/App/Commands/Dump.hs b/app/App/Commands/Dump.hs --- a/app/App/Commands/Dump.hs +++ b/app/App/Commands/Dump.hs @@ -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:????\"" diff --git a/app/App/Commands/DumpBitmap.hs b/app/App/Commands/DumpBitmap.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/DumpBitmap.hs @@ -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 <> ")" diff --git a/app/App/Commands/DumpOnly.hs b/app/App/Commands/DumpOnly.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/DumpOnly.hs @@ -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:????\"" diff --git a/app/App/Commands/EncodeFiles.hs b/app/App/Commands/EncodeFiles.hs --- a/app/App/Commands/EncodeFiles.hs +++ b/app/App/Commands/EncodeFiles.hs @@ -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 diff --git a/app/App/Commands/ExtractFiles.hs b/app/App/Commands/ExtractFiles.hs --- a/app/App/Commands/ExtractFiles.hs +++ b/app/App/Commands/ExtractFiles.hs @@ -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 diff --git a/app/App/Commands/ExtractSegments.hs b/app/App/Commands/ExtractSegments.hs --- a/app/App/Commands/ExtractSegments.hs +++ b/app/App/Commands/ExtractSegments.hs @@ -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 diff --git a/app/App/Commands/Ls.hs b/app/App/Commands/Ls.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Ls.hs @@ -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 diff --git a/app/App/Commands/Options/Type.hs b/app/App/Commands/Options/Type.hs --- a/app/App/Commands/Options/Type.hs +++ b/app/App/Commands/Options/Type.hs @@ -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) diff --git a/app/App/Dump.hs b/app/App/Dump.hs new file mode 100644 --- /dev/null +++ b/app/App/Dump.hs @@ -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 "" diff --git a/asif.cabal b/asif.cabal --- a/asif.cabal +++ b/asif.cabal @@ -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 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 diff --git a/src/Arbor/File/Format/Asif/ByteString/Builder.hs b/src/Arbor/File/Format/Asif/ByteString/Builder.hs --- a/src/Arbor/File/Format/Asif/ByteString/Builder.hs +++ b/src/Arbor/File/Format/Asif/ByteString/Builder.hs @@ -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) diff --git a/src/Arbor/File/Format/Asif/Extract.hs b/src/Arbor/File/Format/Asif/Extract.hs --- a/src/Arbor/File/Format/Asif/Extract.hs +++ b/src/Arbor/File/Format/Asif/Extract.hs @@ -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 diff --git a/src/Arbor/File/Format/Asif/Format.hs b/src/Arbor/File/Format/Asif/Format.hs --- a/src/Arbor/File/Format/Asif/Format.hs +++ b/src/Arbor/File/Format/Asif/Format.hs @@ -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 diff --git a/src/Arbor/File/Format/Asif/Format/SegmentValue.hs b/src/Arbor/File/Format/Asif/Format/SegmentValue.hs new file mode 100644 --- /dev/null +++ b/src/Arbor/File/Format/Asif/Format/SegmentValue.hs @@ -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 -> [] + diff --git a/src/Arbor/File/Format/Asif/Format/Text.hs b/src/Arbor/File/Format/Asif/Format/Text.hs new file mode 100644 --- /dev/null +++ b/src/Arbor/File/Format/Asif/Format/Text.hs @@ -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) diff --git a/src/Arbor/File/Format/Asif/Format/Type.hs b/src/Arbor/File/Format/Asif/Format/Type.hs new file mode 100644 --- /dev/null +++ b/src/Arbor/File/Format/Asif/Format/Type.hs @@ -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) diff --git a/src/Arbor/File/Format/Asif/List.hs b/src/Arbor/File/Format/Asif/List.hs new file mode 100644 --- /dev/null +++ b/src/Arbor/File/Format/Asif/List.hs @@ -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) diff --git a/src/Arbor/File/Format/Asif/Segment.hs b/src/Arbor/File/Format/Asif/Segment.hs --- a/src/Arbor/File/Format/Asif/Segment.hs +++ b/src/Arbor/File/Format/Asif/Segment.hs @@ -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) $ diff --git a/src/Arbor/File/Format/Asif/Type.hs b/src/Arbor/File/Format/Asif/Type.hs --- a/src/Arbor/File/Format/Asif/Type.hs +++ b/src/Arbor/File/Format/Asif/Type.hs @@ -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 diff --git a/test/Arbor/File/Format/Asif/Format/SegmentValueSpec.hs b/test/Arbor/File/Format/Asif/Format/SegmentValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Arbor/File/Format/Asif/Format/SegmentValueSpec.hs @@ -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 diff --git a/test/Arbor/File/Format/Asif/Format/TextSpec.hs b/test/Arbor/File/Format/Asif/Format/TextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Arbor/File/Format/Asif/Format/TextSpec.hs @@ -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] diff --git a/test/Arbor/TestUtils.hs b/test/Arbor/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Arbor/TestUtils.hs @@ -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) +