{-|
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
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
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
Ord)
    deriving newtype (Semigroup HexBytes
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
Monoid, NonEmpty HexBytes -> HexBytes
HexBytes -> HexBytes -> 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 :: forall b. Integral b => 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
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 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 = forall a. Text -> (Text -> Converter a) -> Value -> Converter a
JSON.withText Text
"Z.Data.Text.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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes -> HexBytes
HexBytes Bytes
bs)
            Maybe Bytes
Nothing -> 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
{-# INLINABLE hexEncode #-}
hexEncode :: Bool -> Bytes -> Bytes
hexEncode Bool
upper (V.PrimVector PrimArray Word8
arr Int
s Int
l) = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
    forall a b.
Prim a =>
Int -> (MBA# a -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe (Int
l forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) forall a b. (a -> b) -> a -> b
$ \ MBA# a
buf# ->
        forall a b. Prim a => PrimArray a -> (BA# a -> Int -> IO b) -> IO b
withPrimArrayUnsafe PrimArray Word8
arr forall a b. (a -> b) -> a -> b
$ \ BA# a
parr Int
_ ->
            if Bool
upper
            then MBA# a -> Int -> BA# a -> Int -> Int -> IO ()
hs_hex_encode_upper MBA# a
buf# Int
0 BA# a
parr Int
s Int
l
            else MBA# a -> Int -> BA# a -> Int -> Int -> IO ()
hs_hex_encode MBA# a
buf# Int
0 BA# a
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 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
1) (\ (MutablePrimArray MBA# a
mba#) Int
i -> do
        forall a b. Prim a => PrimArray a -> (BA# a -> Int -> IO b) -> IO b
withPrimArrayUnsafe PrimArray Word8
arr forall a b. (a -> b) -> a -> b
$ \ BA# a
parr Int
_ ->
            if Bool
upper
            then MBA# a -> Int -> BA# a -> Int -> Int -> IO ()
hs_hex_encode_upper MBA# a
mba# Int
i BA# a
parr Int
s Int
l
            else MBA# a -> Int -> BA# a -> Int -> Int -> IO ()
hs_hex_encode MBA# a
mba# Int
i BA# a
parr Int
s Int
l)

-- | Text version of 'hexEncode'.
hexEncodeText :: Bool   -- ^ uppercase?
              -> V.Bytes -> T.Text
{-# INLINABLE hexEncodeText #-}
hexEncodeText :: Bool -> Bytes -> Text
hexEncodeText Bool
upper = Bytes -> Text
T.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
    | forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. a -> Maybe a
Just forall (v :: * -> *) a. Vec v a => v a
V.empty
    | forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba forall a. Bits a => a -> a -> a
.&. Int
1 forall a. Eq a => a -> a -> Bool
== Int
1 = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
        (PrimArray Word8
arr, Int
r) <- forall a b.
Prim a =>
PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
ba forall a b. (a -> b) -> a -> b
$ \ BA# a
ba# Int
s Int
l ->
            forall a b.
Prim a =>
Int -> (MBA# a -> IO b) -> IO (PrimArray a, b)
allocPrimArrayUnsafe (Int
l forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) forall a b. (a -> b) -> a -> b
$ \ MBA# a
buf# ->
                MBA# a -> BA# a -> Int -> Int -> IO Int
hs_hex_decode MBA# a
buf# BA# a
ba# Int
s Int
l
        if Int
r forall a. Ord a => a -> a -> Bool
< Int
0
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (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
    | forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. a -> Maybe a
Just forall (v :: * -> *) a. Vec v a => v a
V.empty
    | Bool
otherwise = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
        (PrimArray Word8
arr, Int
r) <- forall a b.
Prim a =>
PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
ba forall a b. (a -> b) -> a -> b
$ \ BA# a
ba# Int
s Int
l ->
            forall a b.
Prim a =>
Int -> (MBA# a -> IO b) -> IO (PrimArray a, b)
allocPrimArrayUnsafe (Int
l forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
1) forall a b. (a -> b) -> a -> b
$ \ MBA# a
buf# ->
                MBA# a -> BA# a -> Int -> Int -> IO Int
hs_hex_decode_ws MBA# a
buf# BA# a
ba# Int
s Int
l
        if Int
r forall a. Ord a => a -> a -> Bool
< Int
0
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (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
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
{-# INLINE hexDecode' #-}
hexDecode' :: HasCallStack => Bytes -> Bytes
hexDecode' Bytes
ba = case Bytes -> Maybe Bytes
hexDecode Bytes
ba of
    Just Bytes
r -> Bytes
r
    Maybe Bytes
_ -> forall a e. Exception e => e -> a
throw (Bytes -> CallStack -> HexDecodeException
IllegalHexBytes Bytes
ba 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
{-# INLINE hexDecodeWS' #-}
hexDecodeWS' :: HasCallStack => Bytes -> Bytes
hexDecodeWS' Bytes
ba = case Bytes -> Maybe Bytes
hexDecodeWS Bytes
ba of
    Just Bytes
r -> Bytes
r
    Maybe Bytes
_ -> forall a e. Exception e => e -> a
throw (Bytes -> CallStack -> HexDecodeException
IllegalHexBytes Bytes
ba 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