bit-protocol 0.1.0.0 → 0.2.0.0

raw patch · 4 files changed

+200/−54 lines, 4 filesdep +QuickCheckdep +tasty-quickcheckPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, tasty-quickcheck

API changes (from Hackage documentation)

Files

• README.md +22/−1
• bit-protocol.cabal +7/−4
• src/Data/BitProtocol.hs +94/−11
• test/tests.hs +77/−38

@@ -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)

@@ -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

@@ -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)

@@ -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 ()