bit-protocol (empty) → 0.1.0.0
raw patch · 6 files changed
+358/−0 lines, 6 filesdep +basedep +base64-bytestringdep +bit-protocolsetup-changed
Dependencies added: base, base64-bytestring, bit-protocol, bytestring, dlist, ghc-prim, tasty, tasty-hunit
Files
- LICENSE +30/−0
- README.md +31/−0
- Setup.hs +2/−0
- bit-protocol.cabal +56/−0
- src/Data/BitProtocol.hs +79/−0
- test/tests.hs +160/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Kostiantyn Rybnikov (c) 2018++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 Kostiantyn Rybnikov 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.
+ README.md view
@@ -0,0 +1,31 @@+# bit-protocol++A package suitable for binary protocols defined in a manner where you+have bit counts not aligned by 8.++For example, if you have a protocol for sending user profiles saying:++> The value sent must be a base64url-encoded string consisting of four+> values:+> - 6 bits representing user's age+> - 7 bits for their favorite number+> - 5 bits for their lucky number+> - 6 bits for a random number++you could use the library as follows:++```haskell+import Data.BitProtocol+import Data.ByteString.Base64.URL (encode)++main :: IO ()+main = do+ let age = 29+ fav = 12+ 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]+ -- will output "dGNO"+ -- which is the same as `encode (BC8.pack (map chr [0b01110100, 0b01100011, 0b01001110]))`+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bit-protocol.cabal view
@@ -0,0 +1,56 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: ec30889fc43fd0112887509aa2ea887fef7ed2034cdd4ab83046dcb367251dfb++name: bit-protocol+version: 0.1.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+homepage: https://github.com/k-bx/bit-protocol#readme+author: Kostiantyn Rybnikov+maintainer: k-bx@k-bx.com+copyright: Kostiantyn Rybnikov+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ README.md++library+ exposed-modules:+ Data.BitProtocol+ other-modules:+ Paths_bit_protocol+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , base64-bytestring+ , bytestring+ , dlist+ , ghc-prim+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: tests.hs+ other-modules:+ Paths_bit_protocol+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , base64-bytestring+ , bit-protocol+ , bytestring+ , dlist+ , ghc-prim+ , tasty+ , tasty-hunit+ default-language: Haskell2010
+ src/Data/BitProtocol.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.BitProtocol where++import qualified Data.ByteString.Builder as BB+import Data.ByteString.Lazy (ByteString)+import qualified Data.DList as DL+import Data.Word (Word8)++data BitsVal a = BitsVal+ { bvBitsNum :: Int+ , bvVal :: a+ } deriving (Show, Eq)++instance Num a => Semigroup (BitsVal a) where+ (BitsVal size1 val1) <> (BitsVal size2 val2) =+ BitsVal (size1 + size2) (val1 * 2 ^ size2 + val2)++-- | WARNING! Can overflow, so only concat on a small number of items+instance Integral a => Monoid (BitsVal a) where+ mempty = BitsVal 0 0++numToWord8Array :: Integral a => BitsVal a -> [Word8]+numToWord8Array x' = go x'+ where+ go (BitsVal len _)+ | len <= 0 = []+ go (BitsVal len val)+ | len <= 8 = [fromIntegral val]+ go (BitsVal len val) =+ (fromIntegral (val `div` (2 ^ (len - 8)))) :+ go (BitsVal (len - 8) (val `mod` 2 ^ (len - 8)))++word8sToIntegral :: Integral a => [Word8] -> a+word8sToIntegral xs' = go xs' (length xs')+ where+ go [] _ = 0+ go (x:xs) len = fromIntegral x * (2 ^ ((len - 1) * 8)) + go xs (len - 1)++-- | 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 x =+ let word8arr = numToWord8Array x+ (word8arrHead, word8arrTail) = splitAt (bvBitsNum x `div` 8) word8arr+ in ( word8arrHead+ , BitsVal (bvBitsNum x `mod` 8) (word8sToIntegral word8arrTail))++roundTo8 :: Integral a => BitsVal a -> BitsVal a+roundTo8 (BitsVal 0 _val) = BitsVal 0 0+roundTo8 (BitsVal len val) =+ let newLen = len + (8 - (len `mod` 8))+ newVal = val * (2 ^ (newLen - len))+ in BitsVal newLen newVal++-- | 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)+ where+ go :: Integral a => [BitsVal a] -> DL.DList (BitsVal a) -> BB.Builder+ go [] prefix =+ let v = mconcat (DL.toList prefix)+ newV = roundTo8 v+ in mconcat (map BB.word8 (fst (bitsValBiggerToCharUnsafe newV)))+ go (x:xs) prefix =+ let bitsToConvert = sumOfBitsNum prefix + bvBitsNum x+ prefixWithX = DL.snoc prefix x+ in if bitsToConvert < 8+ then go xs prefixWithX+ else let (word8s, bv) =+ bitsValBiggerToCharUnsafe+ (mconcat (DL.toList prefixWithX))+ in mconcat (map BB.word8 word8s) <> go xs (DL.singleton bv)+ sumOfBitsNum = sum . DL.map bvBitsNum
+ test/tests.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.BitProtocol+import qualified Data.ByteString.Base64.URL.Lazy as B64URL+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+ testGroup+ "Tests"+ [ testCase "Semigroup/Monoid 000001 + 000001 == 000001000001" $ do+ mconcat [BitsVal 6 (1 :: Int), BitsVal 6 1] @?=+ BitsVal 12 0b000001000001+ , testCase "numToWord8Array simple" $ do+ numToWord8Array (BitsVal 12 (0b000001000001 :: Int)) @?=+ [0b00000100, 0b0001]+ , testCase "word8sToIntegral simple" $ do+ word8sToIntegral [0b0001] @?= (1 :: Int)+ , testCase "bitsValBiggerToCharUnsafe simple" $ do+ bitsValBiggerToCharUnsafe (BitsVal 12 (0b000001000001 :: Int)) @?=+ ([0b00000100], BitsVal 4 0b0001)+ , testCase "Readme example" $ do+ let age = 29 :: Int+ fav = 12+ lucky = 13+ rand = 14+ B64URL.encode+ (bitsValsToBS8+ [BitsVal 6 age, BitsVal 7 fav, BitsVal 5 lucky, BitsVal 6 rand]) @?=+ "dGNO"+ , testCase "bitsValsToBS8 without encoding" $ do+ bitsValsToBS8+ [ BitsVal 4 (0b0000 :: Int)+ , BitsVal 4 0b0100+ , BitsVal 4 0b1110+ , BitsVal 4 0b0001+ , BitsVal 4 0b0000+ , BitsVal 4 0b0101+ , BitsVal 4 0b0001+ , BitsVal 4 0b0000+ ] @?=+ "\x04\xE1\x05\x10"+ , testCase "mconcat simple test" $+ do mconcat+ [ BitsVal 6 0b000001+ , BitsVal 26 (0b00111000010000010100010000 :: Int)+ ]+ @?= BitsVal 32 0b00000100111000010000010100010000+ , testCase "division logic check" $ do+ (0b00000100111000010000010100010000 :: Int) `div`+ (2 ^ (32 - (8 :: Int))) @?= 0b00000100+ 0b00000100111000010000010100010000 `mod`+ (2 ^ (32 - (8 :: Int))) @?= (0b111000010000010100010000 :: Int)+ , testCase "numToWord8Array simple test" $ do+ numToWord8Array (BitsVal 32 (0b00000100111000010000010100010000 :: Int)) @?=+ [0b00000100, 0b11100001, 0b00000101, 0b00010000]+ , testCase "bitsValBiggerToCharUnsafe simple test" $ do+ bitsValBiggerToCharUnsafe+ (BitsVal 32 (0b00000100111000010000010100010000 :: Int)) @?=+ ([0b00000100, 0b11100001, 0b00000101, 0b00010000], BitsVal 0 0)+ , testCase "bitsValsToBS8 without encoding for the GDPR subcase" $ do+ bitsValsToBS8+ [BitsVal 6 (0b000001 :: Int), BitsVal 26 0b00111000010000010100010000] @?=+ "\x04\xE1\x05\x10"+ , testCase "base64url reassurance" $+ -- 000001 001110000100000101000100000000110010 001110000100000101000100000000110010 ...+ -- 000001001110000100000101000100000000110010001110000100000101000100000000110010 ...+ -- 000001_001110_000100_000101_000100_000000_110010_001110_000100_000101_000100_000000_110010 ...+ -- 1 14 4 5 4 0 50 ...+ -- B O E F E A y ...+ -- 0000_0100_1110_0001_0000_0101_0001_0000_0000_1100_1000_1110_0001_0000_0101_0001_0000_0000_1100_10 ...+ -- 04E105100C ...+ do B64URL.encode "\x04\xE1\x05\x10\x0C" @?= "BOEFEAw="+ , testCase "roundTo8 simple" $ do+ roundTo8 (BitsVal 6 0b000001) @?= BitsVal 8 (0b00000100 :: Int)+ , testCase "roundTo8 zero" $ do+ roundTo8 (BitsVal 0 0) @?= BitsVal 0 (0 :: Int)+ , testCase "GDPR subcase" $ do+ B64URL.encode+ (bitsValsToBS8+ [ BitsVal 6 (0b000001 :: Int)+ , BitsVal 36 0b001110000100000101000100000000110010+ ]) @?=+ "BOEFEAyA"+ , testCase+ "GDPR example (see \"Example Vendor Consent String\" at https://github.com/InteractiveAdvertisingBureau/GDPR-Transparency-and-Consent-Framework/blob/master/Consent%20string%20and%20vendor%20list%20formats%20v1.1%20Final.md#example-vendor-consent-string-)" $ do+ let version = BitsVal 6 (0b000001 :: Int)+ created = BitsVal 36 0b001110000100000101000100000000110010+ lastUpdated = BitsVal 36 0b001110000100000101000100000000110010+ cmpId = BitsVal 12 0b000000000111+ cmpVersion = BitsVal 12 0b000000000001+ consentScreen = BitsVal 6 0b000011+ consentLanguage = BitsVal 12 0b000100001101+ vendorListVersion = BitsVal 12 0b000000001000+ purposesAllowed = BitsVal 24 0b111000000000000000000000+ maxVendorId = BitsVal 16 0b0000011111011011+ encodingType = BitsVal 1 1+ defaultConsent = BitsVal 1 1+ numEntries = BitsVal 12 0b000000000001+ singleOrRange = BitsVal 1 0+ singleVendorId = BitsVal 16 0b0000000000001001+ expectedResult = "BOEFEAyOEFEAyAHABDENAI4AAAB9vABAASA="+ B64URL.encode+ (bitsValsToBS8+ [ version+ , created+ , lastUpdated+ , cmpId+ , cmpVersion+ , consentScreen+ , consentLanguage+ , vendorListVersion+ , purposesAllowed+ , maxVendorId+ , encodingType+ , defaultConsent+ , numEntries+ , singleOrRange+ , 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+ ]++main :: IO ()+main = defaultMain tests