diff --git a/Network/Haskoin/Util.hs b/Network/Haskoin/Util.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util.hs @@ -0,0 +1,288 @@ +{-| + This module defines various utility functions used across the + Network.Haskoin modules. +-} +module Network.Haskoin.Util +( -- * ByteString helpers + toStrictBS +, toLazyBS +, stringToBS +, bsToString +, bsToInteger +, integerToBS +, bsToHex +, hexToBS + + -- * Data.Binary helpers +, encode' +, decode' +, runPut' +, runGet' +, decodeOrFail' +, runGetOrFail' +, fromDecode +, fromRunGet +, decodeToEither +, decodeToMaybe +, isolate + + -- * Maybe and Either monad helpers +, isLeft +, isRight +, fromRight +, fromLeft +, eitherToMaybe +, maybeToEither + + -- * Various helpers +, updateIndex +, matchTemplate + +) where + +import Numeric (showHex, readHex) +import Control.Monad (liftM2) + +import Data.Char (ord, chr) +import Data.Word (Word8) +import Data.Bits ((.|.), shiftL, shiftR) +import Data.List (unfoldr) +import Data.Binary + ( Binary + , encode + , decode + , decodeOrFail + ) +import Data.Binary.Get + ( Get + , runGetOrFail + , getByteString + , ByteOffset + , runGet + ) +import Data.Binary.Put (Put, runPut) + +import qualified Data.ByteString.Lazy as BL + ( ByteString + , toChunks + , fromChunks + ) +import qualified Data.ByteString as BS + ( ByteString + , concat + , pack, unpack + , append + , length + , cons + , span + , replicate + , empty + , null + ) + +-- ByteString helpers + +-- | Transforms a lazy bytestring into a strict bytestring +toStrictBS :: BL.ByteString -> BS.ByteString +toStrictBS = BS.concat . BL.toChunks + +-- | Transforms a strict bytestring into a lazy bytestring +toLazyBS :: BS.ByteString -> BL.ByteString +toLazyBS bs = BL.fromChunks [bs] + +-- | Transforms a string into a strict bytestring +stringToBS :: String -> BS.ByteString +stringToBS s = BS.pack $ map (fromIntegral . ord) s + +-- | Transform a strict bytestring to a string +bsToString :: BS.ByteString -> String +bsToString bs = map (chr . fromIntegral) (BS.unpack bs) + +-- | Decode a big endian Integer from a bytestring +bsToInteger :: BS.ByteString -> Integer +bsToInteger = (foldr f 0) . reverse . BS.unpack + where + f w n = (toInteger w) .|. shiftL n 8 + +-- | Encode an Integer to a bytestring as big endian +integerToBS :: Integer -> BS.ByteString +integerToBS 0 = BS.pack [0] +integerToBS i + | i > 0 = BS.pack $ reverse $ unfoldr f i + | otherwise = error "integerToBS not defined for negative values" + where + f 0 = Nothing + f x = Just $ (fromInteger x :: Word8, x `shiftR` 8) + +-- | Encode a bytestring to a base16 (HEX) representation +bsToHex :: BS.ByteString -> String +bsToHex bs + | BS.null bs = "" + | otherwise = bsToString $ z2 `BS.append` r2 + where + (z,r) = BS.span (== 0) bs + z2 = BS.replicate (BS.length z * 2) 48 + r1 | BS.null r = BS.empty + | otherwise = stringToBS $ showHex (bsToInteger r) "" + r2 | odd (BS.length r1) = BS.cons 48 r1 + | otherwise = r1 + +-- | Decode a base16 (HEX) string from a bytestring. This function can fail +-- if the string contains invalid HEX characters +hexToBS :: String -> Maybe BS.ByteString +hexToBS str + | null str = Just BS.empty + | otherwise = liftM2 BS.append (Just z2) r2 + where + (z,r) = span (== '0') str + z2 = BS.replicate (length z `div` 2) 0 + r1 = readHex r + r2 | null r = Just BS.empty + | null r1 = Nothing + | otherwise = Just $ integerToBS $ fst $ head r1 + +-- Data.Binary helpers + +-- | Strict version of @Data.Binary.encode@ +encode' :: Binary a => a -> BS.ByteString +encode' = toStrictBS . encode + +-- | Strict version of @Data.Binary.decode@ +decode' :: Binary a => BS.ByteString -> a +decode' = decode . toLazyBS + +-- | Strict version of @Data.Binary.runGet@ +runGet' :: Binary a => Get a -> BS.ByteString -> a +runGet' m = (runGet m) . toLazyBS + +-- | Strict version of @Data.Binary.runPut@ +runPut' :: Put -> BS.ByteString +runPut' = toStrictBS . runPut + +-- | Strict version of @Data.Binary.decodeOrFail@ +decodeOrFail' :: + Binary a => + BS.ByteString -> + Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) +decodeOrFail' bs = case decodeOrFail $ toLazyBS bs of + Left (lbs,o,err) -> Left (toStrictBS lbs,o,err) + Right (lbs,o,res) -> Right (toStrictBS lbs,o,res) + +-- | Strict version of @Data.Binary.runGetOrFail@ +runGetOrFail' :: + Binary a => Get a -> BS.ByteString -> + Either (BS.ByteString, ByteOffset, String) (BS.ByteString, ByteOffset, a) +runGetOrFail' m bs = case runGetOrFail m $ toLazyBS bs of + Left (lbs,o,err) -> Left (toStrictBS lbs,o,err) + Right (lbs,o,res) -> Right (toStrictBS lbs,o,res) + +-- | Try to decode a Data.Binary value. If decoding succeeds, apply the function +-- to the result. Otherwise, return the default value. +fromDecode :: Binary a + => BS.ByteString -- ^ The bytestring to decode + -> b -- ^ Default value to return when decoding fails + -> (a -> b) -- ^ Function to apply when decoding succeeds + -> b -- ^ Final result +fromDecode bs def f = either (const def) (f . lst) $ decodeOrFail' bs + where + lst (_,_,c) = c + +-- | Try to run a Data.Binary.Get monad. If decoding succeeds, apply a function +-- to the result. Otherwise, return the default value. +fromRunGet :: Binary a + => Get a -- ^ The Get monad to run + -> BS.ByteString -- ^ The bytestring to decode + -> b -- ^ Default value to return when decoding fails + -> (a -> b) -- ^ Function to apply when decoding succeeds + -> b -- ^ Final result +fromRunGet m bs def f = either (const def) (f . lst) $ runGetOrFail' m bs + where + lst (_,_,c) = c + +-- | Decode a Data.Binary value into the Either monad. A Right value is returned +-- with the result upon success. Otherwise a Left value with the error message +-- is returned. +decodeToEither :: Binary a => BS.ByteString -> Either String a +decodeToEither bs = case decodeOrFail' bs of + Left (_,_,err) -> Left err + Right (_,_,res) -> Right res + +-- | Decode a Data.Binary value into the Maybe monad. A Just value is returned +-- with the result upon success. Otherwise, Nothing is returned. +decodeToMaybe :: Binary a => BS.ByteString -> Maybe a +decodeToMaybe bs = fromDecode bs Nothing Just + +-- | Isolate a Data.Binary.Get monad for the next @Int@ bytes. Only the next +-- @Int@ bytes of the input bytestring will be available for the Get monad to +-- consume. This function will fail if the Get monad fails or some of the input +-- is not consumed. +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" + +-- Maybe and Eithre monad helpers + +-- | Returns True if the Either value is Right +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False + +-- | Returns True if the Either value is Left +isLeft :: Either a b -> Bool +isLeft = not . isRight + +-- | Extract the Right value from an Either value. Fails if the value is Left +fromRight :: Either a b -> b +fromRight (Right b) = b +fromRight _ = error "Either.fromRight: Left" + +-- | Extract the Left value from an Either value. Fails if the value is Right +fromLeft :: Either a b -> a +fromLeft (Left a) = a +fromLeft _ = error "Either.fromLeft: Right" + +-- | Transforms 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 (Right b) = Just b +eitherToMaybe _ = Nothing + +-- | Transforms a Maybe value into an Either value. Just is mapped to Right and +-- Nothing is mapped to Left. You also pass in an error value in case Left is +-- returned. +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither err m = maybe (Left err) Right m + +-- Various helpers + +-- | Applies a function to only one element of a list defined by it's index. +-- If the index is out of the bounds of the list, the original list is returned +updateIndex :: Int -- ^ The index of the element to change + -> [a] -- ^ The list of elements + -> (a -> a) -- ^ The function to apply + -> [a] -- ^ The result with one element changed +updateIndex i xs f + | i < 0 || i >= length xs = xs + | otherwise = l ++ (f h : r) + where + (l,h:r) = splitAt i 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. +matchTemplate :: [a] -- ^ The input list + -> [b] -- ^ The list to serve as a template + -> (a -> b -> Bool) -- ^ The comparison function + -> [Maybe a] -- ^ Results of the template matching +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 + diff --git a/Network/Haskoin/Util/Arbitrary.hs b/Network/Haskoin/Util/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/Arbitrary.hs @@ -0,0 +1,43 @@ +{-| + QuickCheck Arbitrary instances for various utility data types +-} +module Network.Haskoin.Util.Arbitrary (nonEmptyBS) where + +import Test.QuickCheck + ( Arbitrary + , Gen + , arbitrary + , choose + , oneof + ) +import qualified Data.ByteString as BS + ( ByteString + , pack + , drop + , null + ) + +import Control.Applicative + +import Network.Haskoin.Util.BuildMonad (Build(..)) + +-- Arbitrary instance for strict ByteStrings +instance Arbitrary BS.ByteString where + arbitrary = do + bs <- BS.pack `fmap` arbitrary + n <- choose (0, 2) + return $ BS.drop n bs -- to give us some with non-0 offset + +-- | Generate non-empty strict ByteStrings +nonEmptyBS :: Gen BS.ByteString +nonEmptyBS = do + bs <- arbitrary + return $ if BS.null bs then BS.pack [0] else bs + +-- Arbitrary instance for the Build monad +instance Arbitrary a => Arbitrary (Build a) where + arbitrary = oneof [ Complete <$> arbitrary + , Partial <$> arbitrary + , return $ Broken "Arbitrary: Broken" + ] + diff --git a/Network/Haskoin/Util/BuildMonad.hs b/Network/Haskoin/Util/BuildMonad.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/BuildMonad.hs @@ -0,0 +1,139 @@ +{-| + The Build type, and associated operations. +-} +module Network.Haskoin.Util.BuildMonad +( -- *Build monad + Build(..) +, isComplete +, isPartial +, isBroken +, eitherToBuild +, buildToEither +, guardPartial + + -- *BuildT transformer monad +, BuildT(..) +, liftBuild +) where + +import Control.Monad (liftM) +import Control.Monad.Trans + ( MonadTrans + , MonadIO + , lift + , liftIO + ) + +{-| + The Build monad represents computations that can be in one of three states: + + * Complete + + * Partial + + * Broken + + It extends the Either monad with an additional Partial value to describe a + valid computation flagged with a Partial context. The Build monad is useful + when you describe computations where parts of the computation are either + complete, partially complete or broken. Combining only Complete computations + will produce a Complete result. However, if one of the computations is + Partial, the whole computation will be Partial as well. And if some + computation is Broken, the whole computation will be broken as well. + + The Build monad is used by Haskoin to describe the state of the transaction + signing computation. To sign a transaction, all input scripts need to be + signed. The whole transaction will be completely signed only if all the + input scripts are completely signed. If any of the inputs is partially signed, + then the whole transaction will be partially signed as well. And the whole + transaction is broken if one of the inputs failed to parse or is broken. +-} +data Build a + -- | Describes a successful complete computation + = Complete { runBuild :: a } + -- | Describes a successful but partial computation + | Partial { runBuild :: a } + -- | Describes a broken computation + | Broken { runBroken :: String } + deriving Eq + +instance Show a => Show (Build a) where + show (Complete a) = "Complete " ++ (show a) + show (Partial a) = "Partial " ++ (show a) + show (Broken str) = "Broken " ++ str + +instance Functor Build where + fmap f (Complete x) = Complete (f x) + fmap f (Partial x) = Partial (f x) + fmap _ (Broken s) = Broken s + +instance Monad Build where + return = Complete + Complete x >>= f = f x + Partial x >>= f = case f x of + e@(Broken _) -> e + a -> Partial $ runBuild a + Broken s >>= _ = Broken s + +-- | Returns True if the Build value is Complete +isComplete :: Build a -> Bool +isComplete (Complete _) = True +isComplete _ = False + +-- | Returns True if the Build value is Partial +isPartial :: Build a -> Bool +isPartial (Partial _) = True +isPartial _ = False + +-- | Return True if the Build value is Broken +isBroken :: Build a -> Bool +isBroken (Broken _) = True +isBroken _ = False + +-- | Transforms an Either String value into a Build value. Right is mapped to +-- Complete and Left is mapped to Broken +eitherToBuild :: Either String a -> Build a +eitherToBuild m = case m of + Left err -> Broken err + Right res -> Complete res + +-- | Transforms a Build value into an Either String value. Complete and Partial +-- are mapped to Right and Broken is mapped to Left. +buildToEither :: Build a -> Either String a +buildToEither m = case m of + Complete a -> Right a + Partial a -> Right a + Broken err -> Left err + +-- | Binds a Partial value to the computation when the predicate is False. +guardPartial :: Bool -> Build () +guardPartial True = Complete () +guardPartial False = Partial () + +-- | BuildT transformer monad +newtype BuildT m a = BuildT { runBuildT :: m (Build a) } + +mapBuildT :: (m (Build a) -> n (Build b)) -> BuildT m a -> BuildT n b +mapBuildT f = BuildT . f . runBuildT + +instance Functor m => Functor (BuildT m) where + fmap f = mapBuildT (fmap (fmap f)) + +instance Monad m => Monad (BuildT m) where + return = lift . return + x >>= f = BuildT $ do + v <- runBuildT x + case v of Complete a -> runBuildT (f a) + Partial a -> runBuildT (f a) + Broken str -> return $ Broken str + +instance MonadTrans BuildT where + lift = BuildT . liftM Complete + +instance MonadIO m => MonadIO (BuildT m) where + liftIO = lift . liftIO + +-- | Lift a Build computation into the BuildT monad +liftBuild :: Monad m => Build a -> BuildT m a +liftBuild = BuildT . return + diff --git a/Network/Haskoin/Util/Network.hs b/Network/Haskoin/Util/Network.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/Network.hs @@ -0,0 +1,28 @@ +{-| + Declaration of constant values that depend on the network type + (for example: prodnet or testnet). The values exported from this modules + are imported from a network-specific sub-module. +-} +module Network.Haskoin.Util.Network +( -- $doc + addrPrefix +, scriptPrefix +, secretPrefix +, extPubKeyPrefix +, extSecretPrefix +, walletFile +) where + +import Network.Haskoin.Util.Network.Prodnet +--import Network.Haskoin.Util.Network.Testnet + +-- $doc +-- The network-specific values are defined in one of the sub-modules: +-- +-- * @Network.Haskoin.Util.Network.Prodnet@ +-- +-- * @Network.Haskoin.Util.Network.Testnet@ +-- +-- You must import the module for the network you are interested in and compile +-- the libraries against it. + diff --git a/Network/Haskoin/Util/Network/Prodnet.hs b/Network/Haskoin/Util/Network/Prodnet.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/Network/Prodnet.hs @@ -0,0 +1,33 @@ +{-| + Declaration of constant values for Prodnet. This module is intended to be + imported by Network.Haskoin.Util.Network module and not imported directly by + other modules. +-} +module Network.Haskoin.Util.Network.Prodnet where + +import Data.Word (Word8,Word32) + +-- | Prefix for base58 PubKey hash address +addrPrefix :: Word8 +addrPrefix = 0 + +-- | Prefix for base58 script hash address +scriptPrefix :: Word8 +scriptPrefix = 5 + +-- | Prefix for private key WIF format +secretPrefix :: Word8 +secretPrefix = 128 + +-- | Prefix for extended public keys (BIP32) +extPubKeyPrefix :: Word32 +extPubKeyPrefix = 0x0488b21e + +-- | Prefix for extended private keys (BIP32) +extSecretPrefix :: Word32 +extSecretPrefix = 0x0488ade4 + +-- | Wallet database file name +walletFile :: String +walletFile = "walletdb" + diff --git a/Network/Haskoin/Util/Network/Testnet.hs b/Network/Haskoin/Util/Network/Testnet.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Util/Network/Testnet.hs @@ -0,0 +1,33 @@ +{-| + Declaration of constant values for Testnet. This module is intended to be + imported by Network.Haskoin.Util.Network module and not imported directly by + other modules. +-} +module Network.Haskoin.Util.Network.Testnet where + +import Data.Word (Word8,Word32) + +-- | Prefix for base58 PubKey hash address +addrPrefix :: Word8 +addrPrefix = 111 + +-- | Prefix for base58 script hash address +scriptPrefix :: Word8 +scriptPrefix = 196 + +-- | Prefix for private key WIF format +secretPrefix :: Word8 +secretPrefix = 239 + +-- | Prefix for extended public keys (BIP32) +extPubKeyPrefix :: Word32 +extPubKeyPrefix = 0x043587cf + +-- | Prefix for extended private keys (BIP32) +extSecretPrefix :: Word32 +extSecretPrefix = 0x04358394 + +-- | Wallet database file name +walletFile :: String +walletFile = "testwalletdb" + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/haskoin-util.cabal b/haskoin-util.cabal new file mode 100644 --- /dev/null +++ b/haskoin-util.cabal @@ -0,0 +1,56 @@ +name: haskoin-util +version: 0.0.1 +synopsis: Utility functions for the Network.Haskoin project +description: + This package contains utility functions used across the Network.Haskoin + modules such as ByteString and Data.Binary helpers. It also defines a Build + monad describing computations that can be Complete, Partial or Broken. + Additionally, this package defines constants tied to specific Bitcoin + networks such as prodnet and testnet. +homepage: http://github.com/plaprade/haskoin-util +bug-reports: http://github.com/plaprade/haskoin-util/issues +stability: experimental +license: PublicDomain +license-file: UNLICENSE +author: Philippe Laprade +maintainer: plaprade+hackage@gmail.com +category: Bitcoin, Finance, Network +build-type: Simple +cabal-version: >= 1.9.2 + +source-repository head + type: git + location: git://github.com/plaprade/haskoin-util.git + +library + exposed-modules: Network.Haskoin.Util, + Network.Haskoin.Util.Arbitrary, + Network.Haskoin.Util.Network, + Network.Haskoin.Util.BuildMonad + other-modules: Network.Haskoin.Util.Network.Prodnet, + Network.Haskoin.Util.Network.Testnet + build-depends: base == 4.6.*, + binary == 0.7.*, + bytestring == 0.10.*, + either == 4.0.*, + mtl == 2.1.*, + QuickCheck == 2.6.* + ghc-options: -Wall -fno-warn-orphans + +Test-Suite test-haskoin-util + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base == 4.6.*, + binary == 0.7.*, + bytestring == 0.10.*, + either == 4.0.*, + containers == 0.5.*, + mtl == 2.1.*, + QuickCheck == 2.6.*, + HUnit == 1.2.*, + test-framework == 0.8.*, + test-framework-quickcheck2 == 0.3.*, + test-framework-hunit == 0.3.* + hs-source-dirs: . tests + ghc-options: -Wall -fno-warn-orphans + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Test.Framework (defaultMain) +import qualified Network.Haskoin.Util.Tests (tests) + +main :: IO () +main = defaultMain ( Network.Haskoin.Util.Tests.tests ) +