tap (empty) → 0.1.0.0
raw patch · 7 files changed
+567/−0 lines, 7 filesdep +basedep +binarydep +bytestring
Dependencies added: base, binary, bytestring, hedgehog, optparse-applicative, tap, tasty, tasty-hedgehog, tasty-hunit
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- README.md +32/−0
- exe/Main.hs +95/−0
- lib/Data/Tap.hs +269/−0
- tap.cabal +58/−0
- test/Main.hs +87/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for tap++## 0.1.0.0 -- 11-2-2026++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 David Cox++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,32 @@+# tap++https://radiotap.org/++Usage++```+tap --help+tap w | tap r+tap --name foo --num 0 --du8 --du8 w -f 0 --u8 0xab --u8 0xcd foo.bin+tap --name foo --num 0 --du8 --du8 r foo.bin+tap --name foo --num 0 --du8 --du8 --name bar --num 1 --ds16 w \+ -f 0 --u8 0xab --u8 0xcd \+ -f 1 --s16 100 \+ bar.bin+tap --name foo --num 0 --du8 --du8 --name bar --num 1 --ds16 r bar.bin+```++Install++```+cabal install tap+```++Development++```+cabal build+cabal haddock+cabal test+cabal run tap -- --help+```
+ exe/Main.hs view
@@ -0,0 +1,95 @@+module Main (main) where++import Control.Monad+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString.Lazy as BS+import qualified Data.List.NonEmpty as NE+import Data.Tap+import Data.Version+import Data.Word+import Options.Applicative+import Paths_tap++main :: IO ()+main = do+ CLI dfn cmd <- customExecParser prefs' $ pinfo $ showVersion version+ d <- either (fail . mappend "definition error: ") return $ fmt dfn+ case cmd of+ ReadTap fM -> print . runGet (getTap d) =<< maybe BS.getContents BS.readFile fM+ WriteTap (v,p) fs fM -> do+ fs' <- either (fail . mappend "field error: ") return $ unk d =<< fmt fs+ let ps = mkPrsnts $ map num fs'+ hlen = 4 + fromIntegral (NE.length ps) * 4+ slen = sum $ map structLen $ padStructs $ structs =<< fs'+ tlen = hlen + slen+ when (tlen >= fromIntegral (maxBound :: Word16)) $+ fail $ "struct length too long: " <> show tlen+ maybe BS.putStr BS.writeFile fM $ runPut $ putTap $+ Tap (Hdr v p (fromIntegral tlen) ps) fs'++data CLI = CLI [Fld] Cmd++data Cmd = ReadTap (Maybe FilePath)+ | WriteTap (Word8, Word8) [Fld] (Maybe FilePath)++prefs' :: ParserPrefs+prefs' = prefs $ showHelpOnError <> showHelpOnEmpty++pinfo :: String -> ParserInfo CLI+pinfo v = info (parser <**> simpleVersioner v <**> helper) $ progDesc "radiotap"++parser :: Parser CLI+parser = liftA2 CLI (concat <$> many parseDefn) $ hsubparser $ mconcat+ [ command "r" $ info (ReadTap <$>+ optional (fileArg "binary intput file or stream STDIN")) $+ progDesc "read radiotap data"+ , command "w" $ info (WriteTap <$> parseHdr <*> many parseFld <*>+ optional (fileArg "binary output file or stream STDOUT")) $+ progDesc "write radiotap data"]++fileArg :: String -> Parser FilePath+fileArg h = strArgument $ metavar "FILE" <> completer (bashCompleter "file") <> help h++parseHdr :: Parser (Word8, Word8)+parseHdr = parserOptionGroup "Header" $ (,)+ <$> option auto (long "ver" <> metavar "WORD8" <> value 0 <> showDefault <> help "header version")+ <*> option auto (long "hpd" <> metavar "WORD8" <> value 0 <> showDefault <> help "header pad")++parseFld :: Parser Fld+parseFld = parserOptionGroup "Fields" $ Fld ""+ <$> option auto (short 'f' <> metavar "INT" <> help "field num")+ <*> many parseStructVal++parseDefn :: Parser [Fld]+parseDefn = parserOptionGroup "Definition" $ asum+ [ flag' defFlds $ long "dfs" <> help "radiotap defined fields"+ , fmap pure $ Fld+ <$> strOption (long "name" <> metavar "STR" <> help "field definition name")+ <*> option auto (long "num" <> metavar "INT" <> help "field definition num")+ <*> many parseStruct+ ]++parseStruct :: Parser Struct+parseStruct = asum+ [ flag' (U8 0) $ long "du8" <> help "u8 field definition"+ , flag' (S8 0) $ long "ds8" <> help "s8 field definition"+ , flag' (U16 0) $ long "du16" <> help "u16 field definition"+ , flag' (S16 0) $ long "ds16" <> help "s16 field definition"+ , flag' (U32 0) $ long "du32" <> help "u32 field definition"+ , flag' (S32 0) $ long "ds32" <> help "s32 field definition"+ , flag' (U64 0) $ long "du64" <> help "u64 field definition"+ , flag' (S64 0) $ long "ds64" <> help "s64 field definition"+ ]++parseStructVal :: Parser Struct+parseStructVal = asum+ [ fmap U8 $ option auto $ long "u8" <> metavar "WORD8" <> help "u8 value"+ , fmap S8 $ option auto $ long "s8" <> metavar "INT8" <> help "s8 value"+ , fmap U16 $ option auto $ long "u16" <> metavar "WORD16" <> help "u16 value"+ , fmap S16 $ option auto $ long "s16" <> metavar "INT16" <> help "s16 value"+ , fmap U32 $ option auto $ long "u32" <> metavar "WORD32" <> help "u32 value"+ , fmap S32 $ option auto $ long "s32" <> metavar "INT32" <> help "s32 value"+ , fmap U64 $ option auto $ long "u64" <> metavar "WORD64" <> help "u64 value"+ , fmap S64 $ option auto $ long "s64" <> metavar "INT64" <> help "s64 value"+ ]
+ lib/Data/Tap.hs view
@@ -0,0 +1,269 @@+-- | [radiotap](https://radiotap.org/)+module Data.Tap (Tap(..), getTap, putTap+ , Hdr(..), mkPrsnts+ , Fld(..), fmt, unk, defFlds+ , Struct(..), structLen, padStructs) where++import Control.Monad+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import Data.Either+import Data.Function+import Data.Int+import Data.List+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Monoid++-- | radiotap data+data Tap = Tap{hdr :: Hdr, fields :: [Fld]}+ deriving (Eq, Read, Show)++-- | decoder+getTap :: [Fld] -> Get Tap+getTap dfn = get >>= \h -> Tap h <$> getFlds dfn h++-- | encoder+putTap :: Tap -> Put+putTap (Tap h fs) = put h <> foldMap putStruct (padStructs $ structs =<< fs)++getFlds :: [Fld] -> Hdr -> Get [Fld]+getFlds dfn Hdr{prsnt=p:|ps} = do+ prsntStructs <- forM nums $ \n -> case lookupFld dfn n of+ Nothing -> fail $ "present structs: undefined field num: " <> show n+ Just f -> return $ structs f+ either fail return . elaborate dfn nums =<< getStructs (concat prsntStructs)+ where+ nums = concat $ zipWith presents [0..] $ p:ps++presents :: Int -> Word32 -> [Int]+presents i w = [b + i * 32 | b <- [0..30], testBit w b]++-- chunk structs into fields+elaborate :: [Fld] -> [Int] -> [Struct] -> Either String [Fld]+elaborate dfn = go+ where+ go [] [] = Right []+ go [] s@(_:_) = Left $ "elaborate: too many structs: " <> show s+ go ns@(_:_) [] = Left $ "elaborate: too many present: " <> show ns+ go (n:ns) strcts = case lookupFld dfn n of+ Nothing -> Left $ "elaborate: undefined field num: " <> show n+ Just f -> case consume f strcts of+ Left err -> Left err+ Right (f', rest) -> (f':) <$> go ns rest++consume :: Fld -> [Struct] -> Either String (Fld, [Struct])+consume f@Fld{structs=ds} strcts = case match ds strcts of+ Left err -> Left err+ Right (t, rest) -> Right (f{structs=t}, rest)++match :: [Struct] -> [Struct] -> Either String ([Struct], [Struct])+match [] rest = Right ([], rest)+match _ [] = Left "match: not enough structs"+match (d:ds) (s:rest) = case matchStruct d s of+ Left err -> Left err+ Right s' -> case match ds rest of+ Left err -> Left err+ Right (ms, rest') -> Right (s':ms, rest')++matchStruct :: Struct -> Struct -> Either String Struct+matchStruct dfn strct = case (dfn, strct) of+ (U8{}, U8 u8) -> Right $ U8 u8+ (S8{}, S8 s8) -> Right $ S8 s8+ (U16{}, U16 u16) -> Right $ U16 u16+ (S16{}, S16 s16) -> Right $ S16 s16+ (U32{}, U32 u32) -> Right $ U32 u32+ (S32{}, S32 s32) -> Right $ S32 s32+ (U64{}, U64 u64) -> Right $ U64 u64+ (S64{}, S64 s64) -> Right $ S64 s64+ (expct, actual) -> Left $ "expected " ++ renderExp expct ++ " but got " ++ renderAct actual+ where+ renderExp e = case e of+ U8{} -> "u8"+ S8{} -> "s8"+ U16{} -> "u16"+ S16{} -> "s16"+ U32{} -> "u32"+ S32{} -> "s32"+ U64{} -> "u64"+ S64{} -> "s64"+ renderAct e = case e of+ U8 u8 -> "u8 " <> show u8+ S8 s8 -> "s8 " <> show s8+ U16 u16 -> "u16 " <> show u16+ S16 s16 -> "s16 " <> show s16+ U32 u32 -> "u32 " <> show u32+ S32 s32 -> "s32 " <> show s32+ U64 u64 -> "u64 " <> show u64+ S64 s64 -> "s64 " <> show s64++lookupFld :: [Fld] -> Int -> Maybe Fld+lookupFld dfn n = find ((n ==).num) dfn++-- | header+data Hdr = Hdr{ver :: Word8, hpd :: Word8, len :: Word16, prsnt :: NonEmpty Word32}+ deriving (Eq, Read, Show)++instance Binary Hdr where+ get = Hdr <$> getWord8 <*> getWord8 <*> getWord16le <*> getPrsnt+ where+ getPrsnt = do+ p <- getWord32le+ if testBit p 31 then (p:|) <$> go else return $ p:|[]+ where+ go = do+ p <- getWord32le+ if testBit p 31 then (p:) <$> go else return [p]+ put h = do+ putWord8 (ver h) >> putWord8 (hpd h) >> putWord16le (len h)+ let p:|ps = prsnt h+ putWord32le p >> if testBit p 31 then go ps else mempty+ where+ go [] = mempty+ go (p:ps) = putWord32le p <> if testBit p 31 then go ps else mempty++-- | expect sorted input+mkPrsnts :: [Int] -> NonEmpty Word32+mkPrsnts ns = let (ns', w) = setPrsnts ns 0+ in applyWhen (not $ null ns') (`setBit` 31) w :| go ns' 1+ where+ go [] _ = []+ go ns' i = applyWhen (not $ null ns'') (`setBit` 31) w : go ns'' (i + 1)+ where+ (ns'', w) = setPrsnts ns' i++-- req sorted input nums+setPrsnts :: [Int] -> Int -> ([Int], Word32)+setPrsnts ns i = (ns', appEndo e 0)+ where+ (bs, ns') = span (\n -> n < (i + 1) * 32) ns+ e = mconcat [Endo $ flip setBit $ b `mod` 32 | b <- bs]++-- | radiotap field+data Fld = Fld{name :: String, num :: Int, structs :: [Struct]}+ deriving (Eq, Read, Show)++-- | format fields: sort then check reserved and duplicates+fmt :: [Fld] -> Either String [Fld]+fmt = go . NE.groupWith num . sortOn num+ where+ go [] = Right []+ go ((f:|[]):gs)+ | num f `mod` 32 == 31 = Left $ "reserved field number: " <> show f+ | otherwise = (f:) <$> go gs+ go ((f:|fs):_) = Left $ "duplicate numbered fields: " ++ show (f:fs)++-- | verify all fields are defined+unk :: [Fld] -> [Fld] -> Either String [Fld]+unk dfn = go+ where+ go [] = Right []+ go (f:fs) = case lookupFld dfn $ num f of+ Nothing -> Left $ "undefined field: " ++ show f+ Just d+ | mismatchStructs (structs d) (structs f) -> Left $+ "mismatched structs: dfn=" ++ show (structs d) ++ " field=" ++ show (structs f)+ | otherwise -> (f:) <$> go fs++mismatchStructs :: [Struct] -> [Struct] -> Bool+mismatchStructs ds = any isLeft . zipWith matchStruct ds++-- | radiotap structure+data Struct = U8 Word8 | S8 Int8 | U16 Word16 | S16 Int16 | U32 Word32+ | S32 Int32 | U64 Word64 | S64 Int64+ deriving (Eq, Read, Show)++-- | byte length+structLen :: Struct -> Integer+structLen s = case s of+ U8{} -> 1+ S8{} -> 1+ U16{} -> 2+ S16{} -> 2+ U32{} -> 4+ S32{} -> 4+ U64{} -> 8+ S64{} -> 8++getStructs :: [Struct] -> Get [Struct]+getStructs [] = return []+getStructs [s] = pure <$> getStruct s+getStructs (a:b:s) = (:) <$> getStruct a <* replicateM_ (pad a b) getWord8 <*> getStructs (b:s)++getStruct :: Struct -> Get Struct+getStruct s = case s of+ U8{} -> U8 <$> getWord8+ S8{} -> S8 <$> getInt8+ U16{} -> U16 <$> getWord16le+ S16{} -> S16 <$> getInt16le+ U32{} -> U32 <$> getWord32le+ S32{} -> S32 <$> getInt32le+ U64{} -> U64 <$> getWord64le+ S64{} -> S64 <$> getInt64le++-- | insert natural alignment padding+padStructs :: [Struct] -> [Struct]+padStructs [] = []+padStructs [s] = [s]+padStructs (a:b:s) = [a] ++ replicate (pad a b) (U8 0) ++ padStructs (b:s)++putStruct :: Struct -> Put+putStruct s = case s of+ U8 w8 -> putWord8 w8+ S8 s8 -> putInt8 s8+ U16 w16 -> putWord16le w16+ S16 s16 -> putInt16le s16+ U32 w32 -> putWord32le w32+ S32 s32 -> putInt32le s32+ U64 w64 -> putWord64le w64+ S64 s64 -> putInt64le s64++pad :: Struct -> Struct -> Int+pad a b = case (a,b) of+ (U8{}, U16{}) -> 1+ (U8{}, S16{}) -> 1+ (U8{}, U32{}) -> 3+ (U8{}, S32{}) -> 3+ (U8{}, U64{}) -> 7+ (U8{}, S64{}) -> 7+ (S8{}, U16{}) -> 1+ (S8{}, S16{}) -> 1+ (S8{}, U32{}) -> 3+ (S8{}, S32{}) -> 3+ (S8{}, U64{}) -> 7+ (S8{}, S64{}) -> 7+ (U16{},U32{}) -> 2+ (U16{},S32{}) -> 2+ (U16{},U64{}) -> 6+ (U16{},S64{}) -> 6+ (S16{},U32{}) -> 2+ (S16{},S32{}) -> 2+ (S16{},U64{}) -> 6+ (S16{},S64{}) -> 6+ (U32{},U64{}) -> 4+ (U32{},S64{}) -> 4+ (S32{},U64{}) -> 4+ (S32{},S64{}) -> 4+ (_ ,_ ) -> 0++-- | radiotap defined fields+defFlds :: [Fld]+defFlds = [Fld "TSFT" 0 [U64 0], Fld "Flags" 1 [U8 0]+ , Fld "Rate" 2 [U8 0], Fld "Channel" 3 [U16 0, U16 0]+ , Fld "FHSS" 4 [U8 0, U8 0], Fld "Antenna Signal" 5 [S8 0]+ , Fld "Antenna Noise" 6 [S8 0], Fld "Lock quality" 7 [U16 0]+ , Fld "TX attenuation" 8 [U16 0], Fld "dB TX attenuation" 9 [U16 0]+ , Fld "dBm TX power" 10 [S8 0], Fld "Antenna" 11 [U8 0]+ , Fld "dB antenna signal" 12 [U8 0], Fld "dB antenna noise" 13 [U8 0]+ , Fld "RX flags" 14 [U16 0], Fld "TX flags" 15 [U16 0]+ , Fld "MCS" 19 [U8 0, U8 0, U8 0]+ , Fld "A-MPDU status" 20 [U32 0, U16 0, U8 0, U8 0]+ , Fld "VHT" 21 $ [U16 0, U8 0, U8 0] ++ replicate 4 (U8 0) +++ [U8 0, U8 0, U16 0]+ , Fld "timestamp" 22 [U64 0, U16 0, U8 0, U8 0]+ , Fld "HE" 23 $ replicate 6 $ U16 0+ , Fld "HE-MU" 24 $ [U16 0, U16 0] ++ replicate 4 (U8 0) ++ replicate 4 (U8 0)+ , Fld "HE-MU-other-user" 25 [U16 0, U16 0, U8 0, U8 0]+ , Fld "0-length-PSDU" 26 [U8 0], Fld "L-SIG" 27 [U16 0, U16 0]]
+ tap.cabal view
@@ -0,0 +1,58 @@+cabal-version: 3.0+name: tap+version: 0.1.0.0+synopsis: radiotap+description: https://radiotap.org+homepage: https://github.com/dopamane/tap+license: MIT+license-file: LICENSE+author: dopamane+maintainer: dwc1295@gmail.com+copyright: David Cox+category: Data+build-type: Simple+extra-doc-files: CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/dopamane/tap++library+ default-language: Haskell2010+ ghc-options: -Wall -O2+ hs-source-dirs: lib+ exposed-modules: Data.Tap+ build-depends:+ base < 5,+ binary++executable tap+ default-language: Haskell2010+ ghc-options: -Wall -O2 -threaded+ hs-source-dirs: exe+ main-is: Main.hs+ other-modules: Paths_tap+ autogen-modules: Paths_tap+ build-depends:+ base < 5,+ binary,+ bytestring,+ optparse-applicative,+ tap++test-suite test+ default-language: Haskell2010+ ghc-options: -Wall -O2 -threaded+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends:+ base < 5,+ binary,+ bytestring,+ hedgehog,+ tap,+ tasty,+ tasty-hedgehog,+ tasty-hunit
+ test/Main.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE NumericUnderscores #-}++module Main (main) where++import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.Bits+import qualified Data.ByteString.Lazy as BS+import Data.List.NonEmpty (NonEmpty(..))+import Data.Tap+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty+import Test.Tasty.Hedgehog+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain $ testGroup "Data.Tap" [hdrBinTrip, testDetail, testMkPrsnts]++testMkPrsnts :: TestTree+testMkPrsnts = testCaseSteps "mkPrsnts" $ \step -> do+ step "empty"+ mkPrsnts [] @?= 0 :| []+ step "singleton"+ mkPrsnts [0] @?= 1 :| []+ step "few"+ mkPrsnts [0, 3, 5] @?= 0b0000_0000_0000_0000_0000_0000_0010_1001 :| []+ step "two"+ mkPrsnts [0, 35] @?=+ 0b1000_0000_0000_0000_0000_0000_0000_0001 :|+ [0b0000_0000_0000_0000_0000_0000_0000_1000]+ step "gap"+ mkPrsnts [2, 64] @?=+ 0b1000_0000_0000_0000_0000_0000_0000_0100 :|+ [ 0b1000_0000_0000_0000_0000_0000_0000_0000+ , 0b0000_0000_0000_0000_0000_0000_0000_0001]++testDetail :: TestTree+testDetail = testCaseSteps "detail" $ \step -> do+ step "encd"+ BS.unpack (runPut $ putTap detailTap) @?= detailBS+ step "decd"+ runGet (getTap detailFlds) (BS.pack detailBS) @?= detailTap+ step "trip"+ runGet (getTap detailFlds) (runPut $ putTap detailTap) @?= detailTap++detailTap :: Tap+detailTap = Tap (Hdr 0 0 16 $ pure 0b0000_0000_0000_0000_0100_0001_0010_0010)+ detailFlds++detailFlds :: [Fld]+detailFlds = [Fld "foo" 1 [U8 0x10], Fld "bar" 5 [U16 3], Fld "baz" 8 [U8 3]+ , Fld "quz" 14 [U16 0xABCD]]++detailBS :: [Word8]+detailBS = [0,0,16,0,0b0010_0010,0b0100_0001,0,0,0x10,0,3,0,3,0,0xCD,0xAB]++hdrBinTrip :: TestTree+hdrBinTrip = testProperty "HdrBinTrip" $ property $ do+ h <- forAll genHdr+ tripping h encode $ \bs -> case decodeOrFail bs of+ Left (_, _, er) -> Left er+ Right (_, _, h') -> Right (h' :: Hdr)++genHdr :: MonadGen m => m Hdr+genHdr = Hdr <$> genWord8 <*> genWord8 <*> genWord16 <*> genPrsnt++genPrsnt :: MonadGen m => m (NonEmpty Word32)+genPrsnt = do+ p <- genWord32+ if testBit p 31 then (p:|) <$> go else return $ p:|[]+ where+ go = do+ p <- genWord32+ if testBit p 31 then (p:) <$> go else return [p]++genWord32 :: MonadGen m => m Word32+genWord32 = Gen.word32 Range.linearBounded++genWord16 :: MonadGen m => m Word16+genWord16 = Gen.word16 Range.linearBounded++genWord8 :: MonadGen m => m Word8+genWord8 = Gen.word8 Range.linearBounded