{-|
Module      : Z.Data.Vector.Hex
Description : Hex codec for bytes.
Copyright   : (c) Dong Han, 2017-2018
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides hex encoding & decoding tools, as well as 'HexBytes' newtype with hex textual instances.

-}

module Z.Data.Vector.Hex
  ( -- * The HexBytes type
    HexBytes(..)
  -- * Encoding & Decoding functions
  , hexEncode
  , hexEncodeText
  , hexEncodeBuilder
  , hexDecode
  , hexDecode'
  , hexDecodeWS
  , hexDecodeWS'
  , HexDecodeException(..)
  -- * Internal C FFIs
  ,  hs_hex_encode, hs_hex_encode_upper, hs_hex_decode
  ) where

import           Control.Exception
import           Data.Word
import           Data.Bits                      (unsafeShiftL, unsafeShiftR, (.&.))
import           Data.Hashable                  (Hashable(..))
import           GHC.Stack
import           System.IO.Unsafe
import qualified Z.Data.Vector.Base         as V
import qualified Z.Data.Builder.Base        as B
import qualified Z.Data.Text.Base           as T
import qualified Z.Data.Text.Print          as T
import qualified Z.Data.JSON                as JSON
import           Z.Foreign

-- | New type wrapper for 'V.Bytes' with hex encoding(uppercase) Show\/JSON instances.
newtype HexBytes = HexBytes { HexBytes -> Bytes
unHexBytes :: V.Bytes }
    deriving (HexBytes -> HexBytes -> Bool
(HexBytes -> HexBytes -> Bool)
-> (HexBytes -> HexBytes -> Bool) -> Eq HexBytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HexBytes -> HexBytes -> Bool
$c/= :: HexBytes -> HexBytes -> Bool
== :: HexBytes -> HexBytes -> Bool
$c== :: HexBytes -> HexBytes -> Bool
Eq, Eq HexBytes
Eq HexBytes
-> (HexBytes -> HexBytes -> Ordering)
-> (HexBytes -> HexBytes -> Bool)
-> (HexBytes -> HexBytes -> Bool)
-> (HexBytes -> HexBytes -> Bool)
-> (HexBytes -> HexBytes -> Bool)
-> (HexBytes -> HexBytes -> HexBytes)
-> (HexBytes -> HexBytes -> HexBytes)
-> Ord HexBytes
HexBytes -> HexBytes -> Bool
HexBytes -> HexBytes -> Ordering
HexBytes -> HexBytes -> HexBytes
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HexBytes -> HexBytes -> HexBytes
$cmin :: HexBytes -> HexBytes -> HexBytes
max :: HexBytes -> HexBytes -> HexBytes
$cmax :: HexBytes -> HexBytes -> HexBytes
>= :: HexBytes -> HexBytes -> Bool
$c>= :: HexBytes -> HexBytes -> Bool
> :: HexBytes -> HexBytes -> Bool
$c> :: HexBytes -> HexBytes -> Bool
<= :: HexBytes -> HexBytes -> Bool
$c<= :: HexBytes -> HexBytes -> Bool
< :: HexBytes -> HexBytes -> Bool
$c< :: HexBytes -> HexBytes -> Bool
compare :: HexBytes -> HexBytes -> Ordering
$ccompare :: HexBytes -> HexBytes -> Ordering
$cp1Ord :: Eq HexBytes
Ord)
    deriving newtype (Semigroup HexBytes
HexBytes
Semigroup HexBytes
-> HexBytes
-> (HexBytes -> HexBytes -> HexBytes)
-> ([HexBytes] -> HexBytes)
-> Monoid HexBytes
[HexBytes] -> HexBytes
HexBytes -> HexBytes -> HexBytes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [HexBytes] -> HexBytes
$cmconcat :: [HexBytes] -> HexBytes
mappend :: HexBytes -> HexBytes -> HexBytes
$cmappend :: HexBytes -> HexBytes -> HexBytes
mempty :: HexBytes
$cmempty :: HexBytes
$cp1Monoid :: Semigroup HexBytes
Monoid, b -> HexBytes -> HexBytes
NonEmpty HexBytes -> HexBytes
HexBytes -> HexBytes -> HexBytes
(HexBytes -> HexBytes -> HexBytes)
-> (NonEmpty HexBytes -> HexBytes)
-> (forall b. Integral b => b -> HexBytes -> HexBytes)
-> Semigroup HexBytes
forall b. Integral b => b -> HexBytes -> HexBytes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> HexBytes -> HexBytes
$cstimes :: forall b. Integral b => b -> HexBytes -> HexBytes
sconcat :: NonEmpty HexBytes -> HexBytes
$csconcat :: NonEmpty HexBytes -> HexBytes
<> :: HexBytes -> HexBytes -> HexBytes
$c<> :: HexBytes -> HexBytes -> HexBytes
Semigroup, Int -> HexBytes -> Int
HexBytes -> Int
(Int -> HexBytes -> Int) -> (HexBytes -> Int) -> Hashable HexBytes
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: HexBytes -> Int
$chash :: HexBytes -> Int
hashWithSalt :: Int -> HexBytes -> Int
$chashWithSalt :: Int -> HexBytes -> Int
Hashable)

instance Show HexBytes where
    show :: HexBytes -> String
show (HexBytes Bytes
bs) = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Bool -> Bytes -> Text
hexEncodeText Bool
True Bytes
bs

instance T.Print HexBytes where
    {-# INLINE toUTF8BuilderP #-}
    toUTF8BuilderP :: Int -> HexBytes -> Builder ()
toUTF8BuilderP Int
_ (HexBytes Bytes
bs) = Builder () -> Builder ()
B.quotes (Bool -> Bytes -> Builder ()
hexEncodeBuilder Bool
True Bytes
bs)

instance JSON.JSON HexBytes where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter HexBytes
fromValue = Text -> (Text -> Converter HexBytes) -> Value -> Converter HexBytes
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
JSON.withText Text
"Z.Data.Text.HexBytes" ((Text -> Converter HexBytes) -> Value -> Converter HexBytes)
-> (Text -> Converter HexBytes) -> Value -> Converter HexBytes
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        case Bytes -> Maybe Bytes
hexDecode (Text -> Bytes
T.getUTF8Bytes Text
t) of
            Just Bytes
bs -> HexBytes -> Converter HexBytes
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes -> HexBytes
HexBytes Bytes
bs)
            Maybe Bytes
Nothing -> Text -> Converter HexBytes
forall a. Text -> Converter a
JSON.fail' Text
"illegal hex encoding bytes"
    {-# INLINE toValue #-}
    toValue :: HexBytes -> Value
toValue (HexBytes Bytes
bs) = Text -> Value
JSON.String (Bool -> Bytes -> Text
hexEncodeText Bool
True Bytes
bs)
    {-# INLINE encodeJSON #-}
    encodeJSON :: HexBytes -> Builder ()
encodeJSON (HexBytes Bytes
bs) = Bool -> Bytes -> Builder ()
hexEncodeBuilder Bool
True Bytes
bs

-- | Encode 'V.Bytes' using hex(base16) encoding.
hexEncode :: Bool   -- ^ uppercase?
          -> V.Bytes -> V.Bytes
{-# INLINE hexEncode #-}
hexEncode :: Bool -> Bytes -> Bytes
hexEncode Bool
upper (V.PrimVector PrimArray Word8
arr Int
s Int
l) = (Bytes, ()) -> Bytes
forall a b. (a, b) -> a
fst ((Bytes, ()) -> Bytes)
-> (IO (Bytes, ()) -> (Bytes, ())) -> IO (Bytes, ()) -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Bytes, ()) -> (Bytes, ())
forall a. IO a -> a
unsafeDupablePerformIO (IO (Bytes, ()) -> Bytes) -> IO (Bytes, ()) -> Bytes
forall a b. (a -> b) -> a -> b
$ do
    Int -> (MBA# Word8 -> IO ()) -> IO (Bytes, ())
forall a b.
Prim a =>
Int -> (MBA# Word8 -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe (Int
l Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) ((MBA# Word8 -> IO ()) -> IO (Bytes, ()))
-> (MBA# Word8 -> IO ()) -> IO (Bytes, ())
forall a b. (a -> b) -> a -> b
$ \ MBA# Word8
buf# ->
        PrimArray Word8 -> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b.
Prim a =>
PrimArray a -> (BA# Word8 -> Int -> IO b) -> IO b
withPrimArrayUnsafe PrimArray Word8
arr ((BA# Word8 -> Int -> IO ()) -> IO ())
-> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
parr Int
_ ->
            if Bool
upper
            then MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
hs_hex_encode_upper MBA# Word8
buf# Int
0 BA# Word8
parr Int
s Int
l
            else MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
hs_hex_encode MBA# Word8
buf# Int
0 BA# Word8
parr Int
s Int
l

-- | 'B.Builder' version of 'hexEncode'.
hexEncodeBuilder :: Bool -- ^ uppercase?
                 -> V.Bytes -> B.Builder ()
{-# INLINE hexEncodeBuilder #-}
hexEncodeBuilder :: Bool -> Bytes -> Builder ()
hexEncodeBuilder Bool
upper (V.PrimVector PrimArray Word8
arr Int
s Int
l) =
    Int
-> (MutablePrimArray RealWorld Word8 -> Int -> IO ()) -> Builder ()
B.writeN (Int
l Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) (\ (MutablePrimArray MBA# Word8
mba#) Int
i -> do
        PrimArray Word8 -> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b.
Prim a =>
PrimArray a -> (BA# Word8 -> Int -> IO b) -> IO b
withPrimArrayUnsafe PrimArray Word8
arr ((BA# Word8 -> Int -> IO ()) -> IO ())
-> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
parr Int
_ ->
            if Bool
upper
            then MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
hs_hex_encode_upper MBA# Word8
mba# Int
i BA# Word8
parr Int
s Int
l
            else MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
hs_hex_encode MBA# Word8
mba# Int
i BA# Word8
parr Int
s Int
l)

-- | Text version of 'hexEncode'.
hexEncodeText :: Bool   -- ^ uppercase?
              -> V.Bytes -> T.Text
{-# INLINE hexEncodeText #-}
hexEncodeText :: Bool -> Bytes -> Text
hexEncodeText Bool
upper = Bytes -> Text
T.Text (Bytes -> Text) -> (Bytes -> Bytes) -> Bytes -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bytes -> Bytes
hexEncode Bool
upper

-- | Decode a hex encoding string, return Nothing on illegal bytes or incomplete input.
hexDecode :: V.Bytes -> Maybe V.Bytes
{-# INLINABLE hexDecode #-}
hexDecode :: Bytes -> Maybe Bytes
hexDecode Bytes
ba
    | Bytes -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
forall (v :: * -> *) a. Vec v a => v a
V.empty
    | Bytes -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Maybe Bytes
forall a. Maybe a
Nothing
    | Bool
otherwise = IO (Maybe Bytes) -> Maybe Bytes
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe Bytes) -> Maybe Bytes)
-> IO (Maybe Bytes) -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ do
        (PrimArray Word8
arr, Int
r) <- Bytes
-> (BA# Word8 -> Int -> Int -> IO (PrimArray Word8, Int))
-> IO (PrimArray Word8, Int)
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
ba ((BA# Word8 -> Int -> Int -> IO (PrimArray Word8, Int))
 -> IO (PrimArray Word8, Int))
-> (BA# Word8 -> Int -> Int -> IO (PrimArray Word8, Int))
-> IO (PrimArray Word8, Int)
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
ba# Int
s Int
l ->
            Int -> (MBA# Word8 -> IO Int) -> IO (PrimArray Word8, Int)
forall a b.
Prim a =>
Int -> (MBA# Word8 -> IO b) -> IO (PrimArray a, b)
allocPrimArrayUnsafe (Int
l Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) ((MBA# Word8 -> IO Int) -> IO (PrimArray Word8, Int))
-> (MBA# Word8 -> IO Int) -> IO (PrimArray Word8, Int)
forall a b. (a -> b) -> a -> b
$ \ MBA# Word8
buf# ->
                MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int
hs_hex_decode MBA# Word8
buf# BA# Word8
ba# Int
s Int
l
        if Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        then Maybe Bytes -> IO (Maybe Bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bytes
forall a. Maybe a
Nothing
        else Maybe Bytes -> IO (Maybe Bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (PrimArray Word8 -> Int -> Int -> Bytes
forall a. PrimArray a -> Int -> Int -> PrimVector a
V.PrimVector PrimArray Word8
arr Int
0 Int
r))

-- | Decode a hex encoding string, ignore ASCII whitespace(space, tab, newline, vertical tab, form feed, carriage return).
--
-- This is useful when you get some hex nibbles by pasting from web, note only whitesapces between bytes(two nibbles) are allowed:
--
-- >>> hexDecodeWS "6f7481 da0e53"
-- Just [111,116,129,218,14,83]
-- >>> hexDecodeWS "6f7481d a0e53"
-- Nothing
--
hexDecodeWS :: V.Bytes -> Maybe V.Bytes
{-# INLINABLE hexDecodeWS #-}
hexDecodeWS :: Bytes -> Maybe Bytes
hexDecodeWS Bytes
ba
    | Bytes -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
forall (v :: * -> *) a. Vec v a => v a
V.empty
    | Bool
otherwise = IO (Maybe Bytes) -> Maybe Bytes
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe Bytes) -> Maybe Bytes)
-> IO (Maybe Bytes) -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ do
        (PrimArray Word8
arr, Int
r) <- Bytes
-> (BA# Word8 -> Int -> Int -> IO (PrimArray Word8, Int))
-> IO (PrimArray Word8, Int)
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
ba ((BA# Word8 -> Int -> Int -> IO (PrimArray Word8, Int))
 -> IO (PrimArray Word8, Int))
-> (BA# Word8 -> Int -> Int -> IO (PrimArray Word8, Int))
-> IO (PrimArray Word8, Int)
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
ba# Int
s Int
l ->
            Int -> (MBA# Word8 -> IO Int) -> IO (PrimArray Word8, Int)
forall a b.
Prim a =>
Int -> (MBA# Word8 -> IO b) -> IO (PrimArray a, b)
allocPrimArrayUnsafe (Int
l Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) ((MBA# Word8 -> IO Int) -> IO (PrimArray Word8, Int))
-> (MBA# Word8 -> IO Int) -> IO (PrimArray Word8, Int)
forall a b. (a -> b) -> a -> b
$ \ MBA# Word8
buf# ->
                MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int
hs_hex_decode_ws MBA# Word8
buf# BA# Word8
ba# Int
s Int
l
        if Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
        then Maybe Bytes -> IO (Maybe Bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bytes
forall a. Maybe a
Nothing
        else Maybe Bytes -> IO (Maybe Bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (PrimArray Word8 -> Int -> Int -> Bytes
forall a. PrimArray a -> Int -> Int -> PrimVector a
V.PrimVector PrimArray Word8
arr Int
0 Int
r))

-- | Exception during hex decoding.
data HexDecodeException = IllegalHexBytes V.Bytes CallStack
                        | IncompleteHexBytes V.Bytes CallStack
                    deriving Int -> HexDecodeException -> ShowS
[HexDecodeException] -> ShowS
HexDecodeException -> String
(Int -> HexDecodeException -> ShowS)
-> (HexDecodeException -> String)
-> ([HexDecodeException] -> ShowS)
-> Show HexDecodeException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HexDecodeException] -> ShowS
$cshowList :: [HexDecodeException] -> ShowS
show :: HexDecodeException -> String
$cshow :: HexDecodeException -> String
showsPrec :: Int -> HexDecodeException -> ShowS
$cshowsPrec :: Int -> HexDecodeException -> ShowS
Show
instance Exception HexDecodeException

-- | Decode a hex encoding string, throw 'HexDecodeException' on error.
hexDecode' :: HasCallStack => V.Bytes -> V.Bytes
{-# INLINABLE hexDecode' #-}
hexDecode' :: Bytes -> Bytes
hexDecode' Bytes
ba = case Bytes -> Maybe Bytes
hexDecode Bytes
ba of
    Just Bytes
r -> Bytes
r
    Maybe Bytes
_ -> HexDecodeException -> Bytes
forall a e. Exception e => e -> a
throw (Bytes -> CallStack -> HexDecodeException
IllegalHexBytes Bytes
ba CallStack
HasCallStack => CallStack
callStack)

-- | Decode a hex encoding string, ignore ASCII whitespace(space, tab, newline, vertical tab, form feed, carriage return), throw 'HexDecodeException' on error.
hexDecodeWS' :: HasCallStack => V.Bytes -> V.Bytes
{-# INLINABLE hexDecodeWS' #-}
hexDecodeWS' :: Bytes -> Bytes
hexDecodeWS' Bytes
ba = case Bytes -> Maybe Bytes
hexDecodeWS Bytes
ba of
    Just Bytes
r -> Bytes
r
    Maybe Bytes
_ -> HexDecodeException -> Bytes
forall a e. Exception e => e -> a
throw (Bytes -> CallStack -> HexDecodeException
IllegalHexBytes Bytes
ba CallStack
HasCallStack => CallStack
callStack)

--------------------------------------------------------------------------------

foreign import ccall unsafe hs_hex_encode :: MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
foreign import ccall unsafe hs_hex_encode_upper :: MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
foreign import ccall unsafe hs_hex_decode :: MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int
foreign import ccall unsafe hs_hex_decode_ws :: MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int