Merge #128

128: Copy old base16 decode implementation r=newhoggy a=newhoggy

Copy code from `base16-bytestring`, `Data.ByteString.Base16` to facilitate migration from `base16-bytestring-0.1.1.7` to `base16-bytestring-1.0.0.0` into an `Internal` module.

This will unblock upgrade of `base16-bytestring` to `base16-bytestring-1.0.0.0` in a subsequence commit.

New function `decodeEitherBase16` that behaves just like decode from `base16-bytestring-1.0.0.0`.  This function will eventually (soon) be changed to delegate to that function post upgrade which will allow a lot of code introduced in this PR to be deleted.  The purpose of introducing this function so that downstream projects can use it allowing for a smooth upgrade of `base16-bytestring-0.1.1.7` to `base16-bytestring-1.0.0.0`.

Co-authored-by: John Ky <john.ky@iohk.io>

cardano-prelude-test/cardano-prelude-test.cabal

@@ -66,10 +66,13 @@ test-suite cardano-prelude-test-suite
   hs-source-dirs:      test
   main-is:             test.hs
   type:                exitcode-stdio-1.0
-  other-modules:       Test.Cardano.Prelude.GHC.Heap.NormalFormSpec
+  other-modules:       Test.Cardano.Prelude.Base16Spec
+                       Test.Cardano.Prelude.GHC.Heap.NormalFormSpec
                        Test.Cardano.Prelude.GHC.Heap.SizeSpec
                        Test.Cardano.Prelude.GHC.Heap.TreeSpec
+
   build-depends:       base
+                     , base16-bytestring
                      , bytestring
                      , cardano-prelude
                      , cardano-prelude-test

cardano-prelude-test/test/Test/Cardano/Prelude/Base16Spec.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+module Test.Cardano.Prelude.Base16Spec
+  ( tests
+  ) where
+
+import Cardano.Prelude
+import Hedgehog ((===), Property, Range, MonadGen)
+
+import qualified Hedgehog as H
+import qualified Hedgehog.Gen as G
+import qualified Hedgehog.Range as R
+import qualified Data.ByteString.Base16 as B16
+import qualified Cardano.Prelude.Base16.Internal as I
+import qualified Data.ByteString as BS
+import qualified Data.Text.Encoding as T
+
+{- HLINT ignore "Reduce duplication" -}
+
+genByteString :: MonadGen m => Range Int -> m Word8 -> m ByteString
+genByteString r g = BS.pack <$> G.list r g
+
+prop_roundtrip :: Property
+prop_roundtrip = H.withTests 100 . H.property $ do
+  bs <- H.forAll $ genByteString (R.linear 0 10) (G.word8 R.constantBounded)
+  b16 <- H.forAll . pure $ B16.encode bs
+  I.decode b16 === (bs, "")
+
+prop_noRegressionsValid :: Property
+prop_noRegressionsValid = H.withTests 100 . H.property $ do
+  bs <- H.forAll $ genByteString (R.linear 0 10) (G.word8 R.constantBounded)
+  b16 <- H.forAll . pure $ B16.encode bs
+  I.decode b16 === B16.decode b16
+
+prop_noRegressionsInvalidSuffix :: Property
+prop_noRegressionsInvalidSuffix = H.withTests 100 . H.property $ do
+  bs <- H.forAll $ genByteString (R.linear 0 10) (G.word8 R.constantBounded)
+  suffix <- H.forAll $ genByteString (R.linear 0 10) (G.element (BS.unpack (T.encodeUtf8 "qu")))
+  b16 <- H.forAll . pure $ B16.encode bs <> suffix
+  I.decode b16 === B16.decode b16
+
+prop_decodeEitherBase16_examples :: Property
+prop_decodeEitherBase16_examples = H.withTests 1 . H.property $ do
+  decodeEitherBase16 "666f6f" === Right "foo"
+  decodeEitherBase16 "66quux" === Left "invalid character at offset: 2"
+  decodeEitherBase16 "666quux" === Left "invalid character at offset: 3"
+
+tests :: IO Bool
+tests = and <$> sequence [H.checkParallel $$(H.discover)]

cardano-prelude-test/test/test.hs

@@ -1,18 +1,19 @@
 module Main
   ( main
-  )
-where
+  ) where
 
 import Cardano.Prelude
 import Test.Cardano.Prelude
 
+import qualified Test.Cardano.Prelude.Base16Spec
 import qualified Test.Cardano.Prelude.GHC.Heap.NormalFormSpec
 import qualified Test.Cardano.Prelude.GHC.Heap.SizeSpec
 import qualified Test.Cardano.Prelude.GHC.Heap.TreeSpec
 
 main :: IO ()
 main = runTests
-  [ Test.Cardano.Prelude.GHC.Heap.NormalFormSpec.tests
+  [ Test.Cardano.Prelude.Base16Spec.tests
+  , Test.Cardano.Prelude.GHC.Heap.NormalFormSpec.tests
   , Test.Cardano.Prelude.GHC.Heap.SizeSpec.tests
   , Test.Cardano.Prelude.GHC.Heap.TreeSpec.tests
   ]

cardano-prelude/cardano-prelude.cabal

@@ -21,6 +21,7 @@ flag development
 library
   hs-source-dirs:      src
   exposed-modules:     Cardano.Prelude
+                       Cardano.Prelude.Base16.Internal
                        Data.FingerTree.Strict
                        Data.Sequence.Strict
                        Data.Semigroup.Action

cardano-prelude/src/Cardano/Prelude/Base16.hs

@@ -3,19 +3,23 @@
 -- | Helper functions for parsing
 
 module Cardano.Prelude.Base16
-  ( parseBase16
-  , Base16ParseError(..)
+  ( Base16ParseError(..)
+
+  , decodeEitherBase16
+  , parseBase16
   )
 where
 
 import Cardano.Prelude.Base
+import Data.String
+import Formatting (bprint, shown)
+import Formatting.Buildable (Buildable(build))
 
-import qualified Data.ByteString.Base16 as B16
+import qualified Cardano.Prelude.Base16.Internal as B16
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Text.Encoding as Text
-import Formatting (bprint, shown)
-import Formatting.Buildable (Buildable(build))
 
+{- HLINT ignore "Use isDigit" -}
 
 newtype Base16ParseError =
   Base16IncorrectSuffix ByteString
@@ -30,3 +34,13 @@ parseBase16 s = do
   let (bs, suffix) = B16.decode $ Text.encodeUtf8 s
   unless (BS.null suffix) . Left $ Base16IncorrectSuffix suffix
   pure bs
+
+decodeEitherBase16 :: ByteString -> Either String ByteString
+decodeEitherBase16 bs = case B16.decode bs of
+  (decodedBs, "") -> Right decodedBs
+  (_, _) -> Left $ "invalid character at offset: " <> show (BS.length (BS.takeWhile isHex bs))
+  where isHex :: Char -> Bool
+        isHex w =
+          (w >= '0' && w <= '9') ||
+          (w >= 'a' && w <= 'f') ||
+          (w >= 'A' && w <= 'F')

cardano-prelude/src/Cardano/Prelude/Base16/Internal.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE BangPatterns, MagicHash #-}
+
+{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-}
+
+-- |
+-- Module      : Data.ByteString.Base16
+-- Copyright   : (c) 2011 MailRank, Inc.
+--
+-- License     : BSD
+-- Maintainer  : bos@serpentine.com
+-- Stability   : experimental
+-- Portability : GHC
+--
+-- Fast and efficient encoding and decoding of base16-encoded strings.
+--
+-- This code is lifted directly from https://hackage.haskell.org/package/base16-bytestring-0.1.1.7/docs/src/Data.ByteString.Base16.html
+-- and is intended to be temporary to facilitate migration from base16-bytestring-0.1.1.7 to base16-bytestring-1.0.0.0
+
+module Cardano.Prelude.Base16.Internal
+  ( decode
+  ) where
+
+import Data.Functor
+import Data.Eq
+import Data.Bool
+import Data.Function
+import Data.ByteString.Char8 (empty)
+import Control.Monad
+import Data.ByteString.Internal (ByteString(..), createAndTrim')
+import Data.Bits (shiftL)
+import Data.Ord
+import GHC.Num
+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
+import Foreign.Ptr (Ptr, minusPtr, plusPtr)
+import Foreign.Storable (peek, poke)
+import System.IO.Unsafe (unsafePerformIO)
+import GHC.Prim
+import GHC.Types
+import GHC.Word
+import GHC.Real
+
+-- | Decode a string from base16 form. The first element of the
+-- returned tuple contains the decoded data. The second element starts
+-- at the first invalid base16 sequence in the original string.
+--
+-- Examples:
+--
+-- > decode "666f6f"  == ("foo", "")
+-- > decode "66quux"  == ("f", "quux")
+-- > decode "666quux" == ("f", "6quux")
+decode :: ByteString -> (ByteString, ByteString)
+decode (PS sfp soff slen) =
+  unsafePerformIO . createAndTrim' (slen `div` 2) $ \dptr ->
+      withForeignPtr sfp $ \sptr ->
+        dec (sptr `plusPtr` soff) dptr
+ where
+  dec sptr = go sptr where
+    e = sptr `plusPtr` if odd slen then slen - 1 else slen
+    go s d | s == e = let len = e `minusPtr` sptr
+                      in return (0, len `div` 2, ps sfp (soff+len) (slen-len))
+           | otherwise = do
+      hi <- hex `fmap` peek8 s
+      lo <- hex `fmap` peek8 (s `plusPtr` 1)
+      if lo == 0xff || hi == 0xff
+        then let len = s `minusPtr` sptr
+             in return (0, len `div` 2, ps sfp (soff+len) (slen-len))
+        else do
+          poke d . fromIntegral $ lo + (hi `shiftL` 4)
+          go (s `plusPtr` 2) (d `plusPtr` 1)
+
+    hex (I# index) = W8# (indexWord8OffAddr# table index)
+    !table =
+        "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\
+        \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+
+peek8 :: Ptr Word8 -> IO Int
+peek8 p = fromIntegral `fmap` peek p
+
+ps :: ForeignPtr Word8 -> Int -> Int -> ByteString
+ps fp off len
+    | len <= 0 = empty
+    | otherwise = PS fp off len