diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for tap + +## 0.1.0.0 -- 11-2-2026 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -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" + ] diff --git a/lib/Data/Tap.hs b/lib/Data/Tap.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Tap.hs @@ -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]] diff --git a/tap.cabal b/tap.cabal new file mode 100644 --- /dev/null +++ b/tap.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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