{-# LANGUAGE MagicHash, UnboxedTuples, CApiFFI, UnliftedFFITypes, BangPatterns, LambdaCase, GeneralizedNewtypeDeriving #-}

-------------------------------------------------------------------------------
-- |
-- Module:      Crypto.HashString.Implementation
-- Copyright:   (c) 2024 Auth Global
-- License:     Apache2
--
-------------------------------------------------------------------------------

module Crypto.HashString.Implementation where

import           Prelude hiding (Foldable, foldr)

import           Data.Array.Byte
import           Data.Bits((.&.))
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.ByteString.Builder (Builder, shortByteString)
import           Data.ByteString.Internal(c2w, w2c, unsafeCreate)
import           Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen)
import           Data.ByteString.Short.Internal (ShortByteString(..))
import qualified Data.ByteString.Short as SB
import qualified Data.Char as Char
import           Data.Foldable(Foldable, foldr)
import           Data.Maybe
import           Data.Monoid
import           Data.Word
import           Foreign.C
import           Foreign.Ptr
import           GHC.Base hiding (foldr)
import           GHC.Exts
import           GHC.IO

-- | Type intended to represent short-ish cryptographic values, say up to 128
--   bytes or so. Supports constant-time comparisons (i.e. run time depends on
--   length of the inputs but is otherwise independent of content), as well as
--   constant-time base16 and base64 conversions.

newtype HashString = HashString { HashString -> ByteArray
unHashString :: ByteArray } deriving (NonEmpty HashString -> HashString
HashString -> HashString -> HashString
(HashString -> HashString -> HashString)
-> (NonEmpty HashString -> HashString)
-> (forall b. Integral b => b -> HashString -> HashString)
-> Semigroup HashString
forall b. Integral b => b -> HashString -> HashString
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: HashString -> HashString -> HashString
<> :: HashString -> HashString -> HashString
$csconcat :: NonEmpty HashString -> HashString
sconcat :: NonEmpty HashString -> HashString
$cstimes :: forall b. Integral b => b -> HashString -> HashString
stimes :: forall b. Integral b => b -> HashString -> HashString
Semigroup, Semigroup HashString
HashString
Semigroup HashString =>
HashString
-> (HashString -> HashString -> HashString)
-> ([HashString] -> HashString)
-> Monoid HashString
[HashString] -> HashString
HashString -> HashString -> HashString
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: HashString
mempty :: HashString
$cmappend :: HashString -> HashString -> HashString
mappend :: HashString -> HashString -> HashString
$cmconcat :: [HashString] -> HashString
mconcat :: [HashString] -> HashString
Monoid)

instance Eq HashString where
  HashString
x == :: HashString -> HashString -> Bool
== HashString
y = HashString -> HashString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare HashString
x HashString
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord HashString where
  compare :: HashString -> HashString -> Ordering
compare (HashString (ByteArray ByteArray#
x)) (HashString (ByteArray ByteArray#
y)) =
      CInt -> CInt -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ByteArray# -> ByteArray# -> CSize -> CInt
c_const_memcmp_ba ByteArray#
x ByteArray#
y CSize
minlen) CInt
0
        Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
xlen Int
ylen
    where
      xlen :: Int
xlen = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
x)
      ylen :: Int
ylen = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
y)
      minlen :: CSize
minlen = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
xlen Int
ylen)

instance IsString HashString where
  fromString :: String -> HashString
fromString = \case
      ( Char
'b' : Char
'1' : Char
'6' : Char
' ' : String
xs ) -> String -> HashString
doBase16 String
xs
--      ( 'b' : '6' : '4' : ' ' : xs ) -> doBase64 xs
      String
xs -> String -> HashString
doBase16 String
xs
    where
      doBase16 :: String -> HashString
doBase16 = HashString -> Maybe HashString -> HashString
forall a. a -> Maybe a -> a
fromMaybe HashString
forall {a}. a
err (Maybe HashString -> HashString)
-> (String -> Maybe HashString) -> String -> HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> Maybe HashString
fromShortBase16 (ShortByteString -> Maybe HashString)
-> (String -> ShortByteString) -> String -> Maybe HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ShortByteString
SB.pack ([Word8] -> ShortByteString)
-> (String -> [Word8]) -> String -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
myConv
        where
          err :: a
err = String -> a
forall a. HasCallStack => String -> a
error String
"fromString :: String -> HashString  --  base16 syntax error"
          myConv :: Char -> Word8
myConv Char
x = if Char -> Bool
Char.isHexDigit Char
x then Char -> Word8
c2w Char
x else Word8
forall {a}. a
err
{--
      doBase64 = fromMaybe err . fromShortBase64 . SB.pack . map myConv
        where
          err = error "fromString :: String -> HashString  --  base64 syntax error"
          myConv x = if Char.isAscii x then c2w x else err
--}

instance Show HashString where
  show :: HashString -> String
show HashString
xs = Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
: HashString -> String
enc HashString
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
'"']
    where
      enc :: HashString -> String
enc = (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Char
w2c ([Word8] -> String)
-> (HashString -> [Word8]) -> HashString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> [Word8]
SB.unpack (ShortByteString -> [Word8])
-> (HashString -> ShortByteString) -> HashString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashString -> ShortByteString
toShortBase16

-- | Xor two hashstrings. The length of the result is always the same as the
--   length of the left argument; bytes are either removed from or added to the
--   end of the right argument as needed to match length.

xorLeft :: HashString -> HashString -> HashString
xorLeft :: HashString -> HashString -> HashString
xorLeft (HashString strl :: ByteArray
strl@(ByteArray ByteArray#
ptrl)) (HashString strr :: ByteArray
strr@(ByteArray ByteArray#
ptrr))
  | Int# -> Int# -> Ordering
compareInt# Int#
0# (ByteArray# -> ByteArray# -> Int#
forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int#
unsafePtrEquality# ByteArray#
ptrl ByteArray#
ptrr) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
EQ = ShortByteString -> HashString
fromShort (Int -> Word8 -> ShortByteString
SB.replicate (ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrl)) Word8
0)
  | Bool
otherwise =
    IO HashString -> HashString
forall a. IO a -> a
unsafePerformIO (IO HashString -> HashString)
-> ((State# RealWorld -> (# State# RealWorld, HashString #))
    -> IO HashString)
-> (State# RealWorld -> (# State# RealWorld, HashString #))
-> HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# RealWorld -> (# State# RealWorld, HashString #))
-> IO HashString
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, HashString #))
 -> HashString)
-> (State# RealWorld -> (# State# RealWorld, HashString #))
-> HashString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
st ->
      let !lenl0 :: Int
lenl0@(I# Int#
lenl) = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrl)
          !lenr0 :: Int
lenr0@(I# Int#
lenr) = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrr)
          !(# State# RealWorld
st0, MutableByteArray# RealWorld
a #) = Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
lenl State# RealWorld
st
          !(# State# RealWorld
st1, () #) = IO () -> State# RealWorld -> (# State# RealWorld, () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (ByteArray#
-> CSize
-> ByteArray#
-> CSize
-> MutableByteArray# RealWorld
-> IO ()
c_xorleft_ba ByteArray#
ptrl (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenl0) ByteArray#
ptrr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenr0) MutableByteArray# RealWorld
a) State# RealWorld
st0
          !(# State# RealWorld
st2, ByteArray#
b #) = MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
a State# RealWorld
st1
       in  (# State# RealWorld
st2, ByteArray -> HashString
HashString (ByteArray# -> ByteArray
ByteArray ByteArray#
b) #)

-- | Xor two hashstrings. The length of the result is always the same as the
--   length of the shorter argument, removing bytes from the end of the longer
--   string as needed to match length.

xorMin :: HashString -> HashString -> HashString
xorMin :: HashString -> HashString -> HashString
xorMin (HashString strl :: ByteArray
strl@(ByteArray ByteArray#
ptrl)) (HashString strr :: ByteArray
strr@(ByteArray ByteArray#
ptrr))
  | Int# -> Int# -> Ordering
compareInt# Int#
0# (ByteArray# -> ByteArray# -> Int#
forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int#
unsafePtrEquality# ByteArray#
ptrl ByteArray#
ptrr) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
EQ = ShortByteString -> HashString
fromShort (Int -> Word8 -> ShortByteString
SB.replicate (ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrl)) Word8
0)
  | Bool
otherwise =
    IO HashString -> HashString
forall a. IO a -> a
unsafePerformIO (IO HashString -> HashString)
-> ((State# RealWorld -> (# State# RealWorld, HashString #))
    -> IO HashString)
-> (State# RealWorld -> (# State# RealWorld, HashString #))
-> HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# RealWorld -> (# State# RealWorld, HashString #))
-> IO HashString
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, HashString #))
 -> HashString)
-> (State# RealWorld -> (# State# RealWorld, HashString #))
-> HashString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
st ->
      let !minlen0 :: Int
minlen0@(I# Int#
minlen) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrl)) (ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrr))
          !(# State# RealWorld
st0, MutableByteArray# RealWorld
a #) = Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
minlen State# RealWorld
st
          !(# State# RealWorld
st1, () #) = IO () -> State# RealWorld -> (# State# RealWorld, () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (ByteArray#
-> ByteArray# -> CSize -> MutableByteArray# RealWorld -> IO ()
c_xormin_ba ByteArray#
ptrl ByteArray#
ptrr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
minlen0) MutableByteArray# RealWorld
a) State# RealWorld
st0
          !(# State# RealWorld
st2, ByteArray#
b #) = MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
a State# RealWorld
st1
       in  (# State# RealWorld
st2, ByteArray -> HashString
HashString (ByteArray# -> ByteArray
ByteArray ByteArray#
b) #)

-- | Xor two hashstrings.  The length of the result is always the same as the
--   length of the longer argument, adding null bytes onto the end of the
--   shorter string as needed to match length.

xorMax :: HashString -> HashString -> HashString
xorMax :: HashString -> HashString -> HashString
xorMax (HashString strl :: ByteArray
strl@(ByteArray ByteArray#
ptrl)) (HashString strr :: ByteArray
strr@(ByteArray ByteArray#
ptrr))
  | Int# -> Int# -> Ordering
compareInt# Int#
0# (ByteArray# -> ByteArray# -> Int#
forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int#
unsafePtrEquality# ByteArray#
ptrl ByteArray#
ptrr) Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
EQ = ShortByteString -> HashString
fromShort (Int -> Word8 -> ShortByteString
SB.replicate (ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrl)) Word8
0)
  | Bool
otherwise =
    IO HashString -> HashString
forall a. IO a -> a
unsafePerformIO (IO HashString -> HashString)
-> ((State# RealWorld -> (# State# RealWorld, HashString #))
    -> IO HashString)
-> (State# RealWorld -> (# State# RealWorld, HashString #))
-> HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# RealWorld -> (# State# RealWorld, HashString #))
-> IO HashString
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, HashString #))
 -> HashString)
-> (State# RealWorld -> (# State# RealWorld, HashString #))
-> HashString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
st ->
      let !lenl :: Int
lenl = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrl)
          !lenr :: Int
lenr = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptrr)
          !(I# Int#
maxlen) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
lenl Int
lenr
          !(# State# RealWorld
st0, MutableByteArray# RealWorld
a #) = Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
maxlen State# RealWorld
st
          !(# State# RealWorld
st1, () #) = IO () -> State# RealWorld -> (# State# RealWorld, () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (ByteArray#
-> CSize
-> ByteArray#
-> CSize
-> MutableByteArray# RealWorld
-> IO ()
c_xormax_ba ByteArray#
ptrl (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenl) ByteArray#
ptrr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenr) MutableByteArray# RealWorld
a) State# RealWorld
st0
          !(# State# RealWorld
st2, ByteArray#
b #) = MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
a State# RealWorld
st1
       in  (# State# RealWorld
st2, ByteArray -> HashString
HashString (ByteArray# -> ByteArray
ByteArray ByteArray#
b) #)

fromShortBase16 :: ShortByteString -> Maybe HashString
fromShortBase16 :: ShortByteString -> Maybe HashString
fromShortBase16 str :: ShortByteString
str@(SBS ByteArray#
ptr) =
  case Int -> Maybe Int
base16DecodeLength Int
ptrlen of
    Maybe Int
Nothing -> Maybe HashString
forall a. Maybe a
Nothing
    Just !(I# Int#
outlen) ->
      IO (Maybe HashString) -> Maybe HashString
forall a. IO a -> a
unsafePerformIO (IO (Maybe HashString) -> Maybe HashString)
-> ((State# RealWorld -> (# State# RealWorld, Maybe HashString #))
    -> IO (Maybe HashString))
-> (State# RealWorld -> (# State# RealWorld, Maybe HashString #))
-> Maybe HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# RealWorld -> (# State# RealWorld, Maybe HashString #))
-> IO (Maybe HashString)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Maybe HashString #))
 -> Maybe HashString)
-> (State# RealWorld -> (# State# RealWorld, Maybe HashString #))
-> Maybe HashString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
st ->
        let !(# State# RealWorld
st0, MutableByteArray# RealWorld
a #) = Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
outlen State# RealWorld
st
            !(# State# RealWorld
st1, CInt
err #) = IO CInt -> State# RealWorld -> (# State# RealWorld, CInt #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (MutableByteArray# RealWorld -> ByteArray# -> CSize -> IO CInt
c_hexDecode_ba MutableByteArray# RealWorld
a ByteArray#
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ptrlen)) State# RealWorld
st0
            !(# State# RealWorld
st2, ByteArray#
b #) = MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
a State# RealWorld
st1
         in if CInt
err CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0
            then (# State# RealWorld
st2, Maybe HashString
forall a. Maybe a
Nothing #)
            else (# State# RealWorld
st2, HashString -> Maybe HashString
forall a. a -> Maybe a
Just (ByteArray -> HashString
HashString (ByteArray# -> ByteArray
ByteArray ByteArray#
b)) #)
  where
    ptrlen :: Int
ptrlen = ShortByteString -> Int
SB.length ShortByteString
str

toShortBase16 :: HashString -> ShortByteString
toShortBase16 :: HashString -> ShortByteString
toShortBase16 (HashString str :: ByteArray
str@(ByteArray ByteArray#
ptr)) =
    IO ShortByteString -> ShortByteString
forall a. IO a -> a
unsafePerformIO (IO ShortByteString -> ShortByteString)
-> ((State# RealWorld -> (# State# RealWorld, ShortByteString #))
    -> IO ShortByteString)
-> (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> IO ShortByteString
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, ShortByteString #))
 -> ShortByteString)
-> (State# RealWorld -> (# State# RealWorld, ShortByteString #))
-> ShortByteString
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
st ->
      let !(I# Int#
outlen) = Int
ptrlen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
          !(# State# RealWorld
st0, MutableByteArray# RealWorld
a #) = Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
outlen State# RealWorld
st
          !(# State# RealWorld
st1, () #) = IO () -> State# RealWorld -> (# State# RealWorld, () #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (MutableByteArray# RealWorld -> ByteArray# -> CSize -> IO ()
c_hexEncode_ba MutableByteArray# RealWorld
a ByteArray#
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ptrlen)) State# RealWorld
st0
          !(# State# RealWorld
st2, ByteArray#
b #) = MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
a State# RealWorld
st1
       in  (# State# RealWorld
st2, ByteArray# -> ShortByteString
SBS ByteArray#
b #)
  where
    ptrlen :: Int
ptrlen = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptr)

takeBytes :: Foldable f => Int -> f HashString -> [ HashString ]
takeBytes :: forall (f :: * -> *).
Foldable f =>
Int -> f HashString -> [HashString]
takeBytes Int
n f HashString
strings = (HashString -> (Int -> [HashString]) -> Int -> [HashString])
-> (Int -> [HashString]) -> f HashString -> Int -> [HashString]
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HashString -> (Int -> [HashString]) -> Int -> [HashString]
delta ([HashString] -> Int -> [HashString]
forall a b. a -> b -> a
const []) f HashString
strings Int
n
  where
    delta :: HashString -> (Int -> [HashString]) -> Int -> [ HashString ]
    delta :: HashString -> (Int -> [HashString]) -> Int -> [HashString]
delta HashString
str Int -> [HashString]
f Int
n
      | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = []
      | Int
strlen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = HashString
str HashString -> [HashString] -> [HashString]
forall a. a -> [a] -> [a]
: Int -> [HashString]
f (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
strlen)
      | Bool
otherwise = [Int -> HashString -> HashString
tak Int
n HashString
str]
      where strlen :: Int
strlen = HashString -> Int
len HashString
str
    len :: HashString -> Int
len = ShortByteString -> Int
SB.length (ShortByteString -> Int)
-> (HashString -> ShortByteString) -> HashString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashString -> ShortByteString
toShort
    tak :: Int -> HashString -> HashString
tak Int
n = ShortByteString -> HashString
fromShort (ShortByteString -> HashString)
-> (HashString -> ShortByteString) -> HashString -> HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShortByteString -> ShortByteString
SB.take Int
n (ShortByteString -> ShortByteString)
-> (HashString -> ShortByteString) -> HashString -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashString -> ShortByteString
toShort

{--
fromShortBase64 :: ShortByteString -> Maybe HashString
fromShortBase64 str@(SBS ptr) =
  case base64DecodeLength ptrlen of
    Nothing -> Nothing
    Just !(I# outlen) ->
      unsafePerformIO . IO $ \st ->
        let !(# st0, a #) = newByteArray# outlen st
            !(# st1, err #) = unIO (c_base64Decode_ba a ptr (fromIntegral ptrlen)) st0
            !(# st2, b #) = unsafeFreezeByteArray# a st1
         in if err /= 0
            then (# st2, Nothing #)
            else (# st2, Just (HashString (ByteArray b)) #)
  where
    ptrlen0 = SB.length str
    ptrlen  = ptrlen0 - fromIntegral (c_base64PadLength_ba ptr (fromIntegral ptrlen0))

toShortBase64 :: HashString -> ShortByteString
toShortBase64 (HashString str@(ByteArray ptr)) =
    unsafePerformIO . IO $ \st ->
      let !(I# outlen) = base64EncodeLength ptrlen
          !(# st0, a #) = newByteArray# outlen st
          !(# st1, () #) = unIO (c_base64Encode_ba a ptr (fromIntegral ptrlen)) st0
          !(# st2, b #) = unsafeFreezeByteArray# a st1
       in  (# st2, SBS b #)
  where
    ptrlen = SB.length (SBS ptr)
--}

toShort :: HashString -> ShortByteString
toShort :: HashString -> ShortByteString
toShort (HashString (ByteArray ByteArray#
x)) = ByteArray# -> ShortByteString
SBS ByteArray#
x

fromShort :: ShortByteString -> HashString
fromShort :: ShortByteString -> HashString
fromShort (SBS ByteArray#
x) = ByteArray -> HashString
HashString (ByteArray# -> ByteArray
ByteArray ByteArray#
x)

toByteString :: HashString -> ByteString
toByteString :: HashString -> ByteString
toByteString = ShortByteString -> ByteString
SB.fromShort (ShortByteString -> ByteString)
-> (HashString -> ShortByteString) -> HashString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashString -> ShortByteString
toShort

fromByteString :: ByteString -> HashString
fromByteString :: ByteString -> HashString
fromByteString = ShortByteString -> HashString
fromShort (ShortByteString -> HashString)
-> (ByteString -> ShortByteString) -> ByteString -> HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
SB.toShort

toBase16 :: HashString -> ByteString
toBase16 :: HashString -> ByteString
toBase16 (HashString str :: ByteArray
str@(ByteArray ByteArray#
ptr)) =
    Int -> (Ptr Word8 -> IO ()) -> ByteString
unsafeCreate (Int -> Int
base16EncodeLength Int
ptrlen) ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
out ->
      Ptr Word8 -> ByteArray# -> CSize -> IO ()
c_hexEncode_bs_ba Ptr Word8
out ByteArray#
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ptrlen)
  where
    ptrlen :: Int
ptrlen = ShortByteString -> Int
SB.length (ByteArray# -> ShortByteString
SBS ByteArray#
ptr)

{--
toBase64 :: HashString -> ByteString
toBase64 (HashString str@(ByteArray ptr)) =
    unsafeCreate (base64EncodeLength ptrlen) $ \out ->
      c_base64Encode_bs_ba out ptr (fromIntegral ptrlen)
  where
    ptrlen = SB.length (SBS ptr)
--}

fromBase16 :: ByteString -> Maybe HashString
fromBase16 :: ByteString -> Maybe HashString
fromBase16 ByteString
str =
  case Int -> Maybe Int
base16DecodeLength Int
ptrlen of
    Maybe Int
Nothing -> Maybe HashString
forall a. Maybe a
Nothing
    Just !(I# Int#
outlen) ->
      IO (Maybe HashString) -> Maybe HashString
forall a. IO a -> a
unsafePerformIO (IO (Maybe HashString) -> Maybe HashString)
-> ((CString -> IO (Maybe HashString)) -> IO (Maybe HashString))
-> (CString -> IO (Maybe HashString))
-> Maybe HashString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> (CString -> IO (Maybe HashString)) -> IO (Maybe HashString)
forall a. ByteString -> (CString -> IO a) -> IO a
unsafeUseAsCString ByteString
str ((CString -> IO (Maybe HashString)) -> Maybe HashString)
-> (CString -> IO (Maybe HashString)) -> Maybe HashString
forall a b. (a -> b) -> a -> b
$ \CString
ptr -> (State# RealWorld -> (# State# RealWorld, Maybe HashString #))
-> IO (Maybe HashString)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Maybe HashString #))
 -> IO (Maybe HashString))
-> (State# RealWorld -> (# State# RealWorld, Maybe HashString #))
-> IO (Maybe HashString)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
st ->
        let !(# State# RealWorld
st0, MutableByteArray# RealWorld
a #) = Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
outlen State# RealWorld
st
            !(# State# RealWorld
st1, CInt
err #) = IO CInt -> State# RealWorld -> (# State# RealWorld, CInt #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (MutableByteArray# RealWorld -> CString -> CSize -> IO CInt
c_hexDecode_mba_bs MutableByteArray# RealWorld
a CString
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ptrlen)) State# RealWorld
st0
            !(# State# RealWorld
st2, ByteArray#
b #) = MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
a State# RealWorld
st1
         in if CInt
err CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0
            then (# State# RealWorld
st2, Maybe HashString
forall a. Maybe a
Nothing #)
            else (# State# RealWorld
st2, HashString -> Maybe HashString
forall a. a -> Maybe a
Just (ByteArray -> HashString
HashString (ByteArray# -> ByteArray
ByteArray ByteArray#
b)) #)
  where
    ptrlen :: Int
ptrlen = ByteString -> Int
B.length ByteString
str

{--
fromBase64 :: ByteString -> Maybe HashString
fromBase64 str =
  case base64DecodeLength ptrlen of
    Nothing -> Nothing
    Just !(I# outlen) ->
      unsafePerformIO . unsafeUseAsCString str $ \ptr -> IO $ \st ->
        let !(# st0, a #) = newByteArray# outlen st
            !(# st1, err #) = unIO (c_base64Decode_mba_bs a ptr (fromIntegral ptrlen)) st0
            !(# st2, b #) = unsafeFreezeByteArray# a st1
         in if err /= 0
            then (# st2, Nothing #)
            else (# st2, Just (HashString (ByteArray b)) #)
  where
    ptrlen = B.length str - base64PadLength_bs str
--}

-- TODO: implement these functions better

toBase16Builder :: HashString -> Builder
toBase16Builder :: HashString -> Builder
toBase16Builder = ShortByteString -> Builder
shortByteString (ShortByteString -> Builder)
-> (HashString -> ShortByteString) -> HashString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashString -> ShortByteString
toShortBase16

{--
toBase64Builder :: HashString -> Builder
toBase64Builder = shortByteString . toShortBase64
--}

base16EncodeLength :: Int -> Int
base16EncodeLength :: Int -> Int
base16EncodeLength = Int -> Int -> Int
forall a. Num a => a -> a -> a
(*) Int
2

base16DecodeLength :: Int -> Maybe Int
base16DecodeLength :: Int -> Maybe Int
base16DecodeLength Int
n
    | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
q
    | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
  where
    (Int
q,Int
r) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
2

{--
-- | Given the length of some binary blob of data, how long will the base64 encoded
--   version be, without padding?

-- There's probably a "cleaner" way to compute this with bit tricks
base64EncodeLength :: Int -> Int
base64EncodeLength n =
    4 * q + if r == 0 then 0 else 1 + r
  where
    (q,r) = n `divMod` 3

-- | Given the length of some base64 encoded data, how long will the binar blob be?
--   The input length must not include any padding, commonly appearing as one or
--   two @=@ characters at the end of a string.

-- There's probably a "cleaner" way to compute this with bit tricks
base64DecodeLength :: Int -> Maybe Int
base64DecodeLength n
    | r == 0 = Just (3 * q)
    | r == 1 = Nothing
    | otherwise = Just ((3 * q) + (r - 1))
  where
    (q,r) = n `divMod` 4

base64PadLength_bs :: ByteString -> Int
base64PadLength_bs xs = min 2 (B.length (B.takeWhileEnd ((==) (c2w '=')) xs))
--}

foreign import capi unsafe "hs_hashstring_memcmp.h hs_hashstring_const_memcmp"
  c_const_memcmp_ba
    :: ByteArray#
    -> ByteArray#
    -> CSize
    -> CInt

foreign import capi unsafe "hs_hashstring_base16.h hs_hashstring_hexDecode"
  c_hexDecode_ba
    :: MutableByteArray# RealWorld
    -> ByteArray#
    -> CSize
    -> IO CInt

foreign import capi unsafe "hs_hashstring_base16.h hs_hashstring_hexDecode"
  c_hexDecode_mba_bs
    :: MutableByteArray# RealWorld
    -> CString
    -> CSize
    -> IO CInt

foreign import capi unsafe "hs_hashstring_base16.h hs_hashstring_hexEncode"
  c_hexEncode_ba
    :: MutableByteArray# RealWorld
    -> ByteArray#
    -> CSize
    -> IO ()

foreign import capi unsafe "hs_hashstring_base16.h hs_hashstring_hexEncode"
  c_hexEncode_bs_ba
    :: Ptr Word8
    -> ByteArray#
    -> CSize
    -> IO ()

foreign import capi unsafe "hs_hashstring_xor.h hs_hashstring_xorleft"
  c_xorleft_ba
    :: ByteArray#
    -> CSize
    -> ByteArray#
    -> CSize
    -> MutableByteArray# RealWorld
    -> IO ()

foreign import capi unsafe "hs_hashstring_xor.h hs_hashstring_xormin"
  c_xormin_ba
    :: ByteArray#
    -> ByteArray#
    -> CSize
    -> MutableByteArray# RealWorld
    -> IO ()

foreign import capi unsafe "hs_hashstring_xor.h hs_hashstring_xormax"
  c_xormax_ba
    :: ByteArray#
    -> CSize
    -> ByteArray#
    -> CSize
    -> MutableByteArray# RealWorld
    -> IO ()

{--
foreign import capi unsafe "hs_hashstring_base64.h hs_hashstring_base64Decode"
  c_base64Decode_ba
    :: MutableByteArray# RealWorld
    -> ByteArray#
    -> CSize
    -> IO CInt

foreign import capi unsafe "hs_hashstring_base64.h hs_hashstring_base64Decode"
  c_base64Decode_mba_bs
    :: MutableByteArray# RealWorld
    -> CString
    -> CSize
    -> IO CInt

foreign import capi unsafe "hs_hashstring_base64.h hs_hashstring_base64Encode"
  c_base64Encode_ba
    :: MutableByteArray# RealWorld
    -> ByteArray#
    -> CSize
    -> IO ()

foreign import capi unsafe "hs_hashstring_base64.h hs_hashstring_base64Encode"
  c_base64Encode_bs_ba
    :: Ptr Word8
    -> ByteArray#
    -> CSize
    -> IO ()

foreign import capi unsafe "hs_hashstring_base64.h hs_hashstring_base64PadLength"
  c_base64PadLength_ba
    :: ByteArray#
    -> CSize
    -> CInt
--}