asif (empty) → 1.0.0
raw patch · 38 files changed
+1512/−0 lines, 38 filesdep +arbor-ipdep +asifdep +attoparsecsetup-changed
Dependencies added: arbor-ip, asif, attoparsec, base, binary, bytestring, conduit, conduit-combinators, conduit-extra, containers, cpu, directory, either, exceptions, hedgehog, hspec, hw-bits, hw-hspec-hedgehog, iproute, lens, old-locale, optparse-applicative, resourcet, temporary-resourcet, text, thyme, vector
Files
- ChangeLog.md +3/−0
- LICENSE +21/−0
- README.md +74/−0
- Setup.hs +2/−0
- app/App/Commands.hs +18/−0
- app/App/Commands/Dump.hs +155/−0
- app/App/Commands/EncodeFiles.hs +63/−0
- app/App/Commands/ExtractFiles.hs +71/−0
- app/App/Commands/ExtractSegments.hs +59/−0
- app/App/Commands/Options/Lens.hs +12/−0
- app/App/Commands/Options/Type.hs +22/−0
- app/App/IO.hs +12/−0
- app/Main.hs +17/−0
- asif.cabal +159/−0
- src/Arbor/File/Format/Asif.hs +3/−0
- src/Arbor/File/Format/Asif/ByIndex.hs +29/−0
- src/Arbor/File/Format/Asif/ByteString.hs +12/−0
- src/Arbor/File/Format/Asif/ByteString/Builder.hs +116/−0
- src/Arbor/File/Format/Asif/ByteString/Lazy.hs +13/−0
- src/Arbor/File/Format/Asif/Data/Ip.hs +26/−0
- src/Arbor/File/Format/Asif/Data/Read.hs +9/−0
- src/Arbor/File/Format/Asif/Extract.hs +63/−0
- src/Arbor/File/Format/Asif/Format.hs +21/−0
- src/Arbor/File/Format/Asif/Get.hs +47/−0
- src/Arbor/File/Format/Asif/IO.hs +33/−0
- src/Arbor/File/Format/Asif/Lens.hs +12/−0
- src/Arbor/File/Format/Asif/Lookup.hs +43/−0
- src/Arbor/File/Format/Asif/Maybe.hs +6/−0
- src/Arbor/File/Format/Asif/Segment.hs +70/−0
- src/Arbor/File/Format/Asif/Text.hs +12/−0
- src/Arbor/File/Format/Asif/Type.hs +60/−0
- src/Arbor/File/Format/Asif/Whatever.hs +35/−0
- test/Arbor/File/Format/Asif/ByteString/BuilderSpec.hs +61/−0
- test/Arbor/File/Format/Asif/Data/IpSpec.hs +36/−0
- test/Arbor/File/Format/AsifSpec.hs +55/−0
- test/Gen/Feed.hs +42/−0
- test/Spec.hs +1/−0
- test/TestApp.hs +19/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for asif++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Arbor Networks++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,74 @@+# Arbor Safe Intelligence Format (asif)+++Library for creating and querying segmented feeds.++## File Format Specification++### Layer 0: Segments++```++--------------------++|Segmented OSI Model |++--------------------+++ magic, where XXXX is a feed type++---------------------+-------------++| "seg:XXXX" [char:8] | ver: uint64 |++---------------------+-------------+++c -- countries+a -- asns+n -- naics++ header++-----------------++| seg_num: uint64 |++-----------------+++ segments++-----------------------+-----------------------++| segment_offset: int32 | segment_length: int32 |++-----------------------+-----------------------+++ segment vector++-------------++| key: X, ... |++-------------+++ segment vector++-------------++| val: Y, ... |++-------------++```++Vector keys are fixed-length values such as 4-byte IPv4 addresses,+2-byte country codes, or 4-byte NAIC IDs.++All values are little-endian.++Values are other ints or can be null-terminated strings.++### Layer 1: Segment filenames++Segment 0 must contain a concatenated list of null terminated filenames.++The first filename must be `.asif/filenames`.++The n-th filename in the segment 0 describes the n-th segment in the file.++### Layer 2: Additional metadata++The `asif` file may contain contain a named segment `.asif/createtime`.+If it does, this segment concatenated `Word64` numbers representing the create+time of each file in microseconds since epoch. If the segment does not have a+create time, it's create time entry will be `0` instead.++The `asif` file may contain contain a named segment `.asif/formats`.+If it does, this segment concatenated null terminated strings representing the+format of the data in the respective segments. The `dump` command will use+this information to choose the most appropriate way to print the data in each+segment.++## CLI+[CLI documentation](doc/cli.md)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/App/Commands.hs view
@@ -0,0 +1,18 @@+module App.Commands+ ( globalOptions+ ) where++import App.Commands.Dump+import App.Commands.EncodeFiles+import App.Commands.ExtractFiles+import App.Commands.ExtractSegments+import Data.Monoid+import Options.Applicative++globalOptions :: Parser (IO ())+globalOptions = subparser+ ( command "dump" (info commandDump idm)+ <> command "encode-files" (info commandEncodeFiles idm)+ <> command "extract-files" (info commandExtractFiles idm)+ <> command "extract-segments" (info commandExtractSegments idm)+ )
+ app/App/Commands/Dump.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.Dump where++import App.Commands.Options.Type+import Arbor.File.Format.Asif.Data.Ip+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 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 HaskellWorks.Data.Bits.BitShow+import Numeric (showHex)+import Options.Applicative+import System.Locale (defaultTimeLocale, iso8601DateFormat)++import qualified App.Commands.Options.Lens as L+import qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS+import qualified Arbor.File.Format.Asif.Format as F+import qualified Arbor.File.Format.Asif.Lens as L+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++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++parseDumpOptions :: Parser DumpOptions+parseDumpOptions = DumpOptions+ <$> strOption+ ( long "source"+ <> metavar "FILE"+ <> value "-"+ <> help "Input file"+ )+ <*> strOption+ ( long "target"+ <> metavar "FILE"+ <> value "-"+ <> help "Output file"+ )++commandDump :: Parser (IO ())+commandDump = runResourceT . runDump <$> parseDumpOptions++showTime :: FormatTime t => t -> String+showTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S %Z"))++runDump :: MonadResource m => DumpOptions -> m ()+runDump opt = do+ (_, hIn) <- openFileOrStd (opt ^. L.source) IO.ReadMode+ (_, hOut) <- openFileOrStd (opt ^. L.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 "" . (^. L.meta . L.filename) <$> segments+ 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 ^. L.meta . L.format of+ Just (Known F.StringZ) -> do+ when (LBS.length (segment ^. L.payload) > 0) $+ forM_ (init (LBS.split 0 (segment ^. L.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 ^. L.payload)) $ \bs ->+ liftIO $ IO.hPutStrLn hOut $ T.unpack (T.decodeUtf8 (LBS.toStrict bs))+ Just (Known F.TimeMillis64LE) ->+ forM_ (LBS.chunkBy 8 (segment ^. L.payload)) $ \bs -> do+ let w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0))+ let t :: POSIXTime = (w `div` 1000) ^. from microseconds+ liftIO $ IO.hPutStrLn hOut $ showTime (posixSecondsToUTCTime t) <> " (" <> show w <> " ms)"+ Just (Known F.TimeMicros64LE) ->+ forM_ (LBS.chunkBy 8 (segment ^. L.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 ^. L.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.Int64LE) ->+ forM_ (LBS.chunkBy 8 (segment ^. L.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 ^. L.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 ^. L.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 ^. L.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 ^. L.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 ^. L.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 ^. L.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 ^. L.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 ^. L.payload)+ Just (Known F.BitString) ->+ liftIO $ IO.hPutStrLn hOut (bitShow (segment ^. L.payload))+ _ ->+ forM_ (zip (LBS.chunkBy 16 (segment ^. L.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 ""++ where magic = AP.string "seg:" *> (BS.pack <$> many AP.anyWord8) AP.<?> "\"seg:????\""
+ app/App/Commands/EncodeFiles.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.EncodeFiles where++import App.Commands.Options.Type+import Arbor.File.Format.Asif.ByteString.Builder+import Arbor.File.Format.Asif.IO+import Conduit+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource (MonadResource, runResourceT)+import Data.Monoid+import Options.Applicative++import qualified App.Commands.Options.Lens as L+import qualified Data.ByteString as BS+import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as C+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified System.IO as IO++parseEncodeFilesOptions :: Parser EncodeFilesOptions+parseEncodeFilesOptions = EncodeFilesOptions+ <$> strOption+ ( long "source"+ <> metavar "FILE"+ <> help "Input file"+ )+ <*> strOption+ ( long "target"+ <> metavar "FILE"+ <> value "-"+ <> help "Output file"+ )+ <*> strOption+ ( long "asif-type"+ <> metavar "ASIF_TYPE"+ <> help "The magic extension of the asif file"+ )++commandEncodeFiles :: Parser (IO ())+commandEncodeFiles = runResourceT . runEncodeFiles <$> parseEncodeFilesOptions++runEncodeFiles :: MonadResource m => EncodeFilesOptions -> m ()+runEncodeFiles opt = do+ let sourcePath = opt ^. L.source+ filenamesContents <- liftIO $ BS.readFile (sourcePath <> "/.asif/filenames")+ let filenames = mfilter (/= "") $ T.decodeUtf8 <$> BS.split 0 filenamesContents++ handles <- forM filenames $ \filename -> do+ h <- liftIO $ IO.openFile (sourcePath <> "/" <> T.unpack filename) IO.ReadWriteMode+ liftIO $ IO.hSeek h IO.SeekFromEnd 0+ return h++ let contents = segmentsRawC (opt ^. L.asifType) handles++ (_, hTarget) <- openFileOrStd (opt ^. L.target) IO.WriteMode++ C.runConduit $ contents .| C.sinkHandle hTarget++ liftIO $ IO.hFlush hTarget
+ app/App/Commands/ExtractFiles.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.ExtractFiles where++import App.Commands.Options.Type+import Arbor.File.Format.Asif.IO+import Arbor.File.Format.Asif.Segment+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource (MonadResource, runResourceT)+import Data.List+import Data.Maybe+import Data.Monoid+import Options.Applicative+import System.Directory++import qualified App.Commands.Options.Lens as L+import qualified Arbor.File.Format.Asif.Lens as L+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map as M+import qualified Data.Text as T+import qualified System.Directory as IO+import qualified System.IO as IO++parseExtractFilesOptions :: Parser ExtractFilesOptions+parseExtractFilesOptions = ExtractFilesOptions+ <$> strOption+ ( long "source"+ <> metavar "FILE"+ <> value "-"+ <> help "Input file"+ )+ <*> strOption+ ( long "target"+ <> metavar "PATH"+ <> help "Output directory"+ )++commandExtractFiles :: Parser (IO ())+commandExtractFiles = runResourceT . runExtractFiles <$> parseExtractFilesOptions++runExtractFiles :: MonadResource m => ExtractFilesOptions -> m ()+runExtractFiles opt = do+ (_, hIn) <- openFileOrStd (opt ^. L.source) IO.ReadMode+ 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 "" . (^. L.meta . L.filename) <$> segments+ let namedSegments = M.fromList $ mfilter ((/= "") . fst) (zip filenames segments)+ let targetPath = opt ^. L.target++ liftIO $ IO.hPutStrLn IO.stderr $ "Writing to: " <> targetPath+ liftIO $ createDirectoryIfMissing True targetPath++ forM_ (zip [0..] filenames) $ \(i :: Int, filename) ->+ case M.lookup filename namedSegments of+ Just segment -> do+ let outFilename = T.pack targetPath <> "/" <> filename+ let basename = mconcat (intersperse "/" (init (T.splitOn "/" outFilename)))+ liftIO $ IO.createDirectoryIfMissing True (T.unpack basename)+ liftIO $ LBS.writeFile (T.unpack outFilename) (segment ^. L.payload)+ Nothing ->+ liftIO $ IO.hPutStrLn IO.stderr $ "Segment " <> show i <> " has no filename. Skipping"++ where magic = AP.string "seg:" *> (BS.pack <$> many AP.anyWord8) AP.<?> "\"seg:????\""
+ app/App/Commands/ExtractSegments.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.ExtractSegments where++import App.Commands.Options.Type+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.Monoid+import Options.Applicative+import System.Directory+import Text.Printf++import qualified App.Commands.Options.Lens as L+import qualified Arbor.File.Format.Asif.Lens as L+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified System.IO as IO++parseExtractSegmentsOptions :: Parser ExtractSegmentsOptions+parseExtractSegmentsOptions = ExtractSegmentsOptions+ <$> strOption+ ( long "source"+ <> metavar "FILE"+ <> value "-"+ <> help "Input file"+ )+ <*> strOption+ ( long "target"+ <> metavar "PATH"+ <> help "Output directory"+ )++commandExtractSegments :: Parser (IO ())+commandExtractSegments = runResourceT . runExtractSegments <$> parseExtractSegmentsOptions++runExtractSegments :: MonadResource m => ExtractSegmentsOptions -> m ()+runExtractSegments opt = do+ (_, hIn) <- openFileOrStd (opt ^. L.source) IO.ReadMode+ contents <- liftIO $ LBS.hGetContents hIn+ -- TODO pass in magic+ case extractSegments magic contents of+ Left errorMessage -> do+ liftIO $ IO.hPutStrLn IO.stderr $ "Error occured: " <> errorMessage+ return ()+ Right segments -> do+ let targetPath = opt ^. L.target++ liftIO $ IO.hPutStrLn IO.stderr $ "Writing to: " <> targetPath++ liftIO $ createDirectoryIfMissing True targetPath++ forM_ (zip [0..] segments) $ \(i :: Int, segment) ->+ liftIO $ LBS.writeFile (targetPath <> "/" <> printf "%03d" i <> ".seg") (segment ^. L.payload)+ where magic = AP.string "seg:" *> (BS.pack <$> many AP.anyWord8) AP.<?> "\"seg:????\""
+ app/App/Commands/Options/Lens.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TemplateHaskell #-}++module App.Commands.Options.Lens where++import App.Commands.Options.Type+import Control.Lens++makeFields ''DumpOptions+makeFields ''EncodeFilesOptions+makeFields ''ExtractFilesOptions+makeFields ''ExtractSegmentsOptions
+ app/App/Commands/Options/Type.hs view
@@ -0,0 +1,22 @@+module App.Commands.Options.Type where++data EncodeFilesOptions = EncodeFilesOptions+ { encodeFilesOptionsSource :: FilePath+ , encodeFilesOptionsTarget :: FilePath+ , encodeFilesOptionsAsifType :: String+ } deriving (Eq, Show)++data ExtractFilesOptions = ExtractFilesOptions+ { extractFilesOptionsSource :: FilePath+ , extractFilesOptionsTarget :: FilePath+ } deriving (Eq, Show)++data ExtractSegmentsOptions = ExtractSegmentsOptions+ { extractSegmentsOptionsSource :: FilePath+ , extractSegmentsOptionsTarget :: FilePath+ } deriving (Eq, Show)++data DumpOptions = DumpOptions+ { dumpOptionsSource :: FilePath+ , dumpOptionsTarget :: FilePath+ } deriving (Eq, Show)
+ app/App/IO.hs view
@@ -0,0 +1,12 @@+module App.IO where++import System.IO++withFileOrStd :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFileOrStd filePath mode f = if filePath == "-"+ then case mode of+ ReadMode -> f stdin+ WriteMode -> f stdout+ AppendMode -> f stdout+ _ -> error "Cannot open stdin or std out with read/write mode"+ else withFile filePath mode f
+ app/Main.hs view
@@ -0,0 +1,17 @@+module Main+ ( main+ ) where++import App.Commands+import Control.Monad+import Data.Semigroup+import Options.Applicative++import qualified System.IO as IO++main :: IO ()+main = do+ IO.hSetBuffering IO.stderr IO.LineBuffering+ join $ customExecParser+ (prefs $ showHelpOnEmpty <> showHelpOnError)+ (info (globalOptions <**> helper) idm)
+ asif.cabal view
@@ -0,0 +1,159 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 975b1a79df9badb8768dba82941d8968275d859920847e829d62a65978901884++name: asif+version: 1.0.0+description: Please see the README on Github at <https://github.com/packetloop/asif#readme>+category: Services+homepage: https://github.com/packetloop/asif#readme+bug-reports: https://github.com/packetloop/asif/issues+author: Tyler Durden+maintainer: tyler.durden@arbor.net+copyright: Arbor Networks+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ ChangeLog.md+ README.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:+ attoparsec+ , base >=4.7 && <5+ , binary+ , bytestring+ , conduit+ , conduit-combinators+ , conduit-extra+ , containers+ , cpu+ , either+ , exceptions+ , hw-bits+ , iproute+ , lens+ , old-locale+ , resourcet+ , temporary-resourcet+ , text+ , thyme+ , vector+ exposed-modules:+ Arbor.File.Format.Asif+ Arbor.File.Format.Asif.ByIndex+ Arbor.File.Format.Asif.ByteString+ Arbor.File.Format.Asif.ByteString.Builder+ Arbor.File.Format.Asif.ByteString.Lazy+ Arbor.File.Format.Asif.Data.Ip+ Arbor.File.Format.Asif.Data.Read+ Arbor.File.Format.Asif.Extract+ Arbor.File.Format.Asif.Format+ Arbor.File.Format.Asif.Get+ Arbor.File.Format.Asif.IO+ Arbor.File.Format.Asif.Lens+ Arbor.File.Format.Asif.Lookup+ Arbor.File.Format.Asif.Segment+ Arbor.File.Format.Asif.Type+ Arbor.File.Format.Asif.Whatever+ other-modules:+ 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+ default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -O2 -msse4.2+ build-depends:+ asif+ , attoparsec+ , base >=4.7 && <5+ , binary+ , bytestring+ , conduit+ , conduit-combinators+ , conduit-extra+ , containers+ , cpu+ , directory+ , either+ , exceptions+ , hw-bits+ , iproute+ , lens+ , old-locale+ , optparse-applicative+ , resourcet+ , temporary-resourcet+ , text+ , thyme+ , vector+ other-modules:+ App.Commands+ App.Commands.Dump+ App.Commands.EncodeFiles+ App.Commands.ExtractFiles+ App.Commands.ExtractSegments+ App.Commands.Options.Lens+ App.Commands.Options.Type+ App.IO+ Paths_asif+ default-language: Haskell2010++test-suite asif-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ default-extensions: BangPatterns FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings TupleSections+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ arbor-ip+ , asif+ , attoparsec+ , base >=4.7 && <5+ , binary+ , bytestring+ , conduit+ , conduit-combinators+ , conduit-extra+ , containers+ , cpu+ , either+ , exceptions+ , hedgehog+ , hspec+ , hw-bits+ , hw-hspec-hedgehog+ , iproute+ , lens+ , old-locale+ , resourcet+ , temporary-resourcet+ , text+ , thyme+ , vector+ other-modules:+ Arbor.File.Format.Asif.ByteString.BuilderSpec+ Arbor.File.Format.Asif.Data.IpSpec+ Arbor.File.Format.AsifSpec+ Gen.Feed+ TestApp+ Paths_asif+ default-language: Haskell2010
+ src/Arbor/File/Format/Asif.hs view
@@ -0,0 +1,3 @@+module Arbor.File.Format.Asif+ (+ ) where
+ src/Arbor/File/Format/Asif/ByIndex.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Arbor.File.Format.Asif.ByIndex+ ( ByIndex(..)+ ) where++import Data.Monoid++import qualified Data.Semigroup as S++newtype ByIndex a = ByIndex+ { unByIndex :: [a]+ } deriving (Eq, Show)++instance (Monoid a, S.Semigroup a) => S.Semigroup (ByIndex a) where+ ByIndex as <> ByIndex bs = ByIndex (appendByIndex as bs)++instance (Monoid a, S.Semigroup a) => Monoid (ByIndex a) where+ mappend = (S.<>)+ mempty = ByIndex []++appendByIndex :: (Monoid a, S.Semigroup a) => [a] -> [a] -> [a]+appendByIndex (a:as) (b:bs) = (a <> b):appendByIndex as bs+appendByIndex (a:as) bs = a :appendByIndex as bs+appendByIndex as (b:bs) = b :appendByIndex as bs+appendByIndex [] [] = []
+ src/Arbor/File/Format/Asif/ByteString.hs view
@@ -0,0 +1,12 @@++module Arbor.File.Format.Asif.ByteString where++import Data.ByteString (ByteString)++import qualified Data.ByteString as BS++chunkBy :: Int -> ByteString -> [ByteString]+chunkBy n bs = case (BS.take n bs, BS.drop n bs) of+ (as, zs) -> if BS.null zs+ then [as]+ else as:chunkBy n zs
+ src/Arbor/File/Format/Asif/ByteString/Builder.hs view
@@ -0,0 +1,116 @@+module Arbor.File.Format.Asif.ByteString.Builder+ ( magicString+ , withSize+ , segmentsC+ , segmentsRawC+ , makeMagic+ , magicLength+ ) where++import Arbor.File.Format.Asif.Type+import Arbor.File.Format.Asif.Whatever+import Conduit+import Control.Lens+import Control.Monad+import Data.Bits+import Data.ByteString.Builder+import Data.Conduit (Source)+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.Lens as L+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)++magicPrefix :: IsString a => a+magicPrefix = "seg:"++-- magic file identifier for segmented gan feeds.+-- 7 characters. the 8th is meant to be filled in based on feed.+magicString :: String -> LC8.ByteString+magicString s = if LBS.length truncatedMagic < LBS.length rawMagic+ then truncatedMagic+ else error $ "Magic length of " <> show (LC8.unpack truncatedMagic) <> " cannot be greater than " <> show magicLength+ where rawMagic = LC8.pack magicPrefix <> LC8.pack s <> LBS.replicate 12 0+ truncatedMagic = LBS.take magicLength rawMagic++magicLength :: Int64+magicLength = 16++padding64 :: Int64 -> Int64+padding64 s = (8 - s) `mod` 8++withSize :: LBS.ByteString -> (Int64, LBS.ByteString)+withSize bs = (LBS.length bs, bs)++headerLen :: Int64 -> Int64+headerLen n = w64 + magicLength + n * w64+ where w64 :: Int64+ w64 = fromIntegral $ finiteBitSize (0 :: Word64) `quot` 8++intersperse :: Int64 -> Int64 -> B.Builder+intersperse a b = B.word32LE (fromIntegral a) <> B.word32LE (fromIntegral b)++segmentsRawC :: MonadIO m => String -> [IO.Handle] -> Source m BS.ByteString+segmentsRawC asifType handles = do+ let segmentCount = fromIntegral $ length handles :: Int64++ rawSizes <- forM handles $ liftIO . IO.hGetAndResetOffset+ let paddings = padding64 <$> rawSizes+ let paddedSizes = uncurry (+) <$> zip rawSizes paddings++ let offsets = (+ headerLen segmentCount) <$> init (scanl (+) 0 paddedSizes)+ let positions = zip offsets rawSizes++ CL.sourceList+ [ LBS.toStrict . B.toLazyByteString $ makeMagic asifType+ <> B.word64LE (fromIntegral segmentCount) -- seg num+ <> mconcat (uncurry intersperse <$> positions)+ ]++ forM_ (zip paddings handles) $ \(padding, h) -> do+ sourceHandle h+ CL.sourceList (replicate (fromIntegral padding) (BS.singleton 0))++segmentsC :: (MonadIO m, MonadResource m)+ => String+ -> Maybe POSIXTime+ -> [Segment IO.Handle]+ -> m (Source m BS.ByteString)+segmentsC asifType maybeTimestamp metas = do+ fileTime <- maybe (liftIO getPOSIXTime) return maybeTimestamp+ (_, _, hFilenames ) <- IO.openTempFile Nothing "asif-filenames"+ (_, _, hCreateTimes ) <- IO.openTempFile Nothing "asif-timestamps"+ (_, _, hFormats ) <- IO.openTempFile Nothing "asif-formats"++ let metaMeta = metaCreateTime fileTime+ let metaFilenames = segment hFilenames $ metaMeta <> metaFilename ".asif/filenames" <> metaFormat (Known F.StringZ)+ let metaCreateTimes = segment hCreateTimes $ metaMeta <> metaFilename ".asif/createtimes" <> metaFormat (Known F.TimeMicros64LE)+ let metaFormats = segment hFormats $ metaMeta <> metaFilename ".asif/formats" <> metaFormat (Known F.StringZ)+ let moreMetas = metaFilenames:metaCreateTimes:metaFormats:metas++ forM_ moreMetas $ \meta -> do+ liftIO $ B.hPutBuilder hFilenames $ B.byteString (meta ^. L.meta . L.filename & fromMaybe "" & T.encodeUtf8) <> B.word8 0+ liftIO $ B.hPutBuilder hCreateTimes $ B.int64LE $ (meta ^. L.meta . L.createTime) <&> (^. microseconds) & fromMaybe 0+ liftIO $ B.hPutBuilder hFormats $ B.byteString (meta ^. L.meta . L.format <&> tShowWhatever & fromMaybe "" & T.encodeUtf8) <> B.word8 0+ return ()++ let source = segmentsRawC asifType ((^. L.payload) <$> moreMetas)++ return source
+ src/Arbor/File/Format/Asif/ByteString/Lazy.hs view
@@ -0,0 +1,13 @@++module Arbor.File.Format.Asif.ByteString.Lazy where++import Data.ByteString.Lazy (ByteString)+import Data.Int++import qualified Data.ByteString.Lazy as LBS++chunkBy :: Int64 -> ByteString -> [ByteString]+chunkBy n bs = case (LBS.take n bs, LBS.drop n bs) of+ (as, zs) -> if LBS.null zs+ then [as]+ else as:chunkBy n zs
+ src/Arbor/File/Format/Asif/Data/Ip.hs view
@@ -0,0 +1,26 @@+module Arbor.File.Format.Asif.Data.Ip+ ( stringToIpv4+ , ipv4ToString+ , word32ToIpv4+ , ipv4ToWord32+ ) where++import Arbor.File.Format.Asif.Data.Read+import Data.IP+import Data.Word+import System.Endian+import Text.Read++stringToIpv4 :: String -> Maybe IPv4+stringToIpv4 str = if '.' `elem` str+ then readMaybe str+ else word32ToIpv4 <$> stringToAnyDigits str++ipv4ToString :: IPv4 -> String+ipv4ToString = show++word32ToIpv4 :: Word32 -> IPv4+word32ToIpv4 = fromHostAddress . toBE32++ipv4ToWord32 :: IPv4 -> Word32+ipv4ToWord32 = fromBE32 . toHostAddress
+ src/Arbor/File/Format/Asif/Data/Read.hs view
@@ -0,0 +1,9 @@+module Arbor.File.Format.Asif.Data.Read+ ( stringToAnyDigits+ ) where++import Control.Monad+import Text.Read++stringToAnyDigits :: (Read a, Show a) => String -> Maybe a+stringToAnyDigits str = mfilter ((== str) . show) $ readMaybe str
+ src/Arbor/File/Format/Asif/Extract.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Arbor.File.Format.Asif.Extract+ ( formats+ , list+ , map+ , vectorBoxed+ , 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 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+ where step !s = case runGetOrFail g s of+ Left (_, _, _) -> Nothing+ Right (!rs, _, !k) -> Just (k, rs)++vectorUnboxed :: VU.Unbox a => Get a -> LBS.ByteString -> VU.Vector a+vectorUnboxed g = VU.unfoldr step+ where step !s = case runGetOrFail g s of+ Left (_, _, _) -> Nothing+ Right (!rs, _, !k) -> Just (k, rs)++list :: Get a -> LBS.ByteString -> [a]+list g = G.runGet go+ where go = do+ empty <- G.isEmpty+ if not empty+ then (:) <$> g <*> go+ else return []++map :: (Ord a) => LBS.ByteString -> Get a -> LBS.ByteString -> Get b -> M.Map a b+map ks kf vs vf = foldr (\(k, v) m -> M.insert k v m) M.empty $ zip keys values+ where+ keys = list kf ks+ values = list vf vs++formats :: LBS.ByteString -> [Maybe (Whatever Format)]+formats bs = LBS.split 0 bs <&> decodeUtf8' . LBS.toStrict <&> convert+ where convert :: Either UnicodeException Text -> Maybe (Whatever Format)+ convert (Left _) = Nothing+ convert (Right "") = Nothing+ convert (Right t) = Just (tReadWhatever t)
+ src/Arbor/File/Format/Asif/Format.hs view
@@ -0,0 +1,21 @@+module Arbor.File.Format.Asif.Format where++data Format+ = Binary+ | BitString+ | Char+ | Int8+ | Int16LE+ | Int32LE+ | Int64LE+ | Ipv4+ | Repeat Word Format+ | StringZ+ | Text+ | TimeMicros64LE+ | TimeMillis64LE+ | Word8+ | Word16LE+ | Word32LE+ | Word64LE+ deriving (Eq, Read, Show)
+ src/Arbor/File/Format/Asif/Get.hs view
@@ -0,0 +1,47 @@+module Arbor.File.Format.Asif.Get where++import Arbor.File.Format.Asif.ByteString.Builder+import Control.Lens+import Control.Monad+import Data.Binary.Get+import Data.Monoid+import Data.Text (Text)+import Data.Thyme.Clock (microseconds)+import Data.Thyme.Clock.POSIX (POSIXTime)++import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LC8+import qualified Data.Text.Encoding as T++getMagic :: AP.Parser BS.ByteString -> Get ()+getMagic magicParser = do+ a <- getLazyByteString magicLength+ case AP.parseOnly magicParser (LBS.toStrict a) of+ Right _ -> return ()+ Left errorMessage -> fail $ "wrong magic: \"" <> LC8.unpack a <> "\", expected: " <> errorMessage++getSegmentLength :: Get Int+getSegmentLength = fromIntegral <$> getInt64le++getSegmentPosition :: Get (Int, Int)+getSegmentPosition = (,)+ <$> (fromIntegral <$> getInt32le)+ <*> (fromIntegral <$> getInt32le)++getSegmentPositions :: Get [(Int, Int)]+getSegmentPositions = do+ n <- getSegmentLength+ replicateM n getSegmentPosition++getHeader :: AP.Parser BS.ByteString -> Get [(Int, Int)]+getHeader magicParser = do+ getMagic magicParser+ getSegmentPositions++getTimeMicro64 :: Get POSIXTime+getTimeMicro64 = (^. from microseconds) <$> getInt64le++getTextUtf8Z :: Get Text+getTextUtf8Z = T.decodeUtf8 . LBS.toStrict <$> getLazyByteStringNul
+ src/Arbor/File/Format/Asif/IO.hs view
@@ -0,0 +1,33 @@+module Arbor.File.Format.Asif.IO where++import Conduit+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Resource+import Data.Int+import System.IO++import qualified GHC.IO.Handle as IO+import qualified System.IO as IO++withFileOrStd :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFileOrStd filePath mode f = if filePath == "-"+ then case mode of+ ReadMode -> f stdin+ WriteMode -> f stdout+ AppendMode -> f stdout+ _ -> error "Cannot open stdin or std out with read/write mode"+ else withFile filePath mode f++hGetAndResetOffset :: MonadIO m => IO.Handle -> m Int64+hGetAndResetOffset h = do+ IO.HandlePosn _ offset <- liftIO $ IO.hGetPosn h+ liftIO $ hFlush h+ liftIO $ hSeek h AbsoluteSeek 0+ return (fromIntegral offset)++openFileOrStd :: MonadResource m => FilePath -> IO.IOMode -> m (ReleaseKey, IO.Handle)+openFileOrStd "-" IO.WriteMode = allocate (return IO.stdout) (const (return ()))+openFileOrStd "-" IO.ReadMode = allocate (return IO.stdin) (const (return ()))+openFileOrStd filePath ioMode = allocate+ (liftIO $ IO.openFile filePath ioMode)+ (liftIO . IO.hClose)
+ src/Arbor/File/Format/Asif/Lens.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TemplateHaskell #-}++module Arbor.File.Format.Asif.Lens where++import Arbor.File.Format.Asif.Format+import Arbor.File.Format.Asif.Type+import Control.Lens++makeFields ''Format+makeFields ''Segment+makeFields ''SegmentMeta
+ src/Arbor/File/Format/Asif/Lookup.hs view
@@ -0,0 +1,43 @@+module Arbor.File.Format.Asif.Lookup where++import Control.Monad+import Data.Text (Text)++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map.Strict as M+import qualified Data.Vector.Unboxed as VU++binarySearch :: (Ord a, VU.Unbox a) => a -> VU.Vector a -> Maybe Int+binarySearch key values = do+ guard (not (VU.null values))+ let idx = s 0 (VU.length values - 1)+ guard (idx > -1)+ return idx+ where+ s l h+ | l >= h =+ if (values VU.! h) <= key then h else -1+ | otherwise = do+ let m = l + (h - l) `div` 2+ if (values VU.! m) > key then s l m+ else do+ let result = s (m + 1) h+ if result == -1 then m+ else result++binarySearchExact :: (Ord a, VU.Unbox a) => a -> VU.Vector a -> Maybe Int+binarySearchExact key values = go values key 0 (VU.length values - 1)+ where+ go hay needle lo hi+ | hi < lo = Nothing+ | pivot > needle = go hay needle lo (mid - 1)+ | pivot < needle = go hay needle (mid + 1) hi+ | otherwise = Just mid+ where+ mid = lo + (hi - lo) `div` 2+ pivot = hay VU.! mid++lookupSegment :: Text -> M.Map Text LBS.ByteString -> (LBS.ByteString -> [a]) -> [a]+lookupSegment filename directory f = case M.lookup filename directory of+ Just bs -> f bs+ Nothing -> []
+ src/Arbor/File/Format/Asif/Maybe.hs view
@@ -0,0 +1,6 @@+module Arbor.File.Format.Asif.Maybe where++secondJust :: Maybe a -> Maybe a -> Maybe a+secondJust _ (Just b) = Just b+secondJust (Just a) _ = Just a+secondJust _ _ = Nothing
+ src/Arbor/File/Format/Asif/Segment.hs view
@@ -0,0 +1,70 @@+module Arbor.File.Format.Asif.Segment+ ( Segment(..)+ , mkDefaultSegment+ , extractSegments+ , extractNamedSegments+ , segmentNamed+ ) where++import Arbor.File.Format.Asif.ByIndex+import Arbor.File.Format.Asif.Get+import Arbor.File.Format.Asif.Lookup+import Arbor.File.Format.Asif.Type+import Control.Lens+import Control.Monad+import Data.Binary.Get+import Data.Maybe+import Data.Monoid+import Data.Text (Text, pack)++import qualified Arbor.File.Format.Asif.Extract as E+import qualified Arbor.File.Format.Asif.Get as G+import qualified Arbor.File.Format.Asif.Lens as L+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LC8+import qualified Data.Map.Strict as M++mkDefaultSegment :: LBS.ByteString -> Segment LBS.ByteString+mkDefaultSegment bs = segment bs mempty++extractSegments :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String [Segment LBS.ByteString]+extractSegments magicParser bs = do+ bss <- extractSegmentByteStrings magicParser bs+ case bss of+ (as:_) -> if ".asif/filenames\0" `LBS.isPrefixOf` as+ then do+ let filenames = E.list G.getTextUtf8Z as+ let namedSegments = M.fromList (zip filenames bss)++ let metas = mempty+ <> ByIndex (replicate (length bss) mempty)+ <> ByIndex (metaFilename <$> filenames)+ <> ByIndex (metaCreateTime <$> lookupSegment ".asif/createtimes" namedSegments (E.list G.getTimeMicro64))+ <> ByIndex (metaMaybeFormat <$> lookupSegment ".asif/formats" namedSegments E.formats)++ return $ uncurry segment <$> zip bss (unByIndex metas)+ else return (mkDefaultSegment <$> bss)+ _ -> return (mkDefaultSegment <$> bss)++extractNamedSegments :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String (M.Map Text (Segment LBS.ByteString))+extractNamedSegments magicParser bs = do+ segments <- extractSegments magicParser bs+ let filenames = fromMaybe "" . (^. L.meta . L.filename) <$> segments+ return $ M.fromList $ zip filenames segments++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+ 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) $+ fail "XXX segments not read correctly"+ return segs++segmentNamed :: String -> M.Map Text (Segment LC8.ByteString) -> Either String LC8.ByteString+segmentNamed name segments = do+ let seg = M.lookup (pack name) segments >>= (\s -> Just (s ^. L.payload))+ seg & maybe (Left ("Missing segment: " ++ name)) Right
+ src/Arbor/File/Format/Asif/Text.hs view
@@ -0,0 +1,12 @@+module Arbor.File.Format.Asif.Text where++import Data.Text (Text)+import Text.Read++import qualified Data.Text as T++tShow :: Show a => a -> Text+tShow = T.pack . show++tReadMaybe :: Read a => Text -> Maybe a+tReadMaybe = readMaybe . T.unpack
+ src/Arbor/File/Format/Asif/Type.hs view
@@ -0,0 +1,60 @@+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+import Data.Text (Text)+import Data.Thyme.Clock.POSIX (POSIXTime)++data SegmentMeta = SegmentMeta+ { _segmentMetaCreateTime :: Maybe POSIXTime+ , _segmentMetaFilename :: Maybe Text+ , _segmentMetaFormat :: Maybe (Whatever Format)+ } deriving (Eq, Show)++instance Semigroup SegmentMeta where+ a <> b = SegmentMeta+ { _segmentMetaCreateTime = _segmentMetaCreateTime a `secondJust` _segmentMetaCreateTime b+ , _segmentMetaFilename = _segmentMetaFilename a `secondJust` _segmentMetaFilename b+ , _segmentMetaFormat = _segmentMetaFormat a `secondJust` _segmentMetaFormat b+ }++instance Monoid SegmentMeta where+ mappend = (<>)+ mempty = SegmentMeta+ { _segmentMetaCreateTime = Nothing+ , _segmentMetaFilename = Nothing+ , _segmentMetaFormat = Nothing+ }++data Segment a = Segment+ { _segmentMeta :: SegmentMeta+ , _segmentPayload :: a+ }++segment :: a -> SegmentMeta -> Segment a+segment payload meta = Segment+ { _segmentMeta = meta+ , _segmentPayload = payload+ }++metaCreateTime :: POSIXTime -> SegmentMeta+metaCreateTime time = mempty+ { _segmentMetaCreateTime = Just time+ }++metaFilename :: Text -> SegmentMeta+metaFilename filePath = mempty+ { _segmentMetaFilename = Just filePath+ }++metaFormat :: Whatever Format -> SegmentMeta+metaFormat format = mempty+ { _segmentMetaFormat = Just format+ }++metaMaybeFormat :: Maybe (Whatever Format) -> SegmentMeta+metaMaybeFormat maybeFormat = mempty+ { _segmentMetaFormat = maybeFormat+ }
+ src/Arbor/File/Format/Asif/Whatever.hs view
@@ -0,0 +1,35 @@+module Arbor.File.Format.Asif.Whatever where++import Data.Text (Text)+import GHC.Read+import Text.ParserCombinators.ReadP as P+import Text.ParserCombinators.ReadPrec++import qualified Data.Text as T+import qualified Text.ParserCombinators.ReadPrec as R++data Whatever a = Known a | Unknown Text deriving Eq++instance Show a => Show (Whatever a) where+ showsPrec n (Known a) = showsPrec n a+ showsPrec _ (Unknown t) = (T.unpack t ++)++showWhatever :: Show a => Whatever a -> String+showWhatever (Known a) = show a+showWhatever (Unknown a) = T.unpack a++readWhatever :: Read a => String -> Whatever a+readWhatever s =+ case [x | (x,"") <- R.readPrec_to_S read' R.minPrec s] of+ [x] -> Known x+ _ -> Unknown (T.pack s)+ where read' = do+ x <- readPrec+ lift P.skipSpaces+ return x++tShowWhatever :: Show a => Whatever a -> Text+tShowWhatever = T.pack . showWhatever++tReadWhatever :: Read a => Text -> Whatever a+tReadWhatever = readWhatever . T.unpack
+ test/Arbor/File/Format/Asif/ByteString/BuilderSpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Arbor.File.Format.Asif.ByteString.BuilderSpec+ ( spec+ ) where++import Arbor.File.Format.Asif.ByteString.Builder+import Arbor.File.Format.Asif.Segment+import Conduit+import Control.Lens+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import System.IO (openTempFile)+import Test.Hspec++import qualified Arbor.File.Format.Asif as C+import qualified Arbor.File.Format.Asif.ByteString.Builder as LB+import qualified Arbor.File.Format.Asif.Lens as L+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+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 "App.ByteString.Lazy.Builder" $ do+ it "should extract segments" $ require $ withTests 1 $ property $ do+ b1 :: LBS.ByteString <- forAll $ flip LBS.replicate 65 <$> G.int64 (R.linear 0 10)+ b2 :: LBS.ByteString <- forAll $ flip LBS.replicate 66 <$> G.int64 (R.linear 0 10)+ b3 :: LBS.ByteString <- forAll $ flip LBS.replicate 67 <$> G.int64 (R.linear 0 10)++ (_, h1) <- liftIO $ openTempFile "/tmp" "h1.tmp"+ (_, h2) <- liftIO $ openTempFile "/tmp" "h2.tmp"+ (_, h3) <- liftIO $ openTempFile "/tmp" "h3.tmp"++ (_, he) <- liftIO $ openTempFile "/tmp" "he.tmp"++ liftIO $ BS.hPut h1 (LBS.toStrict b1)+ liftIO $ BS.hPut h2 (LBS.toStrict b2)+ liftIO $ BS.hPut h3 (LBS.toStrict b3)++ let segs = LB.segmentsRawC "wxyz"+ [ h1+ , h2+ , h3+ ]++ liftIO $ runConduit $ segs .| sinkHandle he++ liftIO $ IO.hSeek he IO.AbsoluteSeek 0++ contents <- liftIO $ LBS.hGetContents he++ _ <- forAll $ pure $ LBS.unpack contents++ let Right segments = extractSegments (AP.string "seg:wxyz") contents++ ((^. L.payload) <$> segments) === [b1, b2, b3]
+ test/Arbor/File/Format/Asif/Data/IpSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Arbor.File.Format.Asif.Data.IpSpec+ ( spec+ ) where++import Arbor.File.Format.Asif.Data.Ip+import Conduit+import Control.Lens+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import System.IO (openTempFile)+import Test.Hspec++import qualified Arbor.File.Format.Asif as C+import qualified Arbor.File.Format.Asif.ByteString.Builder as LB+import qualified Arbor.File.Format.Asif.Lens as L+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+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.Data.Ip" $ do+ it "word32ToIpv4" $ requireTest $ do+ show (word32ToIpv4 1) === "0.0.0.1"+ it "ipv4ToString" $ requireTest $ do+ ipv4ToString (word32ToIpv4 1) === "0.0.0.1"+ it "stringToIpv4" $ requireTest $ do+ show (stringToIpv4 "0.0.0.1") === "Just 0.0.0.1"+ it "stringToIpv4" $ requireTest $ do+ ipv4ToWord32 (word32ToIpv4 1) === 1
+ test/Arbor/File/Format/AsifSpec.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts #-}++module Arbor.File.Format.AsifSpec+( spec+) where++import Arbor.File.Format.Asif.Lookup+import Data.Word (Word32)+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.Vector.Unboxed as VU++spec :: Spec+spec = describe "Arbor.File.Format.AsifSpec" $ do+ it "binarySearch: Find nothing in empty array" $ requireTest $ do+ let v = VU.fromList ([] :: [Word32])+ binarySearch 0 v === Nothing++ it "binarySearch: Find nothing if less than all" $ requireTest $ do+ let v = VU.fromList ([1] :: [Word32])+ binarySearch 0 v === Nothing++ it "binarySearch: Find if equal" $ requireTest $ do+ let v = VU.fromList ([1] :: [Word32])+ binarySearch 1 v === Just 0++ it "binarySearch: Find if more than some" $ requireTest $ do+ let v = VU.fromList ([1] :: [Word32])+ binarySearch 2 v === Just 0++ it "binarySearch: Find if in interval" $ requireTest $ do+ let v = VU.fromList ([1, 3] :: [Word32])+ binarySearch 2 v === Just 0++ it "binarySearchExact: Find nothing in empty array" $ requireTest $ do+ let v = VU.fromList ([] :: [Word32])+ binarySearchExact 0 v === Nothing++ it "binarySearchExact: Nothing if less" $ requireTest $ do+ let v = VU.fromList ([1] :: [Word32])+ binarySearchExact 0 v === Nothing++ it "binarySearchExact: Find if equal" $ requireTest $ do+ let v = VU.fromList ([1] :: [Word32])+ binarySearchExact 1 v === Just 0++ it "binarySearchExact: Nothing if more" $ requireTest $ do+ let v = VU.fromList ([1] :: [Word32])+ binarySearchExact 2 v === Nothing++ it "binarySearchExact: Nothing if in interval" $ requireTest $ do+ let v = VU.fromList ([1, 3] :: [Word32])+ binarySearchExact 2 v === Nothing
+ test/Gen/Feed.hs view
@@ -0,0 +1,42 @@+module Gen.Feed+ ( feedElement+ , feedElements+ , ipv4+ , ordBy+ ) where++import Arbor.Network.Ip+import Data.Word+import Hedgehog++import qualified Hedgehog.Gen as G+import qualified Hedgehog.Range as R++ipv4 :: MonadGen m => Word8 -> Word8 -> m IPv4+ipv4 start stop = do+ o1 <- w8+ o2 <- w8+ o3 <- w8+ o4 <- w8+ return $ ipFromOctets o1 o2 o3 o4+ where+ w8 = G.word8 (R.linear start stop)++feedElemIp :: MonadGen m => Range Word32 -> m Word32+feedElemIp = G.word32++feedElemValue :: MonadGen m => Range Word64 -> m Word64+feedElemValue = G.word64++feedElement :: MonadGen m => Word32 -> Word32 -> m (Word32, Word32, Word64)+feedElement from to = do+ let mid = to - (to - from) `div` 2+ (,,) <$> feedElemIp (R.linear from mid)+ <*> feedElemIp (R.linear mid to)+ <*> feedElemValue R.linearBounded++feedElements :: MonadGen m => Word32 -> Word32 -> m [(Word32, Word32, Word64)]+feedElements from to = G.list (R.linear 0 100) $ feedElement from to++ordBy :: Ord k => (a -> k) -> a -> a -> Ordering+ordBy f a b = compare (f a) (f b)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestApp.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module TestApp+where++import Control.Monad.Catch+import Control.Monad.IO.Class+import System.IO.Unsafe++newtype TestApp a = TestApp+ { unTestApp :: IO a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch)+++runTestApp :: TestApp a -> IO a+runTestApp = unTestApp++unsafeRunTest :: TestApp a -> a+unsafeRunTest = unsafePerformIO . runTestApp+{-# NOINLINE unsafeRunTest #-}