diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,5 @@ +# Changelog + +- 0.1.0 (2025-01-17) + * Initial release, supporting basic encoding/decoding. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2025 Jared Tobin + +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/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +module Main where + +import Criterion.Main +import qualified Data.ByteString as BS +import qualified "ppad-base16" Data.ByteString.Base16 as B16 +import qualified "base16-bytestring" Data.ByteString.Base16 as R0 +import qualified "base16" Data.ByteString.Base16 as R1 + +main :: IO () +main = defaultMain [ + minimal_encode + , minimal_decode + ] + +minimal_encode :: Benchmark +minimal_encode = bench "ppad-base16" $ nf B16.encode (BS.replicate 1024 0x00) + +minimal_decode :: Benchmark +minimal_decode = bench "ppad-base16" $ nf B16.decode + (B16.encode (BS.replicate 512 0x00)) + +encode :: Benchmark +encode = bgroup "encode" [ + bench "ppad-base16" $ nf B16.encode (BS.replicate 1024 0x00) + , bench "base16-bytestring" $ nf R0.encode (BS.replicate 1024 0x00) + , bench "base16" $ nf R1.encodeBase16' (BS.replicate 1024 0x00) + ] + +decode :: Benchmark +decode = bgroup "decode" [ + bench "ppad-base16" $ nf B16.decode + (B16.encode (BS.replicate 512 0x00)) + , bench "base16-bytestring" $ nf R0.decode + (B16.encode (BS.replicate 512 0x00)) + , bench "base16" $ nf R1.decodeBase16Untyped + (B16.encode (BS.replicate 512 0x00)) + ] + +decode_various :: Benchmark +decode_various = bgroup "base16" [ + bench "1024B input" $ nf B16.decode (B16.encode (BS.replicate 512 0x00)) + , bench "1026B input" $ nf B16.decode (B16.encode (BS.replicate 513 0x00)) + , bench "1028B input" $ nf B16.decode (B16.encode (BS.replicate 514 0x00)) + , bench "1030B input" $ nf B16.decode (B16.encode (BS.replicate 515 0x00)) + , bench "1032B input" $ nf B16.decode (B16.encode (BS.replicate 516 0x00)) + , bench "1034B input" $ nf B16.decode (B16.encode (BS.replicate 517 0x00)) + , bench "1036B input" $ nf B16.decode (B16.encode (BS.replicate 518 0x00)) + , bench "1038B input" $ nf B16.decode (B16.encode (BS.replicate 519 0x00)) + , bench "1040B input" $ nf B16.decode (B16.encode (BS.replicate 520 0x00)) + ] + +encode_various :: Benchmark +encode_various = bgroup "base16" [ + bench "1024B input" $ nf B16.encode (BS.replicate 1024 0x00) + , bench "1023B input" $ nf B16.encode (BS.replicate 1023 0x00) + , bench "1022B input" $ nf B16.encode (BS.replicate 1022 0x00) + ] diff --git a/bench/Weight.hs b/bench/Weight.hs new file mode 100644 --- /dev/null +++ b/bench/Weight.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +module Main where + +import qualified Data.ByteString as BS +import qualified "base16-bytestring" Data.ByteString.Base16 as R0 +import qualified "base16" Data.ByteString.Base16 as R1 +import qualified "ppad-base16" Data.ByteString.Base16 as B16 +import qualified Weigh as W + +inp :: BS.ByteString +inp = "jtobin was here benching stuffjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin was here benching stufjtobin w" + +hinp :: BS.ByteString +hinp = B16.encode inp + +main :: IO () +main = W.mainWith $ do + W.func "ppad-base16 (encode)" B16.encode inp + W.func "base16-bytestring (encode)" R0.encode inp + W.func "base16 (encode)" R1.encodeBase16' inp + + W.func "ppad-base16 (decode)" B16.decode hinp + W.func "base16-bytestring (decode)" R0.decode hinp + W.func "base16 (decode)" R1.decodeBase16Untyped inp diff --git a/lib/Data/ByteString/Base16.hs b/lib/Data/ByteString/Base16.hs new file mode 100644 --- /dev/null +++ b/lib/Data/ByteString/Base16.hs @@ -0,0 +1,286 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Data.ByteString.Base16 +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Pure base16 encoding and decoding of strict bytestrings. + +module Data.ByteString.Base16 ( + encode + , decode + ) where + +import qualified Data.Bits as B +import Data.Bits ((.&.), (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Builder.Extra as BE +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Unsafe as BU +import Data.Word (Word8, Word16) + +to_strict :: BSB.Builder -> BS.ByteString +to_strict = BS.toStrict . BSB.toLazyByteString +{-# INLINE to_strict #-} + +to_strict_small :: BSB.Builder -> BS.ByteString +to_strict_small = BS.toStrict + . BE.toLazyByteStringWith (BE.safeStrategy 128 BE.smallChunkSize) mempty +{-# INLINE to_strict_small #-} + +fi :: (Num a, Integral b) => b -> a +fi = fromIntegral +{-# INLINE fi #-} + +hex_charset :: BS.ByteString +hex_charset = "0123456789abcdef" + +expand_w8 :: Word8 -> Word16 +expand_w8 b = + let !hi = BU.unsafeIndex hex_charset (fi b `B.shiftR` 4) + !lo = BU.unsafeIndex hex_charset (fi b .&. 0b00001111) + in fi hi `B.shiftL` 8 + .|. fi lo +{-# INLINE expand_w8 #-} + +-- | Encode a base256 'ByteString' as base16. +-- +-- >>> encode "hello world" +-- "68656c6c6f20776f726c64" +encode :: BS.ByteString -> BS.ByteString +encode bs@(BI.PS _ _ l) + | l < 64 = to_strict_small loop + | otherwise = to_strict loop + where + -- writing as few words as possible requires performing some length + -- checks up front + loop + | l `rem` 4 == 0 = go64 bs + | (l - 3) `rem` 4 == 0 = case BS.splitAt (l - 3) bs of + (chunk, etc) -> + go64 chunk + <> go32 (BU.unsafeTake 2 etc) + <> go16 (BU.unsafeDrop 2 etc) + | (l - 2) `rem` 4 == 0 = case BS.splitAt (l - 2) bs of + (chunk, etc) -> go64 chunk <> go32 etc + | (l - 1) `rem` 4 == 0 = case BS.splitAt (l - 1) bs of + (chunk, etc) -> go64 chunk <> go16 etc + + | l `rem` 2 == 0 = go32 bs + | (l - 1) `rem` 2 == 0 = case BS.splitAt (l - 1) bs of + (chunk, etc) -> go32 chunk <> go16 etc + + | otherwise = go16 bs + + go64 b = case BS.splitAt 4 b of + (chunk, etc) + | BS.null chunk -> mempty + | otherwise -> + let !w16_0 = expand_w8 (BU.unsafeIndex chunk 0) + !w16_1 = expand_w8 (BU.unsafeIndex chunk 1) + !w16_2 = expand_w8 (BU.unsafeIndex chunk 2) + !w16_3 = expand_w8 (BU.unsafeIndex chunk 3) + + !w64 = fi w16_0 `B.shiftL` 48 + .|. fi w16_1 `B.shiftL` 32 + .|. fi w16_2 `B.shiftL` 16 + .|. fi w16_3 + + in BSB.word64BE w64 <> go64 etc + + go32 b = case BS.splitAt 2 b of + (chunk, etc) + | BS.null chunk -> mempty + | otherwise -> + let !w16_0 = expand_w8 (BU.unsafeIndex chunk 0) + !w16_1 = expand_w8 (BU.unsafeIndex chunk 1) + + !w32 = fi w16_0 `B.shiftL` 16 + .|. fi w16_1 + + in BSB.word32BE w32 <> go32 etc + + go16 b = case BS.uncons b of + Nothing -> mempty + Just (h, t) -> + let !w16 = expand_w8 h + in BSB.word16BE w16 <> go16 t + +word4 :: Word8 -> Maybe Word8 +word4 w8 = fmap fi (BS.elemIndex w8 hex_charset) +{-# INLINE word4 #-} + +-- | Decode a base16 'ByteString' to base256. +-- +-- Invalid inputs (including odd-length inputs) will produce +-- 'Nothing'. +-- +-- >>> decode "68656c6c6f20776f726c64" +-- Just "hello world" +-- >>> decode "068656c6c6f20776f726c64" -- odd-length +-- Nothing +decode :: BS.ByteString -> Maybe BS.ByteString +decode bs@(BI.PS _ _ l) + | B.testBit l 0 = Nothing + | l `quot` 2 < 128 = fmap to_strict_small loop + | otherwise = fmap to_strict loop + where + -- same story, but we need more checks + loop + | l `rem` 16 == 0 = go64 mempty bs + | (l - 2) `rem` 16 == 0 = case BS.splitAt (l - 2) bs of + (chunk, etc) -> do + b0 <- go64 mempty chunk + go8 b0 etc + | (l - 4) `rem` 16 == 0 = case BS.splitAt (l - 4) bs of + (chunk, etc) -> do + b0 <- go64 mempty chunk + go16 b0 etc + | (l - 6) `rem` 16 == 0 = case BS.splitAt (l - 6) bs of + (chunk, etc) -> do + b0 <- go64 mempty chunk + b1 <- go16 b0 (BU.unsafeTake 4 etc) + go8 b1 (BU.unsafeDrop 4 etc) + | (l - 8) `rem` 16 == 0 = case BS.splitAt (l - 8) bs of + (chunk, etc) -> do + b0 <- go64 mempty chunk + go32 b0 etc + | (l - 10) `rem` 16 == 0 = case BS.splitAt (l - 10) bs of + (chunk, etc) -> do + b0 <- go64 mempty chunk + b1 <- go32 b0 (BU.unsafeTake 8 etc) + go8 b1 (BU.unsafeDrop 8 etc) + | (l - 12) `rem` 16 == 0 = case BS.splitAt (l - 12) bs of + (chunk, etc) -> do + b0 <- go64 mempty chunk + b1 <- go32 b0 (BU.unsafeTake 8 etc) + go16 b1 (BU.unsafeDrop 8 etc) + | (l - 14) `rem` 16 == 0 = case BS.splitAt (l - 14) bs of + (chunk, etc) -> do + b0 <- go64 mempty chunk + b1 <- go32 b0 (BU.unsafeTake 8 etc) + b2 <- go16 b1 (BU.unsafeTake 4 (BU.unsafeDrop 8 etc)) + go8 b2 (BU.unsafeDrop 12 etc) + + | l `rem` 8 == 0 = go32 mempty bs + | (l - 2) `rem` 8 == 0 = case BS.splitAt (l - 2) bs of + (chunk, etc) -> do + b0 <- go32 mempty chunk + go8 b0 etc + | (l - 4) `rem` 8 == 0 = case BS.splitAt (l - 4) bs of + (chunk, etc) -> do + b0 <- go32 mempty chunk + go16 b0 etc + | (l - 6) `rem` 8 == 0 = case BS.splitAt (l - 6) bs of + (chunk, etc) -> do + b0 <- go32 mempty chunk + b1 <- go16 b0 (BU.unsafeTake 4 etc) + go8 b1 (BU.unsafeDrop 4 etc) + + | l `rem` 4 == 0 = go16 mempty bs + | (l - 2) `rem` 4 == 0 = case BS.splitAt (l - 2) bs of + (chunk, etc) -> do + b0 <- go16 mempty chunk + go8 b0 etc + + | otherwise = go8 mempty bs + + go64 acc b = case BS.splitAt 16 b of + (chunk, etc) + | BS.null chunk -> pure acc + | otherwise -> do + !w4_00 <- word4 (BU.unsafeIndex chunk 00) + !w4_01 <- word4 (BU.unsafeIndex chunk 01) + !w4_02 <- word4 (BU.unsafeIndex chunk 02) + !w4_03 <- word4 (BU.unsafeIndex chunk 03) + !w4_04 <- word4 (BU.unsafeIndex chunk 04) + !w4_05 <- word4 (BU.unsafeIndex chunk 05) + !w4_06 <- word4 (BU.unsafeIndex chunk 06) + !w4_07 <- word4 (BU.unsafeIndex chunk 07) + !w4_08 <- word4 (BU.unsafeIndex chunk 08) + !w4_09 <- word4 (BU.unsafeIndex chunk 09) + !w4_10 <- word4 (BU.unsafeIndex chunk 10) + !w4_11 <- word4 (BU.unsafeIndex chunk 11) + !w4_12 <- word4 (BU.unsafeIndex chunk 12) + !w4_13 <- word4 (BU.unsafeIndex chunk 13) + !w4_14 <- word4 (BU.unsafeIndex chunk 14) + !w4_15 <- word4 (BU.unsafeIndex chunk 15) + + let !w64 = fi w4_00 `B.shiftL` 60 + .|. fi w4_01 `B.shiftL` 56 + .|. fi w4_02 `B.shiftL` 52 + .|. fi w4_03 `B.shiftL` 48 + .|. fi w4_04 `B.shiftL` 44 + .|. fi w4_05 `B.shiftL` 40 + .|. fi w4_06 `B.shiftL` 36 + .|. fi w4_07 `B.shiftL` 32 + .|. fi w4_08 `B.shiftL` 28 + .|. fi w4_09 `B.shiftL` 24 + .|. fi w4_10 `B.shiftL` 20 + .|. fi w4_11 `B.shiftL` 16 + .|. fi w4_12 `B.shiftL` 12 + .|. fi w4_13 `B.shiftL` 08 + .|. fi w4_14 `B.shiftL` 04 + .|. fi w4_15 + + go64 (acc <> BSB.word64BE w64) etc + + go32 acc b = case BS.splitAt 8 b of + (chunk, etc) + | BS.null chunk -> pure acc + | otherwise -> do + !w4_00 <- word4 (BU.unsafeIndex chunk 00) + !w4_01 <- word4 (BU.unsafeIndex chunk 01) + !w4_02 <- word4 (BU.unsafeIndex chunk 02) + !w4_03 <- word4 (BU.unsafeIndex chunk 03) + !w4_04 <- word4 (BU.unsafeIndex chunk 04) + !w4_05 <- word4 (BU.unsafeIndex chunk 05) + !w4_06 <- word4 (BU.unsafeIndex chunk 06) + !w4_07 <- word4 (BU.unsafeIndex chunk 07) + + let !w32 = fi w4_00 `B.shiftL` 28 + .|. fi w4_01 `B.shiftL` 24 + .|. fi w4_02 `B.shiftL` 20 + .|. fi w4_03 `B.shiftL` 16 + .|. fi w4_04 `B.shiftL` 12 + .|. fi w4_05 `B.shiftL` 08 + .|. fi w4_06 `B.shiftL` 04 + .|. fi w4_07 + + go32 (acc <> BSB.word32BE w32) etc + + go16 acc b = case BS.splitAt 4 b of + (chunk, etc) + | BS.null chunk -> pure acc + | otherwise -> do + !w4_00 <- word4 (BU.unsafeIndex chunk 00) + !w4_01 <- word4 (BU.unsafeIndex chunk 01) + !w4_02 <- word4 (BU.unsafeIndex chunk 02) + !w4_03 <- word4 (BU.unsafeIndex chunk 03) + + let !w16 = fi w4_00 `B.shiftL` 12 + .|. fi w4_01 `B.shiftL` 08 + .|. fi w4_02 `B.shiftL` 04 + .|. fi w4_03 + + go16 (acc <> BSB.word16BE w16) etc + + go8 acc b = case BS.splitAt 2 b of + (chunk, etc) + | BS.null chunk -> pure acc + | otherwise -> do + !w4_00 <- word4 (BU.unsafeIndex chunk 00) + !w4_01 <- word4 (BU.unsafeIndex chunk 01) + + let !w8 = fi w4_00 `B.shiftL` 04 + .|. fi w4_01 + + go8 (acc <> BSB.word8 w8) etc + diff --git a/ppad-base16.cabal b/ppad-base16.cabal new file mode 100644 --- /dev/null +++ b/ppad-base16.cabal @@ -0,0 +1,82 @@ +cabal-version: 3.0 +name: ppad-base16 +version: 0.1.0 +synopsis: Pure base16 encoding and decoding on bytestrings. +license: MIT +license-file: LICENSE +author: Jared Tobin +maintainer: jared@ppad.tech +category: Cryptography +build-type: Simple +tested-with: GHC == 9.8.1 +extra-doc-files: CHANGELOG +description: + Pure base16 (hexadecimal) encoding and decoding on bytestrings. + +source-repository head + type: git + location: git.ppad.tech/base16.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: + -Wall + exposed-modules: + Data.ByteString.Base16 + build-depends: + base >= 4.9 && < 5 + , bytestring >= 0.9 && < 0.13 + +test-suite base16-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + ghc-options: + -rtsopts -Wall -O2 + + build-depends: + base + , base16-bytestring + , bytestring + , ppad-base16 + , tasty + , tasty-quickcheck + +benchmark base16-bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + + ghc-options: + -rtsopts -O2 -Wall + + build-depends: + base + , base16 + , base16-bytestring + , bytestring + , criterion + , ppad-base16 + +benchmark base16-weigh + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Weight.hs + + ghc-options: + -rtsopts -O2 -Wall + + build-depends: + base + , base16 + , base16-bytestring + , bytestring + , criterion + , ppad-base16 + , weigh + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} + +module Main where + +import qualified Data.ByteString as BS +import qualified "ppad-base16" Data.ByteString.Base16 as B16 +import qualified "base16-bytestring" Data.ByteString.Base16 as R0 +import Test.Tasty +import qualified Test.Tasty.QuickCheck as Q + +newtype BS = BS BS.ByteString + deriving (Eq, Show) + +bytes :: Int -> Q.Gen BS.ByteString +bytes k = do + l <- Q.chooseInt (0, k) + v <- Q.vectorOf l Q.arbitrary + pure (BS.pack v) + +instance Q.Arbitrary BS where + arbitrary = do + b <- bytes 1024 + pure (BS b) + +decode_inverts_encode :: BS -> Bool +decode_inverts_encode (BS bs) = case B16.decode (B16.encode bs) of + Nothing -> False + Just b -> b == bs + +encode_matches_reference :: BS -> Bool +encode_matches_reference (BS bs) = + let us = B16.encode bs + r0 = R0.encode bs + in us == r0 + +decode_matches_reference :: BS -> Bool +decode_matches_reference (BS bs) = + let enc = R0.encode bs + us = B16.decode enc + r0 = R0.decode enc + in case us of + Nothing -> case r0 of + Left _ -> True + _ -> False + Just du -> case r0 of + Left _ -> False + Right d0 -> du == d0 + +main :: IO () +main = defaultMain $ + testGroup "ppad-base16" [ + testGroup "property tests" [ + Q.testProperty "decode . encode ~ id" $ + Q.withMaxSuccess 5000 decode_inverts_encode + , Q.testProperty "encode matches reference" $ + Q.withMaxSuccess 5000 encode_matches_reference + , Q.testProperty "decode matches reference" $ + Q.withMaxSuccess 5000 decode_matches_reference + ] + ] +