{-# LANGUAGE MultiParamTypeClasses #-}
module Network.Haskoin.Util
(
bsToInteger
, integerToBS
, encodeHex
, decodeHex
, getBits
, eitherToMaybe
, maybeToEither
, liftEither
, liftMaybe
, updateIndex
, matchTemplate
, convertBits
, fst3
, snd3
, lst3
, dropFieldLabel
, dropSumLabels
) where
import Control.Monad (guard)
import Control.Monad.Except (ExceptT (..))
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.Char (toLower)
import Data.List
import Data.Text (Text)
import qualified Data.Text.Encoding as E
import Data.Word (Word8)
bsToInteger :: ByteString -> Integer
bsToInteger = BS.foldr f 0 . BS.reverse
where
f w n = toInteger w .|. shiftL n 8
integerToBS :: Integer -> ByteString
integerToBS 0 = BS.pack [0]
integerToBS i
| i > 0 = BS.reverse $ BS.unfoldr f i
| otherwise = error "integerToBS not defined for negative values"
where
f 0 = Nothing
f x = Just (fromInteger x :: Word8, x `shiftR` 8)
encodeHex :: ByteString -> Text
encodeHex = E.decodeUtf8 . B16.encode
decodeHex :: Text -> Maybe ByteString
decodeHex text =
let (x, b) = B16.decode (E.encodeUtf8 text)
in guard (b == BS.empty) >> return x
getBits :: Int -> ByteString -> ByteString
getBits b bs
| r == 0 = BS.take q bs
| otherwise = i `BS.snoc` l
where
(q, r) = b `quotRem` 8
s = BS.take (q + 1) bs
i = BS.init s
l = BS.last s .&. (0xff `shiftL` (8 - r))
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Right b) = Just b
eitherToMaybe _ = Nothing
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither err = maybe (Left err) Right
liftEither :: Monad m => Either b a -> ExceptT b m a
liftEither = ExceptT . return
liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a
liftMaybe err = liftEither . maybeToEither err
updateIndex :: Int
-> [a]
-> (a -> a)
-> [a]
updateIndex i xs f
| i < 0 || i >= length xs = xs
| otherwise = l ++ (f h : r)
where
(l,h:r) = splitAt i xs
matchTemplate :: [a]
-> [b]
-> (a -> b -> Bool)
-> [Maybe a]
matchTemplate [] bs _ = replicate (length bs) Nothing
matchTemplate _ [] _ = []
matchTemplate as (b:bs) f = case break (`f` b) as of
(l,r:rs) -> Just r : matchTemplate (l ++ rs) bs f
_ -> Nothing : matchTemplate as bs f
fst3 :: (a,b,c) -> a
fst3 (a,_,_) = a
snd3 :: (a,b,c) -> b
snd3 (_,b,_) = b
lst3 :: (a,b,c) -> c
lst3 (_,_,c) = c
dropFieldLabel :: Int -> Options
dropFieldLabel n = defaultOptions
{ fieldLabelModifier = map toLower . drop n
}
dropSumLabels :: Int -> Int -> String -> Options
dropSumLabels c f tag = (dropFieldLabel f)
{ constructorTagModifier = map toLower . drop c
, sumEncoding = defaultTaggedObject { tagFieldName = tag }
}
convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool)
convertBits pad frombits tobits i = (reverse yout, rem')
where
(xacc, xbits, xout) = foldl' outer (0, 0, []) i
(yout, rem')
| pad && xbits /= 0 =
let xout' = (xacc `shiftL` (tobits - xbits)) .&. maxv : xout
in (xout', False)
| pad = (xout, False)
| xbits /= 0 = (xout, True)
| otherwise = (xout, False)
maxv = 1 `shiftL` tobits - 1
max_acc = 1 `shiftL` (frombits + tobits - 1) - 1
outer (acc, bits, out) it =
let acc' = ((acc `shiftL` frombits) .|. it) .&. max_acc
bits' = bits + frombits
(out', bits'') = inner acc' out bits'
in (acc', bits'', out')
inner acc out bits
| bits >= tobits =
let bits' = bits - tobits
out' = ((acc `shiftR` bits') .&. maxv) : out
in inner acc out' bits'
| otherwise = (out, bits)