diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,7 +25,28 @@ lucky = 13 rand = 14 -- the number in protocol should be base64url(011101_0001100_01101_001110) - print $ encode $ bitsValsToBS8 $ [BitsVal 6 age, BitsVal 7 fav, BitsVal 5 lucky, BitsVal 6 rand] + print $ encode $ encodeBS8 $ [BitsVal 6 age, BitsVal 7 fav, BitsVal 5 lucky, BitsVal 6 rand] -- will output "dGNO" -- which is the same as `encode (BC8.pack (map chr [0b01110100, 0b01100011, 0b01001110]))` ``` + +Parsing can be done like this: + +```haskell + let (Right bs) = decode "dGNO" + let (xs, BitsVal 0 0, "") = parseBS8 [6, 7, 5, 6] bs + print xs +-- Will output: +-- ( [BitsVal 6 29, BitsVal 7 12, BitsVal 5 13, BitsVal 6 14] +-- , BitsVal 0 0 +-- , "") +``` + +Warning! Does not support negative numbers. + +TODO: + +- [ ] use shift operations instead of division in more places +- [ ] add a performance test +- [ ] consider adding checks upon arithmetic overflows (if you use + `Int` in quickcheck test you'll quickly find some) diff --git a/bit-protocol.cabal b/bit-protocol.cabal --- a/bit-protocol.cabal +++ b/bit-protocol.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ec30889fc43fd0112887509aa2ea887fef7ed2034cdd4ab83046dcb367251dfb +-- hash: c8084713be489e1d73baae68e5a9c777a86d8df4dd818e9bc3b0c5b6cfe470a0 name: bit-protocol -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Encode binary protocols with some odd bit numbers into a bytestring description: Encode binary protocols with some odd bit numbers into a bytestring. category: Data, Parsing, Bits, Bytes, Protocols @@ -29,7 +29,8 @@ src ghc-options: -Wall build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , base64-bytestring , bytestring , dlist @@ -45,7 +46,8 @@ test ghc-options: -Wall build-depends: - base >=4.7 && <5 + QuickCheck + , base >=4.7 && <5 , base64-bytestring , bit-protocol , bytestring @@ -53,4 +55,5 @@ , ghc-prim , tasty , tasty-hunit + , tasty-quickcheck default-language: Haskell2010 diff --git a/src/Data/BitProtocol.hs b/src/Data/BitProtocol.hs --- a/src/Data/BitProtocol.hs +++ b/src/Data/BitProtocol.hs @@ -1,20 +1,41 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} -module Data.BitProtocol where +module Data.BitProtocol + ( BitsVal(..) + , encodeBS8 + , parseBS8 + -- * internal + , bitsValBiggerToCharUnsafe + , word8sToIntegral + , numToWord8Array + , roundTo8 + , readBitValue + , byteStringToBitsVal + ) where +import Data.Bits import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy (ByteString) import qualified Data.DList as DL import Data.Word (Word8) +import GHC.Generics (Generic) +import Numeric.Natural +import Test.QuickCheck (Arbitrary(..), arbitrarySizedNatural) data BitsVal a = BitsVal - { bvBitsNum :: Int + { bvBitsNum :: Natural , bvVal :: a - } deriving (Show, Eq) + } deriving (Show, Eq, Generic) +instance Arbitrary a => Arbitrary (BitsVal a) where + arbitrary = BitsVal <$> arbitrarySizedNatural <*> arbitrary + instance Num a => Semigroup (BitsVal a) where (BitsVal size1 val1) <> (BitsVal size2 val2) = BitsVal (size1 + size2) (val1 * 2 ^ size2 + val2) @@ -23,7 +44,7 @@ instance Integral a => Monoid (BitsVal a) where mempty = BitsVal 0 0 -numToWord8Array :: Integral a => BitsVal a -> [Word8] +numToWord8Array :: (Integral a, Bits a) => BitsVal a -> [Word8] numToWord8Array x' = go x' where go (BitsVal len _) @@ -31,7 +52,7 @@ go (BitsVal len val) | len <= 8 = [fromIntegral val] go (BitsVal len val) = - (fromIntegral (val `div` (2 ^ (len - 8)))) : + (fromIntegral (val `shiftR` (fromIntegral len - 8))) : go (BitsVal (len - 8) (val `mod` 2 ^ (len - 8))) word8sToIntegral :: Integral a => [Word8] -> a @@ -43,14 +64,16 @@ -- | Convert left 8 bits to a list of 'Word8', while giving a leftover -- value). Assumes that the 'BitsVal' argument's length is more than -- 8. -bitsValBiggerToCharUnsafe :: Integral a => BitsVal a -> ([Word8], BitsVal a) +bitsValBiggerToCharUnsafe :: + (Bits a, Integral a, Show a) => BitsVal a -> ([Word8], BitsVal a) bitsValBiggerToCharUnsafe x = let word8arr = numToWord8Array x - (word8arrHead, word8arrTail) = splitAt (bvBitsNum x `div` 8) word8arr + (word8arrHead, word8arrTail) = + splitAt (fromIntegral (bvBitsNum x) `div` 8) word8arr in ( word8arrHead , BitsVal (bvBitsNum x `mod` 8) (word8sToIntegral word8arrTail)) -roundTo8 :: Integral a => BitsVal a -> BitsVal a +roundTo8 :: (Integral a, Show a) => BitsVal a -> BitsVal a roundTo8 (BitsVal 0 _val) = BitsVal 0 0 roundTo8 (BitsVal len val) = let newLen = len + (8 - (len `mod` 8)) @@ -59,10 +82,14 @@ -- | Converts a list of chars into a bytestring via construction of -- 8-bit chars. Pads with zeroes on the right if a sum is not divisible by 8. -bitsValsToBS8 :: (Integral a) => [BitsVal a] -> ByteString -bitsValsToBS8 xs' = BB.toLazyByteString (go xs' DL.empty) +encodeBS8 :: (Bits a, Integral a, Show a) => [BitsVal a] -> ByteString +encodeBS8 xs' = BB.toLazyByteString (go xs' DL.empty) where - go :: Integral a => [BitsVal a] -> DL.DList (BitsVal a) -> BB.Builder + go :: + (Bits a, Integral a, Show a) + => [BitsVal a] + -> DL.DList (BitsVal a) + -> BB.Builder go [] prefix = let v = mconcat (DL.toList prefix) newV = roundTo8 v @@ -77,3 +104,59 @@ (mconcat (DL.toList prefixWithX)) in mconcat (map BB.word8 word8s) <> go xs (DL.singleton bv) sumOfBitsNum = sum . DL.map bvBitsNum + +byteStringToBitsVal :: Integral a => ByteString -> BitsVal a +byteStringToBitsVal inp = + let bytes = BL.unpack inp + in go bytes (BitsVal 0 0) + where + go [] acc = acc + go (x:xs) (BitsVal len val) = + go xs (BitsVal (len + 8) (val * (2 ^ (8 :: Int)) + fromIntegral x)) + +-- | Read a single 'BitsVal' from a 'BitsVal' which wasn't consumed +-- (part of a byte) and some 'ByteString' big enough to cover that +-- value +readBitValue :: + (Bits a, Integral a, Show a) + => Natural + -> BitsVal a + -> ByteString + -> (BitsVal a, BitsVal a) +readBitValue numBits leftBv inp = + let rightBv = byteStringToBitsVal inp + inpBvFull = leftBv <> rightBv + inpBvNumBitsOnly = + BitsVal + numBits + (bvVal inpBvFull `shiftR` + (fromIntegral (bvBitsNum inpBvFull - numBits))) + inpBvLeftover = + BitsVal + (bvBitsNum inpBvFull - numBits) + (bvVal inpBvFull `mod` 2 ^ (bvBitsNum inpBvFull - numBits)) + in (inpBvNumBitsOnly, inpBvLeftover) + +-- | Parse a 'ByteString' by a given spec. Return the values consumed, +-- a leftover BitsVal (will be 'BitsVal 0 0' for fully-consumed byte, +-- something else for a half-consumed one) and a leftover 'ByteString' +-- tail. +parseBS8 :: + (Bits a, Integral a, Show a) + => [Natural] + -> ByteString + -> ([BitsVal a], BitsVal a, ByteString) +parseBS8 bitLengths input = + let (bitVals, bvInp, rest) = go bitLengths (BitsVal 0 0) input DL.empty + in (bitVals, bvInp, rest) + where + go [] bvInp inp acc = (DL.toList acc, bvInp, inp) + go (x:xs) bvInp inp acc = + let bytesNeeded = + ((x - bvBitsNum bvInp) `div` 8) + + (if (x - bvBitsNum bvInp) `mod` 8 == 0 + then 0 + else 1) + (chunk, rest) = BL.splitAt (fromIntegral bytesNeeded) inp + (bv, bvLeftover) = readBitValue x bvInp chunk + in go xs bvLeftover rest (DL.snoc acc bv) diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -7,6 +9,7 @@ import qualified Data.ByteString.Base64.URL.Lazy as B64URL import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC tests :: TestTree tests = @@ -29,11 +32,11 @@ lucky = 13 rand = 14 B64URL.encode - (bitsValsToBS8 + (encodeBS8 [BitsVal 6 age, BitsVal 7 fav, BitsVal 5 lucky, BitsVal 6 rand]) @?= "dGNO" - , testCase "bitsValsToBS8 without encoding" $ do - bitsValsToBS8 + , testCase "encodeBS8 without encoding" $ do + encodeBS8 [ BitsVal 4 (0b0000 :: Int) , BitsVal 4 0b0100 , BitsVal 4 0b1110 @@ -62,8 +65,8 @@ bitsValBiggerToCharUnsafe (BitsVal 32 (0b00000100111000010000010100010000 :: Int)) @?= ([0b00000100, 0b11100001, 0b00000101, 0b00010000], BitsVal 0 0) - , testCase "bitsValsToBS8 without encoding for the GDPR subcase" $ do - bitsValsToBS8 + , testCase "encodeBS8 without encoding for the GDPR subcase" $ do + encodeBS8 [BitsVal 6 (0b000001 :: Int), BitsVal 26 0b00111000010000010100010000] @?= "\x04\xE1\x05\x10" , testCase "base64url reassurance" $ @@ -81,7 +84,7 @@ roundTo8 (BitsVal 0 0) @?= BitsVal 0 (0 :: Int) , testCase "GDPR subcase" $ do B64URL.encode - (bitsValsToBS8 + (encodeBS8 [ BitsVal 6 (0b000001 :: Int) , BitsVal 36 0b001110000100000101000100000000110010 ]) @?= @@ -105,7 +108,7 @@ singleVendorId = BitsVal 16 0b0000000000001001 expectedResult = "BOEFEAyOEFEAyAHABDENAI4AAAB9vABAASA=" B64URL.encode - (bitsValsToBS8 + (encodeBS8 [ version , created , lastUpdated @@ -123,37 +126,73 @@ , singleVendorId ]) @?= expectedResult - -- , testCase - -- "GDPR example from https://github.com/InteractiveAdvertisingBureau/Consent-String-SDK-Java/blob/master/src/test/java/com/iab/gdpr/consent/VendorConsentEncoderTest.java" $ do - -- let version = BitsVal 6 0b000011 - -- created = BitsVal 36 0b001110001110110011010000101000000000 - -- lastUpdated = BitsVal 36 0b001110001110110011010000101000000000 - -- cmpId = BitsVal 12 0b000000001111 - -- cmpVersion = BitsVal 12 0b000000000101 - -- consentScreen = BitsVal 6 0b010010 - -- consentLanguage = BitsVal 12 0b000100001101 - -- vendorListVersion = BitsVal 12 0b000010010110 - -- purposesAllowed = BitsVal 24 0b111110000000001000000001 - -- maxVendorId = BitsVal 16 0b0000000000100000 - -- encodingType = BitsVal 1 0 - -- vendorBits = BitsVal 16 0b0000000000100000 - -- expectedResult = "BOOlLqOOOlLqTABABAENAk-AAAAXx799uzGvrf3nW8_39P3g_7_O3_7m_-zzV48_lrQV1yPAUCgA" - -- B64URL.encode - -- (bitsValsToBS8 - -- [ version - -- , created - -- , lastUpdated - -- , cmpId - -- , cmpVersion - -- , consentScreen - -- , consentLanguage - -- , vendorListVersion - -- , purposesAllowed - -- , maxVendorId - -- , encodingType - -- , vendorBits - -- ]) @?= - -- expectedResult + , testCase "byteStringToBitsVal simple" $ do + byteStringToBitsVal "\x04\xE1\xe05\x10" @?= + BitsVal 32 (0b00000100111000010000010100010000 :: Int) + , testCase + "readBitValue reading 6 bits from \"010 + 11111111\" gives \"010111\" and a leftover \"11111\"" $ do + readBitValue 6 (BitsVal 3 (0b010 :: Int)) "\xFF" @?= + (BitsVal 6 0b010111, BitsVal 5 0b11111) + , testCase "parseBS8 simple parse" $ do + parseBS8 [6, 26] "\x04\xE1\x05\x10" @?= + ( [ BitsVal 6 (0b000001 :: Int) + , BitsVal 26 0b00111000010000010100010000 + ] + , BitsVal 0 0 + , "") + , testCase "parseBS8 from readme" $ do + let (Right bs) = B64URL.decode "dGNO" + parseBS8 [6, 7, 5, 6] bs @?= + ( [BitsVal 6 (29 :: Int), BitsVal 7 12, BitsVal 5 13, BitsVal 6 14] + , BitsVal 0 0 + , "") + , testCase "quickcheck failure simplified-02" $ do + readBitValue 20 (BitsVal 7 (0 :: Int)) "\NUL\DLE\ENQ\NUL" @?= + (BitsVal 20 2, BitsVal 19 1280) + , testCase "quickcheck failure simplified-01" $ + do parseBS8 + @Int + [17, 20, 11, 15, 19, 13, 12, 13, 10] + "\NUL\EOT\128\NUL\DLE\ENQ\NUL\STX\NUL\NUL\128\STX\NUL\128\STX\SOH\128" + @?= ( [ BitsVal {bvBitsNum = 17, bvVal = 9} + , BitsVal {bvBitsNum = 20, bvVal = 2} + , BitsVal {bvBitsNum = 11, bvVal = 5} + , BitsVal {bvBitsNum = 15, bvVal = 1} + , BitsVal {bvBitsNum = 19, bvVal = 2} + , BitsVal {bvBitsNum = 13, bvVal = 1} + , BitsVal {bvBitsNum = 12, bvVal = 4} + , BitsVal {bvBitsNum = 13, bvVal = 2} + , BitsVal {bvBitsNum = 10, bvVal = 6} + ] + , BitsVal {bvBitsNum = 6, bvVal = 0} + , "") + , testCase "encode . decode = id from QuickCheck failure" $ do + let xs = + [ BitsVal 17 (9 :: Int) + , BitsVal 20 2 + , BitsVal 11 5 + , BitsVal 15 1 + , BitsVal 19 2 + , BitsVal 13 1 + , BitsVal 12 4 + , BitsVal 13 2 + , BitsVal 10 6 + ] + bitNums = map bvBitsNum xs + (res, _, _) = parseBS8 @Int bitNums (encodeBS8 xs) + res @?= xs + , testCase "encode . decode = id from QuickCheck failure-02" $ do + let xs :: [BitsVal Int] + xs = [BitsVal 12 4, BitsVal 16 2] + bitNums = [12, 16] + (res, _, _) = parseBS8 bitNums (encodeBS8 xs) + res @?= xs + , QC.testProperty "encode . decode = id" $ \(xs' :: [BitsVal (Positive Integer)]) -> + let xs = + map (\(BitsVal len (Positive val)) -> BitsVal (len + 10) val) xs' + bitNums = map bvBitsNum xs + (res, _, _) = parseBS8 bitNums (encodeBS8 xs) + in res == xs ] main :: IO ()