diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for pcapng + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Michał J. Gajda (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Michał J. Gajda nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# pcapng + +This is a partial implementation of PcapNG format +that can be used by Wireshark and system journal. +It provides a fast Conduit for your convenience. + +This release is provided without any warranty +in case you find it useful. +It will not be supported by the author. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,20 @@ +module Main where + +import Conduit +import Control.Lens +import Data.Conduit.List (consume) +import System.Environment + +import qualified Data.WordString32.Conduit as WSC +import Network.Pcap.NG.Block + +main :: IO () +main = do + getArgs >>= mapM_ parse + +parse filename = runConduitRes + $ WSC.sourceFile filename .| blockConduit .| blockTypes .| consume + +blockTypes = awaitForever $ \block -> do + liftIO $ print $ block ^. blockType + yield (block ^. blockType) diff --git a/pcapng.cabal b/pcapng.cabal new file mode 100644 --- /dev/null +++ b/pcapng.cabal @@ -0,0 +1,108 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: e97aedf78580aa053a52e55805fe5c3d47a6cd2a65fe41d68434e000c0940558 + +name: pcapng +version: 0.1.0.0 +description: PCAP-NG and PCAP format reader and writer. +homepage: https://github.com/mgajda/pcapng#readme +bug-reports: https://github.com/mgajda/pcapng/issues +author: Michał J. Gajda +maintainer: mjgajda@gmail.com +copyright: BSD3 +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/mgajda/pcapng + +library + exposed-modules: + Data.WordString32 + Data.WordString32.Conduit + Network.Pcap.NG.Block + Network.Pcap.NG.BlockType + Network.Pcap.NG.Endianness + Network.Pcap.NG.Options + other-modules: + Paths_pcapng + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , cereal + , cereal-conduit + , conduit + , conduit-extra >=1.3.0 + , lens + , resourcet + , text + , unliftio-core + default-language: Haskell2010 + +executable pcapng-exe + main-is: Main.hs + other-modules: + Paths_pcapng + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , cereal + , cereal-conduit + , conduit + , conduit-extra >=1.3.0 + , lens + , pcapng + , resourcet + , text + , unliftio-core + default-language: Haskell2010 + +test-suite pcapng-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Data.WordString32 + Test.Network.Pcap.NG.BlockType + Test.Network.Pcap.NG.Endianness + Test.Network.Pcap.NG.Options + Test.Validity.Enum + Paths_pcapng + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , base >=4.7 && <5 + , bytestring + , bytestring-arbitrary + , cereal + , cereal-conduit + , conduit + , conduit-extra >=1.3.0 + , directory + , filepath + , genvalidity-hspec + , genvalidity-property + , hspec + , hspec-core + , lens + , pcapng + , resourcet + , text + , unliftio-core + , validity + default-language: Haskell2010 diff --git a/src/Data/WordString32.hs b/src/Data/WordString32.hs new file mode 100644 --- /dev/null +++ b/src/Data/WordString32.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Word32 strings for convenient handling +-- Just like ByteString, but with 32-bit each +-- +-- Note that we only use methods from fast-parsing instance of xeno and XML Typelift +-- NOTE: put paper reference here when it is published +module Data.WordString32 ( + WordString -- opaque for safety + , fromBS + , toBS + , null + , index + , drop + , take + , takeBytes + , empty + , length + , append -- Use Semigroup.<> + ) where + +import Control.Exception (assert) +import qualified Data.ByteString as BS (empty, take) +import qualified Data.ByteString.Internal as BS +import Data.Function (on) +import Data.Word +import Debug.Trace +import Foreign.C.Types (CSize (..)) +import Foreign.ForeignPtr (ForeignPtr, castForeignPtr, + withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +import Prelude hiding (drop, length, null, take) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- | Opaque array of 32-bit words +data WordString = WS { + wsPtr :: ForeignPtr Word32 + , wsOffset :: Int + , wsLen :: Int + } + +instance Show WordString where + --show ws = show (BS.take 16 $ toBS ws) + show ws = + unwords [show bsOfs + ,show bsLen + ,show $ BS.take 16 bs + ,show $ BS.take 16 nullBs] + where + bs@(BS.PS bsPtr bsOfs bsLen) = toBS ws + nullBs = BS.PS bsPtr 0 bsLen + +-- | Assume these instances will not be used often. +instance Eq WordString where + (==) = (==) `on` toBS + +instance Ord WordString where + compare = compare `on` toBS + +-- TODO: make a direct conduit? +{-# INLINE fromBS #-} +fromBS :: BS.ByteString -> WordString +fromBS (BS.PS wsPtr bsOffset bsLen) = + if bsOffset `mod` 4 /= 0 + then error $ "ByteString offset must be divisible by 4 for Data.WordString32.fromBS, is: " <> show bsOffset + else + if bsLen `mod` 4 /= 0 + then error $ "ByteString length must be divisible by 4 for Data.WordString32.fromBS, is: " <> show bsLen + else WS (castForeignPtr wsPtr) wsOffset wsLen + where + wsOffset = bsOffset `div` 4 + wsLen = bsLen `div` 4 + +{-# INLINE toBS #-} +toBS :: WordString -> BS.ByteString +toBS (WS wsPtr wsOffset wsLen) = BS.PS (castForeignPtr wsPtr) (wsOffset*4) (wsLen*4) + +{-# INLINE index #-} +index :: WordString -> Int -> Word32 +index _ i | i < 0 = error "index cannot be negative" +index (WS wsPtr wsOffset wsLen) i = + assert (offset < wsLen) $ + unsafeDupablePerformIO $ + withForeignPtr wsPtr $ + (`peekElemOff` offset) + where + offset = wsOffset + i + +{-# INLINE null #-} +null :: WordString -> Bool +null (WS wsPtr wsOffset wsLen) = wsOffset == wsLen + +{-# INLINE drop #-} +drop :: Int -> WordString -> WordString +drop i _ | i < 0 = error "Dropping negative number of words" +drop i (WS wsPtr wsOffset wsLen) = + assert (newWsOffset WordString -> WordString +take i _ | i < 0 = error "Taking negative number of words" +take i (WS wsPtr wsOffset wsLen) = + WS wsPtr wsOffset $ min wsLen $ wsOffset+i + +{-# INLINE takeBytes #-} +takeBytes :: Int -> WordString -> WordString +takeBytes i _ | i < 0 = error "Taking negative number of bytes" +takeBytes i _ | i `mod` 4 /= 0 = error "Can only take number of bytes divisible by 4" +takeBytes i ws = take (i `div` 4) ws + +empty :: WordString +empty = fromBS $ BS.empty + +length :: WordString -> Int +length (WS _ ofs len) = len-ofs + +instance Monoid WordString where + mempty = empty + +instance Semigroup WordString where + (<>) = append + +foreign import ccall unsafe "string.h memcpy" c_memcpy + :: Ptr Word32 -> Ptr Word32 -> CSize -> IO (Ptr Word32) + +memcpy :: Ptr Word32 -> Ptr Word32 -> Int -> IO () +memcpy p q s = do + _ <- c_memcpy p q $ fromIntegral s*4 + return () + +append a b | null b = a +append a b | null a = b +append a@(WS aPtr aOffset aLen) + b@(WS bPtr bOffset bLen) = --trace (": " <> show a <> " <> " <> show b) $ + unsafeDupablePerformIO $ do + newPtr :: ForeignPtr Word32 <- mallocPlainForeignPtrBytes (4*totalLen) + withForeignPtr newPtr $ \destPtrA -> do + withForeignPtr aPtr $ \srcPtrA -> + memcpy destPtrA (srcPtrA `plusWords` aOffset) aWords + let destPtrB = (destPtrA :: Ptr Word32) `plusWords` aWords + withForeignPtr bPtr $ \srcPtrB -> + memcpy destPtrB (srcPtrB `plusWords` bOffset) bWords + let result = WS newPtr 0 totalLen + --trace ("result is: " <> show result) $ + return result + where + totalLen = aWords+bWords + aWords = aLen-aOffset + bWords = bLen-bOffset + +plusWords :: Ptr a -> Int -> Ptr a +plusWords a b = a `plusPtr` (b*4) + +indexWord16 :: BS.ByteString -> Word16 +indexWord16 = undefined + +indexWord64 :: WordString -> Word64 +indexWord64 = undefined diff --git a/src/Data/WordString32/Conduit.hs b/src/Data/WordString32/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/Data/WordString32/Conduit.hs @@ -0,0 +1,57 @@ +module Data.WordString32.Conduit( + sourceFile + , sinkFile + , atLeast + ) where + +import Control.Monad.Trans.Resource (MonadResource (..)) +import qualified Data.ByteString as BS +import Data.Conduit (ConduitT, await, yield, (.|)) +import qualified Data.Conduit.Binary as C +import qualified Data.Conduit.List as C +import qualified Data.WordString32 as WS + +import Debug.Trace (trace) + +sourceFile :: (MonadResource m + ,MonadFail m) + => FilePath + -> ConduitT () WS.WordString m () +sourceFile filepath = C.sourceFile filepath .| go + where + go = do + maybeBs <- trace "sourceFile chunk" $ await + case maybeBs of + Nothing -> return () + Just bs | BS.length bs `mod` 4 /= 0 -> do + -- OMG, why do we need to do this (hspec error) + let msg = "Incorrect PCAP file - not aligned to 4 byte boundary: " <> show (BS.length bs) + trace msg $ + yield $ WS.fromBS $ BS.take ((BS.length bs `div` 4)*4) bs + return () -- fail after partial read + Just bs -> yield $ WS.fromBS bs + +sinkFile :: MonadResource m => FilePath -> ConduitT WS.WordString () m () +sinkFile filepath = C.map WS.toBS .| C.sinkFile filepath + +-- | Make sure that we give chunks of at least N words +-- +-- This conduit has a hidden state, so cannot be easily aborted. +-- NOTE: example of how conduit could get better by feedback upstream (needed input size) +-- WARNING: may lead to suboptimal performance if make misaligned reads +atLeast :: MonadFail m + => Int + -> ConduitT WS.WordString WS.WordString m () +atLeast n = go WS.empty + where + go rest = do + maybeChunk <- await + case maybeChunk of + Nothing | WS.null rest -> return () + Nothing -> fail + $ mconcat ["Not enough bytes to satisfy atLeast: ", + show $ WS.length rest, " wanting: ", show n] + Just chunk | WS.length rest + WS.length chunk >= n -> + trace "long chunk" $ + yield $ rest <> chunk + Just shortChunk -> trace "short chunk" $ go $ rest <> shortChunk diff --git a/src/Network/Pcap/NG/Block.hs b/src/Network/Pcap/NG/Block.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pcap/NG/Block.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.Pcap.NG.Block(Block(..) + ,blockType + ,blockEndianness + ,blockBody + ,blockConduit) where +-- * This module provides a PcapNG conduit +-- for undifferentiated, undecoded PcapNG blocks +-- without using libpcap per set. +-- It sticks to the same types, but allows reading any stream of packets +-- not necessarily from libpcap, file or live source. + +import Conduit +import Control.Exception (assert) +import Control.Lens +import Control.Lens.TH +import Control.Monad (when) +import qualified Data.ByteString.Char8 as BS +import qualified Data.WordString32 as WS +import qualified Data.WordString32.Conduit as WSC +import GHC.Generics + +import Network.Pcap.NG.BlockType +import Network.Pcap.NG.Endianness + +import Debug.Trace (trace) + +data Block = Block { + _blockType :: BlockType + , _blockEndianness :: Endianness + , _blockBody :: BS.ByteString + } deriving (Eq, Show, Generic) + +makeLenses ''Block + +blockConduit :: MonadFail m => ConduitT WS.WordString Block m () +blockConduit = WSC.atLeast 12 -- PcapNG files are expected to be word aligned, with 12 minimum block size + .| blockConduitWithEndianness sameEndianness -- SHB in the beginning should fix endianness anyway + +-- TODO: how to ensure unrolling on endianness? +blockConduitWithEndianness :: + Monad m + => Endianness + -> ConduitT WS.WordString Block m () +blockConduitWithEndianness endianness = + awaitForever $ \dta -> do + if dta `WS.index` 0 == 0x0A0D0D0A + then do -- Section header block, palindromic identification + -- identify endianness from magic number + let newEndianness | dta `WS.index` 2 == 0x1A2B3C4D = trace "same endianness" sameEndianness -- same endianness as the machine + | dta `WS.index` 2 == 0x4D3C2B1A = trace "other endianness" otherEndianness -- opposite endianness on magic + | otherwise = error $ "Cannot recover endianness from: " <> show (dta `WS.index` 2) + decodeBlock newEndianness dta + blockConduitWithEndianness newEndianness + else decodeBlock endianness dta + +{-# INLINE decodeBlock #-} +decodeBlock :: Monad m + => Endianness + -> WS.WordString + -> ConduitT WS.WordString Block m () +decodeBlock endianness dta = + {-trace ("Block type " <> show decodedBlockType + <> " len is " <> show headingLen <> " after swap " <> show (swapper endianness (dta `WS.index` 1)) + <> " data " <> show dta + <> " rest " <> show rest) $-} + assert (headingWords > 3) $ + assert (bodyWords >= 0) $ + assert (headingLen >= 12) $ + assert (headingLen == trailingLen) $ do + yield Block { _blockType = decodedBlockType + , _blockEndianness = endianness + , _blockBody = WS.toBS body + } + when (WS.length rest > 0) $ leftover rest + where + decodedBlockType = toEnum $ fromEnum + $ swapper endianness + $ dta `WS.index` 0 + headingWords = headingLen `div` 4 + headingLen = fromIntegral + $ swapper endianness + $ dta `WS.index` 1 + bodyLen = headingLen - 12 + bodyWords = bodyLen `div` 4 + body = WS.takeBytes bodyLen + $ WS.drop 2 dta + rest = WS.drop headingWords dta + trailingLen = fromIntegral + $ swapper endianness + $ dta `WS.index` (headingLen - 1) + +{- +data Pkt = Pkt { + _hdr :: PktHdr + , _content :: BS.ByteString + } + +data PktHdr = PktHdr { + _epochSeconds :: Word32 + , _nanoSeconds :: Word32 + , _captureLength :: Word32 + , _wireLength :: Word32 + } + +$(makeLenses ''PktHdr) + +data PcapFormat = PcapFormat { + littleEndian :: Endianness + , version :: FormatVersion + } deriving (Eq, Show, Read, Enum, Bounded) + +$(makeLenses ''PcapFormat) + +data FormatVersion = + Pcap + | PcapNG + deriving (Eq, Show, Read, Enum, Bounded) + +magicNumber :: FormatVersion -> Word32 +magicNumber = undefined + +readFormat :: Conduit Void BS.ByteString m () + -> m PcapFormat + +pktConduit :: PcapFormat -> Conduit BS.ByteString Pkt () +pktConduit = return () + -} diff --git a/src/Network/Pcap/NG/BlockType.hs b/src/Network/Pcap/NG/BlockType.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pcap/NG/BlockType.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StrictData #-} +module Network.Pcap.NG.BlockType( + BlockType(..) + , encodeBlockType + , decodeBlockType + , knownBlockTypes + ) where +-- * This module provides a Pcap conduit +-- without using libpcap per set. +-- It sticks to the same types, but allows reading any stream of packets +-- not necessarily from libpcap, file or live source. + +import qualified Data.ByteString.Char8 as BS +import Data.Function +import Data.Serialize +import Data.Typeable +import Data.Word +import GHC.Generics +import Numeric (showHex) + +-- | PCAP-NG block type +-- +-- See: file:///home/m/src/pcapng/draft-tuexen-opsawg-pcapng.html#rfc.section.11.1 +data BlockType = + IfDesc + | Packet + | SimplePacket -- obsolete + | NameResolution + | IfStats + | EnhancedPacket + | IRIGTimestamp + | EncapsulationInfo + | SystemDJournal + | DecryptionSecrets + | HoneMachInfo + | HoneConnEvent + | SysdigMachInfo + | SysdigProcInfo { version :: Int } + | SysdigFDList + | SysdigEvent + | SysdigIfList + | SysdigEventWithFlags + | SysdigUserList + | Custom { copyBlock :: Bool} + | SectionHeader + -- Special block type codes + | Reserved Word32 + | Corruption Word32 + | LocalUse Word32 + deriving (Typeable, Generic) + +instance Show BlockType where + show (Corruption w) = "Corruption " <> showHex w "" + show (Reserved w) = "Reserved " <> showHex w "" + show (LocalUse w) = "LocalUse " <> showHex w "" + show IfDesc = "IfDesc" + show Packet = "Packet" + show SimplePacket = "SimplePacket (obsolete)" + show NameResolution = "NameResolution" + show IfStats = "IfStats" + show EnhancedPacket = "EnhancedPacket" + show IRIGTimestamp = "IRIGTimestamp" + show EncapsulationInfo = "EncapsulationInfo" + show SystemDJournal = "SystemDJournal" + show DecryptionSecrets = "DecryptionSecrets" + show HoneMachInfo = "HoneMachInfo" + show HoneConnEvent = "HoneConnEvent" + show SysdigMachInfo = "SysdigMachInfo" + show SysdigProcInfo { version } = "SysdigProcInfo v" <> show version + show SysdigFDList = "SysdigFDList" + show SysdigEvent = "SysdigEvento" + show SysdigIfList = "SysdigIfList" + show SysdigEventWithFlags = "SysdigEventWithFlags" + show SysdigUserList = "SysdigUserList" + show Custom { copyBlock } = mconcat ["Custom (", copyCode, ">"] + where + copyCode | copyBlock = "copy" + | otherwise = "do not copy" + show SectionHeader = "SectionHeader" + +instance Eq BlockType where + (==) = (==) `on` encodeBlockType + +instance Ord BlockType where + compare = compare `on` encodeBlockType + +instance Enum BlockType where + fromEnum = fromEnum . encodeBlockType + toEnum = decodeBlockType . toEnum + +decodeBlockType 0x00000000 = Reserved 0x00000000 +decodeBlockType 0x00000001 = IfDesc +decodeBlockType 0x00000002 = Packet +decodeBlockType 0x00000003 = SimplePacket +decodeBlockType 0x00000004 = NameResolution +decodeBlockType 0x00000005 = IfStats +decodeBlockType 0x00000006 = EnhancedPacket +decodeBlockType 0x00000007 = IRIGTimestamp +decodeBlockType 0x00000008 = EncapsulationInfo +decodeBlockType 0x00000009 = SystemDJournal +decodeBlockType 0x0000000A = DecryptionSecrets +decodeBlockType 0x00000101 = HoneMachInfo +decodeBlockType 0x00000102 = HoneConnEvent +decodeBlockType 0x00000201 = SysdigMachInfo +decodeBlockType 0x00000202 = SysdigProcInfo 1 +decodeBlockType 0x00000203 = SysdigFDList +decodeBlockType 0x00000204 = SysdigEvent +decodeBlockType 0x00000205 = SysdigIfList +decodeBlockType 0x00000206 = SysdigUserList +decodeBlockType 0x00000207 = SysdigProcInfo 2 +decodeBlockType 0x00000208 = SysdigEventWithFlags +decodeBlockType 0x00000209 = SysdigProcInfo 3 +decodeBlockType 0x00000210 = SysdigProcInfo 4 +decodeBlockType 0x00000211 = SysdigProcInfo 5 +decodeBlockType 0x00000212 = SysdigProcInfo 6 +decodeBlockType 0x00000213 = SysdigProcInfo 7 +decodeBlockType 0x00000BAD = Custom True +decodeBlockType 0x40000BAD = Custom False +decodeBlockType 0x0A0D0D0A = SectionHeader +decodeBlockType a | a >= 0x0A0D0A00 + && a <= 0x0A0D0AFF = Corruption a +decodeBlockType a | a >= 0x000A0D0A + && a <= 0xFF0A0D0A = Corruption a +decodeBlockType a | a >= 0x000A0D0D + && a <= 0xFF0A0D0D = Corruption a +decodeBlockType a | a >= 0x0D0D0A00 + && a <= 0x0D0D0AFF = Corruption a +decodeBlockType a | a >= 0x80000000 + && a <= 0xFFFFFFFF = LocalUse a +decodeBlockType a = Reserved a + +encodeBlockType :: BlockType -> Word32 +encodeBlockType (Corruption c) = c +encodeBlockType (Reserved c) = c +encodeBlockType (LocalUse c) = c +encodeBlockType IfDesc = 0x00000001 +encodeBlockType Packet = 0x00000002 +encodeBlockType SimplePacket = 0x00000003 +encodeBlockType NameResolution = 0x00000004 +encodeBlockType IfStats = 0x00000005 +encodeBlockType EnhancedPacket = 0x00000006 +encodeBlockType IRIGTimestamp = 0x00000007 +encodeBlockType EncapsulationInfo = 0x00000008 +encodeBlockType SystemDJournal = 0x00000009 +encodeBlockType DecryptionSecrets = 0x0000000A +encodeBlockType HoneMachInfo = 0x00000101 +encodeBlockType HoneConnEvent = 0x00000102 +encodeBlockType SysdigMachInfo = 0x00000201 +encodeBlockType (SysdigProcInfo 1) = 0x00000202 +encodeBlockType SysdigFDList = 0x00000203 +encodeBlockType SysdigEvent = 0x00000204 +encodeBlockType SysdigIfList = 0x00000205 +encodeBlockType SysdigUserList = 0x00000206 +encodeBlockType (SysdigProcInfo 2) = 0x00000207 +encodeBlockType SysdigEventWithFlags = 0x00000208 +encodeBlockType (SysdigProcInfo 3) = 0x00000209 +encodeBlockType (SysdigProcInfo 4) = 0x00000210 +encodeBlockType (SysdigProcInfo 5) = 0x00000211 +encodeBlockType (SysdigProcInfo 6) = 0x00000212 +encodeBlockType (SysdigProcInfo 7) = 0x00000213 +encodeBlockType (Custom True ) = 0x00000BAD +encodeBlockType (Custom False) = 0x40000BAD +encodeBlockType SectionHeader = 0x0A0D0D0A +encodeBlockType other = error $ "Error in block type: " <> show other + +knownBlockTypes = [SectionHeader, IfDesc .. EnhancedPacket] + +instance Serialize BlockType where + get = decodeBlockType <$> getWord32le + put = putWord32le . encodeBlockType diff --git a/src/Network/Pcap/NG/Endianness.hs b/src/Network/Pcap/NG/Endianness.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pcap/NG/Endianness.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} +module Network.Pcap.NG.Endianness where +-- * This module provides a PcapNG conduit +-- for undifferentiated, undecoded PcapNG blocks +-- without using libpcap per set. +-- It sticks to the same types, but allows reading any stream of packets +-- not necessarily from libpcap, file or live source. + +import Data.Word +import GHC.Generics + +-- | Big or little endian? +data Endianness = + LittleEndian + | BigEndian + deriving (Eq, Show, Read, Enum, Bounded, Generic) + +-- TODO: use CAF +sameEndianness, otherEndianness :: Endianness +sameEndianness = LittleEndian +otherEndianness = BigEndian + +-- | Swap bytes from given endianness +-- to local byte order. +swapper :: Endianness -> Word32 -> Word32 +swapper endianness + | sameEndianness == endianness = id +swapper _ = byteSwap32 diff --git a/src/Network/Pcap/NG/Options.hs b/src/Network/Pcap/NG/Options.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pcap/NG/Options.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +module Network.Pcap.NG.Options where + +import Control.Exception (assert) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import qualified Data.ByteString as BS +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text (decodeUtf8) +import Data.Typeable +import Data.Word +import GHC.Generics + +import qualified Data.WordString32 as WS +import Network.Pcap.NG.BlockType +import Network.Pcap.NG.Endianness + +{- +Quote from pcap-ng spec: +1 2 3 +0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +| Option Code | Option Length | ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +/ Option Value / +/ variable length, padded to 32 bits / ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +/ / +/ . . . other options . . . / +/ / ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +| Option Code == opt_endofopt | Option Length == 0 | ++-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + + -} + +data Option a where + Option :: { optionCode :: OptionCode a + , optionValue :: WS.WordString + } -> Option a + Comment :: { commentString :: Text } + -> Option a + CustomString :: { + customString :: Text + , customCopy :: Bool + , customPEN :: Word32 + } -> Option a + CustomBinary :: { + customBinary :: WS.WordString + , customCopy :: Bool + , customPEN :: Word32 + } -> Option a + SHBHardware :: { shbHardware :: Text } -> Option SectionHeader + SHBOS :: { shbOsString :: Text } -> Option SectionHeader + SHBUserAppl :: { shbUserAppl :: Text } -> Option SectionHeader + EPBFlags :: { epbInboundOutbound :: InboundOutbound + , epbReceptionType :: ReceptionType + , epbFCSLength :: Word8 -- actually 4 bits + , epbLinkLayerErrors :: Word16 + } + -> Option EnhancedPacket + EPBHash :: { epbHash :: WS.WordString } + -> Option EnhancedPacket -- TODO: check if length is in words? + EPBDropCount :: { epbDropCount :: Word64 } + -> Option EnhancedPacket + +data InboundOutbound = + Inbound + | Outbound + | InboundOutboundNA + +instance Enum InboundOutbound where + toEnum 0b00 = InboundOutboundNA + toEnum 0b01 = Inbound + toEnum 0b10 = Outbound + toEnum other = error + $ "InboundOutbound specification unrecognized: " <> show other + fromEnum InboundOutboundNA = 0b00 + fromEnum Inbound = 0b01 + fromEnum Outbound = 0b10 + +data ReceptionType = + Unspecified + | Unicast + | Multicast + | Broadcast + | Promiscuous + deriving (Eq,Ord,Show,Typeable,Generic) + +instance Enum ReceptionType where + toEnum 0b000 = Unspecified + toEnum 0b001 = Unicast + toEnum 0b010 = Multicast + toEnum 0b011 = Broadcast + toEnum 0b100 = Promiscuous + toEnum other = error ("Unknown reception type: " <> show other) + fromEnum Unspecified = 0b000 + fromEnum Unicast = 0b001 + fromEnum Multicast = 0b010 + fromEnum Broadcast = 0b011 + fromEnum Promiscuous = 0b100 + + +data OptionCode (a :: BlockType) where + OptEnd :: OptionCode a + OptComment :: OptionCode a + OptBlockSpecific :: Word16 -> OptionCode a + OptCustom :: { customContainsString :: Bool + , customDoCopy :: Bool + } -> OptionCode a + OptSHBHardware :: OptionCode SectionHeader + OptSHBOS :: OptionCode SectionHeader + OptSHBUserAppl :: OptionCode SectionHeader + OptIDBName :: OptionCode IfDesc + OptIDBDesc :: OptionCode IfDesc + OptIDBIPv4Addr :: OptionCode IfDesc + OptIDBIPv6Addr :: OptionCode IfDesc + OptIDBEUIAddr :: OptionCode IfDesc + OptIDBSpeed :: OptionCode IfDesc + OptIDBTSResol :: OptionCode IfDesc + OptIDBTZ :: OptionCode IfDesc + OptIDBFilter :: OptionCode IfDesc + OptIDBOS :: OptionCode IfDesc + OptIDBFCSLen :: OptionCode IfDesc + OptIDBTSOffset :: OptionCode IfDesc + OptIDBHardware :: OptionCode IfDesc + OptEPBDropCount :: OptionCode EnhancedPacket + OptEPBHash :: OptionCode EnhancedPacket + OptEPBFlags :: OptionCode EnhancedPacket + +decodeOptionCode :: Proxy a + -> Word16 + -> OptionCode a +decodeOptionCode _ 0 = OptEnd +decodeOptionCode _ 1 = OptComment +decodeOptionCode _ 2988 = OptCustom True True +decodeOptionCode _ 2989 = OptCustom False True +decodeOptionCode _ 19372 = OptCustom True False +decodeOptionCode _ 19373 = OptCustom False False + +decodeBlockSpecific :: forall bt + . Endianness + -> OptionCode bt + -> WS.WordString + -> Option bt +decodeBlockSpecific _ oc ws = + case oc of + OptSHBOS -> decodeTextOption SHBOS ws + OptSHBHardware -> decodeTextOption SHBHardware ws + OptSHBUserAppl -> decodeTextOption SHBOS ws + OptEPBFlags -> decodeWordOption decodeEPBFlags ws + OptEPBHash -> EPBHash ws + OptEPBDropCount -> decodeWord64Option EPBDropCount ws + other -> undefined + +decodeEPBFlags :: Word32 -> Option EnhancedPacket +decodeEPBFlags aWord = EPBFlags {..} + where + epbInboundOutbound = toEnum + $ fromIntegral (aWord .&. 0b11) + epbReceptionType = toEnum + $ fromIntegral ((aWord `shiftR` 3) .&. 0b111) + epbFCSLength = fromIntegral + $ (aWord `shiftR` 5) .&. 0b1111 -- actually 4 bits + epbLinkLayerErrors = fromIntegral + $ aWord `shiftR` 16 + +decodeOptions :: Endianness + -> Proxy bt + -> WS.WordString + -> [Option bt] +decodeOptions endianness bt ws = + case optCode of + OptEnd -> [] + other -> decodedOption optCode + : decodeOptions endianness bt rest + where + decodedOption OptEnd = error "Impossible!" + decodedOption OptCustom { customContainsString = True + , customDoCopy } = + CustomString { customCopy=customDoCopy, .. } + decodedOption OptCustom { customContainsString = False + , customDoCopy } = + CustomBinary { customCopy=customDoCopy, .. } + -- TODO: decode per-block options + decodedOption OptComment = Comment + $ Text.decodeUtf8 + $ WS.toBS optionValue + decodedOption optionCode = + decodeBlockSpecific endianness + optionCode + optionValue + --optionCode -> Option {..} + -- TODO: this swapping is suspect + optCode = decodeOptionCode Proxy + $ fromIntegral + (swapper endianness + (ws `WS.index` 0) + .&. 0xFFFF) + optionLen = (swapper endianness + (ws `WS.index` 0) + .&. 0xFFFF0000) + `shiftL` 16 + optionValue = WS.takeBytes (fromIntegral optionLen) + $ WS.drop 1 ws + customBinary = WS.drop 1 optionValue + customString = Text.decodeUtf8 + $ WS.toBS customBinary + customPEN = WS.index ws 1 + rest = WS.drop (fromIntegral $ optionLen + 1) + ws + +decodeTextOption :: (Text -> Option a) + -> WS.WordString + -> Option a +decodeTextOption opt = opt + . Text.decodeUtf8 + . WS.toBS +decodeWord64Option :: (Word64 -> Option a) + -> WS.WordString + -> Option a +decodeWord64Option opt optionValue = + assert (WS.length optionValue == 2) + -- fixme: word swap + $ opt + $ fromIntegral (WS.index optionValue 0) + .|. (fromIntegral (WS.index optionValue 1) + `shiftR` 32) + -- ignoring high word for now + +decodeWordOption :: (Word32 -> Option a) + -> WS.WordString + -> Option a +decodeWordOption opt ws = + assert (WS.length ws == 1) + $ opt + $ ws `WS.index` 0 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Control.Lens ((^.)) +import Control.Monad (forM, forM_) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Conduit +import Data.Conduit.Cereal (sinkGet) +import qualified Data.Conduit.Combinators as C (head, sourceFile) +import Data.Conduit.List (consume) +import Data.List (isPrefixOf) +import Data.Serialize (get) +import System.Directory +import System.FilePath.Posix (takeExtension, takeFileName, + ()) +import System.IO (hPutStrLn, stderr) +import Test.Hspec +import Test.Hspec.Core.Runner +import Test.QuickCheck + +import qualified Data.WordString32.Conduit as WSC +import Network.Pcap.NG.Block +import Network.Pcap.NG.BlockType + +import qualified Test.Data.WordString32 (spec) +import qualified Test.Network.Pcap.NG.BlockType (spec) +import qualified Test.Network.Pcap.NG.Endianness (spec) +import qualified Test.Network.Pcap.NG.Options (spec) + +main :: IO () +main = hspecWith config spec + where + config = defaultConfig { + configColorMode = ColorAlways + , configFailureReport = Just "failure.log" + , configDiff = True + } + + +filesWithExts :: FilePath -- ^ Directory to search + -> [String ]-- ^ Extensions list + -> IO [FilePath] +filesWithExts dirName exts = + map (dirName ) . filter matchExt <$> getDirectoryContents dirName + where + matchExt = (`elem` exts) + . takeExtension + +consumeBlock :: MonadIO m => ConduitT Block Void m () +consumeBlock = awaitForever + $ liftIO . hPutStrLn stderr . show . (^. blockType) + +testPcapFile :: FilePath -> Spec +testPcapFile filename = + it filename $ do + parse filename >>= (`shouldMatchList` []) + +testPcapFileSections :: FilePath -> [BlockType] -> Spec +testPcapFileSections filename bts = + it filename $ + parse filename >>= (`shouldMatchList` bts) + +testPcapFilePrefixAndCount :: FilePath -> [BlockType] -> Int -> Spec +testPcapFilePrefixAndCount filename prefix count = do + describe filename $ do + it (filename <> " has correct prefix") $ do + actualBts <- parse filename + actualBts `shouldSatisfy` (isPrefixOf prefix) + it (filename <> "has correct number of packets") $ do + actualBts <- parse filename + length actualBts `shouldBe` count + +blockTypes = awaitForever $ \block -> do + liftIO $ print $ block ^. blockType + yield (block ^. blockType) + +parse filename = runConduitRes + $ WSC.sourceFile filename .| blockConduit .| blockTypes .| consume + +{- +parse :: FilePath -> IO () +parse filename = runConduitRes + $ WSC.sourceFile filename .| pcapNgConduit2 .| consumeBlock + -} + +testPcapFileHeader :: FilePath -> Spec +testPcapFileHeader filename = + it filename $ + parseHeader filename `shouldReturn` SectionHeader + +parseHeader filename = do + header :: Maybe Block <- runConduitRes + $ WSC.sourceFile filename .| blockConduit .| C.head + case header of + Just h -> do + print $ h ^. blockType + return $ h ^. blockType + Nothing -> error "No blocktype here!" + +spec = do + describe "Network.Pcap.NG.BlockType" $ + Test.Network.Pcap.NG.BlockType.spec + describe "Network.Pcap.NG.Options" $ + Test.Network.Pcap.NG.Options.spec + describe "Data.WordString32" $ + Test.Data.WordString32.spec + describe "Block recognition" $ do + return () + describe "Undifferentiated blocks" $ do + describe "Pcap.org examples" $ do + files <- runIO $ filesWithExts "test/pcapng.org" [".ntar", ".pcapng"] + runIO $ putStrLn $ "Test files found: " <> show files + describe "parse first block" $ + forM_ files testPcapFileHeader + describe "parse all blocks" $ do + testPcapFileSections "test/pcapng.org/dhcp.pcapng" $ + [SectionHeader, IfDesc, EnhancedPacket, EnhancedPacket, EnhancedPacket, EnhancedPacket] + testPcapFilePrefixAndCount "test/pcapng.org/pcap-ng_Wi-Fi_Bluetooth_USB_Cooked_timestamps_issue_1.ntar" + [SectionHeader,IfDesc,EnhancedPacket] 224 + testPcapFileSections "test/pcapng.org/dhcp_big_endian.pcapng" $ + [SectionHeader, IfDesc, NameResolution] <> replicate 4 EnhancedPacket + testPcapFileSections "test/pcapng.org/dhcp_little_endian.pcapng" $ + [SectionHeader, IfDesc, NameResolution] <> replicate 4 EnhancedPacket + testPcapFileSections "test/pcapng.org/many_interfaces.pcapng" $ + [SectionHeader] <> replicate 11 IfDesc + <> replicate 64 EnhancedPacket + <> [NameResolution] + <> replicate 11 IfStats + xdescribe "Failing tests" $ do + testPcapFileSections "test/pcapng.org/http.bigendian.ntar" $ + [] + testPcapFileSections "test/pcapng.org/icmp2.ntar" $ + [] + describe "Wireshark examples" $ do + testPcapFileSections "test/wireshark/dhcp-nanosecond.pcapng" $ + [SectionHeader, IfDesc] <> replicate 4 EnhancedPacket + testPcapFileSections "test/wireshark/dmgr.pcapng" $ + [SectionHeader, IfDesc] <> replicate 42 EnhancedPacket + testPcapFileSections "test/wireshark/http2-brotli.pcapng" $ + [SectionHeader, IfDesc, DecryptionSecrets] <> replicate 25 EnhancedPacket + testPcapFileSections "test/wireshark/ikev2-decrypt-aes256cbc.pcapng" $ + [SectionHeader, IfDesc, IfDesc] <> replicate 4 EnhancedPacket <> [IfStats, IfStats] + testPcapFileSections "test/wireshark/packet-h2-14_headers.pcapng" $ + [SectionHeader, IfDesc] <> replicate 15 EnhancedPacket <> [IfStats] + testPcapFileSections "test/wireshark/tls12-dsb.pcapng" $ + [SectionHeader, IfDesc, DecryptionSecrets] <> replicate 9 EnhancedPacket + <> [DecryptionSecrets] <> replicate 8 EnhancedPacket + testPcapFileSections "test/wireshark/dhcp.pcapng" $ [SectionHeader, IfDesc] <> replicate 4 EnhancedPacket + testPcapFileSections "test/wireshark/dtls12-aes128ccm8-dsb.pcapng" $ + [SectionHeader, IfDesc, DecryptionSecrets] <> replicate 13 EnhancedPacket + testPcapFileSections "test/wireshark/http-brotli.pcapng" $ + [SectionHeader, IfDesc] <> replicate 10 EnhancedPacket <> [IfStats] + testPcapFileSections "test/wireshark/ikev2-decrypt-aes256ccm16.pcapng" $ + [SectionHeader,IfDesc,IfDesc] <> replicate 4 EnhancedPacket <> replicate 2 IfStats + testPcapFileSections "test/wireshark/sip.pcapng" $ [SectionHeader,IfDesc] <> replicate 6 EnhancedPacket + testPcapFileSections "test/wireshark/wireguard-ping-tcp-dsb.pcapng" $ + [SectionHeader, IfDesc, DecryptionSecrets] <> replicate 22 EnhancedPacket diff --git a/test/Test/Data/WordString32.hs b/test/Test/Data/WordString32.hs new file mode 100644 --- /dev/null +++ b/test/Test/Data/WordString32.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TypeApplications #-} +module Test.Data.WordString32(spec) where + +import Data.WordString32 as WS + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Arbitrary as ABS +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Test.Validity +import Test.Validity.Arbitrary +import Test.Validity.Eq +import Test.Validity.Monoid +import Test.Validity.Ord + +instance Arbitrary WordString where + arbitrary = do + len <- (4*) <$> arbitrary -- choose(1,16) + fromBS <$> ABS.fastRandBs len + shrink = shrinkWS + +instance Validity WordString where + validate ws = valid + {-validate (WS ptr ofs len) = do + check (ofs <= len) "Offset is less than WordString length" + <> check (len >= 0) "Length of the WordString is greater than zero" + <> check (ofs >= 0) "Offset is not less than zero"-} + +instance GenUnchecked WordString where + genUnchecked = arbitrary + shrinkUnchecked = shrinkWS + +shrinkWS ws = + ((`WS.take` ws) <$> [1..WS.length ws]) + <> ((`WS.drop` ws) <$> [1..WS.length ws]) + +instance GenValid WordString where + genValid = arbitrary + shrinkValid = shrinkWS + +spec :: Spec +spec = describe "Data.WordString" $ do + eqSpec @WordString + ordSpec @WordString + monoidSpec @WordString + describe "drop" $ do + prop "decreases length" $ \ws (Positive d) -> + d < WS.length ws && d >= 0 ==> + WS.length (WS.drop d ws) == WS.length ws - d + prop "shifts indices after N-th" $ \ws (Positive d) (Positive i) -> + i+d < WS.length ws ==> + WS.index ws (i+d) == WS.index (WS.drop d ws) i + prop "of empty" $ \(Positive i) -> + WS.take i empty == empty + describe "take" $ do + prop "decreases length" $ \ws d -> + d < WS.length ws && d >= 0 ==> + WS.length (WS.take d ws) `shouldBe` d + prop "preserves initial indices" $ \ws (Positive d) (Positive i) -> + d < WS.length ws && i < d ==> + WS.index (WS.take d ws) i `shouldBe` WS.index ws i + prop "of empty" $ \(Positive i) -> + WS.take i empty == empty + describe "append" $ do + prop "length sums up" $ \ws1 ws2 -> + WS.length (ws1 <> ws2) `shouldBe` + WS.length ws1 + WS.length ws2 + prop "preserves initial indices" $ \ws1 ws2 (Positive i) -> + i < WS.length ws1 ==> + WS.index ws1 i `shouldBe` WS.index (ws1 <> ws2) i + prop "shifts indices in the second argument" $ \ws1 ws2 (Positive i) -> + i < WS.length ws2 ==> + WS.index ws2 i `shouldBe` WS.index (ws1 <> ws2) (WS.length ws1 + i) + describe "length" $ do + it "of empty is zero" $ WS.length WS.empty == 0 + prop "null is always empty" $ \ws -> WS.null ws `shouldBe` WS.length ws == 0 + --arbitraryGeneratesOnlyValid @WordString diff --git a/test/Test/Network/Pcap/NG/BlockType.hs b/test/Test/Network/Pcap/NG/BlockType.hs new file mode 100644 --- /dev/null +++ b/test/Test/Network/Pcap/NG/BlockType.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeApplications #-} +module Test.Network.Pcap.NG.BlockType(spec) where + +import Network.Pcap.NG.BlockType +import Test.Hspec +import Test.QuickCheck +import Test.Validity +import Test.Validity.Enum +import Test.Validity.Eq +import Test.Validity.Ord + +instance Arbitrary BlockType where + arbitrary = genValid + shrink = shrinkValid + +instance GenUnchecked BlockType where + genUnchecked = toEnum <$> arbitrary + shrinkUnchecked _ = [] + +instance Validity BlockType where + validate (Reserved c) = invalid $ "Reserved block type " <> show c + validate (Corruption c) = invalid $ "Corrupt block type " <> show c + validate _ = valid + +instance GenValid BlockType where + +spec = describe "Network.Pcap.NG.BlockType" $ do + eqSpec @BlockType + ordSpec @BlockType + enumSpec @BlockType diff --git a/test/Test/Network/Pcap/NG/Endianness.hs b/test/Test/Network/Pcap/NG/Endianness.hs new file mode 100644 --- /dev/null +++ b/test/Test/Network/Pcap/NG/Endianness.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeApplications #-} +module Test.Network.Pcap.NG.Endianness where + +import Test.Hspec +import Test.QuickCheck +import Test.Validity +import Test.Validity.Enum +import Test.Validity.Eq +import Test.Validity.Ord + +import Network.Pcap.NG.Endianness + +instance Arbitrary Endianness where + arbitrary = elements [LittleEndian .. BigEndian] + +instance GenUnchecked Endianness where + +spec = describe "Network.Pcap.NG.Endianness" $ do + eqSpec @Endianness + enumSpec @Endianness diff --git a/test/Test/Network/Pcap/NG/Options.hs b/test/Test/Network/Pcap/NG/Options.hs new file mode 100644 --- /dev/null +++ b/test/Test/Network/Pcap/NG/Options.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Test.Network.Pcap.NG.Options where + +import Network.Pcap.NG.Options + +import Data.WordString32 as WS + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Arbitrary as ABS +import Data.Typeable +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Test.Validity +import Test.Validity.Arbitrary +import Test.Validity.Enum +import Test.Validity.Eq +import Test.Validity.Functions.Inverse +import Test.Validity.Monoid +import Test.Validity.Ord +import Test.Validity.Utils + +instance Arbitrary ReceptionType where + arbitrary = elements [Unspecified + .. Promiscuous] + +instance Validity ReceptionType where + +instance GenValid ReceptionType where + +instance GenUnchecked ReceptionType where + +spec = do + fdescribe "ReceptionType" $ do + eqSpec @ReceptionType + ordSpec @ReceptionType + enumSpec @ReceptionType diff --git a/test/Test/Validity/Enum.hs b/test/Test/Validity/Enum.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/Enum.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Test.Validity.Enum where + +import Data.WordString32 as WS + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Arbitrary as ABS +import Data.Typeable +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Test.Validity +import Test.Validity.Arbitrary +import Test.Validity.Eq +import Test.Validity.Functions.Inverse +import Test.Validity.Monoid +import Test.Validity.Ord +import Test.Validity.Utils + +enumSpec :: forall a + . (Arbitrary a + ,Typeable a + ,Enum a + ,Show a + ,Eq a + ) => Spec +enumSpec = enumSpecOnGen (arbitrary :: Gen a) + "arbitrary" + (shrink :: a -> [a]) + +enumSpecOnGen :: (Enum a + ,Eq a + ,Show a + ,Typeable a) + => Gen a -- generator + -> String -- generator name + -> (a -> [a]) -- shrinker + -> Spec +enumSpecOnGen (gen :: Gen a) genName shrinker = + describe ("Enum " <> name <> " on " <> genName) $ do + prop "toEnum . fromEnum == id" $ + inverseFunctionsOnGen fromEnum (toEnum :: Int -> a) gen shrinker + --(toEnum :: Int -> a) fromEnum + where + name = nameOf @a + +--toEnumInvertsFromEnumOnGen :: _ +toEnumInvertsFromEnumOnGen gen = do + x <- gen + toEnum (fromEnum x) `shouldBe` x