{-# LANGUAGE CPP                   #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-|
Module      : Haskoin.Util
Copyright   : No rights reserved
License     : MIT
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX

This module defines various utility functions used across the library.
-}
module Haskoin.Util
    (
      -- * ByteString Helpers
      bsToInteger
    , integerToBS
    , hexBuilder
    , encodeHex
    , decodeHex
    , getBits

      -- * Maybe & Either Helpers
    , eitherToMaybe
    , maybeToEither
    , liftEither
    , liftMaybe

      -- * Other Helpers
    , updateIndex
    , matchTemplate
    , convertBits

      -- * Triples
    , fst3
    , snd3
    , lst3

      -- * JSON Utilities
    , dropFieldLabel
    , dropSumLabels

    ) where

import           Control.Monad           (guard)
import           Control.Monad.Except    (ExceptT (..), liftEither)
import           Data.Aeson.Types        (Options (..), SumEncoding (..),
                                          defaultOptions, defaultTaggedObject)
import           Data.Bits
import           Data.ByteString         (ByteString)
import qualified Data.ByteString         as BS
import qualified Data.ByteString.Base16  as B16
import           Data.ByteString.Builder
import qualified Data.ByteString.Lazy    as BL
import           Data.Char               (toLower)
import           Data.List
import           Data.Text               (Text)
import qualified Data.Text.Encoding      as E
import           Data.Word               (Word8)

-- ByteString helpers

-- | Decode a big endian 'Integer' from a 'ByteString'.
bsToInteger :: ByteString -> Integer
bsToInteger :: ByteString -> Integer
bsToInteger = (Word8 -> Integer -> Integer) -> Integer -> ByteString -> Integer
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
BS.foldr Word8 -> Integer -> Integer
forall a. Integral a => a -> Integer -> Integer
f 0 (ByteString -> Integer)
-> (ByteString -> ByteString) -> ByteString -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BS.reverse
  where
    f :: a -> Integer -> Integer
f w :: a
w n :: Integer
n = a -> Integer
forall a. Integral a => a -> Integer
toInteger a
w Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
n 8

-- | Encode an 'Integer' to a 'ByteString' as big endian.
integerToBS :: Integer -> ByteString
integerToBS :: Integer -> ByteString
integerToBS 0 = [Word8] -> ByteString
BS.pack [0]
integerToBS i :: Integer
i
    | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0     = ByteString -> ByteString
BS.reverse (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Integer -> Maybe (Word8, Integer)) -> Integer -> ByteString
forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr Integer -> Maybe (Word8, Integer)
f Integer
i
    | Bool
otherwise = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error "integerToBS not defined for negative values"
  where
    f :: Integer -> Maybe (Word8, Integer)
f 0 = Maybe (Word8, Integer)
forall a. Maybe a
Nothing
    f x :: Integer
x = (Word8, Integer) -> Maybe (Word8, Integer)
forall a. a -> Maybe a
Just (Integer -> Word8
forall a. Num a => Integer -> a
fromInteger Integer
x :: Word8, Integer
x Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` 8)

hexBuilder :: ByteString -> Builder
hexBuilder :: ByteString -> Builder
hexBuilder = ByteString -> Builder
byteStringHex

-- | Encode as string of human-readable hex characters.
encodeHex :: ByteString -> Text
encodeHex :: ByteString -> Text
encodeHex = ByteString -> Text
E.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (ByteString -> Builder) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
byteStringHex

-- | Decode string of human-readable hex characters.
decodeHex :: Text -> Maybe ByteString
# if MIN_VERSION_base16_bytestring(1,0,0)
decodeHex :: Text -> Maybe ByteString
decodeHex = Either [Char] ByteString -> Maybe ByteString
forall a b. Either a b -> Maybe b
eitherToMaybe (Either [Char] ByteString -> Maybe ByteString)
-> (Text -> Either [Char] ByteString) -> Text -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] ByteString
B16.decode (ByteString -> Either [Char] ByteString)
-> (Text -> ByteString) -> Text -> Either [Char] ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
E.encodeUtf8
# else
decodeHex text =
    let (x, b) = B16.decode (E.encodeUtf8 text)
    in guard (b == BS.empty) >> return x
# endif

-- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString'
-- will be smallest required to hold that many bits, padded with zeroes to the
-- right.
getBits :: Int -> ByteString -> ByteString
getBits :: Int -> ByteString -> ByteString
getBits b :: Int
b bs :: ByteString
bs
    | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Int -> ByteString -> ByteString
BS.take Int
q ByteString
bs
    | Bool
otherwise = ByteString
i ByteString -> Word8 -> ByteString
`BS.snoc` Word8
l
  where
    (q :: Int
q, r :: Int
r) = Int
b Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`quotRem` 8
    s :: ByteString
s = Int -> ByteString -> ByteString
BS.take (Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ByteString
bs
    i :: ByteString
i = ByteString -> ByteString
BS.init ByteString
s
    l :: Word8
l = ByteString -> Word8
BS.last ByteString
s Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (0xff Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` (8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)) -- zero unneeded bits

-- Maybe and Either monad helpers

-- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to
-- 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost.
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Right b :: b
b) = b -> Maybe b
forall a. a -> Maybe a
Just b
b
eitherToMaybe _         = Maybe b
forall a. Maybe a
Nothing

-- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to
-- 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required.
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither err :: b
err = Either b a -> (a -> Either b a) -> Maybe a -> Either b a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> Either b a
forall a b. a -> Either a b
Left b
err) a -> Either b a
forall a b. b -> Either a b
Right

-- | Lift a 'Maybe' computation into the 'ExceptT' monad.
liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a
liftMaybe :: b -> Maybe a -> ExceptT b m a
liftMaybe err :: b
err = Either b a -> ExceptT b m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either b a -> ExceptT b m a)
-> (Maybe a -> Either b a) -> Maybe a -> ExceptT b m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe a -> Either b a
forall b a. b -> Maybe a -> Either b a
maybeToEither b
err

-- Various helpers

-- | Applies a function to only one element of a list defined by its index.  If
-- the index is out of the bounds of the list, the original list is returned.
updateIndex :: Int      -- ^ index of the element to change
            -> [a]      -- ^ list of elements
            -> (a -> a) -- ^ function to apply
            -> [a]      -- ^ result with one element changed
updateIndex :: Int -> [a] -> (a -> a) -> [a]
updateIndex i :: Int
i xs :: [a]
xs f :: a -> a
f
    | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs = [a]
xs
    | Bool
otherwise = [a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> a
f a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
r)
  where
    (l :: [a]
l,h :: a
h:r :: [a]
r) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [a]
xs

-- | Use the list @[b]@ as a template and try to match the elements of @[a]@
-- against it. For each element of @[b]@ return the (first) matching element of
-- @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results
-- in same order. Elements of @[a]@ can only appear once.
matchTemplate :: [a]              -- ^ input list
              -> [b]              -- ^ list to serve as a template
              -> (a -> b -> Bool) -- ^ comparison function
              -> [Maybe a]
matchTemplate :: [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate [] bs :: [b]
bs _ = Int -> Maybe a -> [Maybe a]
forall a. Int -> a -> [a]
replicate ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
bs) Maybe a
forall a. Maybe a
Nothing
matchTemplate _  [] _ = []
matchTemplate as :: [a]
as (b :: b
b:bs :: [b]
bs) f :: a -> b -> Bool
f = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a -> b -> Bool
`f` b
b) [a]
as of
    (l :: [a]
l,r :: a
r:rs :: [a]
rs) -> a -> Maybe a
forall a. a -> Maybe a
Just a
r  Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate ([a]
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
rs) [b]
bs a -> b -> Bool
f
    _        -> Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe a]
matchTemplate [a]
as [b]
bs a -> b -> Bool
f

-- | Returns the first value of a triple.
fst3 :: (a,b,c) -> a
fst3 :: (a, b, c) -> a
fst3 (a :: a
a,_,_) = a
a

-- | Returns the second value of a triple.
snd3 :: (a,b,c) -> b
snd3 :: (a, b, c) -> b
snd3 (_,b :: b
b,_) = b
b

-- | Returns the last value of a triple.
lst3 :: (a,b,c) -> c
lst3 :: (a, b, c) -> c
lst3 (_,_,c :: c
c) = c
c

-- | Field label goes lowercase and first @n@ characters get removed.
dropFieldLabel :: Int -> Options
dropFieldLabel :: Int -> Options
dropFieldLabel n :: Int
n = Options
defaultOptions
    { fieldLabelModifier :: [Char] -> [Char]
fieldLabelModifier = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
n
    }

-- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus
-- constructor tags are lowercased and first @c@ characters removed. @tag@ is
-- used as the name of the object field name that will hold the transformed
-- constructor tag as its value.
dropSumLabels :: Int -> Int -> String -> Options
dropSumLabels :: Int -> Int -> [Char] -> Options
dropSumLabels c :: Int
c f :: Int
f tag :: [Char]
tag = (Int -> Options
dropFieldLabel Int
f)
    { constructorTagModifier :: [Char] -> [Char]
constructorTagModifier = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
c
    , sumEncoding :: SumEncoding
sumEncoding = SumEncoding
defaultTaggedObject { tagFieldName :: [Char]
tagFieldName = [Char]
tag }
    }

-- | Convert from one power-of-two base to another, as long as it fits in a
-- 'Word'.
convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool)
convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool)
convertBits pad :: Bool
pad frombits :: Int
frombits tobits :: Int
tobits i :: [Word]
i = ([Word] -> [Word]
forall a. [a] -> [a]
reverse [Word]
yout, Bool
rem')
  where
    (xacc :: Word
xacc, xbits :: Int
xbits, xout :: [Word]
xout) = ((Word, Int, [Word]) -> Word -> (Word, Int, [Word]))
-> (Word, Int, [Word]) -> [Word] -> (Word, Int, [Word])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word, Int, [Word]) -> Word -> (Word, Int, [Word])
outer (0, 0, []) [Word]
i
    (yout :: [Word]
yout, rem' :: Bool
rem')
        | Bool
pad Bool -> Bool -> Bool
&& Int
xbits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 =
            let xout' :: [Word]
xout' = (Word
xacc Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` (Int
tobits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xbits)) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
maxv Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: [Word]
xout
            in ([Word]
xout', Bool
False)
        | Bool
pad = ([Word]
xout, Bool
False)
        | Int
xbits Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 = ([Word]
xout, Bool
True)
        | Bool
otherwise = ([Word]
xout, Bool
False)
    maxv :: Word
maxv = 1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
tobits Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1
    max_acc :: Word
max_acc = 1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` (Int
frombits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tobits Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1
    outer :: (Word, Int, [Word]) -> Word -> (Word, Int, [Word])
outer (acc :: Word
acc, bits :: Int
bits, out :: [Word]
out) it :: Word
it =
        let acc' :: Word
acc' = ((Word
acc Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
frombits) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Word
it) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
max_acc
            bits' :: Int
bits' = Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frombits
            (out' :: [Word]
out', bits'' :: Int
bits'') = Word -> [Word] -> Int -> ([Word], Int)
inner Word
acc' [Word]
out Int
bits'
        in (Word
acc', Int
bits'', [Word]
out')
    inner :: Word -> [Word] -> Int -> ([Word], Int)
inner acc :: Word
acc out :: [Word]
out bits :: Int
bits
        | Int
bits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
tobits =
            let bits' :: Int
bits' = Int
bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tobits
                out' :: [Word]
out' = ((Word
acc Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftR` Int
bits') Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
maxv) Word -> [Word] -> [Word]
forall a. a -> [a] -> [a]
: [Word]
out
            in Word -> [Word] -> Int -> ([Word], Int)
inner Word
acc [Word]
out' Int
bits'
        | Bool
otherwise = ([Word]
out, Int
bits)