diff --git a/asif.cabal b/asif.cabal --- a/asif.cabal +++ b/asif.cabal @@ -1,9 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.18.1. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack +-- +-- hash: c7f6880e469ae305df5407eec0ebfc06d81e68830ba46005a1752adb58472ef6 name: asif -version: 3.4.0 +version: 4.0.0 description: Please see the README on Github at category: Services homepage: https://github.com/packetloop/asif#readme @@ -14,48 +18,15 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 - extra-source-files: - ChangeLog.md README.md + ChangeLog.md source-repository head type: git location: https://github.com/packetloop/asif library - hs-source-dirs: - src - default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints - build-depends: - base >= 4.7 && < 5 - , attoparsec - , binary - , bytestring - , conduit - , conduit-combinators - , conduit-extra - , containers - , cpu - , either - , exceptions - , foldl - , generic-lens - , hw-bits - , hw-ip - , iproute - , lens - , network - , old-locale - , profunctors - , resourcet - , temporary-resourcet - , text - , thyme - , transformers - , vector exposed-modules: Arbor.File.Format.Asif Arbor.File.Format.Asif.ByIndex @@ -81,17 +52,13 @@ Arbor.File.Format.Asif.Maybe Arbor.File.Format.Asif.Text Paths_asif - default-language: Haskell2010 - -executable asif - main-is: Main.hs hs-source-dirs: - app + src default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -O2 -msse4.2 + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints build-depends: - base >= 4.7 && < 5 - , attoparsec + attoparsec + , base >=4.7 && <5 , binary , bytestring , conduit @@ -116,9 +83,10 @@ , thyme , transformers , vector - , asif - , directory - , optparse-applicative + default-language: Haskell2010 + +executable asif + main-is: Main.hs other-modules: App.Commands App.Commands.Dump @@ -131,18 +99,15 @@ App.Commands.Options.Type App.Dump App.IO - default-language: Haskell2010 - -test-suite asif-test - type: exitcode-stdio-1.0 - main-is: Spec.hs + Paths_asif hs-source-dirs: - test + app default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -O2 -msse4.2 build-depends: - base >= 4.7 && < 5 + asif , attoparsec + , base >=4.7 && <5 , binary , bytestring , conduit @@ -150,6 +115,7 @@ , conduit-extra , containers , cpu + , directory , either , exceptions , foldl @@ -160,6 +126,7 @@ , lens , network , old-locale + , optparse-applicative , profunctors , resourcet , temporary-resourcet @@ -167,10 +134,11 @@ , thyme , transformers , vector - , asif - , hspec - , hedgehog - , hw-hspec-hedgehog + default-language: Haskell2010 + +test-suite asif-test + type: exitcode-stdio-1.0 + main-is: Spec.hs other-modules: Arbor.File.Format.Asif.ByteString.BuilderSpec Arbor.File.Format.Asif.Data.IpSpec @@ -181,4 +149,40 @@ Arbor.TestUtils Gen.Feed TestApp + Paths_asif + hs-source-dirs: + test + default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + asif + , attoparsec + , base >=4.7 && <5 + , binary + , bytestring + , conduit + , conduit-combinators + , conduit-extra + , containers + , cpu + , either + , exceptions + , foldl + , generic-lens + , hedgehog + , hspec + , hw-bits + , hw-hspec-hedgehog + , hw-ip + , iproute + , lens + , network + , old-locale + , profunctors + , resourcet + , temporary-resourcet + , text + , thyme + , transformers + , vector default-language: Haskell2010 diff --git a/src/Arbor/File/Format/Asif/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,20 +10,20 @@ , 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.Type as F import qualified Arbor.File.Format.Asif.IO as IO @@ -90,11 +90,11 @@ sourceHandle h CL.sourceList (replicate (fromIntegral padding) (BS.singleton 0)) -segmentsC :: (MonadIO m, MonadResource m) +segmentsC :: MonadResource m => String -> Maybe POSIXTime -> [Z.Segment IO.Handle] - -> m (ConduitT () BS.ByteString m ()) + -> ConduitT () BS.ByteString m () segmentsC asifType maybeTimestamp metas = do fileTime <- maybe (liftIO getPOSIXTime) return maybeTimestamp (_, _, hFilenames ) <- IO.openTempFile Nothing "asif-filenames" @@ -111,8 +111,5 @@ liftIO $ B.hPutBuilder hFilenames $ B.byteString (meta ^. the @"meta" . the @"filename" & fromMaybe "" & T.encodeUtf8) <> B.word8 0 liftIO $ B.hPutBuilder hCreateTimes $ B.int64LE $ (meta ^. the @"meta" . the @"createTime") <&> (^. microseconds) & fromMaybe 0 liftIO $ B.hPutBuilder hFormats $ B.byteString (meta ^. the @"meta" . the @"format" <&> tShowWhatever & fromMaybe "" & T.encodeUtf8) <> B.word8 0 - return () - let source = segmentsRawC asifType ((^. the @"payload") <$> moreMetas) - - return source + segmentsRawC asifType ((^. the @"payload") <$> moreMetas) diff --git a/src/Arbor/File/Format/Asif/Write.hs b/src/Arbor/File/Format/Asif/Write.hs --- a/src/Arbor/File/Format/Asif/Write.hs +++ b/src/Arbor/File/Format/Asif/Write.hs @@ -12,7 +12,8 @@ -- * Encode an entire ASIF bytestring -- $usage writeAsif - , buildAsifBytestring + , asifContent + , asifContentC -- * Folds for Segments -- $segments @@ -55,10 +56,11 @@ import Data.Profunctor (lmap) import Data.Semigroup ((<>)) import Data.Word -import System.IO (Handle, SeekMode (AbsoluteSeek), hFlush, hSeek) +import System.IO (Handle, hFlush) import System.IO.Temp (openTempFile) import qualified Arbor.File.Format.Asif.Format as F +import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as LBS import qualified Data.IP as IP @@ -81,7 +83,7 @@ -- out the constituent pieces to encode into 'Segment's. -- -- 'FoldM's are composable using '<>'. Once you have a single, provide it to --- 'writeAsif' or 'buildAsifBytestring' along with an appropriate foldable. +-- 'writeAsif' or 'asifContent' along with an appropriate foldable. -- Both these functions will stream from the input, assuming the foldable is -- something that can be streamed from. @@ -95,27 +97,37 @@ -> f a -> m () writeAsif hOutput asifType mTimestamp fld foldable = do - segments <- foldM fld foldable - contents <- segmentsC asifType mTimestamp segments - runConduit $ contents .| sinkHandle hOutput + runConduit + $ asifContentC asifType mTimestamp fld foldable + .| sinkHandle hOutput liftIO $ hFlush hOutput + -- | Builds a lazy ASIF bytestring. -- Streams the input foldable if possible. -buildAsifBytestring :: (Foldable f, MonadResource m) +asifContent :: (Foldable f, MonadResource m) => String -> Maybe TY.POSIXTime -> FoldM m a [Segment Handle] -> f a -> m LBS.ByteString -buildAsifBytestring asifType mTimestamp fld foldable = do - (_, _, h) <- openTempFile Nothing "asif" - writeAsif h asifType mTimestamp fld foldable - liftIO $ hSeek h AbsoluteSeek 0 - liftIO $ LBS.hGetContents h +asifContent asifType mTimestamp fld foldable = + runConduit + $ asifContentC asifType mTimestamp fld foldable + .| sinkLazy ------ +-- | Returns ASIF content as a conduit +asifContentC :: (Foldable f, MonadResource m) + => String + -> Maybe TY.POSIXTime + -> FoldM m a [Segment Handle] + -> f a + -> ConduitT () BS.ByteString m () +asifContentC asifType mTimestamp fld foldable = do + segments <- lift $ foldM fld foldable + segmentsC asifType mTimestamp segments +---- -- $segments -- -- Use these to build 'FoldM's for the types you want to encode. diff --git a/test/Arbor/File/Format/Asif/WriteSpec.hs b/test/Arbor/File/Format/Asif/WriteSpec.hs --- a/test/Arbor/File/Format/Asif/WriteSpec.hs +++ b/test/Arbor/File/Format/Asif/WriteSpec.hs @@ -4,17 +4,20 @@ import Arbor.File.Format.Asif.Format import Arbor.File.Format.Asif.Segment import Arbor.File.Format.Asif.Write +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class import Control.Monad.Trans.Resource import Data.Int import Data.Semigroup ((<>)) import Data.Word +import System.IO.Temp (openBinaryTempFile) import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec import qualified Data.Attoparsec.ByteString as AP +import qualified Data.ByteString.Lazy as LBS import qualified Data.IP as IP import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T @@ -23,11 +26,34 @@ import qualified Hedgehog.Gen as G import qualified Hedgehog.Range as R +import qualified System.IO as IO + {-# ANN module ("HLint: ignore Redundant do" :: String) #-} spec :: Spec spec = describe "Arbor.File.Format.Asif.Write" $ do + it "should write file and read it back again" $ require $ property $ do + tplList <- forAll $ G.list (R.linear 0 50) genTriple + + let fld = int64Segment (\(a,_,_) -> a) "first" + <> word16Segment (\(_,a,_) -> a) "second" + <> nullTerminatedStringSegment (\(_,_,a) -> T.toStrict a) "third" + + (_, f, h) <- openBinaryTempFile Nothing "wtite-asif-test.asif" + + _ <- writeAsif h "wxyz" Nothing fld tplList + liftIO $ IO.hSeek h IO.AbsoluteSeek 0 + + lbs <- liftIO $ LBS.hGetContents h + + let Right segments = extractSegments (AP.string "seg:wxyz") lbs + [names, times, types, l1,l2,l3] <- forAll $ pure (segmentValues <$> segments) + + ((\(a,_,_) -> SInt64 a) <$> tplList) === l1 + ((\(_,a,_) -> SWord16 a) <$> tplList) === l2 + ((\(_,_,a) -> SString . T.encodeUtf8 $ a) <$> tplList) === l3 + it "should write several segments, then read them back in" $ require $ property $ do tplList <- forAll $ G.list (R.linear 0 50) genTriple @@ -36,7 +62,7 @@ let f3 = nullTerminatedStringSegment (\(_,_,a) -> T.toStrict a) "third" let fld = f1 <> f2 <> f3 - lbs <- buildAsifBytestring "wxyz" Nothing fld tplList + lbs <- asifContent "wxyz" Nothing fld tplList let Right segments = extractSegments (AP.string "seg:wxyz") lbs @@ -51,7 +77,7 @@ it "should write out and read back in a bool segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) G.bool - lbs <- buildAsifBytestring "wxyz" Nothing (boolSegment id "bool") lst + lbs <- asifContent "wxyz" Nothing (boolSegment id "bool") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -61,7 +87,7 @@ it "should write out and read back in a word8 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.word8 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (word8Segment id "word8") lst + lbs <- asifContent "wxyz" Nothing (word8Segment id "word8") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -71,7 +97,7 @@ it "should write out and read back in a word16 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.word16 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (word16Segment id "word16") lst + lbs <- asifContent "wxyz" Nothing (word16Segment id "word16") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -81,7 +107,7 @@ it "should write out and read back in a word32 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.word32 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (word32Segment id "word32") lst + lbs <- asifContent "wxyz" Nothing (word32Segment id "word32") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -91,7 +117,7 @@ it "should write out and read back in a word64 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.word64 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (word64Segment id "word64") lst + lbs <- asifContent "wxyz" Nothing (word64Segment id "word64") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -103,7 +129,7 @@ it "should write out and read back in a int8 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.int8 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (int8Segment id "int8") lst + lbs <- asifContent "wxyz" Nothing (int8Segment id "int8") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -113,7 +139,7 @@ it "should write out and read back in a int16 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.int16 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (int16Segment id "int16") lst + lbs <- asifContent "wxyz" Nothing (int16Segment id "int16") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -123,7 +149,7 @@ it "should write out and read back in a int32 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.int32 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (int32Segment id "int32") lst + lbs <- asifContent "wxyz" Nothing (int32Segment id "int32") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -133,7 +159,7 @@ it "should write out and read back in a int64 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (G.int64 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (int64Segment id "int64") lst + lbs <- asifContent "wxyz" Nothing (int64Segment id "int64") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -145,7 +171,7 @@ it "should write out and read back in a ipv4 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (word32ToIpv4 <$> G.word32 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (ipv4Segment id "ipv4") lst + lbs <- asifContent "wxyz" Nothing (ipv4Segment id "ipv4") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -155,7 +181,7 @@ it "should write out and read back in a ipv6 segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) genIpv6 - lbs <- buildAsifBytestring "wxyz" Nothing (ipv6Segment id "ipv6") lst + lbs <- asifContent "wxyz" Nothing (ipv6Segment id "ipv6") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -167,7 +193,7 @@ it "should write out and read back in a time segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) (TY.posixSecondsToUTCTime . TY.fromMicroseconds <$> G.int64 R.linearBounded) - lbs <- buildAsifBytestring "wxyz" Nothing (utcTimeMicrosSegment id "time") lst + lbs <- asifContent "wxyz" Nothing (utcTimeMicrosSegment id "time") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -178,7 +204,7 @@ it "should write out and read back in a char segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) G.ascii - lbs <- buildAsifBytestring "wxyz" Nothing (asciiSegment id "char") lst + lbs <- asifContent "wxyz" Nothing (asciiSegment id "char") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -187,7 +213,7 @@ it "should write out and read back in a null-terminated string segment" $ require $ property $ do lst <- forAll $ G.list (R.linear 0 50) genNonNullText - lbs <- buildAsifBytestring "wxyz" Nothing (nullTerminatedStringSegment id "nullterminatedstring") (T.toStrict <$> lst) + lbs <- asifContent "wxyz" Nothing (nullTerminatedStringSegment id "nullterminatedstring") (T.toStrict <$> lst) let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments) @@ -200,7 +226,7 @@ -- get a single Text value. lst <- forAll $ G.list (R.linear 1 50) (G.text (R.linear 0 50) G.unicode) - lbs <- buildAsifBytestring "wxyz" Nothing (textSegment id "text") lst + lbs <- asifContent "wxyz" Nothing (textSegment id "text") lst let Right segments = extractSegments (AP.string "seg:wxyz") lbs [names, times, types, seg] <- forAll $ pure (segmentValues <$> segments)