module Network.Haskoin.Util
(
bsToInteger
, integerToBS
, encodeHex
, decodeHex
, encode'
, decode'
, runPut'
, runGet'
, decodeOrFail'
, runGetOrFail'
, fromDecode
, fromRunGet
, decodeToEither
, decodeToMaybe
, isolate
, isLeft
, isRight
, fromRight
, fromLeft
, eitherToMaybe
, maybeToEither
, liftEither
, liftMaybe
, updateIndex
, matchTemplate
, fst3
, snd3
, lst3
, modify'
, dropFieldLabel
, dropSumLabels
) where
import Control.Monad (guard)
import Control.Monad.Trans.Either (EitherT, hoistEither)
import Control.Monad.State (MonadState, get, put)
import Data.Word (Word8)
import Data.Bits ((.|.), shiftL, shiftR)
import Data.Char (toLower)
import Data.Binary.Put (Put, runPut)
import Data.Binary (Binary, encode, decode, decodeOrFail)
import Data.Binary.Get (Get, runGetOrFail, getByteString, ByteOffset, runGet)
import Data.Aeson.Types
(Options(..), SumEncoding(..), defaultOptions, defaultTaggedObject)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL (toStrict, fromStrict)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString as BS
(pack, null, empty, foldr', reverse, unfoldr)
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 -> ByteString
encodeHex = B16.encode
decodeHex :: ByteString -> Maybe ByteString
decodeHex bs =
let (x, b) = B16.decode bs
in guard (b == BS.empty) >> return x
encode' :: Binary a => a -> ByteString
encode' = BL.toStrict . encode
decode' :: Binary a => ByteString -> a
decode' = decode . BL.fromStrict
runGet' :: Binary a => Get a -> ByteString -> a
runGet' m = (runGet m) . BL.fromStrict
runPut' :: Put -> ByteString
runPut' = BL.toStrict . runPut
decodeOrFail' ::
Binary a =>
ByteString ->
Either (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail' bs = case decodeOrFail $ BL.fromStrict bs of
Left (lbs, o, err) -> Left (BL.toStrict lbs, o, err)
Right (lbs, o, res) -> Right (BL.toStrict lbs, o, res)
runGetOrFail' ::
Get a -> ByteString ->
Either (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail' m bs = case runGetOrFail m $ BL.fromStrict bs of
Left (lbs, o, err) -> Left (BL.toStrict lbs, o, err)
Right (lbs, o, res) -> Right (BL.toStrict lbs, o, res)
fromDecode :: Binary a
=> ByteString
-> b
-> (a -> b)
-> b
fromDecode bs def f = either (const def) (f . lst) $ decodeOrFail' bs
where
lst (_,_,c) = c
fromRunGet :: Binary a
=> Get a
-> ByteString
-> b
-> (a -> b)
-> b
fromRunGet m bs def f = either (const def) (f . lst) $ runGetOrFail' m bs
where
lst (_,_,c) = c
decodeToEither :: Binary a => ByteString -> Either String a
decodeToEither bs = case decodeOrFail' bs of
Left (_,_,err) -> Left err
Right (_,_,res) -> Right res
decodeToMaybe :: Binary a => ByteString -> Maybe a
decodeToMaybe bs = fromDecode bs Nothing Just
isolate :: Binary a => Int -> Get a -> Get a
isolate i g = do
bs <- getByteString i
case runGetOrFail' g bs of
Left (_, _, err) -> fail err
Right (unconsumed, _, res)
| BS.null unconsumed -> return res
| otherwise -> fail "Isolate: unconsumed input"
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _ = False
isLeft :: Either a b -> Bool
isLeft = not . isRight
fromRight :: Either a b -> b
fromRight (Right b) = b
fromRight _ = error "Either.fromRight: Left"
fromLeft :: Either a b -> a
fromLeft (Left a) = a
fromLeft _ = error "Either.fromLeft: Right"
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Right b) = Just b
eitherToMaybe _ = Nothing
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither err m = maybe (Left err) Right m
liftEither :: Monad m => Either b a -> EitherT b m a
liftEither = hoistEither
liftMaybe :: Monad m => b -> Maybe a -> EitherT 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 (flip 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
modify' :: MonadState s m => (s -> s) -> m ()
modify' f = get >>= \x -> put $! f x
dropFieldLabel :: Int -> Options
dropFieldLabel n = defaultOptions
{ fieldLabelModifier = map toLower . drop n
, omitNothingFields = False
}
dropSumLabels :: Int -> Int -> String -> Options
dropSumLabels c f tag = (dropFieldLabel f)
{ constructorTagModifier = map toLower . drop c
, sumEncoding = defaultTaggedObject { tagFieldName = tag }
}