diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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]))` +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bit-protocol.cabal b/bit-protocol.cabal new file mode 100644 --- /dev/null +++ b/bit-protocol.cabal @@ -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 diff --git a/src/Data/BitProtocol.hs b/src/Data/BitProtocol.hs new file mode 100644 --- /dev/null +++ b/src/Data/BitProtocol.hs @@ -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 diff --git a/test/tests.hs b/test/tests.hs new file mode 100644 --- /dev/null +++ b/test/tests.hs @@ -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