mirror of
https://github.com/haskoin/haskoin-core.git
synced 2024-09-11 10:05:34 +03:00
Pass network explicitly and migrate tests to hspec
* No more setNetwork * Test suite now migrated completely to hspec
This commit is contained in:
parent
57b1b20733
commit
0f1280abd7
@ -18,6 +18,8 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
|
||||
- Support for LTS Haskell 12.5.
|
||||
- New tests for various networks and new features.
|
||||
- Added `CHANGELOG.md` file.
|
||||
- Support for SegWit addresses.
|
||||
- Support for CashAddr addresses.
|
||||
|
||||
### Changed
|
||||
- Use of hpack `package.yaml` file to auto-generate Cabal file.
|
||||
|
@ -2,7 +2,7 @@
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 5ddb6bb753c470590debd2bd92138a01e493116359bbed51050cb4fc9de70921
|
||||
-- hash: c15f226b69c129df8ee665fec2652722d4a7d6b2e9d249a8c6b49e0b82c5ee0e
|
||||
|
||||
name: haskoin-core
|
||||
version: 1.0.0
|
||||
@ -20,16 +20,16 @@ build-type: Simple
|
||||
cabal-version: >= 2.0
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
data/forkid_script_tests.json
|
||||
data/forkid_sighash.json
|
||||
data/script_invalid.json
|
||||
data/script_tests.json
|
||||
data/script_valid.json
|
||||
data/sig_nonstrict.json
|
||||
data/sig_strict.json
|
||||
data/sighash.json
|
||||
data/tx_valid.json
|
||||
README.md
|
||||
test/data/forkid_script_tests.json
|
||||
test/data/forkid_sighash.json
|
||||
test/data/script_invalid.json
|
||||
test/data/script_tests.json
|
||||
test/data/script_valid.json
|
||||
test/data/sig_nonstrict.json
|
||||
test/data/sig_strict.json
|
||||
test/data/sighash.json
|
||||
test/data/tx_valid.json
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
@ -63,9 +63,6 @@ library
|
||||
, secp256k1
|
||||
, split
|
||||
, string-conversions
|
||||
, test-framework
|
||||
, test-framework-hunit
|
||||
, test-framework-quickcheck2
|
||||
, time
|
||||
, unordered-containers
|
||||
, vector
|
||||
@ -114,132 +111,11 @@ library
|
||||
Paths_haskoin_core
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite haskoin-core-bch-test
|
||||
test-suite haskoin-core-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
hs-source-dirs:
|
||||
test/bch
|
||||
test/common
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
HUnit
|
||||
, QuickCheck
|
||||
, aeson
|
||||
, array
|
||||
, base >=4.7 && <5
|
||||
, base16-bytestring
|
||||
, bytestring
|
||||
, cereal
|
||||
, conduit
|
||||
, containers
|
||||
, cryptonite
|
||||
, deepseq
|
||||
, entropy
|
||||
, hashable
|
||||
, haskoin-core
|
||||
, hspec
|
||||
, memory
|
||||
, mtl
|
||||
, murmur3
|
||||
, network
|
||||
, safe
|
||||
, scientific
|
||||
, secp256k1
|
||||
, split
|
||||
, string-conversions
|
||||
, test-framework
|
||||
, test-framework-hunit
|
||||
, test-framework-quickcheck2
|
||||
, time
|
||||
, unordered-containers
|
||||
, vector
|
||||
other-modules:
|
||||
Network.Haskoin.Script.Spec
|
||||
Paths_haskoin_core
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite haskoin-core-btc-regtest
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
hs-source-dirs:
|
||||
test/btc-regtest
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
HUnit
|
||||
, QuickCheck
|
||||
, aeson
|
||||
, array
|
||||
, base >=4.7 && <5
|
||||
, base16-bytestring
|
||||
, bytestring
|
||||
, cereal
|
||||
, conduit
|
||||
, containers
|
||||
, cryptonite
|
||||
, deepseq
|
||||
, entropy
|
||||
, hashable
|
||||
, haskoin-core
|
||||
, hspec
|
||||
, memory
|
||||
, mtl
|
||||
, murmur3
|
||||
, network
|
||||
, safe
|
||||
, scientific
|
||||
, secp256k1
|
||||
, split
|
||||
, string-conversions
|
||||
, test-framework
|
||||
, test-framework-hunit
|
||||
, test-framework-quickcheck2
|
||||
, time
|
||||
, unordered-containers
|
||||
, vector
|
||||
other-modules:
|
||||
Paths_haskoin_core
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite haskoin-core-btc-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
hs-source-dirs:
|
||||
test/btc
|
||||
test/common
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
HUnit
|
||||
, QuickCheck
|
||||
, aeson
|
||||
, array
|
||||
, base >=4.7 && <5
|
||||
, base16-bytestring
|
||||
, bytestring
|
||||
, cereal
|
||||
, conduit
|
||||
, containers
|
||||
, cryptonite
|
||||
, deepseq
|
||||
, entropy
|
||||
, hashable
|
||||
, haskoin-core
|
||||
, hspec
|
||||
, memory
|
||||
, mtl
|
||||
, murmur3
|
||||
, network
|
||||
, safe
|
||||
, scientific
|
||||
, secp256k1
|
||||
, split
|
||||
, string-conversions
|
||||
, test-framework
|
||||
, test-framework-hunit
|
||||
, test-framework-quickcheck2
|
||||
, time
|
||||
, unordered-containers
|
||||
, vector
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Network.Haskoin.Block.Spec
|
||||
Network.Haskoin.Block.Tests
|
||||
Network.Haskoin.Block.Units
|
||||
Network.Haskoin.Cereal.Tests
|
||||
@ -256,11 +132,43 @@ test-suite haskoin-core-btc-test
|
||||
Network.Haskoin.Crypto.Units
|
||||
Network.Haskoin.Json.Tests
|
||||
Network.Haskoin.Network.Units
|
||||
Network.Haskoin.Script.Spec
|
||||
Network.Haskoin.Script.Tests
|
||||
Network.Haskoin.Script.Units
|
||||
Network.Haskoin.Transaction.Tests
|
||||
Network.Haskoin.Transaction.Units
|
||||
Network.Haskoin.Util.Tests
|
||||
Network.Haskoin.Script.Spec
|
||||
Paths_haskoin_core
|
||||
hs-source-dirs:
|
||||
test
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
HUnit
|
||||
, QuickCheck
|
||||
, aeson
|
||||
, array
|
||||
, base >=4.7 && <5
|
||||
, base16-bytestring
|
||||
, bytestring
|
||||
, cereal
|
||||
, conduit
|
||||
, containers
|
||||
, cryptonite
|
||||
, deepseq
|
||||
, entropy
|
||||
, hashable
|
||||
, haskoin-core
|
||||
, hspec
|
||||
, memory
|
||||
, mtl
|
||||
, murmur3
|
||||
, network
|
||||
, safe
|
||||
, scientific
|
||||
, secp256k1
|
||||
, split
|
||||
, string-conversions
|
||||
, time
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: Haskell2010
|
||||
|
33
package.yaml
33
package.yaml
@ -13,7 +13,7 @@ homepage: http://github.com/haskoin/haskoin#readme
|
||||
git: git://github.com/haskoin/haskoin.git
|
||||
bug-reports: http://github.com/haskoin/haskoin/issues
|
||||
extra-source-files:
|
||||
- test/data/*.json
|
||||
- data/*.json
|
||||
- README.md
|
||||
- CHANGELOG.md
|
||||
dependencies:
|
||||
@ -41,9 +41,6 @@ dependencies:
|
||||
- secp256k1
|
||||
- split
|
||||
- string-conversions
|
||||
- test-framework
|
||||
- test-framework-quickcheck2
|
||||
- test-framework-hunit
|
||||
- time
|
||||
- unordered-containers
|
||||
- vector
|
||||
@ -61,31 +58,9 @@ library:
|
||||
- Network.Haskoin.Constants
|
||||
- Network.Haskoin.Test
|
||||
tests:
|
||||
haskoin-core-btc-test:
|
||||
main: Main.hs
|
||||
source-dirs:
|
||||
- test/btc
|
||||
- test/common
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- haskoin-core
|
||||
haskoin-core-btc-regtest:
|
||||
main: Main.hs
|
||||
source-dirs: test/btc-regtest
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- haskoin-core
|
||||
haskoin-core-bch-test:
|
||||
main: Main.hs
|
||||
source-dirs:
|
||||
- test/bch
|
||||
- test/common
|
||||
haskoin-core-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
|
@ -4,5 +4,5 @@ import Network.Haskoin.Block.Types
|
||||
import Network.Haskoin.Transaction.Genesis
|
||||
import Network.Haskoin.Constants
|
||||
|
||||
genesisBlock :: Block
|
||||
genesisBlock = Block genesisHeader [genesisTx]
|
||||
genesisBlock :: Network -> Block
|
||||
genesisBlock net = Block (getGenesisHeader net) [genesisTx]
|
||||
|
@ -19,10 +19,11 @@ import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.List (sort, sortBy)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.Serialize (decode, encode)
|
||||
import Data.Serialize as Serialize (Serialize (..))
|
||||
import Data.Serialize.Get (getWord32le)
|
||||
import Data.Serialize.Put (putWord32le)
|
||||
import Data.Serialize as Serialize (Serialize (..),
|
||||
decode, encode, get,
|
||||
put)
|
||||
import Data.Serialize.Get (Get, getWord32le, runGet)
|
||||
import Data.Serialize.Put (Put, Putter, putWord32le, runPut)
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Word (Word32, Word64)
|
||||
import Network.Haskoin.Block.Types
|
||||
@ -49,22 +50,24 @@ data BlockNode
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Serialize BlockNode where
|
||||
get = do
|
||||
nodeHeader <- Serialize.get
|
||||
nodeHeight <- getWord32le
|
||||
nodeWork <- Serialize.get
|
||||
if nodeHeader == genesisHeader
|
||||
then return GenesisNode{..}
|
||||
else do nodeSkip <- Serialize.get
|
||||
return BlockNode{..}
|
||||
put bn = do
|
||||
put $ nodeHeader bn
|
||||
putWord32le $ nodeHeight bn
|
||||
put $ nodeWork bn
|
||||
case bn of
|
||||
GenesisNode{} -> return ()
|
||||
BlockNode{} -> put $ nodeSkip bn
|
||||
getBlockNode :: Network -> Get BlockNode
|
||||
getBlockNode net = do
|
||||
nodeHeader <- Serialize.get
|
||||
nodeHeight <- getWord32le
|
||||
nodeWork <- Serialize.get
|
||||
if nodeHeader == getGenesisHeader net
|
||||
then return GenesisNode{..}
|
||||
else do nodeSkip <- Serialize.get
|
||||
return BlockNode{..}
|
||||
|
||||
putBlockNode :: Putter BlockNode
|
||||
putBlockNode bn = do
|
||||
put $ nodeHeader bn
|
||||
putWord32le $ nodeHeight bn
|
||||
put $ nodeWork bn
|
||||
case bn of
|
||||
GenesisNode{} -> return ()
|
||||
BlockNode{} -> put $ nodeSkip bn
|
||||
|
||||
|
||||
instance NFData BlockNode where
|
||||
@ -90,7 +93,7 @@ instance NFData HeaderMemory where
|
||||
|
||||
class Monad m => BlockHeaders m where
|
||||
addBlockHeader :: BlockNode -> m ()
|
||||
getBlockHeader :: BlockHash -> m (Maybe BlockNode)
|
||||
getBlockHeader :: Network -> BlockHash -> m (Maybe BlockNode)
|
||||
getBestBlockHeader :: m BlockNode
|
||||
setBestBlockHeader :: BlockNode -> m ()
|
||||
addBlockHeaders :: [BlockNode] -> m ()
|
||||
@ -98,7 +101,7 @@ class Monad m => BlockHeaders m where
|
||||
|
||||
instance Monad m => BlockHeaders (StateT HeaderMemory m) where
|
||||
addBlockHeader = modify . addBlockHeaderMemory
|
||||
getBlockHeader bh = getBlockHeaderMemory bh <$> State.get
|
||||
getBlockHeader net bh = getBlockHeaderMemory net bh <$> State.get
|
||||
getBestBlockHeader = gets memoryBestHeader
|
||||
setBestBlockHeader bn = modify $ \s -> s { memoryBestHeader = bn }
|
||||
|
||||
@ -107,10 +110,10 @@ addBlockHeaderMemory bn s@HeaderMemory{..} =
|
||||
let bm' = addBlockToMap bn memoryHeaderMap
|
||||
in s { memoryHeaderMap = bm' }
|
||||
|
||||
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
|
||||
getBlockHeaderMemory bh HeaderMemory{..} = do
|
||||
getBlockHeaderMemory :: Network -> BlockHash -> HeaderMemory -> Maybe BlockNode
|
||||
getBlockHeaderMemory net bh HeaderMemory{..} = do
|
||||
bs <- shortBlockHash bh `HashMap.lookup` memoryHeaderMap
|
||||
eitherToMaybe . decode $ fromShort bs
|
||||
eitherToMaybe . runGet (getBlockNode net) $ fromShort bs
|
||||
|
||||
shortBlockHash :: BlockHash -> ShortBlockHash
|
||||
shortBlockHash = either error id . decode . BS.take 8 . encode
|
||||
@ -119,13 +122,14 @@ addBlockToMap :: BlockNode -> BlockMap -> BlockMap
|
||||
addBlockToMap node =
|
||||
HashMap.insert
|
||||
(shortBlockHash $ headerHash $ nodeHeader node)
|
||||
(toShort $ encode node)
|
||||
(toShort $ runPut $ putBlockNode node)
|
||||
|
||||
getAncestor :: BlockHeaders m
|
||||
=> BlockHeight
|
||||
=> Network
|
||||
-> BlockHeight
|
||||
-> BlockNode
|
||||
-> m (Maybe BlockNode)
|
||||
getAncestor height node
|
||||
getAncestor net height node
|
||||
| height > nodeHeight node = return Nothing
|
||||
| otherwise = go node
|
||||
where
|
||||
@ -144,10 +148,10 @@ getAncestor height node
|
||||
)
|
||||
)
|
||||
then do walk' <- fromMaybe e1 <$>
|
||||
getBlockHeader (nodeSkip walk)
|
||||
getBlockHeader net (nodeSkip walk)
|
||||
go walk'
|
||||
else do walk' <- fromMaybe e2 <$>
|
||||
getBlockHeader (prevBlock (nodeHeader walk))
|
||||
getBlockHeader net (prevBlock (nodeHeader walk))
|
||||
go walk'
|
||||
| otherwise = return $ Just walk
|
||||
|
||||
@ -155,34 +159,37 @@ isGenesis :: BlockNode -> Bool
|
||||
isGenesis GenesisNode{} = True
|
||||
isGenesis BlockNode{} = False
|
||||
|
||||
initialChain :: HeaderMemory
|
||||
initialChain = HeaderMemory
|
||||
{ memoryHeaderMap = genesisMap
|
||||
, memoryBestHeader = genesisNode
|
||||
initialChain :: Network -> HeaderMemory
|
||||
initialChain net = HeaderMemory
|
||||
{ memoryHeaderMap = genesisMap net
|
||||
, memoryBestHeader = genesisNode net
|
||||
}
|
||||
|
||||
genesisMap :: BlockMap
|
||||
genesisMap =
|
||||
genesisMap :: Network -> BlockMap
|
||||
genesisMap net =
|
||||
HashMap.singleton
|
||||
(shortBlockHash $ headerHash genesisHeader)
|
||||
(toShort $ encode genesisNode)
|
||||
(shortBlockHash (headerHash (getGenesisHeader net)))
|
||||
(toShort (runPut (putBlockNode (genesisNode net))))
|
||||
|
||||
genesisNode :: BlockNode
|
||||
genesisNode = GenesisNode { nodeHeader = genesisHeader
|
||||
, nodeHeight = 0
|
||||
, nodeWork = headerWork genesisHeader
|
||||
}
|
||||
genesisNode :: Network -> BlockNode
|
||||
genesisNode net =
|
||||
GenesisNode
|
||||
{ nodeHeader = getGenesisHeader net
|
||||
, nodeHeight = 0
|
||||
, nodeWork = headerWork (getGenesisHeader net)
|
||||
}
|
||||
|
||||
connectBlocks :: BlockHeaders m
|
||||
=> Timestamp -- ^ current time
|
||||
=> Network
|
||||
-> Timestamp -- ^ current time
|
||||
-> [BlockHeader]
|
||||
-> m (Either String [BlockNode])
|
||||
connectBlocks _ [] = return $ Right []
|
||||
connectBlocks t bhs@(bh : _) = runExceptT $ do
|
||||
connectBlocks _ _ [] = return $ Right []
|
||||
connectBlocks net t bhs@(bh : _) = runExceptT $ do
|
||||
unless (chained bhs) $
|
||||
throwError "Blocks to connect do not form a chain"
|
||||
par <- ExceptT $ parentBlock bh
|
||||
pars <- lift $ getParents 10 par
|
||||
par <- ExceptT $ parentBlock net bh
|
||||
pars <- lift $ getParents net 10 par
|
||||
bb <- lift getBestBlockHeader
|
||||
bns@(bn : _) <- go par [] bb par pars bhs
|
||||
lift $ addBlockHeaders bns
|
||||
@ -195,7 +202,7 @@ connectBlocks t bhs@(bh : _) = runExceptT $ do
|
||||
skip lbh ls par
|
||||
| sh == nodeHeight lbh = return lbh
|
||||
| sh < nodeHeight lbh = do
|
||||
skM <- lift $ getAncestor sh lbh
|
||||
skM <- lift $ getAncestor net sh lbh
|
||||
case skM of
|
||||
Just sk -> return sk
|
||||
Nothing -> throwError $ "BUG: Could not get skip for block "
|
||||
@ -210,64 +217,68 @@ connectBlocks t bhs@(bh : _) = runExceptT $ do
|
||||
go _ acc _ _ _ [] = return acc
|
||||
go lbh acc bb par pars (h : hs) = do
|
||||
sk <- skip lbh acc par
|
||||
bn <- ExceptT . return $ validBlock t bb par pars h sk
|
||||
bn <- ExceptT . return $ validBlock net t bb par pars h sk
|
||||
go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs
|
||||
|
||||
parentBlock :: BlockHeaders m
|
||||
=> BlockHeader
|
||||
=> Network
|
||||
-> BlockHeader
|
||||
-> m (Either String BlockNode)
|
||||
parentBlock bh = runExceptT $ do
|
||||
parM <- lift $ getBlockHeader $ prevBlock bh
|
||||
parentBlock net bh = runExceptT $ do
|
||||
parM <- lift $ getBlockHeader net $ prevBlock bh
|
||||
case parM of
|
||||
Nothing -> throwError $ "Parent block not found for " ++ show (prevBlock bh)
|
||||
Just par -> return par
|
||||
|
||||
connectBlock :: BlockHeaders m
|
||||
=> Timestamp -- ^ current time
|
||||
-> BlockHeader
|
||||
-> m (Either String BlockNode)
|
||||
connectBlock t bh = runExceptT $ do
|
||||
par <- ExceptT $ parentBlock bh
|
||||
pars <- lift $ getParents 10 par
|
||||
skM <- lift $ getAncestor (skipHeight (nodeHeight par + 1)) par
|
||||
connectBlock ::
|
||||
BlockHeaders m
|
||||
=> Network
|
||||
-> Timestamp -- ^ current time
|
||||
-> BlockHeader
|
||||
-> m (Either String BlockNode)
|
||||
connectBlock net t bh = runExceptT $ do
|
||||
par <- ExceptT $ parentBlock net bh
|
||||
pars <- lift $ getParents net 10 par
|
||||
skM <- lift $ getAncestor net (skipHeight (nodeHeight par + 1)) par
|
||||
sk <- case skM of
|
||||
Just sk -> return sk
|
||||
Nothing -> throwError $ "BUG: Could not get skip for block "
|
||||
++ show (headerHash $ nodeHeader par)
|
||||
bb <- lift getBestBlockHeader
|
||||
bn <- ExceptT . return $ validBlock t bb par pars bh sk
|
||||
bn <- ExceptT . return $ validBlock net t bb par pars bh sk
|
||||
let bb' = chooseBest bb bn
|
||||
lift $ addBlockHeader bn
|
||||
when (bb /= bb') . lift $ setBestBlockHeader bb'
|
||||
return bn
|
||||
|
||||
validBlock :: Timestamp -- ^ current time
|
||||
validBlock :: Network
|
||||
-> Timestamp -- ^ current time
|
||||
-> BlockNode -- ^ best block
|
||||
-> BlockNode -- ^ immediate parent
|
||||
-> [BlockNode] -- ^ 10 parents above
|
||||
-> BlockHeader -- ^ header to validate
|
||||
-> BlockNode -- ^ skip
|
||||
-> Either String BlockNode
|
||||
validBlock t bb par pars bh sk = do
|
||||
validBlock net t bb par pars bh sk = do
|
||||
let mt = medianTime . map (blockTimestamp . nodeHeader) $ par : pars
|
||||
nt = blockTimestamp bh
|
||||
hh = headerHash bh
|
||||
nv = blockVersion bh
|
||||
ng = nodeHeight par + 1
|
||||
aw = nodeWork par + headerWork bh
|
||||
unless (isValidPOW bh) $
|
||||
unless (isValidPOW net bh) $
|
||||
Left $ "Proof of work failed: " ++ show (headerHash bh)
|
||||
unless (nt <= t + 2 * 60 * 60) $
|
||||
Left $ "Invalid header timestamp: " ++ show nt
|
||||
unless (nt >= mt) $
|
||||
Left $ "Block timestamp too early: " ++ show nt
|
||||
unless (afterLastCP (nodeHeight bb) ng) $
|
||||
unless (afterLastCP net (nodeHeight bb) ng) $
|
||||
Left $ "Rewriting pre-checkpoint chain: " ++ show ng
|
||||
unless (validCP ng hh) $
|
||||
unless (validCP net ng hh) $
|
||||
Left $ "Rejected checkpoint: " ++ show ng
|
||||
unless (bip34 ng hh) $
|
||||
unless (bip34 net ng hh) $
|
||||
Left $ "Rejected BIP-34 block: " ++ show hh
|
||||
unless (validVersion ng nv) $
|
||||
unless (validVersion net ng nv) $
|
||||
Left $ "Invalid block version: " ++ show nv
|
||||
return BlockNode { nodeHeader = bh
|
||||
, nodeHeight = ng
|
||||
@ -290,104 +301,116 @@ invertLowestOne :: BlockHeight -> BlockHeight
|
||||
invertLowestOne height = height .&. (height - 1)
|
||||
|
||||
getParents :: BlockHeaders m
|
||||
=> Int
|
||||
=> Network
|
||||
-> Int
|
||||
-> BlockNode
|
||||
-> m [BlockNode] -- ^ starting from closest parent
|
||||
getParents = getpars []
|
||||
getParents net = getpars []
|
||||
where
|
||||
getpars acc 0 _ = return $ reverse acc
|
||||
getpars acc _ GenesisNode{} = return $ reverse acc
|
||||
getpars acc n BlockNode{..} = do
|
||||
parM <- getBlockHeader $ prevBlock nodeHeader
|
||||
parM <- getBlockHeader net $ prevBlock nodeHeader
|
||||
case parM of
|
||||
Just bn -> getpars (bn : acc) (n - 1) bn
|
||||
Nothing -> error "BUG: All non-genesis blocks should have a parent"
|
||||
|
||||
-- | Verify that checkpoint location is valid.
|
||||
validCP :: BlockHeight -- ^ new child height
|
||||
validCP :: Network
|
||||
-> BlockHeight -- ^ new child height
|
||||
-> BlockHash -- ^ new child hash
|
||||
-> Bool
|
||||
validCP height newChildHash =
|
||||
case lookup height checkpoints of
|
||||
validCP net height newChildHash =
|
||||
case lookup height (getCheckpoints net) of
|
||||
Just cpHash -> cpHash == newChildHash
|
||||
Nothing -> True
|
||||
|
||||
afterLastCP :: BlockHeight -- ^ best height
|
||||
afterLastCP :: Network
|
||||
-> BlockHeight -- ^ best height
|
||||
-> BlockHeight -- ^ new child height
|
||||
-> Bool
|
||||
afterLastCP bestHeight newChildHeight =
|
||||
afterLastCP net bestHeight newChildHeight =
|
||||
case lM of
|
||||
Just l -> l < newChildHeight
|
||||
Nothing -> True
|
||||
where
|
||||
lM = listToMaybe . reverse $
|
||||
[ fst c | c <- checkpoints, fst c <= bestHeight ]
|
||||
lM =
|
||||
listToMaybe . reverse $
|
||||
[fst c | c <- getCheckpoints net, fst c <= bestHeight]
|
||||
|
||||
bip34 :: BlockHeight -- ^ new child height
|
||||
bip34 :: Network
|
||||
-> BlockHeight -- ^ new child height
|
||||
-> BlockHash -- ^ new child hash
|
||||
-> Bool
|
||||
bip34 height hash
|
||||
| fst bip34Block == 0 = True
|
||||
| fst bip34Block == height = snd bip34Block == hash
|
||||
bip34 net height hash
|
||||
| fst (getBip34Block net) == 0 = True
|
||||
| fst (getBip34Block net) == height = snd (getBip34Block net) == hash
|
||||
| otherwise = True
|
||||
|
||||
validVersion :: BlockHeight -- ^ new child height
|
||||
validVersion :: Network
|
||||
-> BlockHeight -- ^ new child height
|
||||
-> Word32 -- ^ new child version
|
||||
-> Bool
|
||||
validVersion height version
|
||||
| version < 2 = height < fst bip34Block
|
||||
| version < 3 = height < bip66Height
|
||||
| version < 4 = height < bip65Height
|
||||
validVersion net height version
|
||||
| version < 2 = height < fst (getBip34Block net)
|
||||
| version < 3 = height < getBip66Height net
|
||||
| version < 4 = height < getBip65Height net
|
||||
| otherwise = True
|
||||
|
||||
-- | Find last block with normal, as opposed to minimum difficulty (for test
|
||||
-- networks).
|
||||
lastNoMinDiff :: BlockHeaders m => BlockNode -> m BlockNode
|
||||
lastNoMinDiff bn@BlockNode{..} = do
|
||||
let i = nodeHeight `mod` diffInterval /= 0
|
||||
c = encodeCompact powLimit
|
||||
lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode
|
||||
lastNoMinDiff net bn@BlockNode {..} = do
|
||||
let i = nodeHeight `mod` diffInterval net /= 0
|
||||
c = encodeCompact (getPowLimit net)
|
||||
l = blockBits nodeHeader == c
|
||||
e1 = error $ "Could not get block header for parent of " ++
|
||||
show (headerHash nodeHeader)
|
||||
e1 =
|
||||
error $
|
||||
"Could not get block header for parent of " ++
|
||||
show (headerHash nodeHeader)
|
||||
if i && l
|
||||
then do bn' <- fromMaybe e1 <$> getBlockHeader (prevBlock nodeHeader)
|
||||
lastNoMinDiff bn'
|
||||
then do
|
||||
bn' <- fromMaybe e1 <$> getBlockHeader net (prevBlock nodeHeader)
|
||||
lastNoMinDiff net bn'
|
||||
else return bn
|
||||
|
||||
lastNoMinDiff bn@GenesisNode{} = return bn
|
||||
lastNoMinDiff _ bn@GenesisNode{} = return bn
|
||||
|
||||
-- | Returns the work required on a block header given the previous block. This
|
||||
-- coresponds to bitcoind function GetNextWorkRequired in main.cpp.
|
||||
nextWorkRequired :: BlockHeaders m
|
||||
=> BlockNode
|
||||
=> Network
|
||||
-> BlockNode
|
||||
-> BlockHeader
|
||||
-> m Word32
|
||||
nextWorkRequired par bh = do
|
||||
nextWorkRequired net par bh = do
|
||||
let mf = daa <|> eda <|> pow
|
||||
case mf of
|
||||
Just f -> f par bh
|
||||
Just f -> f net par bh
|
||||
Nothing ->
|
||||
error
|
||||
"Could not get an appropriate difficulty calculation algorithm"
|
||||
where
|
||||
daa = daaBlockHeight >>= \daaHeight -> do
|
||||
daa = getDaaBlockHeight net >>= \daaHeight -> do
|
||||
guard (nodeHeight par + 1 >= daaHeight)
|
||||
return nextDAAWorkRequired
|
||||
eda = edaBlockHeight >>= \edaHeight -> do
|
||||
return nextDaaWorkRequired
|
||||
eda = getEdaBlockHeight net >>= \edaHeight -> do
|
||||
guard (nodeHeight par + 1 >= edaHeight)
|
||||
return nextEDAWorkRequired
|
||||
return nextEdaWorkRequired
|
||||
pow = return nextPOWWorkRequired
|
||||
|
||||
nextEDAWorkRequired :: BlockHeaders m => BlockNode -> BlockHeader -> m Word32
|
||||
nextEDAWorkRequired par bh
|
||||
| nodeHeight par + 1 `mod` diffInterval == 0 = nextWorkRequired par bh
|
||||
| minDifficulty = return (encodeCompact powLimit)
|
||||
| blockBits (nodeHeader par) == encodeCompact powLimit =
|
||||
return (encodeCompact powLimit)
|
||||
nextEdaWorkRequired ::
|
||||
BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
|
||||
nextEdaWorkRequired net par bh
|
||||
| nodeHeight par + 1 `mod` diffInterval net == 0 =
|
||||
nextWorkRequired net par bh
|
||||
| minDifficulty = return (encodeCompact (getPowLimit net))
|
||||
| blockBits (nodeHeader par) == encodeCompact (getPowLimit net) =
|
||||
return (encodeCompact (getPowLimit net))
|
||||
| otherwise = do
|
||||
par6 <- fromMaybe e1 <$> getAncestor (nodeHeight par - 6) par
|
||||
pars <- getParents 10 par
|
||||
pars6 <- getParents 10 par6
|
||||
par6 <- fromMaybe e1 <$> getAncestor net (nodeHeight par - 6) par
|
||||
pars <- getParents net 10 par
|
||||
pars6 <- getParents net 10 par6
|
||||
let par6med =
|
||||
medianTime $ map (blockTimestamp . nodeHeader) (par6 : pars6)
|
||||
parmed = medianTime $ map (blockTimestamp . nodeHeader) (par : pars)
|
||||
@ -397,99 +420,103 @@ nextEDAWorkRequired par bh
|
||||
else return $
|
||||
let (diff, _) = decodeCompact (blockBits (nodeHeader par))
|
||||
ndiff = diff + (diff `shiftR` 2)
|
||||
in if powLimit > ndiff
|
||||
then encodeCompact powLimit
|
||||
else encodeCompact ndiff
|
||||
in if getPowLimit net > ndiff
|
||||
then encodeCompact (getPowLimit net)
|
||||
else encodeCompact ndiff
|
||||
where
|
||||
minDifficulty =
|
||||
blockTimestamp bh > blockTimestamp (nodeHeader par) + targetSpacing * 2
|
||||
blockTimestamp bh >
|
||||
blockTimestamp (nodeHeader par) + getTargetSpacing net * 2
|
||||
e1 = error "Could not get seventh ancestor of block"
|
||||
|
||||
nextDAAWorkRequired :: BlockHeaders m => BlockNode -> BlockHeader -> m Word32
|
||||
nextDAAWorkRequired par bh
|
||||
| minDifficulty = return (encodeCompact powLimit)
|
||||
nextDaaWorkRequired ::
|
||||
BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
|
||||
nextDaaWorkRequired net par bh
|
||||
| minDifficulty = return (encodeCompact (getPowLimit net))
|
||||
| otherwise = do
|
||||
let height = nodeHeight par
|
||||
unless (height >= diffInterval) $
|
||||
unless (height >= diffInterval net) $
|
||||
error "Block height below difficulty interval"
|
||||
l <- getSuitableBlock par
|
||||
par144 <- fromMaybe e1 <$> getAncestor (height - 144) par
|
||||
f <- getSuitableBlock par144
|
||||
let nextTarget = computeTarget f l
|
||||
if nextTarget > powLimit
|
||||
then return $ encodeCompact powLimit
|
||||
l <- getSuitableBlock net par
|
||||
par144 <- fromMaybe e1 <$> getAncestor net (height - 144) par
|
||||
f <- getSuitableBlock net par144
|
||||
let nextTarget = computeTarget net f l
|
||||
if nextTarget > getPowLimit net
|
||||
then return $ encodeCompact (getPowLimit net)
|
||||
else return $ encodeCompact nextTarget
|
||||
where
|
||||
e1 = error "Cannot get ancestor at parent - 144 height"
|
||||
minDifficulty =
|
||||
blockTimestamp bh > blockTimestamp (nodeHeader par) + targetSpacing * 2
|
||||
blockTimestamp bh >
|
||||
blockTimestamp (nodeHeader par) + getTargetSpacing net * 2
|
||||
|
||||
computeTarget :: BlockNode -> BlockNode -> Integer
|
||||
computeTarget f l =
|
||||
let work = (nodeWork l - nodeWork f) * fromIntegral targetSpacing
|
||||
computeTarget :: Network -> BlockNode -> BlockNode -> Integer
|
||||
computeTarget net f l =
|
||||
let work = (nodeWork l - nodeWork f) * fromIntegral (getTargetSpacing net)
|
||||
actualTimespan =
|
||||
blockTimestamp (nodeHeader l) - blockTimestamp (nodeHeader f)
|
||||
actualTimespan'
|
||||
| actualTimespan > 288 * targetSpacing = 288 * targetSpacing
|
||||
| actualTimespan < 72 * targetSpacing = 72 * targetSpacing
|
||||
| actualTimespan > 288 * getTargetSpacing net =
|
||||
288 * getTargetSpacing net
|
||||
| actualTimespan < 72 * getTargetSpacing net =
|
||||
72 * getTargetSpacing net
|
||||
| otherwise = actualTimespan
|
||||
work' = work `div` fromIntegral actualTimespan'
|
||||
in 2 ^ (256 :: Integer) `div` work'
|
||||
in 2 ^ (256 :: Integer) `div` work'
|
||||
|
||||
getSuitableBlock :: BlockHeaders m => BlockNode -> m BlockNode
|
||||
getSuitableBlock par = do
|
||||
getSuitableBlock :: BlockHeaders m => Network -> BlockNode -> m BlockNode
|
||||
getSuitableBlock net par = do
|
||||
unless (nodeHeight par >= 3) $ error "Block height is less than three"
|
||||
blocks <- (par :) <$> getParents 2 par
|
||||
blocks <- (par :) <$> getParents net 2 par
|
||||
return $ sortBy (compare `on` blockTimestamp . nodeHeader) blocks !! 1
|
||||
|
||||
-- | Returns the work required on a block header given the previous block. This
|
||||
-- coresponds to bitcoind function GetNextWorkRequired in main.cpp.
|
||||
nextPOWWorkRequired :: BlockHeaders m
|
||||
=> BlockNode
|
||||
-> BlockHeader
|
||||
-> m Word32
|
||||
nextPOWWorkRequired par bh
|
||||
| nodeHeight par + 1 `mod` diffInterval /= 0 =
|
||||
if allowMinDifficultyBlocks
|
||||
then if ht > pt + delta
|
||||
then return $ encodeCompact powLimit
|
||||
else do d <- lastNoMinDiff par
|
||||
return $ blockBits $ nodeHeader d
|
||||
else return $ blockBits $ nodeHeader par
|
||||
nextPOWWorkRequired :: BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32
|
||||
nextPOWWorkRequired net par bh
|
||||
| nodeHeight par + 1 `mod` diffInterval net /= 0 =
|
||||
if getAllowMinDifficultyBlocks net
|
||||
then if ht > pt + delta
|
||||
then return $ encodeCompact (getPowLimit net)
|
||||
else do
|
||||
d <- lastNoMinDiff net par
|
||||
return $ blockBits $ nodeHeader d
|
||||
else return $ blockBits $ nodeHeader par
|
||||
| otherwise = do
|
||||
let rh = nodeHeight par - (diffInterval - 1)
|
||||
a <- fromMaybe e1 <$> getAncestor rh par
|
||||
let t = blockTimestamp $ nodeHeader a
|
||||
return $ calcNextWork (nodeHeader par) t
|
||||
let rh = nodeHeight par - (diffInterval net - 1)
|
||||
a <- fromMaybe e1 <$> getAncestor net rh par
|
||||
let t = blockTimestamp $ nodeHeader a
|
||||
return $ calcNextWork net (nodeHeader par) t
|
||||
where
|
||||
e1 = error "Could not get ancestor for block header"
|
||||
pt = blockTimestamp $ nodeHeader par
|
||||
ht = blockTimestamp bh
|
||||
delta = targetSpacing * 2
|
||||
delta = getTargetSpacing net * 2
|
||||
|
||||
-- | Computes the work required for the first block in a new retarget period.
|
||||
calcNextWork :: BlockHeader -- ^ last block in previous retarget (parent)
|
||||
calcNextWork :: Network
|
||||
-> BlockHeader -- ^ last block in previous retarget (parent)
|
||||
-> Timestamp -- ^ timestamp of first block in previous retarget
|
||||
-> Word32
|
||||
calcNextWork header time
|
||||
| powNoRetargetting = blockBits header
|
||||
| new > powLimit = encodeCompact powLimit
|
||||
calcNextWork net header time
|
||||
| getPowNoRetargetting net = blockBits header
|
||||
| new > getPowLimit net = encodeCompact (getPowLimit net)
|
||||
| otherwise = encodeCompact new
|
||||
where
|
||||
s = blockTimestamp header - time
|
||||
n | s < targetTimespan `div` 4 = targetTimespan `div` 4
|
||||
| s > targetTimespan * 4 = targetTimespan * 4
|
||||
n | s < getTargetTimespan net `div` 4 = getTargetTimespan net `div` 4
|
||||
| s > getTargetTimespan net * 4 = getTargetTimespan net * 4
|
||||
| otherwise = s
|
||||
l = fst $ decodeCompact $ blockBits header
|
||||
new = l * fromIntegral n `div` fromIntegral targetTimespan
|
||||
new = l * fromIntegral n `div` fromIntegral (getTargetTimespan net)
|
||||
|
||||
-- | Returns True if the difficulty target (bits) of the header is valid and the
|
||||
-- proof of work of the header matches the advertised difficulty target. This
|
||||
-- function corresponds to the function CheckProofOfWork from bitcoind in
|
||||
-- main.cpp.
|
||||
isValidPOW :: BlockHeader -> Bool
|
||||
isValidPOW h
|
||||
| target <= 0 || over || target > powLimit = False
|
||||
isValidPOW :: Network -> BlockHeader -> Bool
|
||||
isValidPOW net h
|
||||
| target <= 0 || over || target > getPowLimit net = False
|
||||
| otherwise = blockPOW (headerHash h) <= fromIntegral target
|
||||
where
|
||||
(target, over) = decodeCompact $ blockBits h
|
||||
@ -508,8 +535,8 @@ headerWork bh = largestHash `div` (target + 1)
|
||||
largestHash = 1 `shiftL` 256
|
||||
|
||||
-- | Number of blocks on average between difficulty cycles (2016 blocks).
|
||||
diffInterval :: Word32
|
||||
diffInterval = targetTimespan `div` targetSpacing
|
||||
diffInterval :: Network -> Word32
|
||||
diffInterval net = getTargetTimespan net `div` getTargetSpacing net
|
||||
|
||||
-- | Compare two blocks to get the best.
|
||||
chooseBest :: BlockNode -> BlockNode -> BlockNode
|
||||
@ -521,8 +548,8 @@ chooseBest b1 b2 | nodeWork b1 == nodeWork b2 =
|
||||
| otherwise = b2
|
||||
|
||||
-- | Get list of blocks for a block locator.
|
||||
blockLocatorNodes :: BlockHeaders m => BlockNode -> m [BlockNode]
|
||||
blockLocatorNodes best =
|
||||
blockLocatorNodes :: BlockHeaders m => Network -> BlockNode -> m [BlockNode]
|
||||
blockLocatorNodes net best =
|
||||
reverse <$> go [] best 1
|
||||
where
|
||||
e1 = error "Could not get ancestor"
|
||||
@ -532,44 +559,48 @@ blockLocatorNodes best =
|
||||
then n * 2
|
||||
else 1
|
||||
in if nodeHeight bn < n'
|
||||
then do a <- fromMaybe e1 <$> getAncestor 0 bn
|
||||
then do a <- fromMaybe e1 <$> getAncestor net 0 bn
|
||||
return $ a : loc'
|
||||
else do let h = nodeHeight bn - n'
|
||||
bn' <- fromMaybe e1 <$> getAncestor h bn
|
||||
bn' <- fromMaybe e1 <$> getAncestor net h bn
|
||||
go loc' bn' n'
|
||||
|
||||
blockLocator :: BlockHeaders m => BlockNode -> m BlockLocator
|
||||
blockLocator bn =
|
||||
map (headerHash . nodeHeader) <$> blockLocatorNodes bn
|
||||
blockLocator :: BlockHeaders m => Network -> BlockNode -> m BlockLocator
|
||||
blockLocator net bn =
|
||||
map (headerHash . nodeHeader) <$> blockLocatorNodes net bn
|
||||
|
||||
-- | Become rich beyond your wildest dreams.
|
||||
mineBlock :: Word32 -> BlockHeader -> BlockHeader
|
||||
mineBlock seed h =
|
||||
head [ j | i <- (+seed) <$> [0..maxBound],
|
||||
let j = h{ bhNonce = i },
|
||||
isValidPOW j ]
|
||||
mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader
|
||||
mineBlock net seed h =
|
||||
head
|
||||
[ j
|
||||
| i <- (+ seed) <$> [0 .. maxBound]
|
||||
, let j = h {bhNonce = i}
|
||||
, isValidPOW net j
|
||||
]
|
||||
|
||||
-- | Generate and append new blocks (mining). Only practical in regtest network.
|
||||
appendBlocks
|
||||
:: Word32 -- ^ random seed
|
||||
appendBlocks ::
|
||||
Network
|
||||
-> Word32 -- ^ random seed
|
||||
-> BlockHeader
|
||||
-> Int
|
||||
-> [BlockHeader]
|
||||
appendBlocks _ _ 0 = []
|
||||
appendBlocks seed bh i =
|
||||
bh' : appendBlocks seed bh' (i - 1)
|
||||
appendBlocks _ _ _ 0 = []
|
||||
appendBlocks net seed bh i =
|
||||
bh' : appendBlocks net seed bh' (i - 1)
|
||||
where
|
||||
bh' = mineBlock seed bh
|
||||
bh' = mineBlock net seed bh
|
||||
{ prevBlock = headerHash bh
|
||||
-- Just to make it different in every header
|
||||
, merkleRoot = sha256 $ encode seed
|
||||
}
|
||||
|
||||
splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode
|
||||
splitPoint l r = do
|
||||
splitPoint :: BlockHeaders m => Network -> BlockNode -> BlockNode -> m BlockNode
|
||||
splitPoint net l r = do
|
||||
let h = min (nodeHeight l) (nodeHeight r)
|
||||
ll <- fromMaybe e <$> getAncestor h l
|
||||
lr <- fromMaybe e <$> getAncestor h r
|
||||
ll <- fromMaybe e <$> getAncestor net h l
|
||||
lr <- fromMaybe e <$> getAncestor net h r
|
||||
f ll lr
|
||||
where
|
||||
e = error "BUG: Could not get ancestor at lowest height"
|
||||
@ -578,6 +609,6 @@ splitPoint l r = do
|
||||
then return lr
|
||||
else do
|
||||
let h = nodeHeight ll - 1
|
||||
pl <- fromMaybe e <$> getAncestor h ll
|
||||
pr <- fromMaybe e <$> getAncestor h lr
|
||||
pl <- fromMaybe e <$> getAncestor net h ll
|
||||
pr <- fromMaybe e <$> getAncestor net h lr
|
||||
f pl pr
|
||||
|
@ -159,15 +159,16 @@ traverseAndExtract height pos ntx flags hashes
|
||||
-- | Extracts the matching hashes from a partial merkle tree. This will return
|
||||
-- the list of transaction hashes that have been included (set to True) in
|
||||
-- a call to 'buildPartialMerkle'.
|
||||
extractMatches :: FlagBits -- ^ Flag bits (produced by buildPartialMerkle).
|
||||
extractMatches :: Network
|
||||
-> FlagBits -- ^ Flag bits (produced by buildPartialMerkle).
|
||||
-> PartialMerkleTree -- ^ Partial merkle tree.
|
||||
-> Int -- ^ Number of transaction at height 0 (leaf nodes).
|
||||
-> Either String (MerkleRoot, [TxHash])
|
||||
-- ^ Merkle root and the list of matching transaction hashes.
|
||||
extractMatches flags hashes ntx
|
||||
extractMatches net flags hashes ntx
|
||||
| ntx == 0 = Left
|
||||
"extractMatches: number of transactions can not be 0"
|
||||
| ntx > maxBlockSize `div` 60 = Left
|
||||
| ntx > getMaxBlockSize net `div` 60 = Left
|
||||
"extractMatches: number of transactions excessively high"
|
||||
| length hashes > ntx = Left
|
||||
"extractMatches: More hashes provided than the number of transactions"
|
||||
@ -193,15 +194,15 @@ boolsToWord8 :: [Bool] -> Word8
|
||||
boolsToWord8 [] = 0
|
||||
boolsToWord8 xs = foldl setBit 0 (map snd $ filter fst $ zip xs [0..7])
|
||||
|
||||
merkleBlockTxs :: MerkleBlock -> Either String [TxHash]
|
||||
merkleBlockTxs b =
|
||||
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
|
||||
merkleBlockTxs net b =
|
||||
let flags = mFlags b
|
||||
hs = mHashes b
|
||||
n = fromIntegral $ merkleTotalTxns b
|
||||
merkle = merkleRoot $ merkleHeader b
|
||||
in do (root, ths) <- extractMatches flags hs n
|
||||
in do (root, ths) <- extractMatches net flags hs n
|
||||
when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect"
|
||||
return ths
|
||||
|
||||
testMerkleRoot :: MerkleBlock -> Bool
|
||||
testMerkleRoot = isRight . merkleBlockTxs
|
||||
testMerkleRoot :: Network -> MerkleBlock -> Bool
|
||||
testMerkleRoot net = isRight . merkleBlockTxs net
|
||||
|
@ -1,4 +1,4 @@
|
||||
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-|
|
||||
Network specific constants
|
||||
@ -12,63 +12,31 @@ module Network.Haskoin.Constants
|
||||
, bch
|
||||
, bchTest
|
||||
, bchRegTest
|
||||
-- ** Functions
|
||||
, setBTC
|
||||
, setBTCtest
|
||||
, setBTCregTest
|
||||
, setBCH
|
||||
, setBCHtest
|
||||
, setBCHregTest
|
||||
, setNetwork
|
||||
, getNetwork
|
||||
-- ** Network parameters
|
||||
, networkName
|
||||
, addrPrefix
|
||||
, scriptPrefix
|
||||
, secretPrefix
|
||||
, extPubKeyPrefix
|
||||
, extSecretPrefix
|
||||
, networkMagic
|
||||
, genesisHeader
|
||||
, maxBlockSize
|
||||
, maxSatoshi
|
||||
, haskoinUserAgent
|
||||
, defaultPort
|
||||
, allowMinDifficultyBlocks
|
||||
, powNoRetargetting
|
||||
, powLimit
|
||||
, bip34Block
|
||||
, bip65Height
|
||||
, bip66Height
|
||||
, targetTimespan
|
||||
, targetSpacing
|
||||
, checkpoints
|
||||
, bip44Coin
|
||||
, seeds
|
||||
, sigHashForkId
|
||||
, edaBlockHeight
|
||||
, daaBlockHeight
|
||||
, segWit
|
||||
, cashAddrPrefix
|
||||
, bech32Prefix
|
||||
, allNets
|
||||
, netByName
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.DeepSeq
|
||||
import Control.Monad
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String
|
||||
import Data.Version
|
||||
import Data.Word (Word32, Word64, Word8)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Haskoin.Block.Types
|
||||
import Paths_haskoin_core
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Text.Read
|
||||
|
||||
versionString :: IsString a => a
|
||||
versionString = fromString (showVersion version)
|
||||
|
||||
data Network = Network
|
||||
{ getNetworkName :: !String
|
||||
, getNetworkIdent :: !String
|
||||
, getAddrPrefix :: !Word8
|
||||
, getScriptPrefix :: !Word8
|
||||
, getSecretPrefix :: !Word8
|
||||
@ -92,150 +60,34 @@ data Network = Network
|
||||
, getBip44Coin :: !Word32
|
||||
, getSeeds :: ![String]
|
||||
, getSigHashForkId :: !(Maybe Word32)
|
||||
, getEDABlockHeight :: !(Maybe Word32)
|
||||
, getDAABlockHeight :: !(Maybe Word32)
|
||||
, getEdaBlockHeight :: !(Maybe Word32)
|
||||
, getDaaBlockHeight :: !(Maybe Word32)
|
||||
, getSegWit :: !Bool
|
||||
, getCashAddrPrefix :: !(Maybe ByteString)
|
||||
, getBech32Prefix :: !(Maybe ByteString)
|
||||
} deriving (Eq)
|
||||
} deriving (Eq, Generic)
|
||||
|
||||
setBTC :: IO ()
|
||||
setBTC = setNetwork btc
|
||||
instance NFData Network
|
||||
|
||||
setBTCtest :: IO ()
|
||||
setBTCtest = setNetwork btcTest
|
||||
instance Show Network where
|
||||
show = getNetworkIdent
|
||||
|
||||
setBTCregTest :: IO ()
|
||||
setBTCregTest = setNetwork btcRegTest
|
||||
instance Read Network where
|
||||
readPrec = do
|
||||
Ident str <- lexP
|
||||
maybe pfail return (netByIdent str)
|
||||
|
||||
setBCH :: IO ()
|
||||
setBCH = setNetwork bch
|
||||
netByName :: String -> Maybe Network
|
||||
netByName str = find ((== str) . getNetworkName) allNets
|
||||
|
||||
setBCHtest :: IO ()
|
||||
setBCHtest = setNetwork bchTest
|
||||
|
||||
setBCHregTest :: IO ()
|
||||
setBCHregTest = setNetwork bchRegTest
|
||||
|
||||
setNetwork :: Network -> IO ()
|
||||
setNetwork net = do
|
||||
success <- tryPutMVar networkMVar net
|
||||
unless success $ error "The network has already been set"
|
||||
|
||||
{-# NOINLINE networkMVar #-}
|
||||
networkMVar :: MVar Network
|
||||
networkMVar = unsafePerformIO newEmptyMVar
|
||||
|
||||
{-# NOINLINE getNetwork #-}
|
||||
getNetwork :: Network
|
||||
getNetwork =
|
||||
fromMaybe err $ unsafePerformIO $ tryTakeMVar networkMVar
|
||||
where
|
||||
err = error "Use Network.Haskoin.Constants.setNetwork"
|
||||
|
||||
networkName :: String
|
||||
networkName = getNetworkName getNetwork
|
||||
|
||||
addrPrefix :: Word8
|
||||
addrPrefix = getAddrPrefix getNetwork
|
||||
|
||||
scriptPrefix :: Word8
|
||||
scriptPrefix = getScriptPrefix getNetwork
|
||||
|
||||
secretPrefix :: Word8
|
||||
secretPrefix = getSecretPrefix getNetwork
|
||||
|
||||
extPubKeyPrefix :: Word32
|
||||
extPubKeyPrefix = getExtPubKeyPrefix getNetwork
|
||||
|
||||
extSecretPrefix :: Word32
|
||||
extSecretPrefix = getExtSecretPrefix getNetwork
|
||||
|
||||
networkMagic :: Word32
|
||||
networkMagic = getNetworkMagic getNetwork
|
||||
|
||||
genesisHeader :: BlockHeader
|
||||
genesisHeader = getGenesisHeader getNetwork
|
||||
|
||||
maxBlockSize :: Int
|
||||
maxBlockSize = getMaxBlockSize getNetwork
|
||||
|
||||
maxSatoshi :: Word64
|
||||
maxSatoshi = getMaxSatoshi getNetwork
|
||||
|
||||
haskoinUserAgent :: ByteString
|
||||
haskoinUserAgent = getHaskoinUserAgent getNetwork
|
||||
|
||||
defaultPort :: Int
|
||||
defaultPort = getDefaultPort getNetwork
|
||||
|
||||
allowMinDifficultyBlocks :: Bool
|
||||
allowMinDifficultyBlocks = getAllowMinDifficultyBlocks getNetwork
|
||||
|
||||
powNoRetargetting :: Bool
|
||||
powNoRetargetting = getPowNoRetargetting getNetwork
|
||||
|
||||
powLimit :: Integer
|
||||
powLimit = getPowLimit getNetwork
|
||||
|
||||
-- | Version 2 blocks start here.
|
||||
bip34Block :: (BlockHeight, BlockHash)
|
||||
bip34Block = getBip34Block getNetwork
|
||||
|
||||
-- | Version 3 blocks start here.
|
||||
bip65Height :: BlockHeight
|
||||
bip65Height = getBip65Height getNetwork
|
||||
|
||||
-- | Version 4 blocks start here.
|
||||
bip66Height :: BlockHeight
|
||||
bip66Height = getBip66Height getNetwork
|
||||
|
||||
-- | Time between difficulty cycles (2 weeks on average).
|
||||
targetTimespan :: Word32
|
||||
targetTimespan = getTargetTimespan getNetwork
|
||||
|
||||
-- | Time between blocks (10 minutes per block).
|
||||
targetSpacing :: Word32
|
||||
targetSpacing = getTargetSpacing getNetwork
|
||||
|
||||
-- | Checkpoints to enfore.
|
||||
checkpoints :: [(Word32, BlockHash)]
|
||||
checkpoints = getCheckpoints getNetwork
|
||||
|
||||
-- | Bip44 coin derivation (m/44'/coin'/account'/internal/address/)
|
||||
bip44Coin :: Word32
|
||||
bip44Coin = getBip44Coin getNetwork
|
||||
|
||||
-- | DNS seeds.
|
||||
seeds :: [String]
|
||||
seeds = getSeeds getNetwork
|
||||
|
||||
-- | The Fork ID used for producing signatures on different networks.
|
||||
sigHashForkId :: Maybe Word32
|
||||
sigHashForkId = getSigHashForkId getNetwork
|
||||
|
||||
-- | EDA Block height. Used by Bitcoin Cash network.
|
||||
edaBlockHeight :: Maybe Word32
|
||||
edaBlockHeight = getEDABlockHeight getNetwork
|
||||
|
||||
-- | DAA Block height. Used by Bitcoin Cash network.
|
||||
daaBlockHeight :: Maybe Word32
|
||||
daaBlockHeight = getDAABlockHeight getNetwork
|
||||
|
||||
-- | Only connect to nodes advertising SegWit support.
|
||||
segWit :: Bool
|
||||
segWit = getSegWit getNetwork
|
||||
|
||||
cashAddrPrefix :: Maybe ByteString
|
||||
cashAddrPrefix = getCashAddrPrefix getNetwork
|
||||
|
||||
bech32Prefix :: Maybe ByteString
|
||||
bech32Prefix = getBech32Prefix getNetwork
|
||||
netByIdent :: String -> Maybe Network
|
||||
netByIdent str = find ((== str) . getNetworkIdent) allNets
|
||||
|
||||
btc :: Network
|
||||
btc =
|
||||
Network
|
||||
{ getNetworkName = "btc"
|
||||
, getNetworkIdent = "btc"
|
||||
, getAddrPrefix = 0
|
||||
, getScriptPrefix = 5
|
||||
, getSecretPrefix = 128
|
||||
@ -306,8 +158,8 @@ btc =
|
||||
]
|
||||
, getBip44Coin = 0
|
||||
, getSigHashForkId = Nothing
|
||||
, getEDABlockHeight = Nothing
|
||||
, getDAABlockHeight = Nothing
|
||||
, getEdaBlockHeight = Nothing
|
||||
, getDaaBlockHeight = Nothing
|
||||
, getSegWit = True
|
||||
, getCashAddrPrefix = Nothing
|
||||
, getBech32Prefix = Just "bc"
|
||||
@ -317,6 +169,7 @@ btcTest :: Network
|
||||
btcTest =
|
||||
Network
|
||||
{ getNetworkName = "btc-test"
|
||||
, getNetworkIdent = "btcTest"
|
||||
, getAddrPrefix = 111
|
||||
, getScriptPrefix = 196
|
||||
, getSecretPrefix = 239
|
||||
@ -359,8 +212,8 @@ btcTest =
|
||||
]
|
||||
, getBip44Coin = 1
|
||||
, getSigHashForkId = Nothing
|
||||
, getEDABlockHeight = Nothing
|
||||
, getDAABlockHeight = Nothing
|
||||
, getEdaBlockHeight = Nothing
|
||||
, getDaaBlockHeight = Nothing
|
||||
, getSegWit = True
|
||||
, getCashAddrPrefix = Nothing
|
||||
, getBech32Prefix = Just "tb"
|
||||
@ -370,6 +223,7 @@ btcRegTest :: Network
|
||||
btcRegTest =
|
||||
Network
|
||||
{ getNetworkName = "btc-regtest"
|
||||
, getNetworkIdent = "btcRegTest"
|
||||
, getAddrPrefix = 111
|
||||
, getScriptPrefix = 196
|
||||
, getSecretPrefix = 239
|
||||
@ -404,8 +258,8 @@ btcRegTest =
|
||||
, getSeeds = ["localhost"]
|
||||
, getBip44Coin = 1
|
||||
, getSigHashForkId = Nothing
|
||||
, getEDABlockHeight = Nothing
|
||||
, getDAABlockHeight = Nothing
|
||||
, getEdaBlockHeight = Nothing
|
||||
, getDaaBlockHeight = Nothing
|
||||
, getSegWit = True
|
||||
, getCashAddrPrefix = Nothing
|
||||
, getBech32Prefix = Just "bcrt"
|
||||
@ -415,6 +269,7 @@ bch :: Network
|
||||
bch =
|
||||
Network
|
||||
{ getNetworkName = "bch"
|
||||
, getNetworkIdent = "bch"
|
||||
, getAddrPrefix = 0
|
||||
, getScriptPrefix = 5
|
||||
, getSecretPrefix = 128
|
||||
@ -489,8 +344,8 @@ bch =
|
||||
]
|
||||
, getBip44Coin = 145
|
||||
, getSigHashForkId = Just 0
|
||||
, getEDABlockHeight = Just 478559
|
||||
, getDAABlockHeight = Just 404031
|
||||
, getEdaBlockHeight = Just 478559
|
||||
, getDaaBlockHeight = Just 404031
|
||||
, getSegWit = False
|
||||
, getCashAddrPrefix = Just "bitcoincash"
|
||||
, getBech32Prefix = Nothing
|
||||
@ -500,6 +355,7 @@ bchTest :: Network
|
||||
bchTest =
|
||||
Network
|
||||
{ getNetworkName = "bch-test"
|
||||
, getNetworkIdent = "bchTest"
|
||||
, getAddrPrefix = 111
|
||||
, getScriptPrefix = 196
|
||||
, getSecretPrefix = 239
|
||||
@ -549,8 +405,8 @@ bchTest =
|
||||
]
|
||||
, getBip44Coin = 1
|
||||
, getSigHashForkId = Just 0
|
||||
, getEDABlockHeight = Just 1155876
|
||||
, getDAABlockHeight = Just 1188697
|
||||
, getEdaBlockHeight = Just 1155876
|
||||
, getDaaBlockHeight = Just 1188697
|
||||
, getSegWit = False
|
||||
, getCashAddrPrefix = Just "bchtest"
|
||||
, getBech32Prefix = Nothing
|
||||
@ -560,6 +416,7 @@ bchRegTest :: Network
|
||||
bchRegTest =
|
||||
Network
|
||||
{ getNetworkName = "bch-regtest"
|
||||
, getNetworkIdent = "bchRegTest"
|
||||
, getAddrPrefix = 111
|
||||
, getScriptPrefix = 196
|
||||
, getSecretPrefix = 239
|
||||
@ -597,9 +454,12 @@ bchRegTest =
|
||||
, getSeeds = ["localhost"]
|
||||
, getBip44Coin = 1
|
||||
, getSigHashForkId = Just 0
|
||||
, getEDABlockHeight = Nothing
|
||||
, getDAABlockHeight = Just 0
|
||||
, getEdaBlockHeight = Nothing
|
||||
, getDaaBlockHeight = Just 0
|
||||
, getSegWit = False
|
||||
, getCashAddrPrefix = Just "bchreg"
|
||||
, getBech32Prefix = Nothing
|
||||
}
|
||||
|
||||
allNets :: [Network]
|
||||
allNets = [btc, bch, btcTest, bchTest, btcRegTest, bchRegTest]
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Crypto.Address where
|
||||
|
||||
@ -5,6 +6,7 @@ import Control.Applicative
|
||||
import Control.DeepSeq
|
||||
import Control.Monad
|
||||
import Data.Aeson as A
|
||||
import Data.Aeson.Types
|
||||
import qualified Data.Array as Arr
|
||||
import Data.Bits
|
||||
import Data.ByteString (ByteString)
|
||||
@ -17,6 +19,7 @@ import Data.Serialize as S
|
||||
import Data.String
|
||||
import Data.String.Conversions
|
||||
import Data.Word
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto.Base58
|
||||
import Network.Haskoin.Crypto.Bech32
|
||||
@ -28,110 +31,98 @@ import Text.Read as R
|
||||
-- | Data type representing a Bitcoin address
|
||||
data Address
|
||||
-- | Public Key Hash Address
|
||||
= PubKeyAddress { getAddrHash :: !Hash160 }
|
||||
= PubKeyAddress { getAddrHash :: !Hash160
|
||||
, getAddrNet :: !Network }
|
||||
-- | Script Hash Address
|
||||
| ScriptAddress { getAddrHash :: !Hash160 }
|
||||
| ScriptAddress { getAddrHash :: !Hash160
|
||||
, getAddrNet :: !Network }
|
||||
-- | SegWit Public Key Hash Address
|
||||
| WitnessPubKeyAddress { getAddrHash :: !Hash160 }
|
||||
| WitnessPubKeyAddress { getAddrHash :: !Hash160
|
||||
, getAddrNet :: !Network }
|
||||
-- | SegWit Script Hash Address
|
||||
| WitnessScriptAddress { getScriptHash :: !Hash256 }
|
||||
deriving (Eq, Ord)
|
||||
| WitnessScriptAddress { getScriptHash :: !Hash256
|
||||
, getAddrNet :: !Network }
|
||||
deriving (Eq, Generic)
|
||||
|
||||
base58get :: Get Address
|
||||
base58get = do
|
||||
pfx <- getWord8
|
||||
addr <- S.get
|
||||
f pfx addr
|
||||
where
|
||||
f x a | x == addrPrefix = return (PubKeyAddress a)
|
||||
| x == scriptPrefix = return (ScriptAddress a)
|
||||
| otherwise = fail "Does not recognize address prefix"
|
||||
instance NFData Address
|
||||
|
||||
base58get :: Network -> Get Address
|
||||
base58get net = do
|
||||
pfx <- getWord8
|
||||
addr <- S.get
|
||||
f pfx addr
|
||||
where
|
||||
f x a
|
||||
| x == getAddrPrefix net = return (PubKeyAddress a net)
|
||||
| x == getScriptPrefix net = return (ScriptAddress a net)
|
||||
| otherwise = fail "Does not recognize address prefix"
|
||||
|
||||
base58put :: Putter Address
|
||||
base58put (PubKeyAddress h) = do
|
||||
putWord8 addrPrefix
|
||||
base58put (PubKeyAddress h net) = do
|
||||
putWord8 (getAddrPrefix net)
|
||||
put h
|
||||
base58put (ScriptAddress h) = do
|
||||
putWord8 scriptPrefix
|
||||
base58put (ScriptAddress h net) = do
|
||||
putWord8 (getScriptPrefix net)
|
||||
put h
|
||||
|
||||
instance Show Address where
|
||||
showsPrec d a =
|
||||
case addrToString a of
|
||||
Just s -> showParen (d > 10) $ showString "Address " . shows s
|
||||
Just s -> shows s
|
||||
Nothing -> showString "InvalidAddress"
|
||||
|
||||
instance Read Address where
|
||||
readPrec = j <|> n
|
||||
where
|
||||
j =
|
||||
parens $ do
|
||||
R.Ident "Address" <- lexP
|
||||
R.String str <- lexP
|
||||
maybe pfail return $ stringToAddr $ cs str
|
||||
n =
|
||||
parens $ do
|
||||
R.Ident "InvalidAddress" <- lexP
|
||||
pfail
|
||||
|
||||
instance IsString Address where
|
||||
fromString =
|
||||
fromMaybe e . stringToAddr . cs
|
||||
where
|
||||
e = error "Could not decode bitcoin address"
|
||||
|
||||
instance NFData Address where
|
||||
rnf (PubKeyAddress h) = rnf h
|
||||
rnf (ScriptAddress h) = rnf h
|
||||
|
||||
instance FromJSON Address where
|
||||
parseJSON = withText "address" $ maybe mzero return . stringToAddr . cs
|
||||
|
||||
instance ToJSON Address where
|
||||
toJSON =
|
||||
A.String .
|
||||
cs . fromMaybe (error "Could not encode address") . addrToString
|
||||
|
||||
addrFromJSON :: Network -> Value -> Parser Address
|
||||
addrFromJSON net =
|
||||
withText "address" $ \t ->
|
||||
case stringToAddr net (cs t) of
|
||||
Nothing -> fail "could not decode address"
|
||||
Just x -> return x
|
||||
|
||||
-- | Transforms an Address into an encoded String
|
||||
addrToString :: Address -> Maybe ByteString
|
||||
addrToString a@PubKeyAddress {getAddrHash = h}
|
||||
| isNothing cashAddrPrefix =
|
||||
addrToString a@PubKeyAddress {getAddrHash = h, getAddrNet = net}
|
||||
| isNothing (getCashAddrPrefix net) =
|
||||
return $ encodeBase58Check $ runPut $ base58put a
|
||||
| otherwise = cashAddrEncode 0 (S.encode h)
|
||||
addrToString a@ScriptAddress {getAddrHash = h}
|
||||
| isNothing cashAddrPrefix =
|
||||
| otherwise = cashAddrEncode net 0 (S.encode h)
|
||||
addrToString a@ScriptAddress {getAddrHash = h, getAddrNet = net}
|
||||
| isNothing (getCashAddrPrefix net) =
|
||||
return $ encodeBase58Check $ runPut $ base58put a
|
||||
| otherwise = cashAddrEncode 1 (S.encode h)
|
||||
addrToString WitnessPubKeyAddress {getAddrHash = h} = do
|
||||
hrp <- bech32Prefix
|
||||
| otherwise = cashAddrEncode net 1 (S.encode h)
|
||||
addrToString WitnessPubKeyAddress {getAddrHash = h, getAddrNet = net} = do
|
||||
hrp <- (getBech32Prefix net)
|
||||
segwitEncode hrp 0 (B.unpack (S.encode h))
|
||||
addrToString WitnessScriptAddress {getScriptHash = h} = do
|
||||
hrp <- bech32Prefix
|
||||
addrToString WitnessScriptAddress {getScriptHash = h, getAddrNet = net} = do
|
||||
hrp <- (getBech32Prefix net)
|
||||
segwitEncode hrp 0 (B.unpack (S.encode h))
|
||||
|
||||
-- | Decodes an Address from an encoded String. This function can fail
|
||||
-- if the String is not properly encoded or its checksum fails.
|
||||
stringToAddr :: ByteString -> Maybe Address
|
||||
stringToAddr bs = b58 <|> cash <|> segwit
|
||||
stringToAddr :: Network -> ByteString -> Maybe Address
|
||||
stringToAddr net bs = cash <|> segwit <|> b58
|
||||
where
|
||||
b58 = eitherToMaybe . runGet base58get =<< decodeBase58Check bs
|
||||
cash = cashAddrDecode bs >>= \(ver, bs') -> case ver of
|
||||
b58 = eitherToMaybe . runGet (base58get net) =<< decodeBase58Check bs
|
||||
cash = cashAddrDecode net bs >>= \(ver, bs') -> case ver of
|
||||
0 -> do
|
||||
h <- eitherToMaybe (S.decode bs')
|
||||
return $ PubKeyAddress h
|
||||
return $ PubKeyAddress h net
|
||||
1 -> do
|
||||
h <- eitherToMaybe (S.decode bs')
|
||||
return $ ScriptAddress h
|
||||
return $ ScriptAddress h net
|
||||
segwit = do
|
||||
hrp <- bech32Prefix
|
||||
hrp <- getBech32Prefix net
|
||||
(ver, bs') <- segwitDecode hrp bs
|
||||
guard (ver == 0)
|
||||
let bs'' = B.pack bs'
|
||||
case B.length bs'' of
|
||||
20 -> do
|
||||
h <- eitherToMaybe (S.decode bs'')
|
||||
return $ WitnessPubKeyAddress h
|
||||
return $ WitnessPubKeyAddress h net
|
||||
32 -> do
|
||||
h <- eitherToMaybe (S.decode bs'')
|
||||
return $ WitnessScriptAddress h
|
||||
return $ WitnessScriptAddress h net
|
||||
_ -> Nothing
|
||||
|
@ -1,14 +1,7 @@
|
||||
{- Copied from reference implementation contributed by Marko Bencun -}
|
||||
module Network.Haskoin.Crypto.Bech32
|
||||
( bech32Encode
|
||||
, bech32Decode
|
||||
, toBase32
|
||||
, toBase256
|
||||
, segwitEncode
|
||||
( segwitEncode
|
||||
, segwitDecode
|
||||
, Word5()
|
||||
, word5
|
||||
, fromWord5
|
||||
) where
|
||||
|
||||
import Control.Monad (guard)
|
||||
|
@ -36,9 +36,9 @@ charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
|
||||
base32char :: Char -> Maybe Word8
|
||||
base32char = fmap fromIntegral . (`elemIndex` charset)
|
||||
|
||||
cashAddrDecode :: CashAddr -> Maybe (CashVersion, ByteString)
|
||||
cashAddrDecode ca' = do
|
||||
epfx <- cashAddrPrefix
|
||||
cashAddrDecode :: Network -> CashAddr -> Maybe (CashVersion, ByteString)
|
||||
cashAddrDecode net ca' = do
|
||||
epfx <- getCashAddrPrefix net
|
||||
guard (B.length ca <= 90)
|
||||
guard (C.map toUpper ca' == ca' || ca == ca')
|
||||
let (cpfx', cdat) = C.breakEnd (== ':') ca
|
||||
@ -55,9 +55,9 @@ cashAddrDecode ca' = do
|
||||
where
|
||||
ca = C.map toLower ca'
|
||||
|
||||
cashAddrEncode :: CashVersion -> ByteString -> Maybe CashAddr
|
||||
cashAddrEncode cv bs = do
|
||||
pfx <- cashAddrPrefix
|
||||
cashAddrEncode :: Network -> CashVersion -> ByteString -> Maybe CashAddr
|
||||
cashAddrEncode net cv bs = do
|
||||
pfx <- getCashAddrPrefix net
|
||||
ver <- encodeCashVersion cv
|
||||
len <- encodeCashLength (B.length bs)
|
||||
let vb = ver .|. len
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | ECDSA Signatures
|
||||
module Network.Haskoin.Crypto.ECDSA
|
||||
( SecretT
|
||||
@ -45,7 +46,7 @@ withSource :: Monad m => (Int -> m ByteString) -> SecretT m a -> m a
|
||||
withSource f m = do
|
||||
seed <- f 32 -- Read 256 bits from the random source
|
||||
nonce <- f 16 -- Read 128 bits from the random source
|
||||
let ws = hmacDRBGNew seed nonce haskoinUserAgent
|
||||
let ws = hmacDRBGNew seed nonce "haskoin"
|
||||
S.evalStateT m (ws,f)
|
||||
|
||||
-- | Generate a new random 'EC.SecKey' value from the 'SecretT' monad. This
|
||||
@ -54,7 +55,7 @@ withSource f m = do
|
||||
nextSecret :: Monad m => SecretT m EC.SecKey
|
||||
nextSecret = do
|
||||
(ws, f) <- S.get
|
||||
let (ws', randM) = hmacDRBGGen ws 32 haskoinUserAgent
|
||||
let (ws', randM) = hmacDRBGGen ws 32 "haskoin"
|
||||
case randM of
|
||||
(Just rand) -> do
|
||||
S.put (ws', f)
|
||||
@ -63,7 +64,7 @@ nextSecret = do
|
||||
Nothing -> nextSecret
|
||||
Nothing -> do
|
||||
seed <- lift $ f 32 -- Read 256 bits to re-seed the PRNG
|
||||
let ws0 = hmacDRBGRsd ws' seed haskoinUserAgent
|
||||
let ws0 = hmacDRBGRsd ws' seed "haskoin"
|
||||
S.put (ws0, f)
|
||||
nextSecret
|
||||
|
||||
|
@ -26,6 +26,12 @@ module Network.Haskoin.Crypto.ExtendedKeys
|
||||
, xPubImport
|
||||
, xPrvImport
|
||||
, xPrvWif
|
||||
, putXPrvKey
|
||||
, putXPubKey
|
||||
, getXPrvKey
|
||||
, getXPubKey
|
||||
, xPubFromJSON
|
||||
, xPrvFromJSON
|
||||
|
||||
-- Helpers
|
||||
, prvSubKeys
|
||||
@ -79,6 +85,7 @@ import Data.Aeson as A (FromJSON, ToJSON,
|
||||
Value (String),
|
||||
parseJSON, toJSON,
|
||||
withText)
|
||||
import Data.Aeson.Types (Parser)
|
||||
import Data.Bits (clearBit, setBit, testBit)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
@ -89,9 +96,10 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Serialize as S (Serialize, decode,
|
||||
encode, get, put)
|
||||
import Data.Serialize.Get (Get, getWord32be, getWord8)
|
||||
import Data.Serialize.Put (Put, putWord32be, putWord8,
|
||||
runPut)
|
||||
import Data.Serialize.Get (Get, getWord32be, getWord8,
|
||||
runGet)
|
||||
import Data.Serialize.Put (Put, Putter, putWord32be,
|
||||
putWord8, runPut)
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Typeable (Typeable)
|
||||
@ -122,50 +130,36 @@ type KeyIndex = Word32
|
||||
-- is a node in a tree of key derivations. It has a depth in the tree, a
|
||||
-- parent node and an index to differentiate it from other siblings.
|
||||
data XPrvKey = XPrvKey
|
||||
{ xPrvDepth :: !Word8 -- ^ Depth in the tree of key derivations.
|
||||
, xPrvParent :: !Word32 -- ^ Fingerprint of the parent key.
|
||||
, xPrvIndex :: !KeyIndex -- ^ Key derivation index.
|
||||
{ xPrvDepth :: !Word8 -- ^ Depth in the tree of key derivations.
|
||||
, xPrvParent :: !Word32 -- ^ Fingerprint of the parent key.
|
||||
, xPrvIndex :: !KeyIndex -- ^ Key derivation index.
|
||||
, xPrvChain :: !ChainCode -- ^ Chain code.
|
||||
, xPrvKey :: !PrvKeyC -- ^ The private key of this extended key node.
|
||||
, xPrvKey :: !PrvKeyC -- ^ The private key of this extended key node.
|
||||
, xPrvNet :: !Network
|
||||
} deriving (Eq)
|
||||
|
||||
instance Ord XPrvKey where
|
||||
compare k1 k2 = xPrvExport k1 `compare` xPrvExport k2
|
||||
|
||||
instance Show XPrvKey where
|
||||
showsPrec d k = showParen (d > 10) $
|
||||
showString "XPrvKey " . shows (xPrvExport k)
|
||||
|
||||
instance Read XPrvKey where
|
||||
readPrec =
|
||||
parens $ do
|
||||
R.Ident "XPrvKey" <- lexP
|
||||
R.String str <- lexP
|
||||
maybe pfail return $ xPrvImport $ cs str
|
||||
|
||||
instance IsString XPrvKey where
|
||||
fromString =
|
||||
fromMaybe e . xPrvImport . cs
|
||||
where
|
||||
e = error "Could not decode extended private key"
|
||||
showsPrec d k = shows (xPrvExport k)
|
||||
|
||||
instance NFData XPrvKey where
|
||||
rnf (XPrvKey d p i c k) =
|
||||
rnf d `seq` rnf p `seq` rnf i `seq` rnf c `seq` rnf k
|
||||
rnf (XPrvKey d p i c k n) =
|
||||
rnf d `seq`
|
||||
rnf p `seq` rnf i `seq` rnf c `seq` rnf k `seq` rnf n `seq` ()
|
||||
|
||||
instance ToJSON XPrvKey where
|
||||
toJSON = A.String . cs . xPrvExport
|
||||
|
||||
instance FromJSON XPrvKey where
|
||||
parseJSON = withText "xprvkey" $ maybe mzero return . xPrvImport . cs
|
||||
|
||||
-- | Data type representing an extended BIP32 public key.
|
||||
data XPubKey = XPubKey
|
||||
{ xPubDepth :: !Word8 -- ^ Depth in the tree of key derivations.
|
||||
, xPubParent :: !Word32 -- ^ Fingerprint of the parent key.
|
||||
, xPubIndex :: !KeyIndex -- ^ Key derivation index.
|
||||
{ xPubDepth :: !Word8 -- ^ Depth in the tree of key derivations.
|
||||
, xPubParent :: !Word32 -- ^ Fingerprint of the parent key.
|
||||
, xPubIndex :: !KeyIndex -- ^ Key derivation index.
|
||||
, xPubChain :: !ChainCode -- ^ Chain code.
|
||||
, xPubKey :: !PubKeyC -- ^ The public key of this extended key node.
|
||||
, xPubKey :: !PubKeyC -- ^ The public key of this extended key node.
|
||||
, xPubNet :: !Network
|
||||
} deriving (Eq)
|
||||
|
||||
instance Ord XPubKey where
|
||||
@ -175,33 +169,33 @@ instance Show XPubKey where
|
||||
showsPrec d k = showParen (d > 10) $
|
||||
showString "XPubKey " . shows (xPubExport k)
|
||||
|
||||
instance Read XPubKey where
|
||||
readPrec = parens $ do
|
||||
R.Ident "XPubKey" <- lexP
|
||||
R.String str <- lexP
|
||||
maybe pfail return $ xPubImport $ cs str
|
||||
|
||||
instance IsString XPubKey where
|
||||
fromString =
|
||||
fromMaybe e . xPubImport . cs
|
||||
where
|
||||
e = error "Could not import extended public key"
|
||||
|
||||
instance NFData XPubKey where
|
||||
rnf (XPubKey d p i c k) =
|
||||
rnf d `seq` rnf p `seq` rnf i `seq` rnf c `seq` rnf k
|
||||
rnf (XPubKey d p i c k n) =
|
||||
rnf d `seq`
|
||||
rnf p `seq` rnf i `seq` rnf c `seq` rnf k `seq` rnf n `seq` ()
|
||||
|
||||
instance ToJSON XPubKey where
|
||||
toJSON = A.String . cs . xPubExport
|
||||
|
||||
instance FromJSON XPubKey where
|
||||
parseJSON = withText "xpubkey" $ maybe mzero return . xPubImport . cs
|
||||
xPubFromJSON :: Network -> Value -> Parser XPubKey
|
||||
xPubFromJSON net =
|
||||
withText "xpub" $ \t ->
|
||||
case xPubImport net (cs t) of
|
||||
Nothing -> fail "could not read xpub"
|
||||
Just x -> return x
|
||||
|
||||
xPrvFromJSON :: Network -> Value -> Parser XPrvKey
|
||||
xPrvFromJSON net =
|
||||
withText "xprv" $ \t ->
|
||||
case xPrvImport net (cs t) of
|
||||
Nothing -> fail "could not read xprv"
|
||||
Just x -> return x
|
||||
|
||||
-- | Build a BIP32 compatible extended private key from a bytestring. This will
|
||||
-- produce a root node (depth=0 and parent=0).
|
||||
makeXPrvKey :: ByteString -> XPrvKey
|
||||
makeXPrvKey bs =
|
||||
XPrvKey 0 0 0 c k
|
||||
makeXPrvKey :: Network -> ByteString -> XPrvKey
|
||||
makeXPrvKey net bs =
|
||||
XPrvKey 0 0 0 c k net
|
||||
where
|
||||
(p, c) = split512 $ hmac512 "Bitcoin seed" bs
|
||||
k = maybe err makePrvKeyC (EC.secKey (encode p))
|
||||
@ -211,7 +205,7 @@ makeXPrvKey bs =
|
||||
-- will preserve the depth, parent, index and chaincode fields of the extended
|
||||
-- private keys.
|
||||
deriveXPubKey :: XPrvKey -> XPubKey
|
||||
deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k)
|
||||
deriveXPubKey (XPrvKey d p i c k n) = XPubKey d p i c (derivePubKey k) n
|
||||
|
||||
-- | Compute a private, soft child key derivation. A private soft derivation
|
||||
-- will allow the equivalent extended public key to derive the public key for
|
||||
@ -227,14 +221,14 @@ prvSubKey :: XPrvKey -- ^ Extended parent private key
|
||||
-> XPrvKey -- ^ Extended child private key
|
||||
prvSubKey xkey child
|
||||
| child >= 0 && child < 0x80000000 =
|
||||
XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k
|
||||
XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k (xPrvNet xkey)
|
||||
| otherwise = error "Invalid child derivation index"
|
||||
where
|
||||
pK = xPubKey $ deriveXPubKey xkey
|
||||
msg = BS.append (encode pK) (encode child)
|
||||
pK = xPubKey $ deriveXPubKey xkey
|
||||
msg = BS.append (encode pK) (encode child)
|
||||
(a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) msg
|
||||
k = fromMaybe err $ tweakPrvKeyC (xPrvKey xkey) a
|
||||
err = throw $ DerivationException "Invalid prvSubKey derivation"
|
||||
k = fromMaybe err $ tweakPrvKeyC (xPrvKey xkey) a
|
||||
err = throw $ DerivationException "Invalid prvSubKey derivation"
|
||||
|
||||
-- | Compute a public, soft child key derivation. Given a parent key /M/
|
||||
-- and a derivation index /i/, this function will compute M\/i\/.
|
||||
@ -243,7 +237,7 @@ pubSubKey :: XPubKey -- ^ Extended Parent public key
|
||||
-> XPubKey -- ^ Extended child public key
|
||||
pubSubKey xKey child
|
||||
| child >= 0 && child < 0x80000000 =
|
||||
XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK
|
||||
XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK (xPubNet xKey)
|
||||
| otherwise = error "Invalid child derivation index"
|
||||
where
|
||||
msg = BS.append (encode $ xPubKey xKey) (encode child)
|
||||
@ -262,7 +256,7 @@ hardSubKey :: XPrvKey -- ^ Extended Parent private key
|
||||
-> XPrvKey -- ^ Extended child private key
|
||||
hardSubKey xkey child
|
||||
| child >= 0 && child < 0x80000000 =
|
||||
XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k
|
||||
XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k (xPrvNet xkey)
|
||||
| otherwise = error "Invalid child derivation index"
|
||||
where
|
||||
i = setBit child 31
|
||||
@ -315,69 +309,71 @@ xPubFP =
|
||||
|
||||
-- | Computer the 'Address' of an extended public key.
|
||||
xPubAddr :: XPubKey -> Address
|
||||
xPubAddr = pubKeyAddr . xPubKey
|
||||
xPubAddr xkey = pubKeyAddr (xPubNet xkey) (xPubKey xkey)
|
||||
|
||||
-- | Exports an extended private key to the BIP32 key export format (base 58).
|
||||
xPrvExport :: XPrvKey -> ByteString
|
||||
xPrvExport = encodeBase58Check . encode
|
||||
xPrvExport = encodeBase58Check . runPut . putXPrvKey
|
||||
|
||||
-- | Exports an extended public key to the BIP32 key export format (base 58).
|
||||
xPubExport :: XPubKey -> ByteString
|
||||
xPubExport = encodeBase58Check . encode
|
||||
xPubExport = encodeBase58Check . runPut . putXPubKey
|
||||
|
||||
-- | Decodes a BIP32 encoded extended private key. This function will fail if
|
||||
-- invalid base 58 characters are detected or if the checksum fails.
|
||||
xPrvImport :: ByteString -> Maybe XPrvKey
|
||||
xPrvImport = eitherToMaybe . decode <=< decodeBase58Check
|
||||
xPrvImport :: Network -> ByteString -> Maybe XPrvKey
|
||||
xPrvImport net = eitherToMaybe . runGet (getXPrvKey net) <=< decodeBase58Check
|
||||
|
||||
-- | Decodes a BIP32 encoded extended public key. This function will fail if
|
||||
-- invalid base 58 characters are detected or if the checksum fails.
|
||||
xPubImport :: ByteString -> Maybe XPubKey
|
||||
xPubImport = eitherToMaybe . decode <=< decodeBase58Check
|
||||
xPubImport :: Network -> ByteString -> Maybe XPubKey
|
||||
xPubImport net = eitherToMaybe . runGet (getXPubKey net) <=< decodeBase58Check
|
||||
|
||||
-- | Export an extended private key to WIF (Wallet Import Format).
|
||||
xPrvWif :: XPrvKey -> ByteString
|
||||
xPrvWif = toWif . xPrvKey
|
||||
xPrvWif xkey = toWif (xPrvNet xkey) (xPrvKey xkey)
|
||||
|
||||
instance Serialize XPrvKey where
|
||||
|
||||
get = do
|
||||
getXPrvKey :: Network -> Get XPrvKey
|
||||
getXPrvKey net = do
|
||||
ver <- getWord32be
|
||||
unless (ver == extSecretPrefix) $ fail
|
||||
unless (ver == getExtSecretPrefix net) $ fail
|
||||
"Get: Invalid version for extended private key"
|
||||
XPrvKey <$> getWord8
|
||||
<*> getWord32be
|
||||
<*> getWord32be
|
||||
<*> S.get
|
||||
<*> getPadPrvKey
|
||||
<*> pure net
|
||||
|
||||
put k = do
|
||||
putWord32be extSecretPrefix
|
||||
putXPrvKey :: Putter XPrvKey
|
||||
putXPrvKey k = do
|
||||
putWord32be $ getExtSecretPrefix (xPrvNet k)
|
||||
putWord8 $ xPrvDepth k
|
||||
putWord32be $ xPrvParent k
|
||||
putWord32be $ xPrvIndex k
|
||||
put $ xPrvChain k
|
||||
putPadPrvKey $ xPrvKey k
|
||||
|
||||
instance Serialize XPubKey where
|
||||
|
||||
get = do
|
||||
getXPubKey :: Network -> Get XPubKey
|
||||
getXPubKey net = do
|
||||
ver <- getWord32be
|
||||
unless (ver == extPubKeyPrefix) $ fail
|
||||
unless (ver == getExtPubKeyPrefix net) $ fail
|
||||
"Get: Invalid version for extended public key"
|
||||
XPubKey <$> getWord8
|
||||
<*> getWord32be
|
||||
<*> getWord32be
|
||||
<*> S.get
|
||||
<*> S.get
|
||||
<*> pure net
|
||||
|
||||
put k = do
|
||||
putWord32be extPubKeyPrefix
|
||||
putXPubKey :: Putter XPubKey
|
||||
putXPubKey k = do
|
||||
putWord32be $ getExtPubKeyPrefix (xPubNet k)
|
||||
putWord8 $ xPubDepth k
|
||||
putWord32be $ xPubParent k
|
||||
putWord32be $ xPubIndex k
|
||||
put $ xPubChain k
|
||||
put $ xPubKey k
|
||||
put $ xPubKey k
|
||||
|
||||
{- Derivation helpers -}
|
||||
|
||||
@ -415,22 +411,24 @@ deriveAddrs k =
|
||||
-- | Derive a multisig address from a list of public keys, the number of
|
||||
-- required signatures (m) and a derivation index. The derivation type is a
|
||||
-- public, soft derivation.
|
||||
deriveMSAddr :: [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript)
|
||||
deriveMSAddr keys m i =
|
||||
(p2shAddr rdm, rdm)
|
||||
deriveMSAddr :: Network -> [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript)
|
||||
deriveMSAddr net keys m i
|
||||
| all ((== net) . xPubNet) keys = (p2shAddr net rdm, rdm)
|
||||
| otherwise = error "Some extended public keys on the wrong network"
|
||||
where
|
||||
rdm = sortMulSig $ PayMulSig k m
|
||||
k = map (toPubKeyG . xPubKey . flip pubSubKey i) keys
|
||||
k = map (toPubKeyG . xPubKey . flip pubSubKey i) keys
|
||||
|
||||
-- | Cyclic list of all multisig addresses derived from a list of public keys,
|
||||
-- a number of required signatures (m) and starting from an offset index. The
|
||||
-- derivation type is a public, soft derivation.
|
||||
deriveMSAddrs :: [XPubKey] -> Int -> KeyIndex
|
||||
deriveMSAddrs :: Network -> [XPubKey] -> Int -> KeyIndex
|
||||
-> [(Address, RedeemScript, KeyIndex)]
|
||||
deriveMSAddrs keys m =
|
||||
map f . cycleIndex
|
||||
deriveMSAddrs net keys m = map f . cycleIndex
|
||||
where
|
||||
f i = let (a, rdm) = deriveMSAddr keys m i in (a, rdm, i)
|
||||
f i =
|
||||
let (a, rdm) = deriveMSAddr net keys m i
|
||||
in (a, rdm, i)
|
||||
|
||||
cycleIndex :: KeyIndex -> [KeyIndex]
|
||||
cycleIndex i
|
||||
@ -656,8 +654,8 @@ instance Show ParsedPath where
|
||||
where
|
||||
f =
|
||||
case p of
|
||||
ParsedPrv d' -> "m" <> pathToStr d'
|
||||
ParsedPub d' -> "M" <> pathToStr d'
|
||||
ParsedPrv d' -> "m" <> pathToStr d'
|
||||
ParsedPub d' -> "M" <> pathToStr d'
|
||||
ParsedEmpty d' -> pathToStr d'
|
||||
|
||||
instance Read ParsedPath where
|
||||
@ -729,8 +727,11 @@ parseHard = toHard . getParsedPath <=< parsePath
|
||||
parseSoft :: String -> Maybe SoftPath
|
||||
parseSoft = toSoft . getParsedPath <=< parsePath
|
||||
|
||||
data XKey = XPrv { getXPrvKey :: !XPrvKey }
|
||||
| XPub { getXPubKey :: !XPubKey }
|
||||
data XKey
|
||||
= XPrv { getXKeyPrv :: !XPrvKey
|
||||
, getXKeyNet :: !Network }
|
||||
| XPub { getXKeyPub :: !XPubKey
|
||||
, getXKeyNet :: !Network }
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Apply a parsed path to an extended key to derive the new key defined in the
|
||||
@ -739,27 +740,30 @@ data XKey = XPrv { getXPrvKey :: !XPrvKey }
|
||||
-- public key, and public derivations with a hard segment, return an error
|
||||
-- value.
|
||||
applyPath :: ParsedPath -> XKey -> Either String XKey
|
||||
applyPath path key = case (path, key) of
|
||||
(ParsedPrv _, XPrv k) -> return $ XPrv $ derivPrvF k
|
||||
(ParsedPrv _, XPub _) -> Left "applyPath: Invalid public key"
|
||||
(ParsedPub _, XPrv k) -> return $ XPub $ deriveXPubKey $ derivPrvF k
|
||||
(ParsedPub _, XPub k) -> derivPubFE >>= \f -> return $ XPub $ f k
|
||||
applyPath path key =
|
||||
case (path, key) of
|
||||
(ParsedPrv _, XPrv k n) -> return $ XPrv (derivPrvF k) n
|
||||
(ParsedPrv _, XPub {}) -> Left "applyPath: Invalid public key"
|
||||
(ParsedPub _, XPrv k n) -> return $ XPub (deriveXPubKey (derivPrvF k)) n
|
||||
(ParsedPub _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n
|
||||
-- For empty parsed paths, we take a hint from the provided key
|
||||
(ParsedEmpty _, XPrv k) -> return $ XPrv $ derivPrvF k
|
||||
(ParsedEmpty _, XPub k) -> derivPubFE >>= \f -> return $ XPub $ f k
|
||||
(ParsedEmpty _, XPrv k n) -> return $ XPrv (derivPrvF k) n
|
||||
(ParsedEmpty _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n
|
||||
where
|
||||
derivPrvF = goPrv id $ getParsedPath path
|
||||
derivPrvF = goPrv id $ getParsedPath path
|
||||
derivPubFE = goPubE id $ getParsedPath path
|
||||
-- Build the full private derivation function starting from the end
|
||||
goPrv f p = case p of
|
||||
next :| i -> goPrv (f . flip hardSubKey i) next
|
||||
next :/ i -> goPrv (f . flip prvSubKey i) next
|
||||
Deriv -> f
|
||||
goPrv f p =
|
||||
case p of
|
||||
next :| i -> goPrv (f . flip hardSubKey i) next
|
||||
next :/ i -> goPrv (f . flip prvSubKey i) next
|
||||
Deriv -> f
|
||||
-- Build the full public derivation function starting from the end
|
||||
goPubE f p = case p of
|
||||
next :/ i -> goPubE (f . flip pubSubKey i) next
|
||||
Deriv -> Right f
|
||||
_ -> Left "applyPath: Invalid hard derivation"
|
||||
goPubE f p =
|
||||
case p of
|
||||
next :/ i -> goPubE (f . flip pubSubKey i) next
|
||||
Deriv -> Right f
|
||||
_ -> Left "applyPath: Invalid hard derivation"
|
||||
|
||||
{- Helpers for derivation paths and addresses -}
|
||||
|
||||
@ -769,22 +773,34 @@ derivePathAddr key path = deriveAddr (derivePubPath path key)
|
||||
|
||||
-- | Cyclic list of all addresses derived from a given parent path and starting
|
||||
-- from the given offset index.
|
||||
derivePathAddrs :: XPubKey -> SoftPath -> KeyIndex
|
||||
-> [(Address, PubKeyC, KeyIndex)]
|
||||
derivePathAddrs ::
|
||||
XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKeyC, KeyIndex)]
|
||||
derivePathAddrs key path = deriveAddrs (derivePubPath path key)
|
||||
|
||||
-- | Derive a multisig address from a given parent path. The number of required
|
||||
-- signatures (m in m of n) is also needed.
|
||||
derivePathMSAddr :: [XPubKey] -> SoftPath -> Int -> KeyIndex
|
||||
-> (Address, RedeemScript)
|
||||
derivePathMSAddr keys path = deriveMSAddr $ map (derivePubPath path) keys
|
||||
derivePathMSAddr ::
|
||||
Network
|
||||
-> [XPubKey]
|
||||
-> SoftPath
|
||||
-> Int
|
||||
-> KeyIndex
|
||||
-> (Address, RedeemScript)
|
||||
derivePathMSAddr net keys path =
|
||||
deriveMSAddr net $ map (derivePubPath path) keys
|
||||
|
||||
-- | Cyclic list of all multisig addresses derived from a given parent path and
|
||||
-- starting from the given offset index. The number of required signatures
|
||||
-- (m in m of n) is also needed.
|
||||
derivePathMSAddrs :: [XPubKey] -> SoftPath -> Int -> KeyIndex
|
||||
-> [(Address, RedeemScript, KeyIndex)]
|
||||
derivePathMSAddrs keys path = deriveMSAddrs $ map (derivePubPath path) keys
|
||||
derivePathMSAddrs ::
|
||||
Network
|
||||
-> [XPubKey]
|
||||
-> SoftPath
|
||||
-> Int
|
||||
-> KeyIndex
|
||||
-> [(Address, RedeemScript, KeyIndex)]
|
||||
derivePathMSAddrs net keys path =
|
||||
deriveMSAddrs net $ map (derivePubPath path) keys
|
||||
|
||||
{- Utilities for extended keys -}
|
||||
|
||||
|
@ -221,8 +221,8 @@ instance Serialize PubKeyU where
|
||||
put pk = putByteString $ EC.exportPubKey False $ pubKeyPoint pk
|
||||
|
||||
-- | Computes an 'Address' from a public key
|
||||
pubKeyAddr :: Serialize (PubKeyI c) => PubKeyI c -> Address
|
||||
pubKeyAddr = PubKeyAddress . addressHash . encode
|
||||
pubKeyAddr :: Serialize (PubKeyI c) => Network -> PubKeyI c -> Address
|
||||
pubKeyAddr net k = PubKeyAddress (addressHash (encode k)) net
|
||||
|
||||
-- | Tweak a compressed public key
|
||||
tweakPubKeyC :: PubKeyC -> Hash256 -> Maybe PubKeyC
|
||||
@ -243,70 +243,10 @@ tweakPubKeyC pub h =
|
||||
data PrvKeyI c = PrvKeyI
|
||||
{ prvKeySecKey :: !EC.SecKey
|
||||
, prvKeyCompressed :: !Bool
|
||||
} deriving (Eq)
|
||||
} deriving (Eq, Show, Read)
|
||||
|
||||
instance NFData (PrvKeyI c) where
|
||||
rnf (PrvKeyI s b) = s `seq` b `seq` ()
|
||||
|
||||
instance Show PrvKey where
|
||||
showsPrec d k = showParen (d > 10) $
|
||||
showString "PrvKey " . shows (toWif k)
|
||||
|
||||
instance Show PrvKeyC where
|
||||
showsPrec d k = showParen (d > 10) $
|
||||
showString "PrvKeyC " . shows (toWif k)
|
||||
|
||||
instance Show PrvKeyU where
|
||||
showsPrec d k = showParen (d > 10) $
|
||||
showString "PrvKeyU " . shows (toWif k)
|
||||
|
||||
instance Read PrvKey where
|
||||
readPrec = parens $ do
|
||||
Read.Ident "PrvKey" <- lexP
|
||||
Read.String str <- lexP
|
||||
maybe pfail return $ fromWif $ cs str
|
||||
|
||||
instance Read PrvKeyC where
|
||||
readPrec = parens $ do
|
||||
Read.Ident "PrvKeyC" <- lexP
|
||||
Read.String str <- lexP
|
||||
key <- maybe pfail return $ fromWif $ cs str
|
||||
case eitherPrvKey key of
|
||||
Left _ -> pfail
|
||||
Right k -> return k
|
||||
|
||||
instance Read PrvKeyU where
|
||||
readPrec = parens $ do
|
||||
Read.Ident "PrvKeyU" <- lexP
|
||||
Read.String str <- lexP
|
||||
key <- maybe pfail return $ fromWif $ cs str
|
||||
case eitherPrvKey key of
|
||||
Left k -> return k
|
||||
Right _ -> pfail
|
||||
|
||||
instance IsString PrvKey where
|
||||
fromString str =
|
||||
fromMaybe e $ fromWif $ cs str
|
||||
where
|
||||
e = error "Could not decode WIF"
|
||||
|
||||
instance IsString PrvKeyC where
|
||||
fromString str =
|
||||
case eitherPrvKey key of
|
||||
Left _ -> undefined
|
||||
Right k -> k
|
||||
where
|
||||
key = fromMaybe e $ fromWif $ cs str
|
||||
e = error "Could not decode WIF"
|
||||
|
||||
instance IsString PrvKeyU where
|
||||
fromString str =
|
||||
case eitherPrvKey key of
|
||||
Left k -> k
|
||||
Right _ -> undefined
|
||||
where
|
||||
key = fromMaybe e $ fromWif $ cs str
|
||||
e = error "Could not decode WIF"
|
||||
rnf (PrvKeyI k c) = k `seq` c `seq` ()
|
||||
|
||||
type PrvKey = PrvKeyI Generic
|
||||
type PrvKeyC = PrvKeyI Compressed
|
||||
@ -367,11 +307,11 @@ prvKeyPutMonad (PrvKeyI k _) = putByteString $ EC.getSecKey k
|
||||
-- fail if the input string does not decode correctly as a base 58 string or if
|
||||
-- the checksum fails.
|
||||
-- <http://en.bitcoin.it/wiki/Wallet_import_format>
|
||||
fromWif :: ByteString -> Maybe PrvKey
|
||||
fromWif wif = do
|
||||
fromWif :: Network -> ByteString -> Maybe PrvKey
|
||||
fromWif net wif = do
|
||||
bs <- decodeBase58Check wif
|
||||
-- Check that this is a private key
|
||||
guard (BS.head bs == secretPrefix)
|
||||
guard (BS.head bs == getSecretPrefix net)
|
||||
case BS.length bs of
|
||||
-- Uncompressed format
|
||||
33 -> makePrvKeyG False <$> EC.secKey (BS.tail bs)
|
||||
@ -383,10 +323,9 @@ fromWif wif = do
|
||||
_ -> Nothing
|
||||
|
||||
-- | Encodes a private key into WIF format
|
||||
toWif :: PrvKeyI c -> ByteString
|
||||
toWif (PrvKeyI k c) =
|
||||
encodeBase58Check $
|
||||
BS.cons secretPrefix $
|
||||
toWif :: Network -> PrvKeyI c -> ByteString
|
||||
toWif net (PrvKeyI k c) =
|
||||
encodeBase58Check . BS.cons (getSecretPrefix net) $
|
||||
if c
|
||||
then EC.getSecKey k `BS.snoc` 0x01
|
||||
else EC.getSecKey k
|
||||
|
@ -2,17 +2,19 @@ module Network.Haskoin.Network.Message
|
||||
( Message(..)
|
||||
, MessageHeader(..)
|
||||
, msgType
|
||||
, putMessage
|
||||
, getMessage
|
||||
) where
|
||||
|
||||
import Control.DeepSeq (NFData, rnf)
|
||||
import Control.Monad (unless)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Serialize (Serialize, encode, get, put)
|
||||
import Data.Serialize.Get (getByteString, getWord32be,
|
||||
getWord32le, isolate,
|
||||
lookAhead)
|
||||
import Data.Serialize.Put (putByteString, putWord32be,
|
||||
putWord32le)
|
||||
import Data.Serialize.Get (Get, getByteString,
|
||||
getWord32be, getWord32le,
|
||||
isolate, lookAhead)
|
||||
import Data.Serialize.Put (Putter, putByteString,
|
||||
putWord32be, putWord32le)
|
||||
import Data.Word (Word32)
|
||||
import Network.Haskoin.Block.Merkle
|
||||
import Network.Haskoin.Block.Types
|
||||
@ -109,68 +111,73 @@ msgType MMempool = "mempool"
|
||||
msgType (MReject _) = "reject"
|
||||
msgType MSendHeaders = "sendheaders"
|
||||
|
||||
instance Serialize Message where
|
||||
get = do
|
||||
(MessageHeader mgc cmd len chk) <- get
|
||||
bs <- lookAhead $ getByteString $ fromIntegral len
|
||||
unless (mgc == networkMagic)
|
||||
(fail $ "get: Invalid network magic bytes: " ++ show mgc)
|
||||
unless (checkSum32 bs == chk)
|
||||
(fail $ "get: Invalid message checksum: " ++ show chk)
|
||||
if len > 0
|
||||
then isolate (fromIntegral len) $ case cmd of
|
||||
MCVersion -> MVersion <$> get
|
||||
MCAddr -> MAddr <$> get
|
||||
MCInv -> MInv <$> get
|
||||
MCGetData -> MGetData <$> get
|
||||
MCNotFound -> MNotFound <$> get
|
||||
MCGetBlocks -> MGetBlocks <$> get
|
||||
MCGetHeaders -> MGetHeaders <$> get
|
||||
MCTx -> MTx <$> get
|
||||
MCBlock -> MBlock <$> get
|
||||
MCMerkleBlock -> MMerkleBlock <$> get
|
||||
MCHeaders -> MHeaders <$> get
|
||||
MCFilterLoad -> MFilterLoad <$> get
|
||||
MCFilterAdd -> MFilterAdd <$> get
|
||||
MCPing -> MPing <$> get
|
||||
MCPong -> MPong <$> get
|
||||
MCAlert -> MAlert <$> get
|
||||
MCReject -> MReject <$> get
|
||||
_ -> fail $ "get: Invalid command " ++ show cmd
|
||||
else case cmd of
|
||||
MCGetAddr -> return MGetAddr
|
||||
MCVerAck -> return MVerAck
|
||||
MCFilterClear -> return MFilterClear
|
||||
MCMempool -> return MMempool
|
||||
MCSendHeaders -> return MSendHeaders
|
||||
_ -> fail $ "get: Invalid command " ++ show cmd
|
||||
put msg = do
|
||||
let (cmd, payload) = case msg of
|
||||
MVersion m -> (MCVersion, encode m)
|
||||
MVerAck -> (MCVerAck, BS.empty)
|
||||
MAddr m -> (MCAddr, encode m)
|
||||
MInv m -> (MCInv, encode m)
|
||||
MGetData m -> (MCGetData, encode m)
|
||||
MNotFound m -> (MCNotFound, encode m)
|
||||
MGetBlocks m -> (MCGetBlocks, encode m)
|
||||
MGetHeaders m -> (MCGetHeaders, encode m)
|
||||
MTx m -> (MCTx, encode m)
|
||||
MBlock m -> (MCBlock, encode m)
|
||||
MMerkleBlock m -> (MCMerkleBlock, encode m)
|
||||
MHeaders m -> (MCHeaders, encode m)
|
||||
MGetAddr -> (MCGetAddr, BS.empty)
|
||||
MFilterLoad m -> (MCFilterLoad, encode m)
|
||||
MFilterAdd m -> (MCFilterAdd, encode m)
|
||||
MFilterClear -> (MCFilterClear, BS.empty)
|
||||
MPing m -> (MCPing, encode m)
|
||||
MPong m -> (MCPong, encode m)
|
||||
MAlert m -> (MCAlert, encode m)
|
||||
MMempool -> (MCMempool, BS.empty)
|
||||
MReject m -> (MCReject, encode m)
|
||||
MSendHeaders -> (MCSendHeaders, BS.empty)
|
||||
chk = checkSum32 payload
|
||||
len = fromIntegral $ BS.length payload
|
||||
header = MessageHeader networkMagic cmd len chk
|
||||
put header
|
||||
putByteString payload
|
||||
getMessage :: Network -> Get Message
|
||||
getMessage net = do
|
||||
(MessageHeader mgc cmd len chk) <- get
|
||||
bs <- lookAhead $ getByteString $ fromIntegral len
|
||||
unless
|
||||
(mgc == getNetworkMagic net)
|
||||
(fail $ "get: Invalid network magic bytes: " ++ show mgc)
|
||||
unless
|
||||
(checkSum32 bs == chk)
|
||||
(fail $ "get: Invalid message checksum: " ++ show chk)
|
||||
if len > 0
|
||||
then isolate (fromIntegral len) $
|
||||
case cmd of
|
||||
MCVersion -> MVersion <$> get
|
||||
MCAddr -> MAddr <$> get
|
||||
MCInv -> MInv <$> get
|
||||
MCGetData -> MGetData <$> get
|
||||
MCNotFound -> MNotFound <$> get
|
||||
MCGetBlocks -> MGetBlocks <$> get
|
||||
MCGetHeaders -> MGetHeaders <$> get
|
||||
MCTx -> MTx <$> get
|
||||
MCBlock -> MBlock <$> get
|
||||
MCMerkleBlock -> MMerkleBlock <$> get
|
||||
MCHeaders -> MHeaders <$> get
|
||||
MCFilterLoad -> MFilterLoad <$> get
|
||||
MCFilterAdd -> MFilterAdd <$> get
|
||||
MCPing -> MPing <$> get
|
||||
MCPong -> MPong <$> get
|
||||
MCAlert -> MAlert <$> get
|
||||
MCReject -> MReject <$> get
|
||||
_ -> fail $ "get: Invalid command " ++ show cmd
|
||||
else case cmd of
|
||||
MCGetAddr -> return MGetAddr
|
||||
MCVerAck -> return MVerAck
|
||||
MCFilterClear -> return MFilterClear
|
||||
MCMempool -> return MMempool
|
||||
MCSendHeaders -> return MSendHeaders
|
||||
_ -> fail $ "get: Invalid command " ++ show cmd
|
||||
|
||||
putMessage :: Network -> Putter Message
|
||||
putMessage net msg = do
|
||||
let (cmd, payload) =
|
||||
case msg of
|
||||
MVersion m -> (MCVersion, encode m)
|
||||
MVerAck -> (MCVerAck, BS.empty)
|
||||
MAddr m -> (MCAddr, encode m)
|
||||
MInv m -> (MCInv, encode m)
|
||||
MGetData m -> (MCGetData, encode m)
|
||||
MNotFound m -> (MCNotFound, encode m)
|
||||
MGetBlocks m -> (MCGetBlocks, encode m)
|
||||
MGetHeaders m -> (MCGetHeaders, encode m)
|
||||
MTx m -> (MCTx, encode m)
|
||||
MBlock m -> (MCBlock, encode m)
|
||||
MMerkleBlock m -> (MCMerkleBlock, encode m)
|
||||
MHeaders m -> (MCHeaders, encode m)
|
||||
MGetAddr -> (MCGetAddr, BS.empty)
|
||||
MFilterLoad m -> (MCFilterLoad, encode m)
|
||||
MFilterAdd m -> (MCFilterAdd, encode m)
|
||||
MFilterClear -> (MCFilterClear, BS.empty)
|
||||
MPing m -> (MCPing, encode m)
|
||||
MPong m -> (MCPong, encode m)
|
||||
MAlert m -> (MCAlert, encode m)
|
||||
MMempool -> (MCMempool, BS.empty)
|
||||
MReject m -> (MCReject, encode m)
|
||||
MSendHeaders -> (MCSendHeaders, BS.empty)
|
||||
chk = checkSum32 payload
|
||||
len = fromIntegral $ BS.length payload
|
||||
header = MessageHeader (getNetworkMagic net) cmd len chk
|
||||
put header
|
||||
putByteString payload
|
||||
|
@ -46,6 +46,7 @@ import Data.Maybe (isJust, mapMaybe)
|
||||
import Data.Serialize (decode, encode)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word32, Word64, Word8)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Script.SigHash
|
||||
import Network.Haskoin.Script.Types
|
||||
@ -786,23 +787,24 @@ runStack = stack
|
||||
|
||||
-- | A wrapper around 'verifySig' which handles grabbing the hash type
|
||||
verifySigWithType ::
|
||||
Tx -> Int -> Word64 -> [ScriptOp] -> TxSignature -> PubKey -> Bool
|
||||
verifySigWithType tx i val outOps txSig pubKey =
|
||||
Network -> Tx -> Int -> Word64 -> [ScriptOp] -> TxSignature -> PubKey -> Bool
|
||||
verifySigWithType net tx i val outOps txSig pubKey =
|
||||
let outScript = Script outOps
|
||||
h = txSigHash tx outScript val i (txSignatureSigHash txSig)
|
||||
h = txSigHash net tx outScript val i (txSignatureSigHash txSig)
|
||||
in verifySig h (txSignature txSig) pubKey
|
||||
|
||||
-- | Uses `evalScript` to check that the input script of a spending
|
||||
-- transaction satisfies the output script.
|
||||
verifySpend :: Tx -- ^ The spending transaction
|
||||
verifySpend :: Network
|
||||
-> Tx -- ^ The spending transaction
|
||||
-> Int -- ^ The input index
|
||||
-> Script -- ^ The output script we are spending
|
||||
-> Word64 -- ^ The value of the output script
|
||||
-> [Flag] -- ^ Evaluation flags
|
||||
-> Bool
|
||||
verifySpend tx i outscript val flags =
|
||||
verifySpend net tx i outscript val flags =
|
||||
let scriptSig = either err id . decode . scriptInput $ txIn tx !! i
|
||||
verifyFcn = verifySigWithType tx i val
|
||||
verifyFcn = verifySigWithType net tx i val
|
||||
err e = error $ "Could not decode scriptInput in verifySpend: " ++ e
|
||||
in evalScript scriptSig outscript verifyFcn flags
|
||||
|
||||
|
@ -110,22 +110,24 @@ isSigHashUnknown =
|
||||
sigHashAddForkId :: SigHash -> Word32 -> SigHash
|
||||
sigHashAddForkId sh w = (fromIntegral w `shiftL` 8) .|. (sh .&. 0x000000ff)
|
||||
|
||||
sigHashAddNetworkId :: SigHash -> SigHash
|
||||
sigHashAddNetworkId = (`sigHashAddForkId` fromMaybe 0 sigHashForkId)
|
||||
sigHashAddNetworkId :: Network -> SigHash -> SigHash
|
||||
sigHashAddNetworkId net =
|
||||
(`sigHashAddForkId` fromMaybe 0 (getSigHashForkId net))
|
||||
|
||||
sigHashGetForkId :: SigHash -> Word32
|
||||
sigHashGetForkId = fromIntegral . (`shiftR` 8)
|
||||
|
||||
-- | Computes the hash that will be used for signing a transaction.
|
||||
txSigHash :: Tx -- ^ Transaction to sign.
|
||||
txSigHash :: Network
|
||||
-> Tx -- ^ Transaction to sign.
|
||||
-> Script -- ^ Output script that is being spent.
|
||||
-> Word64 -- ^ Value of the output being spent.
|
||||
-> Int -- ^ Index of the input that is being signed.
|
||||
-> SigHash -- ^ What parts of the transaction should be signed.
|
||||
-> Hash256 -- ^ Result hash to be signed.
|
||||
txSigHash tx out v i sh
|
||||
| hasForkIdFlag sh && isJust sigHashForkId =
|
||||
txSigHashForkId tx out v i sh
|
||||
txSigHash net tx out v i sh
|
||||
| hasForkIdFlag sh && isJust (getSigHashForkId net) =
|
||||
txSigHashForkId net tx out v i sh
|
||||
| otherwise = do
|
||||
let newIn = buildInputs (txIn tx) fout i sh
|
||||
-- When SigSingle and input index > outputs, then sign integer 1
|
||||
@ -170,13 +172,14 @@ buildOutputs txos i sh
|
||||
-- | Computes the hash that will be used for signing a transaction. This
|
||||
-- function is used when the sigHashForkId flag is set.
|
||||
txSigHashForkId
|
||||
:: Tx -- ^ Transaction to sign.
|
||||
:: Network
|
||||
-> Tx -- ^ Transaction to sign.
|
||||
-> Script -- ^ Output script that is being spent.
|
||||
-> Word64 -- ^ Value of the output being spent.
|
||||
-> Int -- ^ Index of the input that is being signed.
|
||||
-> SigHash -- ^ What parts of the transaction should be signed.
|
||||
-> Hash256 -- ^ Result hash to be signed.
|
||||
txSigHashForkId tx out v i sh =
|
||||
txSigHashForkId net tx out v i sh =
|
||||
doubleSHA256 . runPut $ do
|
||||
putWord32le $ txVersion tx
|
||||
put hashPrevouts
|
||||
@ -187,7 +190,7 @@ txSigHashForkId tx out v i sh =
|
||||
putWord32le $ txInSequence $ txIn tx !! i
|
||||
put hashOutputs
|
||||
putWord32le $ txLockTime tx
|
||||
putWord32le $ fromIntegral $ sigHashAddNetworkId sh
|
||||
putWord32le $ fromIntegral $ sigHashAddNetworkId net sh
|
||||
where
|
||||
hashPrevouts
|
||||
| not $ hasAnyoneCanPayFlag sh =
|
||||
@ -237,14 +240,14 @@ decodeTxLaxSig bs =
|
||||
TxSignature <$> decode (BS.init bs)
|
||||
<*> return (fromIntegral $ BS.last bs)
|
||||
|
||||
decodeTxStrictSig :: ByteString -> Either String TxSignature
|
||||
decodeTxStrictSig bs =
|
||||
decodeTxStrictSig :: Network -> ByteString -> Either String TxSignature
|
||||
decodeTxStrictSig net bs =
|
||||
case decodeStrictSig $ BS.init bs of
|
||||
Just sig -> do
|
||||
let sh = fromIntegral $ BS.last bs
|
||||
when (isSigHashUnknown sh) $
|
||||
Left "Non-canonical signature: unknown hashtype byte"
|
||||
when (isNothing sigHashForkId && hasForkIdFlag sh) $
|
||||
when (isNothing (getSigHashForkId net) && hasForkIdFlag sh) $
|
||||
Left "Non-canonical signature: invalid network for forkId"
|
||||
return $ TxSignature sig sh
|
||||
Nothing -> Left "Non-canonical signature: could not parse signature"
|
||||
|
@ -48,6 +48,7 @@ import Data.Function (on)
|
||||
import Data.List (sortBy)
|
||||
import Data.Serialize (decode, encode)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto.Address
|
||||
import Network.Haskoin.Crypto.Hash
|
||||
import Network.Haskoin.Crypto.Keys
|
||||
@ -129,13 +130,13 @@ isDataCarrier _ = False
|
||||
|
||||
-- | Computes a script address from a script output. This address can be used
|
||||
-- in a pay to script hash output.
|
||||
p2shAddr :: ScriptOutput -> Address
|
||||
p2shAddr = ScriptAddress . addressHash . encodeOutputBS
|
||||
p2shAddr :: Network -> ScriptOutput -> Address
|
||||
p2shAddr net out = ScriptAddress (addressHash (encodeOutputBS out)) net
|
||||
|
||||
-- | Computes a script address from a script output for a
|
||||
-- pay-to-witness-script-hash output.
|
||||
p2wshAddr :: ScriptOutput -> Address
|
||||
p2wshAddr = WitnessScriptAddress . sha256 . encodeOutputBS
|
||||
p2wshAddr :: Network -> ScriptOutput -> Address
|
||||
p2wshAddr net out = WitnessScriptAddress (sha256 (encodeOutputBS out)) net
|
||||
|
||||
-- | Sorts the public keys of a multisignature output in ascending order by
|
||||
-- comparing their serialized representations. This feature allows for easier
|
||||
@ -148,10 +149,10 @@ sortMulSig out = case out of
|
||||
_ -> error "Can only call orderMulSig on PayMulSig scripts"
|
||||
|
||||
addressToOutput :: Address -> ScriptOutput
|
||||
addressToOutput (PubKeyAddress h) = PayPKHash h
|
||||
addressToOutput (ScriptAddress h) = PayScriptHash h
|
||||
addressToOutput (WitnessPubKeyAddress h) = PayWitnessPKHash h
|
||||
addressToOutput (WitnessScriptAddress h) = PayWitnessScriptHash h
|
||||
addressToOutput (PubKeyAddress h _) = PayPKHash h
|
||||
addressToOutput (ScriptAddress h _) = PayScriptHash h
|
||||
addressToOutput (WitnessPubKeyAddress h _) = PayWitnessPKHash h
|
||||
addressToOutput (WitnessScriptAddress h _) = PayWitnessScriptHash h
|
||||
|
||||
-- | Get output script AST for an address.
|
||||
addressToScript :: Address -> Script
|
||||
@ -162,11 +163,11 @@ addressToScriptBS :: Address -> ByteString
|
||||
addressToScriptBS = encode . addressToScript
|
||||
|
||||
-- | Encode an output script as an address if it has such representation.
|
||||
scriptToAddress :: Script -> Maybe Address
|
||||
scriptToAddress = eitherToMaybe . (outputAddress <=< decodeOutput)
|
||||
scriptToAddress :: Network -> Script -> Maybe Address
|
||||
scriptToAddress net = eitherToMaybe . (outputAddress net <=< decodeOutput)
|
||||
|
||||
scriptToAddressBS :: ByteString -> Maybe Address
|
||||
scriptToAddressBS = eitherToMaybe . (outputAddress <=< decodeOutputBS)
|
||||
scriptToAddressBS :: Network -> ByteString -> Maybe Address
|
||||
scriptToAddressBS net = eitherToMaybe . (outputAddress net <=< decodeOutputBS)
|
||||
|
||||
-- | Computes a 'Script' from a 'ScriptOutput'. The 'Script' is a list of
|
||||
-- 'ScriptOp' can can be used to build a 'Tx'.
|
||||
@ -258,20 +259,20 @@ scriptOpToInt s
|
||||
res = fromIntegral (BS.head $ encode s) - 0x50
|
||||
|
||||
-- | Get the address of a `ScriptOutput`
|
||||
outputAddress :: ScriptOutput -> Either String Address
|
||||
outputAddress s = case s of
|
||||
PayPKHash h -> return $ PubKeyAddress h
|
||||
PayScriptHash h -> return $ ScriptAddress h
|
||||
PayPK k -> return $ pubKeyAddr k
|
||||
PayWitnessPKHash h -> return $ WitnessPubKeyAddress h
|
||||
PayWitnessScriptHash h -> return $ WitnessScriptAddress h
|
||||
outputAddress :: Network -> ScriptOutput -> Either String Address
|
||||
outputAddress net s = case s of
|
||||
PayPKHash h -> return $ PubKeyAddress h net
|
||||
PayScriptHash h -> return $ ScriptAddress h net
|
||||
PayPK k -> return $ pubKeyAddr net k
|
||||
PayWitnessPKHash h -> return $ WitnessPubKeyAddress h net
|
||||
PayWitnessScriptHash h -> return $ WitnessScriptAddress h net
|
||||
_ -> Left "outputAddress: bad output script type"
|
||||
|
||||
-- | Get the address of a `ScriptInput`
|
||||
inputAddress :: ScriptInput -> Either String Address
|
||||
inputAddress s = case s of
|
||||
RegularInput (SpendPKHash _ key) -> return $ pubKeyAddr key
|
||||
ScriptHashInput _ rdm -> return $ p2shAddr rdm
|
||||
inputAddress :: Network -> ScriptInput -> Either String Address
|
||||
inputAddress net s = case s of
|
||||
RegularInput (SpendPKHash _ key) -> return $ pubKeyAddr net key
|
||||
ScriptHashInput _ rdm -> return $ p2shAddr net rdm
|
||||
_ -> Left "inputAddress: bad input script type"
|
||||
|
||||
-- | Data type describing standard transaction input scripts. Input scripts
|
||||
@ -338,12 +339,12 @@ encodeSimpleInput s =
|
||||
f TxSignatureEmpty = OP_0
|
||||
f ts = opPushData $ encodeTxSig ts
|
||||
|
||||
decodeSimpleInput :: Bool -> Script -> Either String SimpleInput
|
||||
decodeSimpleInput strict (Script ops) =
|
||||
decodeSimpleInput :: Network -> Bool -> Script -> Either String SimpleInput
|
||||
decodeSimpleInput net strict (Script ops) =
|
||||
maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops
|
||||
where
|
||||
matchPK [op] = SpendPK <$> f op
|
||||
matchPK _ = Nothing
|
||||
matchPK _ = Nothing
|
||||
matchPKHash [op, OP_PUSHDATA pub _] =
|
||||
SpendPKHash <$> f op <*> eitherToMaybe (decode pub)
|
||||
matchPKHash _ = Nothing
|
||||
@ -357,7 +358,7 @@ decodeSimpleInput strict (Script ops) =
|
||||
f OP_0 = return TxSignatureEmpty
|
||||
f (OP_PUSHDATA "" OPCODE) = f OP_0
|
||||
f (OP_PUSHDATA bs _)
|
||||
| strict = eitherToMaybe $ decodeTxStrictSig bs
|
||||
| strict = eitherToMaybe $ decodeTxStrictSig net bs
|
||||
| otherwise = eitherToMaybe $ decodeTxLaxSig bs
|
||||
f _ = Nothing
|
||||
errMsg = "decodeInput: Could not decode script input"
|
||||
@ -374,31 +375,33 @@ encodeInputBS = encode . encodeInput
|
||||
|
||||
-- | Decodes a 'ScriptInput' from a 'Script'. This function fails if the
|
||||
-- script can not be parsed as a standard script input.
|
||||
decodeInput :: Script -> Either String ScriptInput
|
||||
decodeInput = decodeInputGen False
|
||||
decodeInput :: Network -> Script -> Either String ScriptInput
|
||||
decodeInput net = decodeInputGen net False
|
||||
|
||||
-- | Like 'decodeInput' but uses strict signature decoding
|
||||
decodeInputStrict :: Script -> Either String ScriptInput
|
||||
decodeInputStrict = decodeInputGen True
|
||||
decodeInputStrict :: Network -> Script -> Either String ScriptInput
|
||||
decodeInputStrict net = decodeInputGen net True
|
||||
|
||||
decodeInputGen :: Bool -> Script -> Either String ScriptInput
|
||||
decodeInputGen strict s@(Script ops) = maybeToEither errMsg $
|
||||
matchSimpleInput <|> matchPayScriptHash
|
||||
decodeInputGen :: Network -> Bool -> Script -> Either String ScriptInput
|
||||
decodeInputGen net strict s@(Script ops) =
|
||||
maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash
|
||||
where
|
||||
matchSimpleInput = RegularInput <$> eitherToMaybe (decodeSimpleInput strict s)
|
||||
matchPayScriptHash = case splitAt (length (scriptOps s) - 1) ops of
|
||||
(is, [OP_PUSHDATA bs _]) -> do
|
||||
rdm <- eitherToMaybe $ decodeOutputBS bs
|
||||
inp <- eitherToMaybe $ decodeSimpleInput strict $ Script is
|
||||
return $ ScriptHashInput inp rdm
|
||||
_ -> Nothing
|
||||
matchSimpleInput =
|
||||
RegularInput <$> eitherToMaybe (decodeSimpleInput net strict s)
|
||||
matchPayScriptHash =
|
||||
case splitAt (length (scriptOps s) - 1) ops of
|
||||
(is, [OP_PUSHDATA bs _]) -> do
|
||||
rdm <- eitherToMaybe $ decodeOutputBS bs
|
||||
inp <- eitherToMaybe $ decodeSimpleInput net strict $ Script is
|
||||
return $ ScriptHashInput inp rdm
|
||||
_ -> Nothing
|
||||
errMsg = "decodeInput: Could not decode script input"
|
||||
|
||||
-- | Like 'decodeInput' but decodes from a ByteString
|
||||
decodeInputBS :: ByteString -> Either String ScriptInput
|
||||
decodeInputBS = decodeInput <=< decode
|
||||
decodeInputBS :: Network -> ByteString -> Either String ScriptInput
|
||||
decodeInputBS net = decodeInput net <=< decode
|
||||
|
||||
-- | Like 'decodeInputStrict' but decodes from a ByteString
|
||||
decodeInputStrictBS :: ByteString -> Either String ScriptInput
|
||||
decodeInputStrictBS = decodeInputStrict <=< decode
|
||||
decodeInputStrictBS :: Network -> ByteString -> Either String ScriptInput
|
||||
decodeInputStrictBS net = decodeInputStrict net <=< decode
|
||||
|
||||
|
@ -5,16 +5,17 @@ module Network.Haskoin.Test.Block where
|
||||
|
||||
import Network.Haskoin.Block.Merkle
|
||||
import Network.Haskoin.Block.Types
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Test.Crypto
|
||||
import Network.Haskoin.Test.Network
|
||||
import Network.Haskoin.Test.Transaction
|
||||
import Test.QuickCheck
|
||||
|
||||
arbitraryBlock :: Gen Block
|
||||
arbitraryBlock = do
|
||||
arbitraryBlock :: Network -> Gen Block
|
||||
arbitraryBlock net = do
|
||||
h <- arbitraryBlockHeader
|
||||
c <- choose (0,10)
|
||||
txs <- vectorOf c arbitraryTx
|
||||
txs <- vectorOf c (arbitraryTx net)
|
||||
return $ Block h txs
|
||||
|
||||
arbitraryBlockHeader :: Gen BlockHeader
|
||||
|
@ -9,6 +9,7 @@ import Data.Either (fromRight)
|
||||
import Data.List (foldl')
|
||||
import Data.Serialize (decode)
|
||||
import Data.Word (Word32)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto.Address
|
||||
import Network.Haskoin.Crypto.ECDSA
|
||||
import Network.Haskoin.Crypto.ExtendedKeys
|
||||
@ -66,18 +67,17 @@ arbitraryPubKeyU :: Gen (PrvKeyU, PubKeyU)
|
||||
arbitraryPubKeyU = (\k -> (k, derivePubKey k)) <$> arbitraryPrvKeyU
|
||||
|
||||
-- | Arbitrary non-witness address (can be a pubkey or script hash address)
|
||||
arbitraryAddress :: Gen Address
|
||||
arbitraryAddress = oneof [ arbitraryPubKeyAddress
|
||||
, arbitraryScriptAddress
|
||||
]
|
||||
arbitraryAddress :: Network -> Gen Address
|
||||
arbitraryAddress net =
|
||||
oneof [arbitraryPubKeyAddress net, arbitraryScriptAddress net]
|
||||
|
||||
-- | Arbitrary public key hash address
|
||||
arbitraryPubKeyAddress :: Gen Address
|
||||
arbitraryPubKeyAddress = PubKeyAddress <$> arbitraryHash160
|
||||
arbitraryPubKeyAddress :: Network -> Gen Address
|
||||
arbitraryPubKeyAddress net = PubKeyAddress <$> arbitraryHash160 <*> pure net
|
||||
|
||||
-- | Arbitrary script hash address
|
||||
arbitraryScriptAddress :: Gen Address
|
||||
arbitraryScriptAddress = ScriptAddress <$> arbitraryHash160
|
||||
arbitraryScriptAddress :: Network -> Gen Address
|
||||
arbitraryScriptAddress net = ScriptAddress <$> arbitraryHash160 <*> pure net
|
||||
|
||||
-- | Arbitrary message hash, private key, nonce and corresponding signature.
|
||||
-- The signature is generated with a random message, random private key and a
|
||||
@ -90,16 +90,15 @@ arbitrarySignature = do
|
||||
return (msg, key, sig)
|
||||
|
||||
-- | Arbitrary extended private key.
|
||||
arbitraryXPrvKey :: Gen XPrvKey
|
||||
arbitraryXPrvKey = XPrvKey <$> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitraryHash256
|
||||
<*> arbitraryPrvKeyC
|
||||
arbitraryXPrvKey :: Network -> Gen XPrvKey
|
||||
arbitraryXPrvKey net =
|
||||
XPrvKey <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryHash256 <*>
|
||||
arbitraryPrvKeyC <*>
|
||||
pure net
|
||||
|
||||
-- | Arbitrary extended public key with its corresponding private key.
|
||||
arbitraryXPubKey :: Gen (XPrvKey, XPubKey)
|
||||
arbitraryXPubKey = (\k -> (k, deriveXPubKey k)) <$> arbitraryXPrvKey
|
||||
arbitraryXPubKey :: Network -> Gen (XPrvKey, XPubKey)
|
||||
arbitraryXPubKey net = (\k -> (k, deriveXPubKey k)) <$> arbitraryXPrvKey net
|
||||
|
||||
{- Custom derivations -}
|
||||
|
||||
|
@ -3,6 +3,7 @@
|
||||
-}
|
||||
module Network.Haskoin.Test.Message where
|
||||
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Network.Message
|
||||
import Network.Haskoin.Test.Block
|
||||
import Network.Haskoin.Test.Crypto
|
||||
@ -19,8 +20,8 @@ arbitraryMessageHeader =
|
||||
<*> arbitraryCheckSum32
|
||||
|
||||
-- | Arbitrary Message
|
||||
arbitraryMessage :: Gen Message
|
||||
arbitraryMessage =
|
||||
arbitraryMessage :: Network -> Gen Message
|
||||
arbitraryMessage net =
|
||||
oneof
|
||||
[ MVersion <$> arbitraryVersion
|
||||
, return MVerAck
|
||||
@ -30,8 +31,8 @@ arbitraryMessage =
|
||||
, MNotFound <$> arbitraryNotFound
|
||||
, MGetBlocks <$> arbitraryGetBlocks
|
||||
, MGetHeaders <$> arbitraryGetHeaders
|
||||
, MTx <$> arbitraryTx
|
||||
, MBlock <$> arbitraryBlock
|
||||
, MTx <$> arbitraryTx net
|
||||
, MBlock <$> arbitraryBlock net
|
||||
, MMerkleBlock <$> arbitraryMerkleBlock
|
||||
, MHeaders <$> arbitraryHeaders
|
||||
, return MGetAddr
|
||||
|
@ -4,6 +4,7 @@
|
||||
module Network.Haskoin.Test.Script where
|
||||
|
||||
import Data.Word
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Script
|
||||
import Network.Haskoin.Test.Crypto
|
||||
@ -194,13 +195,13 @@ arbitraryMSParam = do
|
||||
return (m, n)
|
||||
|
||||
-- | Arbitrary ScriptOutput (Can by any valid type)
|
||||
arbitraryScriptOutput :: Gen ScriptOutput
|
||||
arbitraryScriptOutput =
|
||||
arbitraryScriptOutput :: Network -> Gen ScriptOutput
|
||||
arbitraryScriptOutput net =
|
||||
oneof
|
||||
[ arbitraryPKOutput
|
||||
, arbitraryPKHashOutput
|
||||
, arbitraryMSOutput
|
||||
, arbitrarySHOutput
|
||||
, arbitrarySHOutput net
|
||||
, arbitraryDCOutput
|
||||
]
|
||||
|
||||
@ -237,8 +238,9 @@ arbitraryMSCOutput = do
|
||||
return $ PayMulSig keys m
|
||||
|
||||
-- | Arbitrary ScriptOutput of type PayScriptHash
|
||||
arbitrarySHOutput :: Gen ScriptOutput
|
||||
arbitrarySHOutput = PayScriptHash . getAddrHash <$> arbitraryScriptAddress
|
||||
arbitrarySHOutput :: Network -> Gen ScriptOutput
|
||||
arbitrarySHOutput net =
|
||||
PayScriptHash . getAddrHash <$> arbitraryScriptAddress net
|
||||
|
||||
-- | Arbitrary ScriptOutput of type DataCarrier
|
||||
arbitraryDCOutput :: Gen ScriptOutput
|
||||
|
@ -26,18 +26,18 @@ arbitraryTxHash :: Gen TxHash
|
||||
arbitraryTxHash = TxHash <$> arbitraryHash256
|
||||
|
||||
-- | Arbitrary amount of Satoshi as Word64 (Between 1 and 21e14)
|
||||
arbitrarySatoshi :: Gen TestCoin
|
||||
arbitrarySatoshi = TestCoin <$> choose (1, maxSatoshi)
|
||||
arbitrarySatoshi :: Network -> Gen TestCoin
|
||||
arbitrarySatoshi net = TestCoin <$> choose (1, getMaxSatoshi net)
|
||||
|
||||
-- | Arbitrary OutPoint
|
||||
arbitraryOutPoint :: Gen OutPoint
|
||||
arbitraryOutPoint = OutPoint <$> arbitraryTxHash <*> arbitrary
|
||||
|
||||
-- | Arbitrary TxOut
|
||||
arbitraryTxOut :: Gen TxOut
|
||||
arbitraryTxOut =
|
||||
TxOut <$> (getTestCoin <$> arbitrarySatoshi)
|
||||
<*> (encodeOutputBS <$> arbitraryScriptOutput)
|
||||
arbitraryTxOut :: Network -> Gen TxOut
|
||||
arbitraryTxOut net =
|
||||
TxOut <$> (getTestCoin <$> arbitrarySatoshi net)
|
||||
<*> (encodeOutputBS <$> arbitraryScriptOutput net)
|
||||
|
||||
-- | Arbitrary TxIn
|
||||
arbitraryTxIn :: Gen TxIn
|
||||
@ -46,29 +46,29 @@ arbitraryTxIn =
|
||||
<*> (encodeInputBS <$> arbitraryScriptInput)
|
||||
<*> arbitrary
|
||||
|
||||
arbitraryTx :: Gen Tx
|
||||
arbitraryTx = oneof [arbitraryLegacyTx, arbitraryWitnessTx]
|
||||
arbitraryTx :: Network -> Gen Tx
|
||||
arbitraryTx net = oneof [arbitraryLegacyTx net, arbitraryWitnessTx net]
|
||||
|
||||
-- | Arbitrary Legacy Tx
|
||||
arbitraryLegacyTx :: Gen Tx
|
||||
arbitraryLegacyTx = do
|
||||
arbitraryLegacyTx :: Network -> Gen Tx
|
||||
arbitraryLegacyTx net = do
|
||||
v <- arbitrary
|
||||
ni <- choose (0,5)
|
||||
no <- choose (if ni == 0 then 2 else 0, 5) -- avoid witness case
|
||||
inps <- vectorOf ni arbitraryTxIn
|
||||
outs <- vectorOf no arbitraryTxOut
|
||||
outs <- vectorOf no (arbitraryTxOut net)
|
||||
let uniqueInps = nubBy (\a b -> prevOutput a == prevOutput b) inps
|
||||
t <- arbitrary
|
||||
return $ Tx v uniqueInps outs [] t
|
||||
|
||||
-- | Arbitrary Legacy Tx (Witness data is bogus)
|
||||
arbitraryWitnessTx :: Gen Tx
|
||||
arbitraryWitnessTx = do
|
||||
arbitraryWitnessTx :: Network -> Gen Tx
|
||||
arbitraryWitnessTx net = do
|
||||
v <- arbitrary
|
||||
ni <- choose (0,5)
|
||||
no <- choose (0,5)
|
||||
inps <- vectorOf ni arbitraryTxIn
|
||||
outs <- vectorOf no arbitraryTxOut
|
||||
outs <- vectorOf no (arbitraryTxOut net)
|
||||
let uniqueInps = nubBy (\a b -> prevOutput a == prevOutput b) inps
|
||||
t <- arbitrary
|
||||
w <- vectorOf (length uniqueInps) (listOf arbitraryBS)
|
||||
@ -77,24 +77,24 @@ arbitraryWitnessTx = do
|
||||
-- | Arbitrary Tx containing only inputs of type SpendPKHash, SpendScriptHash
|
||||
-- (multisig) and outputs of type PayPKHash and PaySH. Only compressed
|
||||
-- public keys are used.
|
||||
arbitraryAddrOnlyTx :: Gen Tx
|
||||
arbitraryAddrOnlyTx = do
|
||||
arbitraryAddrOnlyTx :: Network -> Gen Tx
|
||||
arbitraryAddrOnlyTx net = do
|
||||
v <- arbitrary
|
||||
ni <- choose (0,5)
|
||||
no <- choose (0,5)
|
||||
inps <- vectorOf ni arbitraryAddrOnlyTxIn
|
||||
outs <- vectorOf no arbitraryAddrOnlyTxOut
|
||||
outs <- vectorOf no (arbitraryAddrOnlyTxOut net)
|
||||
t <- arbitrary
|
||||
return $ Tx v inps outs [] t
|
||||
|
||||
-- | Like 'arbitraryAddrOnlyTx' without empty signatures in the inputs
|
||||
arbitraryAddrOnlyTxFull :: Gen Tx
|
||||
arbitraryAddrOnlyTxFull = do
|
||||
arbitraryAddrOnlyTxFull :: Network -> Gen Tx
|
||||
arbitraryAddrOnlyTxFull net = do
|
||||
v <- arbitrary
|
||||
ni <- choose (0,5)
|
||||
no <- choose (0,5)
|
||||
inps <- vectorOf ni arbitraryAddrOnlyTxInFull
|
||||
outs <- vectorOf no arbitraryAddrOnlyTxOut
|
||||
outs <- vectorOf no (arbitraryAddrOnlyTxOut net)
|
||||
t <- arbitrary
|
||||
return $ Tx v inps outs [] t
|
||||
|
||||
@ -116,50 +116,50 @@ arbitraryAddrOnlyTxInFull = do
|
||||
return $ TxIn o (encodeInputBS inp) s
|
||||
|
||||
-- | Arbitrary TxOut that can only be of type PayPKHash or PaySH
|
||||
arbitraryAddrOnlyTxOut :: Gen TxOut
|
||||
arbitraryAddrOnlyTxOut = do
|
||||
v <- getTestCoin <$> arbitrarySatoshi
|
||||
out <- oneof [ arbitraryPKHashOutput, arbitrarySHOutput ]
|
||||
arbitraryAddrOnlyTxOut :: Network -> Gen TxOut
|
||||
arbitraryAddrOnlyTxOut net = do
|
||||
v <- getTestCoin <$> arbitrarySatoshi net
|
||||
out <- oneof [ arbitraryPKHashOutput, arbitrarySHOutput net ]
|
||||
return $ TxOut v $ encodeOutputBS out
|
||||
|
||||
-- | Arbitrary SigInput with the corresponding private keys used
|
||||
-- to generate the ScriptOutput or RedeemScript
|
||||
arbitrarySigInput :: Gen (SigInput, [PrvKey])
|
||||
arbitrarySigInput =
|
||||
arbitrarySigInput :: Network -> Gen (SigInput, [PrvKey])
|
||||
arbitrarySigInput net =
|
||||
oneof
|
||||
[ arbitraryPKSigInput >>= \(si, k) -> return (si, [k])
|
||||
, arbitraryPKHashSigInput >>= \(si, k) -> return (si, [k])
|
||||
, arbitraryMSSigInput
|
||||
, arbitrarySHSigInput
|
||||
[ arbitraryPKSigInput net >>= \(si, k) -> return (si, [k])
|
||||
, arbitraryPKHashSigInput net >>= \(si, k) -> return (si, [k])
|
||||
, arbitraryMSSigInput net
|
||||
, arbitrarySHSigInput net
|
||||
]
|
||||
|
||||
-- | Arbitrary SigInput with a ScriptOutput of type PayPK
|
||||
arbitraryPKSigInput :: Gen (SigInput, PrvKey)
|
||||
arbitraryPKSigInput = do
|
||||
arbitraryPKSigInput :: Network -> Gen (SigInput, PrvKey)
|
||||
arbitraryPKSigInput net = do
|
||||
k <- arbitraryPrvKey
|
||||
let out = PayPK $ derivePubKey k
|
||||
val <- getTestCoin <$> arbitrarySatoshi
|
||||
val <- getTestCoin <$> arbitrarySatoshi net
|
||||
op <- arbitraryOutPoint
|
||||
sh <- arbitraryValidSigHash
|
||||
return (SigInput out val op sh Nothing, k)
|
||||
|
||||
-- | Arbitrary SigInput with a ScriptOutput of type PayPKHash
|
||||
arbitraryPKHashSigInput :: Gen (SigInput, PrvKey)
|
||||
arbitraryPKHashSigInput = do
|
||||
arbitraryPKHashSigInput :: Network -> Gen (SigInput, PrvKey)
|
||||
arbitraryPKHashSigInput net = do
|
||||
k <- arbitraryPrvKey
|
||||
let out = PayPKHash $ getAddrHash $ pubKeyAddr $ derivePubKey k
|
||||
val <- getTestCoin <$> arbitrarySatoshi
|
||||
let out = PayPKHash $ getAddrHash $ pubKeyAddr net $ derivePubKey k
|
||||
val <- getTestCoin <$> arbitrarySatoshi net
|
||||
op <- arbitraryOutPoint
|
||||
sh <- arbitraryValidSigHash
|
||||
return (SigInput out val op sh Nothing, k)
|
||||
|
||||
-- | Arbitrary SigInput with a ScriptOutput of type PayMulSig
|
||||
arbitraryMSSigInput :: Gen (SigInput, [PrvKey])
|
||||
arbitraryMSSigInput = do
|
||||
arbitraryMSSigInput :: Network -> Gen (SigInput, [PrvKey])
|
||||
arbitraryMSSigInput net = do
|
||||
(m,n) <- arbitraryMSParam
|
||||
ks <- vectorOf n arbitraryPrvKey
|
||||
let out = PayMulSig (map derivePubKey ks) m
|
||||
val <- getTestCoin <$> arbitrarySatoshi
|
||||
val <- getTestCoin <$> arbitrarySatoshi net
|
||||
op <- arbitraryOutPoint
|
||||
sh <- arbitraryValidSigHash
|
||||
perm <- choose (0,n-1)
|
||||
@ -167,51 +167,51 @@ arbitraryMSSigInput = do
|
||||
return (SigInput out val op sh Nothing, ksPerm)
|
||||
|
||||
-- | Arbitrary SigInput with ScriptOutput of type PaySH and a RedeemScript
|
||||
arbitrarySHSigInput :: Gen (SigInput, [PrvKey])
|
||||
arbitrarySHSigInput = do
|
||||
arbitrarySHSigInput :: Network -> Gen (SigInput, [PrvKey])
|
||||
arbitrarySHSigInput net = do
|
||||
(SigInput rdm val op sh _, ks) <- oneof
|
||||
[ f <$> arbitraryPKSigInput
|
||||
, f <$> arbitraryPKHashSigInput
|
||||
, arbitraryMSSigInput
|
||||
[ f <$> arbitraryPKSigInput net
|
||||
, f <$> arbitraryPKHashSigInput net
|
||||
, arbitraryMSSigInput net
|
||||
]
|
||||
let out = PayScriptHash $ getAddrHash $ p2shAddr rdm
|
||||
let out = PayScriptHash $ getAddrHash $ p2shAddr net rdm
|
||||
return (SigInput out val op sh $ Just rdm, ks)
|
||||
where
|
||||
f (si, k) = (si, [k])
|
||||
|
||||
-- | Arbitrary Tx (empty TxIn), SigInputs and PrvKeys that can be passed to
|
||||
-- signTx or detSignTx to fully sign the Tx.
|
||||
arbitrarySigningData :: Gen (Tx, [SigInput], [PrvKey])
|
||||
arbitrarySigningData = do
|
||||
arbitrarySigningData :: Network -> Gen (Tx, [SigInput], [PrvKey])
|
||||
arbitrarySigningData net = do
|
||||
v <- arbitrary
|
||||
ni <- choose (1,5)
|
||||
no <- choose (1,5)
|
||||
sigis <- vectorOf ni arbitrarySigInput
|
||||
sigis <- vectorOf ni (arbitrarySigInput net)
|
||||
let uSigis = nubBy (\(a,_) (b,_) -> sigInputOP a == sigInputOP b) sigis
|
||||
inps <- forM uSigis $ \(s,_) -> do
|
||||
sq <- arbitrary
|
||||
return $ TxIn (sigInputOP s) BS.empty sq
|
||||
outs <- vectorOf no arbitraryTxOut
|
||||
outs <- vectorOf no (arbitraryTxOut net)
|
||||
l <- arbitrary
|
||||
perm <- choose (0, length inps - 1)
|
||||
let tx = Tx v (permutations inps !! perm) outs [] l
|
||||
keys = concatMap snd uSigis
|
||||
return (tx, map fst uSigis, keys)
|
||||
|
||||
arbitraryEmptyTx :: Gen Tx
|
||||
arbitraryEmptyTx = do
|
||||
arbitraryEmptyTx :: Network -> Gen Tx
|
||||
arbitraryEmptyTx net = do
|
||||
v <- arbitrary
|
||||
no <- choose (1,5)
|
||||
ni <- choose (1,5)
|
||||
outs <- vectorOf no arbitraryTxOut
|
||||
outs <- vectorOf no (arbitraryTxOut net)
|
||||
ops <- vectorOf ni arbitraryOutPoint
|
||||
t <- arbitrary
|
||||
s <- arbitrary
|
||||
return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t
|
||||
|
||||
arbitraryPartialTxs :: Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)])
|
||||
arbitraryPartialTxs = do
|
||||
tx <- arbitraryEmptyTx
|
||||
arbitraryPartialTxs :: Network -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)])
|
||||
arbitraryPartialTxs net = do
|
||||
tx <- arbitraryEmptyTx net
|
||||
res <-
|
||||
forM (map prevOutput $ txIn tx) $ \op -> do
|
||||
(so, val, rdmM, prvs, m, n) <- arbitraryData
|
||||
@ -223,10 +223,10 @@ arbitraryPartialTxs = do
|
||||
sh <- arbitraryValidSigHash
|
||||
let sigi = SigInput so val op sh rdmM
|
||||
return . fromRight (error "Colud not decode transaction") $
|
||||
signTx tx [sigi] [prv]
|
||||
signTx net tx [sigi] [prv]
|
||||
arbitraryData = do
|
||||
(m, n) <- arbitraryMSParam
|
||||
val <- getTestCoin <$> arbitrarySatoshi
|
||||
val <- getTestCoin <$> arbitrarySatoshi net
|
||||
nPrv <- choose (m, n)
|
||||
keys <- vectorOf n arbitraryPubKey
|
||||
perm <- choose (0, length keys - 1)
|
||||
@ -235,7 +235,7 @@ arbitraryPartialTxs = do
|
||||
let so = PayMulSig pubKeys m
|
||||
elements
|
||||
[ (so, val, Nothing, prvKeys, m, n)
|
||||
, ( PayScriptHash $ getAddrHash $ p2shAddr so
|
||||
, ( PayScriptHash $ getAddrHash $ p2shAddr net so
|
||||
, val
|
||||
, Just so
|
||||
, prvKeys
|
||||
|
@ -22,6 +22,7 @@ import Data.Maybe (catMaybes, fromJust,
|
||||
import Data.Serialize (encode)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word64)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Network.Types
|
||||
import Network.Haskoin.Script
|
||||
@ -199,11 +200,11 @@ guessMSSize (m, n)
|
||||
|
||||
-- | Build a transaction by providing a list of outpoints as inputs
|
||||
-- and a list of recipients addresses and amounts as outputs.
|
||||
buildAddrTx :: [OutPoint] -> [(ByteString, Word64)] -> Either String Tx
|
||||
buildAddrTx xs ys =
|
||||
buildAddrTx :: Network -> [OutPoint] -> [(ByteString, Word64)] -> Either String Tx
|
||||
buildAddrTx net xs ys =
|
||||
buildTx xs =<< mapM f ys
|
||||
where
|
||||
f (s, v) = case stringToAddr s of
|
||||
f (s, v) = case stringToAddr net s of
|
||||
Just a -> return (addressToOutput a, v)
|
||||
_ -> Left $ "buildAddrTx: Invalid address " ++ cs s
|
||||
|
||||
@ -256,29 +257,30 @@ instance FromJSON SigInput where
|
||||
-- | Sign a transaction by providing the 'SigInput' signing paramters and
|
||||
-- a list of private keys. The signature is computed deterministically as
|
||||
-- defined in RFC-6979.
|
||||
signTx :: Tx -- ^ Transaction to sign
|
||||
signTx :: Network
|
||||
-> Tx -- ^ Transaction to sign
|
||||
-> [SigInput] -- ^ SigInput signing parameters
|
||||
-> [PrvKey] -- ^ List of private keys to use for signing
|
||||
-> Either String Tx -- ^ Signed transaction
|
||||
signTx otx sigis allKeys
|
||||
signTx net otx sigis allKeys
|
||||
| null ti = Left "signTx: Transaction has no inputs"
|
||||
| otherwise = foldM go otx $ findSigInput sigis ti
|
||||
where
|
||||
ti = txIn otx
|
||||
go tx (sigi@(SigInput so _ _ _ rdmM), i) = do
|
||||
keys <- sigKeys so rdmM allKeys
|
||||
foldM (\t k -> signInput t i sigi k) tx keys
|
||||
keys <- sigKeys net so rdmM allKeys
|
||||
foldM (\t k -> signInput net t i sigi k) tx keys
|
||||
|
||||
-- | Sign a single input in a transaction deterministically (RFC-6979).
|
||||
signInput :: Tx -> Int -> SigInput -> PrvKey -> Either String Tx
|
||||
signInput tx i (SigInput so val _ sh rdmM) key = do
|
||||
signInput :: Network -> Tx -> Int -> SigInput -> PrvKey -> Either String Tx
|
||||
signInput net tx i (SigInput so val _ sh rdmM) key = do
|
||||
let sig = TxSignature (signMsg msg key) sh
|
||||
si <- buildInput tx i so val rdmM sig $ derivePubKey key
|
||||
si <- buildInput net tx i so val rdmM sig $ derivePubKey key
|
||||
let ins = updateIndex i (txIn tx) (f si)
|
||||
return $ Tx (txVersion tx) ins (txOut tx) [] (txLockTime tx)
|
||||
where
|
||||
f si x = x{ scriptInput = encodeInputBS si }
|
||||
msg = txSigHash tx (encodeOutput $ fromMaybe so rdmM) val i sh
|
||||
f si x = x {scriptInput = encodeInputBS si}
|
||||
msg = txSigHash net tx (encodeOutput $ fromMaybe so rdmM) val i sh
|
||||
|
||||
-- Order the SigInput with respect to the transaction inputs. This allow the
|
||||
-- users to provide the SigInput in any order. Users can also provide only a
|
||||
@ -293,26 +295,30 @@ findSigInput si ti =
|
||||
|
||||
-- Find from the list of private keys which one is required to sign the
|
||||
-- provided ScriptOutput.
|
||||
sigKeys :: ScriptOutput -> Maybe RedeemScript -> [PrvKey]
|
||||
-> Either String [PrvKey]
|
||||
sigKeys so rdmM keys =
|
||||
sigKeys ::
|
||||
Network
|
||||
-> ScriptOutput
|
||||
-> Maybe RedeemScript
|
||||
-> [PrvKey]
|
||||
-> Either String [PrvKey]
|
||||
sigKeys net so rdmM keys =
|
||||
case (so, rdmM) of
|
||||
(PayPK p, Nothing) ->
|
||||
return $ map fst $ maybeToList $ find ((== p) . snd) zipKeys
|
||||
return . map fst . maybeToList $ find ((== p) . snd) zipKeys
|
||||
(PayPKHash h, Nothing) ->
|
||||
return $
|
||||
map fst $
|
||||
maybeToList $ find ((== h) . getAddrHash . pubKeyAddr . snd) zipKeys
|
||||
return . map fst . maybeToList $
|
||||
find ((== h) . getAddrHash . pubKeyAddr net . snd) zipKeys
|
||||
(PayMulSig ps r, Nothing) ->
|
||||
return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys
|
||||
(PayScriptHash _, Just rdm) -> sigKeys rdm Nothing keys
|
||||
(PayScriptHash _, Just rdm) -> sigKeys net rdm Nothing keys
|
||||
_ -> Left "sigKeys: Could not decode output script"
|
||||
where
|
||||
zipKeys = zip keys (map derivePubKey keys)
|
||||
|
||||
-- Construct an input, given a signature and a public key
|
||||
buildInput ::
|
||||
Tx
|
||||
Network
|
||||
-> Tx
|
||||
-> Int
|
||||
-> ScriptOutput
|
||||
-> Word64
|
||||
@ -320,36 +326,38 @@ buildInput ::
|
||||
-> TxSignature
|
||||
-> PubKey
|
||||
-> Either String ScriptInput
|
||||
buildInput tx i so val rdmM sig pub = case (so, rdmM) of
|
||||
(PayPK _, Nothing) ->
|
||||
return $ RegularInput $ SpendPK sig
|
||||
(PayPKHash _, Nothing) ->
|
||||
return $ RegularInput $ SpendPKHash sig pub
|
||||
(PayMulSig msPubs r, Nothing) -> do
|
||||
let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f
|
||||
return $ RegularInput $ SpendMulSig mSigs
|
||||
(PayScriptHash _, Just rdm) -> do
|
||||
inp <- buildInput tx i rdm val Nothing sig pub
|
||||
return $ ScriptHashInput (getRegularInput inp) rdm
|
||||
_ -> Left "buildInput: Invalid output/redeem script combination"
|
||||
buildInput net tx i so val rdmM sig pub =
|
||||
case (so, rdmM) of
|
||||
(PayPK _, Nothing) -> return $ RegularInput $ SpendPK sig
|
||||
(PayPKHash _, Nothing) -> return $ RegularInput $ SpendPKHash sig pub
|
||||
(PayMulSig msPubs r, Nothing) -> do
|
||||
let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f
|
||||
return $ RegularInput $ SpendMulSig mSigs
|
||||
(PayScriptHash _, Just rdm) -> do
|
||||
inp <- buildInput net tx i rdm val Nothing sig pub
|
||||
return $ ScriptHashInput (getRegularInput inp) rdm
|
||||
_ -> Left "buildInput: Invalid output/redeem script combination"
|
||||
where
|
||||
scp = scriptInput $ txIn tx !! i
|
||||
allSigs = nub $ sig : case decodeInputBS scp of
|
||||
Right (ScriptHashInput (SpendMulSig xs) _) -> xs
|
||||
Right (RegularInput (SpendMulSig xs)) -> xs
|
||||
_ -> []
|
||||
scp = scriptInput $ txIn tx !! i
|
||||
allSigs =
|
||||
nub $
|
||||
sig :
|
||||
case decodeInputBS net scp of
|
||||
Right (ScriptHashInput (SpendMulSig xs) _) -> xs
|
||||
Right (RegularInput (SpendMulSig xs)) -> xs
|
||||
_ -> []
|
||||
out = encodeOutput so
|
||||
f (TxSignature x sh) p = verifySig (txSigHash tx out val i sh) x p
|
||||
f (TxSignature x sh) p = verifySig (txSigHash net tx out val i sh) x p
|
||||
f TxSignatureEmpty _ = False
|
||||
|
||||
{- Merge multisig transactions -}
|
||||
|
||||
mergeTxs :: [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx
|
||||
mergeTxs txs os
|
||||
mergeTxs :: Network -> [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx
|
||||
mergeTxs net txs os
|
||||
| null txs = error "Transaction list is empty"
|
||||
| length (nub emptyTxs) /= 1 = Left "Transactions do not match"
|
||||
| length txs == 1 = return $ head txs
|
||||
| otherwise = foldM (mergeTxInput txs) (head emptyTxs) outs
|
||||
| otherwise = foldM (mergeTxInput net txs) (head emptyTxs) outs
|
||||
where
|
||||
zipOp = zip (matchTemplate os (txIn $ head txs) f) [0..]
|
||||
outs = map (first $ (\(o,v,_) -> (o,v)) . fromJust) $ filter (isJust . fst) zipOp
|
||||
@ -359,8 +367,13 @@ mergeTxs txs os
|
||||
clearInput tx (_, i) =
|
||||
Tx (txVersion tx) (ins (txIn tx) i) (txOut tx) [] (txLockTime tx)
|
||||
|
||||
mergeTxInput :: [Tx] -> Tx -> ((ScriptOutput, Word64), Int) -> Either String Tx
|
||||
mergeTxInput txs tx ((so, val), i) = do
|
||||
mergeTxInput ::
|
||||
Network
|
||||
-> [Tx]
|
||||
-> Tx
|
||||
-> ((ScriptOutput, Word64), Int)
|
||||
-> Either String Tx
|
||||
mergeTxInput net txs tx ((so, val), i) = do
|
||||
-- Ignore transactions with empty inputs
|
||||
let ins = map (scriptInput . (!! i) . txIn) txs
|
||||
sigRes <- mapM extractSigs $ filter (not . BS.null) ins
|
||||
@ -381,57 +394,62 @@ mergeTxInput txs tx ((so, val), i) = do
|
||||
return $ ScriptHashInput (getRegularInput si) rdm
|
||||
_ -> Left "Invalid output script type"
|
||||
_ -> Left "Invalid output script type"
|
||||
extractSigs si = case decodeInputBS si of
|
||||
extractSigs si = case decodeInputBS net si of
|
||||
Right (RegularInput (SpendMulSig sigs)) -> Right (sigs, Nothing)
|
||||
Right (ScriptHashInput (SpendMulSig sigs) rdm) -> Right (sigs, Just rdm)
|
||||
_ -> Left "Invalid script input type"
|
||||
f out (TxSignature x sh) p =
|
||||
verifySig (txSigHash tx (encodeOutput out) val i sh) x p
|
||||
verifySig (txSigHash net tx (encodeOutput out) val i sh) x p
|
||||
f _ TxSignatureEmpty _ = False
|
||||
|
||||
{- Tx verification -}
|
||||
|
||||
-- | Verify if a transaction is valid and all of its inputs are standard.
|
||||
verifyStdTx :: Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
||||
verifyStdTx = verifyStdTxGen False
|
||||
verifyStdTx :: Network -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
||||
verifyStdTx net = verifyStdTxGen net False
|
||||
|
||||
-- | Like 'verifyStdTx' but using strict signature decoding
|
||||
verifyStdTxStrict :: Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
||||
verifyStdTxStrict = verifyStdTxGen True
|
||||
verifyStdTxStrict :: Network -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
||||
verifyStdTxStrict net = verifyStdTxGen net True
|
||||
|
||||
verifyStdTxGen :: Bool -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
||||
verifyStdTxGen strict tx xs =
|
||||
not (null (txIn tx)) && all go (zip (matchTemplate xs (txIn tx) f) [0..])
|
||||
verifyStdTxGen :: Network -> Bool -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
||||
verifyStdTxGen net strict tx xs =
|
||||
not (null (txIn tx)) && all go (zip (matchTemplate xs (txIn tx) f) [0 ..])
|
||||
where
|
||||
f (_,_,o) txin = o == prevOutput txin
|
||||
go (Just (so,val,_), i) = verifyStdInput strict tx i so val
|
||||
go _ = False
|
||||
f (_, _, o) txin = o == prevOutput txin
|
||||
go (Just (so, val, _), i) = verifyStdInput net strict tx i so val
|
||||
go _ = False
|
||||
|
||||
-- | Verify if a transaction input is valid and standard.
|
||||
verifyStdInput :: Bool -> Tx -> Int -> ScriptOutput -> Word64 -> Bool
|
||||
verifyStdInput strict tx i = go (scriptInput $ txIn tx !! i)
|
||||
verifyStdInput :: Network -> Bool -> Tx -> Int -> ScriptOutput -> Word64 -> Bool
|
||||
verifyStdInput net strict tx i = go (scriptInput $ txIn tx !! i)
|
||||
where
|
||||
dec = if strict then decodeInputStrictBS else decodeInputBS
|
||||
dec =
|
||||
if strict
|
||||
then decodeInputStrictBS net
|
||||
else decodeInputBS net
|
||||
go inp so val =
|
||||
case dec inp of
|
||||
Right (RegularInput (SpendPK (TxSignature sig sh))) ->
|
||||
case so of
|
||||
PayPK pub -> verifySig (txSigHash tx out val i sh) sig pub
|
||||
PayPK pub ->
|
||||
verifySig (txSigHash net tx out val i sh) sig pub
|
||||
_ -> False
|
||||
Right (RegularInput (SpendPKHash (TxSignature sig sh) pub)) ->
|
||||
case so of
|
||||
PayPKHash h ->
|
||||
pubKeyAddr pub == PubKeyAddress h &&
|
||||
verifySig (txSigHash tx out val i sh) sig pub
|
||||
pubKeyAddr net pub == PubKeyAddress h net &&
|
||||
verifySig (txSigHash net tx out val i sh) sig pub
|
||||
_ -> False
|
||||
Right (RegularInput (SpendMulSig sigs)) ->
|
||||
case so of
|
||||
PayMulSig pubs r -> countMulSig tx out val i pubs sigs == r
|
||||
PayMulSig pubs r ->
|
||||
countMulSig net tx out val i pubs sigs == r
|
||||
_ -> False
|
||||
Right (ScriptHashInput si rdm) ->
|
||||
case so of
|
||||
PayScriptHash h ->
|
||||
p2shAddr rdm == ScriptAddress h &&
|
||||
p2shAddr net rdm == ScriptAddress h net &&
|
||||
go (encodeInputBS $ RegularInput si) rdm val
|
||||
_ -> False
|
||||
_ -> False
|
||||
@ -439,12 +457,12 @@ verifyStdInput strict tx i = go (scriptInput $ txIn tx !! i)
|
||||
out = encodeOutput so
|
||||
|
||||
-- Count the number of valid signatures
|
||||
countMulSig :: Tx -> Script -> Word64 -> Int -> [PubKey] -> [TxSignature] -> Int
|
||||
countMulSig _ _ _ _ [] _ = 0
|
||||
countMulSig _ _ _ _ _ [] = 0
|
||||
countMulSig tx out val i (_:pubs) (TxSignatureEmpty:rest) =
|
||||
countMulSig tx out val i pubs rest
|
||||
countMulSig tx out val i (pub:pubs) sigs@(TxSignature sig sh:rest)
|
||||
| verifySig (txSigHash tx out val i sh) sig pub =
|
||||
1 + countMulSig tx out val i pubs rest
|
||||
| otherwise = countMulSig tx out val i pubs sigs
|
||||
countMulSig :: Network -> Tx -> Script -> Word64 -> Int -> [PubKey] -> [TxSignature] -> Int
|
||||
countMulSig _ _ _ _ _ [] _ = 0
|
||||
countMulSig _ _ _ _ _ _ [] = 0
|
||||
countMulSig net tx out val i (_:pubs) (TxSignatureEmpty:rest) =
|
||||
countMulSig net tx out val i pubs rest
|
||||
countMulSig net tx out val i (pub:pubs) sigs@(TxSignature sig sh:rest)
|
||||
| verifySig (txSigHash net tx out val i sh) sig pub =
|
||||
1 + countMulSig net tx out val i pubs rest
|
||||
| otherwise = countMulSig net tx out val i pubs sigs
|
||||
|
@ -251,7 +251,7 @@ data OutPoint = OutPoint
|
||||
-- | The position of the specific output in the transaction.
|
||||
-- The first output position is 0.
|
||||
, outPointIndex :: !Word32
|
||||
} deriving (Show, Eq, Ord)
|
||||
} deriving (Show, Read, Eq, Ord)
|
||||
|
||||
instance NFData OutPoint where
|
||||
rnf (OutPoint h i) = rnf h `seq` rnf i
|
||||
|
@ -1,6 +1,5 @@
|
||||
resolver: lts-12.5
|
||||
resolver: lts-12.7
|
||||
nix:
|
||||
enable: true
|
||||
packages:
|
||||
- autoconf
|
||||
- automake
|
||||
|
83
test/Network/Haskoin/Block/Spec.hs
Normal file
83
test/Network/Haskoin/Block/Spec.hs
Normal file
@ -0,0 +1,83 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Block.Spec
|
||||
( spec
|
||||
) where
|
||||
import Control.Monad.State.Strict
|
||||
import Network.Haskoin.Block
|
||||
import Network.Haskoin.Constants
|
||||
import Test.Hspec
|
||||
|
||||
myTime :: Timestamp
|
||||
myTime = 1499083075
|
||||
|
||||
withChain :: Network -> State HeaderMemory a -> a
|
||||
withChain net f = evalState f (initialChain net)
|
||||
|
||||
chain :: BlockHeaders m => Network -> BlockHeader -> Int -> m ()
|
||||
chain net bh i = do
|
||||
bnsE <- connectBlocks net myTime bhs
|
||||
either error (const $ return ()) bnsE
|
||||
where
|
||||
bhs = appendBlocks net 6 bh i
|
||||
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "blockchain headers" $ do
|
||||
it "gets best block" $
|
||||
let bb =
|
||||
withChain net $ do
|
||||
chain net (getGenesisHeader net) 100
|
||||
getBestBlockHeader
|
||||
in nodeHeight bb `shouldBe` 100
|
||||
it "builds a block locator" $
|
||||
let net = bchRegTest
|
||||
loc =
|
||||
withChain net $ do
|
||||
chain net (getGenesisHeader net) 100
|
||||
bb <- getBestBlockHeader
|
||||
blockLocatorNodes net bb
|
||||
heights = map nodeHeight loc
|
||||
in heights `shouldBe` [100,99 .. 90] <> [88, 84, 76, 60, 28, 0]
|
||||
it "follows split chains" $
|
||||
let bb = withChain net $ splitChain net >> getBestBlockHeader
|
||||
in nodeHeight bb `shouldBe` 4035
|
||||
|
||||
-- 0 → → 2015 → → → → → → → 4031
|
||||
-- ↓
|
||||
-- → → 2035 → → → → → → 4035*
|
||||
-- ↓
|
||||
-- → → 2185
|
||||
splitChain :: Network -> State HeaderMemory ()
|
||||
splitChain net = do
|
||||
start <- go 1 (getGenesisHeader net) 2015
|
||||
e 2015 (head start)
|
||||
tail1 <- go 2 (nodeHeader $ head start) 2016
|
||||
e 4031 (head tail1)
|
||||
tail2 <- go 3 (nodeHeader $ head start) 20
|
||||
e 2035 (head tail2)
|
||||
tail3 <- go 4 (nodeHeader $ head tail2) 2000
|
||||
e 4035 (head tail3)
|
||||
tail4 <- go 5 (nodeHeader $ head tail2) 150
|
||||
e 2185 (head tail4)
|
||||
sp1 <- splitPoint net (head tail1) (head tail3)
|
||||
unless (sp1 == head start) $
|
||||
error $
|
||||
"Split point wrong between blocks 4031 and 4035: " ++
|
||||
show (nodeHeight sp1)
|
||||
sp2 <- splitPoint net (head tail4) (head tail3)
|
||||
unless (sp2 == head tail2) $
|
||||
error $
|
||||
"Split point wrong between blocks 2185 and 4035: " ++
|
||||
show (nodeHeight sp2)
|
||||
where
|
||||
e n bn =
|
||||
unless (nodeHeight bn == n) $
|
||||
error $
|
||||
"Node height " ++
|
||||
show (nodeHeight bn) ++ " of first chunk should be " ++ show n
|
||||
go seed start n = do
|
||||
let bhs = appendBlocks net seed start n
|
||||
bnE <- connectBlocks net myTime bhs
|
||||
case bnE of
|
||||
Right bn -> return bn
|
||||
Left ex -> error ex
|
@ -1,36 +1,34 @@
|
||||
module Network.Haskoin.Block.Tests (tests) where
|
||||
module Network.Haskoin.Block.Tests (spec) where
|
||||
|
||||
import Data.Either (fromRight)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Haskoin.Block
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Transaction
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"Block hash tests"
|
||||
[ testProperty "decode . encode block hash" $
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "block hash" $ do
|
||||
it "encodes and decodes block hash" $
|
||||
property $
|
||||
forAll arbitraryBlockHash $ \h ->
|
||||
hexToBlockHash (blockHashToHex h) == Just h
|
||||
, testProperty "From string block hash" $
|
||||
it "From string block hash" $
|
||||
property $
|
||||
forAll arbitraryBlockHash $ \h ->
|
||||
fromString (cs $ blockHashToHex h) == h
|
||||
]
|
||||
, testGroup
|
||||
"Merkle trees"
|
||||
[ testProperty "Width of tree at maxmum height = 1" testTreeWidth
|
||||
, testProperty "Width of tree at height 0 is # txns" testBaseWidth
|
||||
, testProperty "extract . build partial merkle tree" $
|
||||
describe "merkle trees" $ do
|
||||
it "builds tree of right width at height 1" $ property testTreeWidth
|
||||
it "builds tree of right width at height 0" $ property testBaseWidth
|
||||
it "builds and extracts partial merkle tree" $
|
||||
property $
|
||||
forAll
|
||||
(listOf1 ((,) <$> arbitraryTxHash <*> arbitrary))
|
||||
buildExtractTree
|
||||
]
|
||||
]
|
||||
(buildExtractTree net)
|
||||
|
||||
{- Merkle Trees -}
|
||||
|
||||
@ -40,11 +38,11 @@ testTreeWidth i = i /= 0 ==> calcTreeWidth (abs i) (calcTreeHeight $ abs i) == 1
|
||||
testBaseWidth :: Int -> Property
|
||||
testBaseWidth i = i /= 0 ==> calcTreeWidth (abs i) 0 == abs i
|
||||
|
||||
buildExtractTree :: [(TxHash, Bool)] -> Bool
|
||||
buildExtractTree txs =
|
||||
buildExtractTree :: Network -> [(TxHash, Bool)] -> Bool
|
||||
buildExtractTree net txs =
|
||||
r == buildMerkleRoot (map fst txs) && m == map fst (filter snd txs)
|
||||
where
|
||||
(f, h) = buildPartialMerkle txs
|
||||
(r, m) =
|
||||
fromRight (error "Could not extract matches from Merkle tree") $
|
||||
extractMatches f h (length txs)
|
||||
extractMatches net f h (length txs)
|
@ -1,126 +1,119 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Block.Units (tests) where
|
||||
module Network.Haskoin.Block.Units (spec) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe (fromJust)
|
||||
import Network.Haskoin.Block
|
||||
import Network.Haskoin.Transaction
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool,
|
||||
assertEqual)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool,
|
||||
assertEqual)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"Merkle Roots"
|
||||
(zipWith (curry mapMerkleVectors) merkleVectors [0 ..])
|
||||
, testGroup
|
||||
"Compact number representation"
|
||||
[ testCase "Compact number representations" testCompact
|
||||
, testCase
|
||||
"Compact number representations from Bitcoin Core tests"
|
||||
testCompactBitcoinCore
|
||||
]
|
||||
]
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "merkle roots" $
|
||||
sequence_ $ zipWith (curry mapMerkleVectors) merkleVectors [0 ..]
|
||||
describe "compact number representation" $ do
|
||||
it "check local vectors" testCompact
|
||||
it "check vectors from Bitcoin Core" testCompactBitcoinCore
|
||||
|
||||
testCompact :: Assertion
|
||||
testCompact = do
|
||||
assertEqual "Vector 1" 0x05123456 (encodeCompact 0x1234560000)
|
||||
assertEqual "Vector 2" (0x1234560000, False) (decodeCompact 0x05123456)
|
||||
assertEqual "Vector 3" 0x0600c0de (encodeCompact 0xc0de000000)
|
||||
assertEqual "Vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de)
|
||||
assertEqual "Vector 5" 0x05c0de00 (encodeCompact (-0x40de000000))
|
||||
assertEqual "Vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00)
|
||||
assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000)
|
||||
assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456)
|
||||
assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000)
|
||||
assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de)
|
||||
assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000))
|
||||
assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00)
|
||||
|
||||
testCompactBitcoinCore :: Assertion
|
||||
testCompactBitcoinCore = do
|
||||
assertEqual "Zero" (0, False) (decodeCompact 0x00000000)
|
||||
assertEqual "zero" (0, False) (decodeCompact 0x00000000)
|
||||
assertEqual
|
||||
"Zero (encode · decode)"
|
||||
"zero (encode · decode)"
|
||||
0x00000000
|
||||
(encodeCompact . fst $ decodeCompact 0x00000000)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x00123456)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x01003456)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x02000056)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x03000000)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x04000000)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x00923456)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x01803456)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x02800056)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x03800000)
|
||||
assertEqual "Rounds to zero" (0, False) (decodeCompact 0x04800000)
|
||||
assertEqual "Vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000)
|
||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000)
|
||||
assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456)
|
||||
assertEqual
|
||||
"Vector 1 (encode · decode)"
|
||||
"vector 1 (encode · decode)"
|
||||
0x01120000
|
||||
(encodeCompact . fst $ decodeCompact 0x01123456)
|
||||
assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80)
|
||||
assertEqual
|
||||
"Vector 2 (negative) (decode)"
|
||||
"vector 2 (negative) (decode)"
|
||||
(-0x7e, False)
|
||||
(decodeCompact 0x01fedcba)
|
||||
assertEqual
|
||||
"Vector 2 (negative) (encode · decode)"
|
||||
"vector 2 (negative) (encode · decode)"
|
||||
0x01fe0000
|
||||
(encodeCompact . fst $ decodeCompact 0x01fedcba)
|
||||
assertEqual "Vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456)
|
||||
assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456)
|
||||
assertEqual
|
||||
"Vector 3 (encode · decode)"
|
||||
"vector 3 (encode · decode)"
|
||||
0x02123400
|
||||
(encodeCompact . fst $ decodeCompact 0x02123456)
|
||||
assertEqual "Vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456)
|
||||
assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456)
|
||||
assertEqual
|
||||
"Vector 4 (encode · decode)"
|
||||
"vector 4 (encode · decode)"
|
||||
0x03123456
|
||||
(encodeCompact . fst $ decodeCompact 0x03123456)
|
||||
assertEqual
|
||||
"Vector 5 (decode)"
|
||||
"vector 5 (decode)"
|
||||
(0x12345600, False)
|
||||
(decodeCompact 0x04123456)
|
||||
assertEqual
|
||||
"Vector 5 (encode · decode)"
|
||||
"vector 5 (encode · decode)"
|
||||
0x04123456
|
||||
(encodeCompact . fst $ decodeCompact 0x04123456)
|
||||
assertEqual
|
||||
"Vector 6 (decode)"
|
||||
"vector 6 (decode)"
|
||||
(-0x12345600, False)
|
||||
(decodeCompact 0x04923456)
|
||||
assertEqual
|
||||
"Vector 6 (encode · decode)"
|
||||
"vector 6 (encode · decode)"
|
||||
0x04923456
|
||||
(encodeCompact . fst $ decodeCompact 0x04923456)
|
||||
assertEqual
|
||||
"Vector 7 (decode)"
|
||||
"vector 7 (decode)"
|
||||
(0x92340000, False)
|
||||
(decodeCompact 0x05009234)
|
||||
assertEqual
|
||||
"Vector 7 (encode · decode)"
|
||||
"vector 7 (encode · decode)"
|
||||
0x05009234
|
||||
(encodeCompact . fst $ decodeCompact 0x05009234)
|
||||
assertEqual
|
||||
"Vector 8 (decode)"
|
||||
"vector 8 (decode)"
|
||||
( 0x1234560000000000000000000000000000000000000000000000000000000000
|
||||
, False)
|
||||
(decodeCompact 0x20123456)
|
||||
assertEqual
|
||||
"Vector 8 (encode · decode)"
|
||||
"vector 8 (encode · decode)"
|
||||
0x20123456
|
||||
(encodeCompact . fst $ decodeCompact 0x20123456)
|
||||
assertBool "Vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456)
|
||||
assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456)
|
||||
assertBool
|
||||
"Vector 9 (decode) (positive)"
|
||||
"vector 9 (decode) (positive)"
|
||||
((> 0) . fst $ decodeCompact 0xff123456)
|
||||
|
||||
mapMerkleVectors :: ((ByteString, [ByteString]), Int) -> Test.Framework.Test
|
||||
mapMerkleVectors :: ((ByteString, [ByteString]), Int) -> Spec
|
||||
mapMerkleVectors (v, i) =
|
||||
testCase name $ runMerkleVector v
|
||||
it name $ runMerkleVector v
|
||||
where
|
||||
name = "MerkleRoot vector " ++ show i
|
||||
name = "merkle root vector " ++ show i
|
||||
|
||||
runMerkleVector :: (ByteString, [ByteString]) -> Assertion
|
||||
runMerkleVector (r, hs) =
|
||||
assertBool " > Merkle Vector" $
|
||||
assertBool "merkle vector" $
|
||||
buildMerkleRoot (map f hs) == getTxHash (f r)
|
||||
where
|
||||
f = fromJust . hexToTxHash
|
108
test/Network/Haskoin/Cereal/Tests.hs
Normal file
108
test/Network/Haskoin/Cereal/Tests.hs
Normal file
@ -0,0 +1,108 @@
|
||||
module Network.Haskoin.Cereal.Tests (spec) where
|
||||
|
||||
import Data.Serialize
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Network
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "serialization of keys and hashes" $ do
|
||||
it "encodes and decodes bytestring" $
|
||||
property $ forAll arbitraryBS testId
|
||||
it "encodes and decodes hash160" $
|
||||
property $ forAll arbitraryHash160 testId
|
||||
it "encodes and decodes hash256" $
|
||||
property $ forAll arbitraryHash256 testId
|
||||
it "encodes and decodes hash512" $
|
||||
property $ forAll arbitraryHash512 testId
|
||||
it "encodes and decodes signature" $
|
||||
property $ forAll arbitrarySignature $ testId . lst3
|
||||
it "encodes and decodes public key" $
|
||||
property $ forAll arbitraryPubKey $ testId . snd
|
||||
it "encodes and decodes extended private key" $
|
||||
property $
|
||||
forAll (arbitraryXPrvKey net) $
|
||||
testPutGet (getXPrvKey net) putXPrvKey
|
||||
describe "serialization of protocol types" $ do
|
||||
it "encodes and decodes varint" $
|
||||
property $ forAll arbitraryVarInt testId
|
||||
it "encodes and decodes varstring" $
|
||||
property $ forAll arbitraryVarString testId
|
||||
it "encodes and decodes network address" $
|
||||
property $ forAll arbitraryNetworkAddress testId
|
||||
it "encodes and decodes invtype" $
|
||||
property $ forAll arbitraryInvType testId
|
||||
it "encodes and decodes invvector" $
|
||||
property $ forAll arbitraryInvVector testId
|
||||
it "encodes and decodes inv" $ property $ forAll arbitraryInv1 testId
|
||||
it "encodes and decodes version" $
|
||||
property $ forAll arbitraryVersion testId
|
||||
it "encodes and decodes addr" $ property $ forAll arbitraryAddr1 testId
|
||||
it "encodes and decodes alert" $ property $ forAll arbitraryAlert testId
|
||||
it "encodes and decodes reject" $
|
||||
property $forAll arbitraryReject testId
|
||||
it "encodes and decodes getdata" $
|
||||
property $ forAll arbitraryGetData testId
|
||||
it "encodes and decodes notfound" $
|
||||
property $ forAll arbitraryNotFound testId
|
||||
it "encodes and decodes ping" $ property $ forAll arbitraryPing testId
|
||||
it "encodes and decodes pong" $ property $ forAll arbitraryPong testId
|
||||
it "encodes and decodes message command" $
|
||||
property $ forAll arbitraryMessageCommand testId
|
||||
it "encodes and decodes message header" $
|
||||
property $ forAll arbitraryMessageHeader testId
|
||||
it "encodes and decodes message" $
|
||||
property $
|
||||
forAll (arbitraryMessage net) $
|
||||
testPutGet (getMessage net) (putMessage net)
|
||||
describe "serialization of script types" $ do
|
||||
it "encodes and decodes script op" $
|
||||
property $ forAll arbitraryScriptOp testId
|
||||
it "encodes and decodes script" $
|
||||
property $ forAll arbitraryScript testId
|
||||
describe "serialization of transaction types" $ do
|
||||
it "encodes and decodes tx input" $
|
||||
property $ forAll arbitraryTxIn testId
|
||||
it "encodes and decodes tx output" $
|
||||
property $ forAll (arbitraryTxOut net) testId
|
||||
it "encodes and decodes outpoint" $
|
||||
property $ forAll arbitraryOutPoint testId
|
||||
it "encodes and decodes transaction" $
|
||||
property $ forAll (arbitraryTx net) testId
|
||||
it "encodes and decodes witness transaction" $
|
||||
property $ forAll (arbitraryWitnessTx net) testId
|
||||
it "encodes and decodes legacy transaction" $
|
||||
property $ forAll (arbitraryLegacyTx net) testId
|
||||
describe "serialization of block types" $ do
|
||||
it "encodes and decodes block" $
|
||||
property $ forAll (arbitraryBlock net) testId
|
||||
it "encodes and decodes block header" $
|
||||
property $ forAll arbitraryBlockHeader testId
|
||||
it "encodes and decodes getblocks" $
|
||||
property $ forAll arbitraryGetBlocks testId
|
||||
it "encodes and decodes getheaders" $
|
||||
property $ forAll arbitraryGetHeaders testId
|
||||
it "encodes and decdoes headers" $
|
||||
property $ forAll arbitraryHeaders testId
|
||||
it "encodes and decodes merklel block" $
|
||||
property $ forAll arbitraryMerkleBlock testId
|
||||
describe "serialization of bloom types" $ do
|
||||
it "encodes and decodes bloom flags" $
|
||||
property $ forAll arbitraryBloomFlags testId
|
||||
it "encodes and decodes bloom filter" $
|
||||
property $ forAll arbitraryBloomFilter $ testId . lst3
|
||||
it "encodes and decodes filterload" $
|
||||
property $ forAll arbitraryFilterLoad testId
|
||||
it "encodes and decodes filteradd" $
|
||||
property $ forAll arbitraryFilterAdd testId
|
||||
|
||||
testId :: (Serialize a, Eq a) => a -> Bool
|
||||
testId x = decode (encode x) == Right x
|
||||
|
||||
testPutGet :: Eq a => Get a -> Putter a -> a -> Bool
|
||||
testPutGet g p a = runGet g (runPut (p a)) == Right a
|
27
test/Network/Haskoin/Crypto/Base58/Tests.hs
Normal file
27
test/Network/Haskoin/Crypto/Base58/Tests.hs
Normal file
@ -0,0 +1,27 @@
|
||||
module Network.Haskoin.Crypto.Base58.Tests
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
spec :: Network -> Spec
|
||||
spec net =
|
||||
describe "base58 addresses" $ do
|
||||
it "encodes and decodes base58 bytestring" $
|
||||
property $
|
||||
forAll arbitraryBS $ \bs ->
|
||||
decodeBase58 (encodeBase58 bs) == Just bs
|
||||
it "encodes and decodes base58 bytestring with checksum" $
|
||||
property $
|
||||
forAll arbitraryBS $ \bs ->
|
||||
decodeBase58Check (encodeBase58Check bs) == Just bs
|
||||
it "encodes and decodes address" $
|
||||
property $
|
||||
forAll (arbitraryAddress net) $ \a ->
|
||||
(stringToAddr net =<< addrToString a) == Just a
|
@ -1,22 +1,20 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Crypto.Base58.Units (tests) where
|
||||
module Network.Haskoin.Crypto.Base58.Units (spec) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS (append, empty, pack)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS (append, empty, pack)
|
||||
import Network.Haskoin.Crypto
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "Test base58 encodings" $
|
||||
zipWith (curry mapBase58Vec) vectors [0..]
|
||||
]
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "base58 encodings" $
|
||||
sequence_ $ zipWith (curry mapBase58Vec) vectors [0 ..]
|
||||
|
||||
mapBase58Vec :: ((ByteString, ByteString, ByteString), Int) -> Test.Framework.Test
|
||||
mapBase58Vec :: ((ByteString, ByteString, ByteString), Int) -> Spec
|
||||
mapBase58Vec (v, i) =
|
||||
testCase (unwords [ "Test base58 vector", show i ]) $ runVector v
|
||||
it (unwords ["test base58 vector", show i]) $ runVector v
|
||||
|
||||
runVector :: (ByteString, ByteString, ByteString) -> Assertion
|
||||
runVector (bs, e, chk) = do
|
@ -1,37 +1,35 @@
|
||||
module Network.Haskoin.Crypto.ECDSA.Tests (tests) where
|
||||
module Network.Haskoin.Crypto.ECDSA.Tests (spec) where
|
||||
|
||||
import Data.Bits (testBit)
|
||||
import qualified Data.ByteString as BS (index, length)
|
||||
import Data.Serialize (encode)
|
||||
import Data.Bits (testBit)
|
||||
import qualified Data.ByteString as BS (index, length)
|
||||
import Data.Serialize (encode)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"ECDSA signatures"
|
||||
[ testProperty "Verify signature" $
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "ecdsa signatures" $ do
|
||||
it "verify signature" $
|
||||
property $
|
||||
forAll arbitrarySignature $ \(msg, key, sig) ->
|
||||
verifySig msg sig (derivePubKey key)
|
||||
, testProperty "S component <= order/2" $
|
||||
forAll arbitrarySignature $ isCanonicalHalfOrder . lst3
|
||||
]
|
||||
, testGroup
|
||||
"ECDSA Binary"
|
||||
[ testProperty "Encoded signature is canonical" $
|
||||
forAll arbitrarySignature $ testIsCanonical . lst3
|
||||
, testProperty "decodeStrict . encode sig == id" $
|
||||
it "s component ≤ order ÷ 2" $
|
||||
property $ forAll arbitrarySignature $ isCanonicalHalfOrder . lst3
|
||||
describe "ecdsa binary" $ do
|
||||
it "encoded signature is canonical" $
|
||||
property $ forAll arbitrarySignature $ testIsCanonical . lst3
|
||||
it "decodeStrict . encode sig == id" $
|
||||
property $
|
||||
forAll arbitrarySignature $
|
||||
(\s -> decodeStrictSig (encode s) == Just s) . lst3
|
||||
, testProperty "decode . encode sig == id" $
|
||||
it "decode . encode sig == id" $
|
||||
property $
|
||||
forAll arbitrarySignature $
|
||||
(\s -> decodeLaxSig (encode s) == Just s) . lst3
|
||||
]
|
||||
]
|
||||
|
||||
{- ECDSA Canonical -}
|
||||
|
61
test/Network/Haskoin/Crypto/ExtendedKeys/Tests.hs
Normal file
61
test/Network/Haskoin/Crypto/ExtendedKeys/Tests.hs
Normal file
@ -0,0 +1,61 @@
|
||||
module Network.Haskoin.Crypto.ExtendedKeys.Tests (spec) where
|
||||
|
||||
import Data.Bits ((.&.))
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word32)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck hiding ((.&.))
|
||||
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "extended keys" $ do
|
||||
it "computes pubkey of a subkey is subkey of the pubkey" $
|
||||
property $
|
||||
forAll (arbitraryXPrvKey net) pubKeyOfSubKeyIsSubKeyOfPubKey
|
||||
it "exports and imports extended private key" $
|
||||
property $
|
||||
forAll (arbitraryXPrvKey net) $ \k ->
|
||||
xPrvImport net (xPrvExport k) == Just k
|
||||
it "exports and imports extended public key" $
|
||||
property $
|
||||
forAll (arbitraryXPubKey net) $ \(_, k) ->
|
||||
xPubImport net (xPubExport k) == Just k
|
||||
it "show and read derivation path" $
|
||||
property $ forAll arbitraryDerivPath $ \p -> read (show p) == p
|
||||
it "show and read hard derivation path" $
|
||||
property $ forAll arbitraryHardPath $ \p -> read (show p) == p
|
||||
it "show and read soft derivation path" $
|
||||
property $ forAll arbitrarySoftPath $ \p -> read (show p) == p
|
||||
it "from string derivation path" $
|
||||
property $
|
||||
forAll arbitraryDerivPath $ \p -> fromString (cs $ pathToStr p) == p
|
||||
it "from string hard derivation path" $
|
||||
property $
|
||||
forAll arbitraryHardPath $ \p -> fromString (cs $ pathToStr p) == p
|
||||
it "from string soft derivation path" $
|
||||
property $
|
||||
forAll arbitrarySoftPath $ \p -> fromString (cs $ pathToStr p) == p
|
||||
it "from and to lists of derivation paths" $
|
||||
property $
|
||||
forAll arbitraryDerivPath $ \p -> listToPath (pathToList p) == p
|
||||
it "from and to lists of hard derivation paths" $
|
||||
property $
|
||||
forAll arbitraryHardPath $ \p ->
|
||||
toHard (listToPath $ pathToList p) == Just p
|
||||
it "from and to lists of soft derivation paths" $
|
||||
property $
|
||||
forAll arbitrarySoftPath $ \p ->
|
||||
toSoft (listToPath $ pathToList p) == Just p
|
||||
it "read and show parsed path" $
|
||||
property $ forAll arbitraryParsedPath $ \p -> read (show p) == p
|
||||
|
||||
pubKeyOfSubKeyIsSubKeyOfPubKey :: XPrvKey -> Word32 -> Bool
|
||||
pubKeyOfSubKeyIsSubKeyOfPubKey k i =
|
||||
deriveXPubKey (prvSubKey k i') == pubSubKey (deriveXPubKey k) i'
|
||||
where
|
||||
i' = fromIntegral $ i .&. 0x7fffffff -- make it a public derivation
|
||||
|
@ -1,67 +1,63 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Crypto.ExtendedKeys.Units (tests) where
|
||||
module Network.Haskoin.Crypto.ExtendedKeys.Units (spec) where
|
||||
|
||||
import qualified Data.Aeson as Aeson (decode, encode)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy.Char8 as B8
|
||||
import Data.Either (isLeft)
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.Serialize (encode)
|
||||
import Data.String (fromString)
|
||||
import qualified Data.Aeson as Aeson (decode, encode)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy.Char8 as B8
|
||||
import Data.Either (isLeft)
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.Serialize (encode, runPut)
|
||||
import Data.String (fromString)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool,
|
||||
assertEqual)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool, assertEqual)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "BIP32 derivation vector 1"
|
||||
[ testCase "Chain m" $ runXKeyVec (head xKeyVec)
|
||||
, testCase "Chain m/0'" $ runXKeyVec (xKeyVec !! 1)
|
||||
, testCase "Chain m/0'/1" $ runXKeyVec (xKeyVec !! 2)
|
||||
, testCase "Chain m/0'/1/2'" $ runXKeyVec (xKeyVec !! 3)
|
||||
, testCase "Chain m/0'/1/2'/2" $ runXKeyVec (xKeyVec !! 4)
|
||||
, testCase "Chain m/0'/1/2'/2/1000000000" $
|
||||
runXKeyVec (xKeyVec !! 5)
|
||||
]
|
||||
, testGroup "BIP32 subkey derivation vector 2"
|
||||
[ testCase "Chain m" $ runXKeyVec (head xKeyVec2)
|
||||
, testCase "Chain m/0" $ runXKeyVec (xKeyVec2 !! 1)
|
||||
, testCase "Chain m/0/2147483647'" $
|
||||
runXKeyVec (xKeyVec2 !! 2)
|
||||
, testCase "Chain m/0/2147483647'/1" $
|
||||
runXKeyVec (xKeyVec2 !! 3)
|
||||
, testCase "Chain m/0/2147483647'/1/2147483646'" $
|
||||
runXKeyVec (xKeyVec2 !! 4)
|
||||
, testCase "Chain m/0/2147483647'/1/2147483646'/2" $
|
||||
runXKeyVec (xKeyVec2 !! 5)
|
||||
]
|
||||
, testGroup "BIP32 subkey derivation using string path"
|
||||
[ testGroup "Either Derivations" testApplyPath
|
||||
, testGroup "Either Derivations" testBadApplyPath
|
||||
, testGroup "Public Derivations" testDerivePubPath
|
||||
, testGroup "Private Derivations" testDerivePrvPath
|
||||
, testGroup "Path Parsing" testParsePath
|
||||
, testGroup "FromJSON" testFromJsonPath
|
||||
, testGroup "ToJSON" testToJsonPath
|
||||
]
|
||||
]
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "BIP32 derivation vector 1" $ do
|
||||
it "chain m" $ runXKeyVec (head xKeyVec)
|
||||
it "chain m/0'" $ runXKeyVec (xKeyVec !! 1)
|
||||
it "chain m/0'/1" $ runXKeyVec (xKeyVec !! 2)
|
||||
it "chain m/0'/1/2'" $ runXKeyVec (xKeyVec !! 3)
|
||||
it "chain m/0'/1/2'/2" $ runXKeyVec (xKeyVec !! 4)
|
||||
it "chain m/0'/1/2'/2/1000000000" $ runXKeyVec (xKeyVec !! 5)
|
||||
describe "BIP32 subkey derivation vector 2" $ do
|
||||
it "chain m" $ runXKeyVec (head xKeyVec2)
|
||||
it "chain m/0" $ runXKeyVec (xKeyVec2 !! 1)
|
||||
it "chain m/0/2147483647'" $ runXKeyVec (xKeyVec2 !! 2)
|
||||
it "chain m/0/2147483647'/1" $ runXKeyVec (xKeyVec2 !! 3)
|
||||
it "chain m/0/2147483647'/1/2147483646'" $ runXKeyVec (xKeyVec2 !! 4)
|
||||
it "Chain m/0/2147483647'/1/2147483646'/2" $ runXKeyVec (xKeyVec2 !! 5)
|
||||
describe "BIP32 subkey derivation using string path" $ do
|
||||
it "either derivations" testApplyPath
|
||||
it "either derivations" testBadApplyPath
|
||||
it "dublic derivations" testDerivePubPath
|
||||
it "private derivations" testDerivePrvPath
|
||||
it "path parsing" testParsePath
|
||||
it "from json" testFromJsonPath
|
||||
it "to json" testToJsonPath
|
||||
|
||||
testFromJsonPath :: [Test]
|
||||
testFromJsonPath = do
|
||||
path <- jsonPathVectors
|
||||
return $ testCase ("Path " ++ path) $
|
||||
assertEqual path (Just [fromString path :: DerivPath])
|
||||
(Aeson.decode $ B8.pack $ "[\"" ++ path ++ "\"]")
|
||||
testFromJsonPath :: Assertion
|
||||
testFromJsonPath =
|
||||
sequence_ $ do
|
||||
path <- jsonPathVectors
|
||||
return $
|
||||
assertEqual
|
||||
path
|
||||
(Just [fromString path :: DerivPath])
|
||||
(Aeson.decode $ B8.pack $ "[\"" ++ path ++ "\"]")
|
||||
|
||||
testToJsonPath :: [Test]
|
||||
testToJsonPath = do
|
||||
path <- jsonPathVectors
|
||||
return $ testCase ("Path " ++ path) $
|
||||
assertEqual path (B8.pack $ "[\"" ++ path ++ "\"]")
|
||||
(Aeson.encode [fromString path :: ParsedPath])
|
||||
testToJsonPath :: Assertion
|
||||
testToJsonPath =
|
||||
sequence_ $ do
|
||||
path <- jsonPathVectors
|
||||
return $
|
||||
assertEqual
|
||||
path
|
||||
(B8.pack $ "[\"" ++ path ++ "\"]")
|
||||
(Aeson.encode [fromString path :: ParsedPath])
|
||||
|
||||
jsonPathVectors :: [String]
|
||||
jsonPathVectors =
|
||||
@ -77,11 +73,11 @@ jsonPathVectors =
|
||||
, "M/1'/2'/3/4"
|
||||
]
|
||||
|
||||
testParsePath :: [Test]
|
||||
testParsePath = do
|
||||
(path, t) <- parsePathVectors
|
||||
return $ testCase ("Path " ++ path) $
|
||||
assertBool path (t $ parsePath path)
|
||||
testParsePath :: Assertion
|
||||
testParsePath =
|
||||
sequence_ $ do
|
||||
(path, t) <- parsePathVectors
|
||||
return $ assertBool path (t $ parsePath path)
|
||||
|
||||
parsePathVectors :: [(String, Maybe ParsedPath -> Bool)]
|
||||
parsePathVectors =
|
||||
@ -105,32 +101,34 @@ parsePathVectors =
|
||||
, ("NaN", isNothing)
|
||||
]
|
||||
|
||||
testApplyPath :: [Test]
|
||||
testApplyPath = do
|
||||
(key, path, final) <- applyPathVectors
|
||||
return $ testCase ("Path " ++ path) $
|
||||
assertEqual path final $
|
||||
applyPath (fromJust $ parsePath path) key
|
||||
testApplyPath :: Assertion
|
||||
testApplyPath =
|
||||
sequence_ $ do
|
||||
(key, path, final) <- applyPathVectors
|
||||
return $
|
||||
assertEqual path final $ applyPath (fromJust $ parsePath path) key
|
||||
|
||||
testBadApplyPath :: [Test]
|
||||
testBadApplyPath = do
|
||||
(key, path) <- badApplyPathVectors
|
||||
return $ testCase ("Path " ++ path) $
|
||||
assertBool path $ isLeft $
|
||||
applyPath (fromJust $ parsePath path) key
|
||||
testBadApplyPath :: Assertion
|
||||
testBadApplyPath =
|
||||
sequence_ $ do
|
||||
(key, path) <- badApplyPathVectors
|
||||
return $
|
||||
assertBool path $ isLeft $ applyPath (fromJust $ parsePath path) key
|
||||
|
||||
testDerivePubPath :: [Test]
|
||||
testDerivePubPath = do
|
||||
(key, path, final) <- derivePubPathVectors
|
||||
return $ testCase ("Path " ++ path) $
|
||||
assertEqual path final $
|
||||
testDerivePubPath :: Assertion
|
||||
testDerivePubPath =
|
||||
sequence_ $ do
|
||||
(key, path, final) <- derivePubPathVectors
|
||||
return $
|
||||
assertEqual path final $
|
||||
derivePubPath (fromString path :: SoftPath) key
|
||||
|
||||
testDerivePrvPath :: [Test]
|
||||
testDerivePrvPath = do
|
||||
(key, path, final) <- derivePrvPathVectors
|
||||
return $ testCase ("Path " ++ path) $
|
||||
assertEqual path final $
|
||||
testDerivePrvPath :: Assertion
|
||||
testDerivePrvPath =
|
||||
sequence_ $ do
|
||||
(key, path, final) <- derivePrvPathVectors
|
||||
return $
|
||||
assertEqual path final $
|
||||
derivePath (fromString path :: DerivPath) key
|
||||
|
||||
derivePubPathVectors :: [(XPubKey, String, XPubKey)]
|
||||
@ -140,7 +138,7 @@ derivePubPathVectors =
|
||||
, ( xpub, "M/8/30/1", foldl pubSubKey xpub [8,30,1] )
|
||||
]
|
||||
where
|
||||
xprv = fromJust $ xPrvImport
|
||||
xprv = fromJust $ xPrvImport btc
|
||||
"xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\
|
||||
\WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB"
|
||||
xpub = deriveXPubKey xprv
|
||||
@ -165,48 +163,56 @@ derivePrvPathVectors =
|
||||
)
|
||||
]
|
||||
where
|
||||
xprv = fromJust $ xPrvImport
|
||||
xprv = fromJust $ xPrvImport btc
|
||||
"xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\
|
||||
\WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB"
|
||||
|
||||
applyPathVectors :: [(XKey, String, Either String XKey)]
|
||||
applyPathVectors =
|
||||
[ ( XPrv xprv, "m", Right $ XPrv xprv )
|
||||
, ( XPrv xprv, "M", Right $ XPub xpub )
|
||||
, ( XPrv xprv, "m/8'", Right $ XPrv $ hardSubKey xprv 8 )
|
||||
, ( XPrv xprv, "M/8'", Right $ XPub $ deriveXPubKey $ hardSubKey xprv 8 )
|
||||
, ( XPrv xprv, "m/8'/30/1"
|
||||
, Right $ XPrv $ foldl prvSubKey (hardSubKey xprv 8) [30,1]
|
||||
)
|
||||
, ( XPrv xprv, "M/8'/30/1"
|
||||
, Right $ XPub $
|
||||
deriveXPubKey $ foldl prvSubKey (hardSubKey xprv 8) [30,1]
|
||||
)
|
||||
, ( XPrv xprv, "m/3/20"
|
||||
, Right $ XPrv $ foldl prvSubKey xprv [3,20]
|
||||
)
|
||||
, ( XPrv xprv, "M/3/20"
|
||||
, Right $ XPub $ deriveXPubKey $ foldl prvSubKey xprv [3,20]
|
||||
)
|
||||
, ( XPub xpub, "M/3/20"
|
||||
, Right $ XPub $ deriveXPubKey $ foldl prvSubKey xprv [3,20]
|
||||
)
|
||||
[ (XPrv xprv btc, "m", Right (XPrv xprv btc))
|
||||
, (XPrv xprv btc, "M", Right (XPub xpub btc))
|
||||
, (XPrv xprv btc, "m/8'", Right (XPrv (hardSubKey xprv 8) btc))
|
||||
, ( XPrv xprv btc
|
||||
, "M/8'"
|
||||
, Right (XPub (deriveXPubKey (hardSubKey xprv 8)) btc))
|
||||
, ( XPrv xprv btc
|
||||
, "m/8'/30/1"
|
||||
, Right (XPrv (foldl prvSubKey (hardSubKey xprv 8) [30, 1]) btc))
|
||||
, ( XPrv xprv btc
|
||||
, "M/8'/30/1"
|
||||
, Right
|
||||
(XPub
|
||||
(deriveXPubKey (foldl prvSubKey (hardSubKey xprv 8) [30, 1]))
|
||||
btc))
|
||||
, (XPrv xprv btc, "m/3/20", Right (XPrv (foldl prvSubKey xprv [3, 20]) btc))
|
||||
, ( XPrv xprv btc
|
||||
, "M/3/20"
|
||||
, Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc))
|
||||
, ( XPub xpub btc
|
||||
, "M/3/20"
|
||||
, Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc))
|
||||
]
|
||||
where
|
||||
xprv = fromJust $ xPrvImport
|
||||
"xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\
|
||||
xprv =
|
||||
fromJust $
|
||||
xPrvImport
|
||||
btc
|
||||
"xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\
|
||||
\WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB"
|
||||
xpub = deriveXPubKey xprv
|
||||
|
||||
badApplyPathVectors :: [(XKey, String)]
|
||||
badApplyPathVectors = [
|
||||
( XPub xpub, "m/8'" )
|
||||
, ( XPub xpub, "M/8'" )
|
||||
, ( XPub xpub, "M/1/2/3'/4/5" )
|
||||
]
|
||||
badApplyPathVectors =
|
||||
[ (XPub xpub btc, "m/8'")
|
||||
, (XPub xpub btc, "M/8'")
|
||||
, (XPub xpub btc, "M/1/2/3'/4/5")
|
||||
]
|
||||
where
|
||||
xprv = fromJust $ xPrvImport
|
||||
"xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\
|
||||
xprv =
|
||||
fromJust $
|
||||
xPrvImport
|
||||
btc
|
||||
"xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\
|
||||
\WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB"
|
||||
xpub = deriveXPubKey xprv
|
||||
|
||||
@ -217,16 +223,14 @@ runXKeyVec (v, m) = do
|
||||
assertBool "xPrvFP" $ encodeHex (encode $ xPrvFP m) == v !! 1
|
||||
assertBool "xPrvAddr" $
|
||||
addrToString (xPubAddr $ deriveXPubKey m) == Just (v !! 2)
|
||||
assertBool "prvKey" $
|
||||
encodeHex (encodePrvKey $ xPrvKey m) == v !! 3
|
||||
assertBool "prvKey" $ encodeHex (encodePrvKey $ xPrvKey m) == v !! 3
|
||||
assertBool "xPrvWIF" $ xPrvWif m == v !! 4
|
||||
assertBool "pubKey" $
|
||||
encodeHex (encode $ xPubKey $ deriveXPubKey m) == v !! 5
|
||||
assertBool "chain code" $
|
||||
encodeHex (encode $ xPrvChain m) == v !! 6
|
||||
assertBool "chain code" $ encodeHex (encode $ xPrvChain m) == v !! 6
|
||||
assertBool "Hex PubKey" $
|
||||
encodeHex (encode $ deriveXPubKey m) == v !! 7
|
||||
assertBool "Hex PrvKey" $ encodeHex (encode m) == v !! 8
|
||||
encodeHex (runPut $ putXPubKey $ deriveXPubKey m) == v !! 7
|
||||
assertBool "Hex PrvKey" $ encodeHex (runPut (putXPrvKey m)) == v !! 8
|
||||
assertBool "Base58 PubKey" $ xPubExport (deriveXPubKey m) == v !! 9
|
||||
assertBool "Base58 PrvKey" $ xPrvExport m == v !! 10
|
||||
|
||||
@ -236,7 +240,7 @@ runXKeyVec (v, m) = do
|
||||
xKeyVec :: [([ByteString], XPrvKey)]
|
||||
xKeyVec = zip xKeyResVec $ foldl f [m] der
|
||||
where f acc d = acc ++ [d $ last acc]
|
||||
m = makeXPrvKey $ fromJust $ decodeHex m0
|
||||
m = makeXPrvKey btc $ fromJust $ decodeHex m0
|
||||
der = [ flip hardSubKey 0
|
||||
, flip prvSubKey 1
|
||||
, flip hardSubKey 2
|
||||
@ -247,7 +251,7 @@ xKeyVec = zip xKeyResVec $ foldl f [m] der
|
||||
xKeyVec2 :: [([ByteString], XPrvKey)]
|
||||
xKeyVec2 = zip xKeyResVec2 $ foldl f [m] der
|
||||
where f acc d = acc ++ [d $ last acc]
|
||||
m = makeXPrvKey $ fromJust $ decodeHex m1
|
||||
m = makeXPrvKey btc $ fromJust $ decodeHex m1
|
||||
der = [ flip prvSubKey 0
|
||||
, flip hardSubKey 2147483647
|
||||
, flip prvSubKey 1
|
46
test/Network/Haskoin/Crypto/Hash/Tests.hs
Normal file
46
test/Network/Haskoin/Crypto/Hash/Tests.hs
Normal file
@ -0,0 +1,46 @@
|
||||
module Network.Haskoin.Crypto.Hash.Tests (spec) where
|
||||
|
||||
import Data.Serialize (encode)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions
|
||||
import Network.Haskoin.Block
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util (encodeHex)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "hash" $ do
|
||||
it "join512( split512(h) ) == h" $
|
||||
property $
|
||||
forAll arbitraryHash256 $ forAll arbitraryHash256 . joinSplit512
|
||||
it "decodeCompact . encodeCompact i == i" $ property decEncCompact
|
||||
it "from string 64-byte hash" $
|
||||
property $
|
||||
forAll arbitraryHash512 $ \h ->
|
||||
fromString (cs $ encodeHex $ encode h) == h
|
||||
it "from string 32-byte hash" $
|
||||
property $
|
||||
forAll arbitraryHash256 $ \h ->
|
||||
fromString (cs $ encodeHex $ encode h) == h
|
||||
it "from string 20-byte hash" $
|
||||
property $
|
||||
forAll arbitraryHash160 $ \h ->
|
||||
fromString (cs $ encodeHex $ encode h) == h
|
||||
|
||||
joinSplit512 :: Hash256 -> Hash256 -> Bool
|
||||
joinSplit512 a b = split512 (join512 (a, b)) == (a, b)
|
||||
|
||||
-- After encoding and decoding, we may loose precision so the new result is >=
|
||||
-- to the old one.
|
||||
decEncCompact :: Integer -> Bool
|
||||
decEncCompact i
|
||||
-- Integer completely fits inside the mantisse
|
||||
| abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False)
|
||||
-- Otherwise precision will be lost and the decoded result will
|
||||
-- be smaller than the original number
|
||||
| i >= 0 = fst (decodeCompact (encodeCompact i)) < i
|
||||
| otherwise = fst (decodeCompact (encodeCompact i)) > i
|
||||
|
@ -1,37 +1,35 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Crypto.Hash.Units (tests) where
|
||||
module Network.Haskoin.Crypto.Hash.Units (spec) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe (fromJust)
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
|
||||
-- Test vectors from NIST
|
||||
-- http://csrc.nist.gov/groups/STM/cavp/documents/drbg/drbgtestvectors.zip
|
||||
-- About 1/3 of HMAC DRBG SHA-256 test vectors are tested here
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "HMAC DRBG Suite 1" [mapDRBG t1]
|
||||
, testGroup "HMAC DRBG Suite 2" [mapDRBG t2]
|
||||
, testGroup "HMAC DRBG Suite 3" [mapDRBG t3]
|
||||
, testGroup "HMAC DRBG Suite 4" [mapDRBG t4]
|
||||
, testGroup "HMAC DRBG Suite 5 (Reseed)" [mapDRBGRsd r1]
|
||||
, testGroup "HMAC DRBG Suite 6 (Reseed)" [mapDRBGRsd r2]
|
||||
, testGroup "HMAC DRBG Suite 7 (Reseed)" [mapDRBGRsd r3]
|
||||
, testGroup "HMAC DRBG Suite 8 (Reseed)" [mapDRBGRsd r4]
|
||||
]
|
||||
spec :: Spec
|
||||
spec = describe "HMAC DRBG" $ do
|
||||
it "HMAC DRBG suite 1" $ sequence_ [mapDRBG t1]
|
||||
it "HMAC DRBG suite 2" $ sequence_ [mapDRBG t2]
|
||||
it "HMAC DRBG suite 3" $ sequence_ [mapDRBG t3]
|
||||
it "HMAC DRBG suite 4" $ sequence_ [mapDRBG t4]
|
||||
it "HMAC DRBG suite 5 (Reseed)" $ sequence_ [mapDRBGRsd r1]
|
||||
it "HMAC DRBG suite 6 (Reseed)" $ sequence_ [mapDRBGRsd r2]
|
||||
it "HMAC DRBG suite 7 (Reseed)" $ sequence_ [mapDRBGRsd r3]
|
||||
it "HMAC DRBG suite 8 (Reseed)" $ sequence_ [mapDRBGRsd r4]
|
||||
|
||||
type TestVector = [ByteString]
|
||||
|
||||
mapDRBG :: [TestVector] -> Test.Framework.Test
|
||||
mapDRBG vs = testCase "HMAC DRBG Vectors" $ mapM_ testDRBG $ zip vs [0..]
|
||||
mapDRBG :: [TestVector] -> Assertion
|
||||
mapDRBG vs = mapM_ testDRBG $ zip vs [0..]
|
||||
|
||||
mapDRBGRsd :: [TestVector] -> Test.Framework.Test
|
||||
mapDRBGRsd vs = testCase "HMAC DRBG Vectors" $ mapM_ testDRBGRsd $ zip vs [0..]
|
||||
mapDRBGRsd :: [TestVector] -> Assertion
|
||||
mapDRBGRsd vs = mapM_ testDRBGRsd $ zip vs [0..]
|
||||
|
||||
testDRBG :: (TestVector, Int) -> Assertion
|
||||
testDRBG (s,i) = do
|
110
test/Network/Haskoin/Crypto/Keys/Tests.hs
Normal file
110
test/Network/Haskoin/Crypto/Keys/Tests.hs
Normal file
@ -0,0 +1,110 @@
|
||||
module Network.Haskoin.Crypto.Keys.Tests (spec) where
|
||||
|
||||
import qualified Crypto.Secp256k1 as EC
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Serialize (encode, runGet, runPut)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "pubkey binary" $ do
|
||||
it "is public key canonical" $
|
||||
property $ forAll arbitraryPubKey (isCanonicalPubKey . snd)
|
||||
it "makeKey . toKey" $ property makeToKey
|
||||
it "makeKeyU . toKey" $ property makeToKeyU
|
||||
describe "key formats" $ do
|
||||
it "fromWif . toWif PrvKey" $
|
||||
property $
|
||||
forAll arbitraryPrvKey $ \pk ->
|
||||
fromWif net (toWif net pk) == Just pk
|
||||
it "constant 32-byte encoding PrvKey" $
|
||||
property $ forAll arbitraryPrvKey binaryPrvKey
|
||||
describe "key compression" $ do
|
||||
it "compressed public key" $ property testCompressed
|
||||
it "uncompressed public key" $ property testUnCompressed
|
||||
it "compressed private key" $ property testPrivateCompressed
|
||||
it "uncompressed private key" $ property testPrivateUnCompressed
|
||||
describe "keys from and to strings" $ do
|
||||
it "read and show public key" $
|
||||
property $ forAll arbitraryPubKey $ \(_, k) -> read (show k) == k
|
||||
it "read and show compressed public key" $
|
||||
property $ forAll arbitraryPubKeyC $ \(_, k) -> read (show k) == k
|
||||
it "read and show uncompressed public key" $
|
||||
property $ forAll arbitraryPubKeyU $ \(_, k) -> read (show k) == k
|
||||
it "read and show private key" $
|
||||
property $ forAll arbitraryPrvKey $ \k -> read (show k) == k
|
||||
it "read and show compressed private key" $
|
||||
property $ forAll arbitraryPrvKeyC $ \k -> read (show k) == k
|
||||
it "read and show uncompressed private key" $
|
||||
property $ forAll arbitraryPrvKeyU $ \k -> read (show k) == k
|
||||
it "from string public key" $
|
||||
property $
|
||||
forAll arbitraryPubKey $ \(_, k) ->
|
||||
fromString (cs . encodeHex $ encode k) == k
|
||||
it "from string compressed public key" $
|
||||
property $
|
||||
forAll arbitraryPubKeyC $ \(_, k) ->
|
||||
fromString (cs . encodeHex $ encode k) == k
|
||||
it "from string uncompressed public key" $
|
||||
property $
|
||||
forAll arbitraryPubKeyU $ \(_, k) ->
|
||||
fromString (cs . encodeHex $ encode k) == k
|
||||
|
||||
-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp
|
||||
-- from function IsCanonicalPubKey
|
||||
isCanonicalPubKey :: PubKey -> Bool
|
||||
isCanonicalPubKey p = not $
|
||||
-- Non-canonical public key: too short
|
||||
(BS.length bs < 33) ||
|
||||
-- Non-canonical public key: invalid length for uncompressed key
|
||||
(BS.index bs 0 == 4 && BS.length bs /= 65) ||
|
||||
-- Non-canonical public key: invalid length for compressed key
|
||||
(BS.index bs 0 `elem` [2,3] && BS.length bs /= 33) ||
|
||||
-- Non-canonical public key: compressed nor uncompressed
|
||||
(BS.index bs 0 `notElem` [2,3,4])
|
||||
where
|
||||
bs = encode p
|
||||
|
||||
makeToKey :: EC.SecKey -> Bool
|
||||
makeToKey i = prvKeySecKey (makePrvKey i) == i
|
||||
|
||||
makeToKeyU :: EC.SecKey -> Bool
|
||||
makeToKeyU i = prvKeySecKey (makePrvKeyU i) == i
|
||||
|
||||
{- Key formats -}
|
||||
|
||||
binaryPrvKey :: PrvKey -> Bool
|
||||
binaryPrvKey k =
|
||||
(Right k == runGet (prvKeyGetMonad f) (runPut $ prvKeyPutMonad k)) &&
|
||||
(Just k == decodePrvKey f (encodePrvKey k))
|
||||
where
|
||||
f = makePrvKeyG (prvKeyCompressed k)
|
||||
|
||||
{- Key Compression -}
|
||||
|
||||
testCompressed :: EC.SecKey -> Bool
|
||||
testCompressed n =
|
||||
pubKeyCompressed (derivePubKey $ makePrvKey n) &&
|
||||
pubKeyCompressed (derivePubKey $ makePrvKeyG True n)
|
||||
|
||||
testUnCompressed :: EC.SecKey -> Bool
|
||||
testUnCompressed n =
|
||||
not (pubKeyCompressed $ derivePubKey $ makePrvKeyG False n) &&
|
||||
not (pubKeyCompressed $ derivePubKey $ makePrvKeyU n)
|
||||
|
||||
testPrivateCompressed :: EC.SecKey -> Bool
|
||||
testPrivateCompressed n =
|
||||
prvKeyCompressed (makePrvKey n) &&
|
||||
prvKeyCompressed (makePrvKeyC n)
|
||||
|
||||
testPrivateUnCompressed :: EC.SecKey -> Bool
|
||||
testPrivateUnCompressed n =
|
||||
not (prvKeyCompressed $ makePrvKeyG False n) &&
|
||||
not (prvKeyCompressed $ makePrvKeyU n)
|
@ -1,47 +1,37 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Crypto.Mnemonic.Tests (tests) where
|
||||
module Network.Haskoin.Crypto.Mnemonic.Tests (spec) where
|
||||
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import Data.Either (fromRight)
|
||||
import Data.Serialize (Serialize, encode)
|
||||
import Data.Word (Word32, Word64)
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import Data.Either (fromRight)
|
||||
import Data.Serialize (Serialize, encode)
|
||||
import Data.Word (Word32, Word64)
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck (Arbitrary, Property,
|
||||
arbitrary, choose, (==>))
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck hiding ((.&.))
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "Encode mnemonic"
|
||||
[ testProperty "128-bit entropy -> 12 words" toMnemonic128
|
||||
, testProperty "160-bit entropy -> 18 words" toMnemonic160
|
||||
, testProperty "256-bit entropy -> 24 words" toMnemonic256
|
||||
, testProperty "512-bit entropy -> 48 words" toMnemonic512
|
||||
, testProperty "n-bit entropy -> m words" toMnemonicVar
|
||||
]
|
||||
, testGroup "Encode/Decode Mnemonic"
|
||||
[ testProperty "128-bit entropy" fromToMnemonic128
|
||||
, testProperty "160-bit entropy" fromToMnemonic160
|
||||
, testProperty "256-bit entropy" fromToMnemonic256
|
||||
, testProperty "512-bit entropy" fromToMnemonic512
|
||||
, testProperty "n-bit entropy" fromToMnemonicVar
|
||||
]
|
||||
, testGroup "Mnemonic to seed"
|
||||
[ testProperty "128-bit entropy" mnemonicToSeed128
|
||||
, testProperty "160-bit entropy" mnemonicToSeed160
|
||||
, testProperty "256-bit entropy" mnemonicToSeed256
|
||||
, testProperty "512-bit entropy" mnemonicToSeed512
|
||||
, testProperty "n-bit entropy" mnemonicToSeedVar
|
||||
]
|
||||
, testGroup "Get bits from ByteString"
|
||||
[ testProperty "Byte count" getBitsByteCount
|
||||
, testProperty "End bits" getBitsEndBits
|
||||
]
|
||||
]
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "mnemonic" $ do
|
||||
it "generate 12 words" $ property toMnemonic128
|
||||
it "generate 18 words" $ property toMnemonic160
|
||||
it "generate 24 words" $ property toMnemonic256
|
||||
it "generate 48 words" $ property toMnemonic512
|
||||
it "generate any number of words" $ property toMnemonicVar
|
||||
it "encode and decode 128-bit entropy" $ property fromToMnemonic128
|
||||
it "encode and decode 160-bit entropy" $ property fromToMnemonic160
|
||||
it "encode and decode 256-bit entropy" $ property fromToMnemonic256
|
||||
it "encode and decode 512-bit entropy" $ property fromToMnemonic512
|
||||
it "encode and decode n-bit entropy" $ property fromToMnemonicVar
|
||||
it "convert 128-bit mnemonic to seed" $ property mnemonicToSeed128
|
||||
it "convert 160-bit mnemonic to seed" $ property mnemonicToSeed160
|
||||
it "convert 256-bit mnemonic to seed" $ property mnemonicToSeed256
|
||||
it "convert 512-bit mnemonic to seed" $ property mnemonicToSeed512
|
||||
it "convert n-bit mnemonic to seed" $ property mnemonicToSeedVar
|
||||
it "get bits" $ property getBitsByteCount
|
||||
it "get end bits" $ property getBitsEndBits
|
||||
|
||||
binWordsToBS :: Serialize a => [a] -> BS.ByteString
|
||||
binWordsToBS = foldr f BS.empty
|
@ -1,72 +1,64 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Crypto.Mnemonic.Units (tests) where
|
||||
module Network.Haskoin.Crypto.Mnemonic.Units (spec) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import Data.Either (fromRight)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import Data.Either (fromRight)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (assertBool, assertEqual)
|
||||
import Test.Hspec
|
||||
import Test.HUnit
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "Entropy to mnemonic sentence" toMnemonicTest
|
||||
, testGroup "Mnemonic sentence to entropy" fromMnemonicTest
|
||||
, testGroup "Mnemonic sentence to seed" mnemonicToSeedTest
|
||||
, testGroup "Mnemonic sentence with invalid checksum" fromMnemonicInvalidTest
|
||||
, testGroup "Empty mnemonic sentence is invalid" [emptyMnemonicTest]
|
||||
]
|
||||
spec :: Spec
|
||||
spec = describe "mnemonic units" $ do
|
||||
it "entropy to mnemonic sentence" toMnemonicTest
|
||||
it "mnemonic sentence to entropy" fromMnemonicTest
|
||||
it "mnemonic sentence to seed" mnemonicToSeedTest
|
||||
it "mnemonic sentence with invalid checksum" fromMnemonicInvalidTest
|
||||
it "empty mnemonic sentence is invalid" $ sequence_ [emptyMnemonicTest]
|
||||
|
||||
toMnemonicTest :: [Test]
|
||||
toMnemonicTest = zipWith f ents mss
|
||||
toMnemonicTest :: Assertion
|
||||
toMnemonicTest = sequence_ $ zipWith f ents mss
|
||||
where
|
||||
f e m = g (cs e) . assertEqual "" m . h $ e
|
||||
g = testCase
|
||||
f e m = assertEqual "" m . h $ e
|
||||
h =
|
||||
fromRight (error "Could not decode mnemonic sentence") .
|
||||
toMnemonic . fromJust . decodeHex
|
||||
|
||||
fromMnemonicTest :: [Test]
|
||||
fromMnemonicTest = zipWith f ents mss
|
||||
fromMnemonicTest :: Assertion
|
||||
fromMnemonicTest = sequence_ $ zipWith f ents mss
|
||||
where
|
||||
f e = g (cs e) . assertEqual "" e . h
|
||||
g = testCase
|
||||
f e = assertEqual "" e . h
|
||||
h =
|
||||
encodeHex .
|
||||
fromRight (error "Could not decode mnemonic sentence") . fromMnemonic
|
||||
|
||||
mnemonicToSeedTest :: [Test]
|
||||
mnemonicToSeedTest = zipWith f mss seeds
|
||||
mnemonicToSeedTest :: Assertion
|
||||
mnemonicToSeedTest = sequence_ $ zipWith f mss seeds
|
||||
where
|
||||
f m s = g s . assertEqual "" s . h $ m
|
||||
g = testCase . (++ "...") . cs . BS.take 50
|
||||
f m s = assertEqual "" s . h $ m
|
||||
h =
|
||||
encodeHex .
|
||||
fromRight (error "Could not decode mnemonic seed") .
|
||||
mnemonicToSeed "TREZOR"
|
||||
|
||||
fromMnemonicInvalidTest :: [Test]
|
||||
fromMnemonicInvalidTest = map f invalidMss
|
||||
fromMnemonicInvalidTest :: Assertion
|
||||
fromMnemonicInvalidTest = sequence_ $ map f invalidMss
|
||||
where
|
||||
f m = g m . assertBool "" . h $ m
|
||||
g m = let ms = length (C.words m)
|
||||
msg = concat [ "[MS: ", show ms, "]"
|
||||
, cs (BS.take 50 m), "..." ]
|
||||
in testCase msg
|
||||
f m = assertBool "" . h $ m
|
||||
h m = case fromMnemonic m of
|
||||
Right _ -> False
|
||||
Left err -> "fromMnemonic: checksum failed:" `isPrefixOf` err
|
||||
|
||||
emptyMnemonicTest :: Test
|
||||
emptyMnemonicTest = testCase "mnemonic sentence can not be empty" $
|
||||
assertBool "" $ case fromMnemonic "" of
|
||||
Right _ -> False
|
||||
emptyMnemonicTest :: Assertion
|
||||
emptyMnemonicTest =
|
||||
assertBool "" $
|
||||
case fromMnemonic "" of
|
||||
Right _ -> False
|
||||
Left err -> "fromMnemonic: empty mnemonic" `isPrefixOf` err
|
||||
|
||||
ents :: [ByteString]
|
@ -1,18 +1,18 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Crypto.Units (tests) where
|
||||
module Network.Haskoin.Crypto.Units (spec) where
|
||||
|
||||
import Control.Monad (replicateM_)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Crypto.Secp256k1 as EC (SecKey, exportCompactSig)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as C (pack)
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.Serialize (encode)
|
||||
import Control.Monad (replicateM_)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Crypto.Secp256k1 as EC (SecKey, exportCompactSig)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as C (pack)
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.Serialize (encode)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
|
||||
-- Unit tests copied from bitcoind implementation
|
||||
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_tests.cpp
|
||||
@ -51,16 +51,16 @@ sigMsg =
|
||||
]
|
||||
|
||||
sec1 :: PrvKey
|
||||
sec1 = fromJust $ fromWif strSecret1
|
||||
sec1 = fromJust $ fromWif btc strSecret1
|
||||
|
||||
sec2 :: PrvKey
|
||||
sec2 = fromJust $ fromWif strSecret2
|
||||
sec2 = fromJust $ fromWif btc strSecret2
|
||||
|
||||
sec1C :: PrvKey
|
||||
sec1C = fromJust $ fromWif strSecret1C
|
||||
sec1C = fromJust $ fromWif btc strSecret1C
|
||||
|
||||
sec2C :: PrvKey
|
||||
sec2C = fromJust $ fromWif strSecret2C
|
||||
sec2C = fromJust $ fromWif btc strSecret2C
|
||||
|
||||
pub1 :: PubKey
|
||||
pub1 = derivePubKey sec1
|
||||
@ -74,35 +74,34 @@ pub1C = derivePubKey sec1C
|
||||
pub2C :: PubKey
|
||||
pub2C = derivePubKey sec2C
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "ECDSA PRNG unit tests"
|
||||
[ testCase "genPrvKey produces unique keys" uniqueKeys
|
||||
]
|
||||
, testGroup "bitcoind /src/test/key_tests.cpp" $
|
||||
[ testCase "Decode Valid WIF" checkPrivkey
|
||||
, testCase "Decode Invalid WIF" checkInvalidKey
|
||||
, testCase "Decode MiniKey format" checkMiniKey
|
||||
, testCase "Check private key compression" checkPrvKeyCompressed
|
||||
, testCase "Check public key compression" checkKeyCompressed
|
||||
, testCase "Check matching address" checkMatchingAddress
|
||||
] ++
|
||||
map (\x -> testCase ("Check sig: " ++ show x) $ checkSignatures (doubleSHA256 x)) sigMsg
|
||||
, testGroup "Trezor RFC 6979 Test Vectors"
|
||||
[ testCase "RFC 6979 Test Vector 1" (testSigning $ head detVec)
|
||||
, testCase "RFC 6979 Test Vector 2" (testSigning $ detVec !! 1)
|
||||
, testCase "RFC 6979 Test Vector 3" (testSigning $ detVec !! 2)
|
||||
, testCase "RFC 6979 Test Vector 4" (testSigning $ detVec !! 3)
|
||||
, testCase "RFC 6979 Test Vector 5" (testSigning $ detVec !! 4)
|
||||
, testCase "RFC 6979 Test Vector 6" (testSigning $ detVec !! 5)
|
||||
, testCase "RFC 6979 Test Vector 7" (testSigning $ detVec !! 6)
|
||||
, testCase "RFC 6979 Test Vector 8" (testSigning $ detVec !! 7)
|
||||
, testCase "RFC 6979 Test Vector 9" (testSigning $ detVec !! 8)
|
||||
, testCase "RFC 6979 Test Vector 10" (testSigning $ detVec !! 9)
|
||||
, testCase "RFC 6979 Test Vector 11" (testSigning $ detVec !! 10)
|
||||
, testCase "RFC 6979 Test Vector 12" (testSigning $ detVec !! 11)
|
||||
]
|
||||
]
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "ECDSA PRNG unit tests" $
|
||||
it "genPrvKey produces unique keys" uniqueKeys
|
||||
describe "bitcoind /src/test/key_tests.cpp" $ do
|
||||
it "decode valid WIF" checkPrivkey
|
||||
it "decode invalid WIF" checkInvalidKey
|
||||
it "decode minikey format" checkMiniKey
|
||||
it "check private key compression" checkPrvKeyCompressed
|
||||
it "check public key compression" checkKeyCompressed
|
||||
it "check matching address" checkMatchingAddress
|
||||
mapM_
|
||||
(\x ->
|
||||
it ("check sig: " ++ show x) $ checkSignatures (doubleSHA256 x))
|
||||
sigMsg
|
||||
describe "trezor RFC 6979 test vectors" $ do
|
||||
it "RFC 6979 test vector 1" (testSigning $ head detVec)
|
||||
it "RFC 6979 test vector 2" (testSigning $ detVec !! 1)
|
||||
it "RFC 6979 test vector 3" (testSigning $ detVec !! 2)
|
||||
it "RFC 6979 test vector 4" (testSigning $ detVec !! 3)
|
||||
it "RFC 6979 test vector 5" (testSigning $ detVec !! 4)
|
||||
it "RFC 6979 test vector 6" (testSigning $ detVec !! 5)
|
||||
it "RFC 6979 test vector 7" (testSigning $ detVec !! 6)
|
||||
it "RFC 6979 test vector 8" (testSigning $ detVec !! 7)
|
||||
it "RFC 6979 test vector 9" (testSigning $ detVec !! 8)
|
||||
it "RFC 6979 test vector 10" (testSigning $ detVec !! 9)
|
||||
it "RFC 6979 test vector 11" (testSigning $ detVec !! 10)
|
||||
it "RFC 6979 test vector 12" (testSigning $ detVec !! 11)
|
||||
|
||||
{- ECDSA PRNG unit tests -}
|
||||
|
||||
@ -120,14 +119,14 @@ uniqueKeys = do
|
||||
|
||||
checkPrivkey :: Assertion
|
||||
checkPrivkey = do
|
||||
assertBool "Key 1" $ isJust $ fromWif strSecret1
|
||||
assertBool "Key 2" $ isJust $ fromWif strSecret2
|
||||
assertBool "Key 1C" $ isJust $ fromWif strSecret1C
|
||||
assertBool "Key 2C" $ isJust $ fromWif strSecret2C
|
||||
assertBool "Key 1" $ isJust $ fromWif btc strSecret1
|
||||
assertBool "Key 2" $ isJust $ fromWif btc strSecret2
|
||||
assertBool "Key 1C" $ isJust $ fromWif btc strSecret1C
|
||||
assertBool "Key 2C" $ isJust $ fromWif btc strSecret2C
|
||||
|
||||
checkInvalidKey :: Assertion
|
||||
checkInvalidKey =
|
||||
assertBool "Bad key" $ isNothing $ fromWif strAddressBad
|
||||
assertBool "Bad key" $ isNothing $ fromWif btc strAddressBad
|
||||
|
||||
checkMiniKey :: Assertion
|
||||
checkMiniKey =
|
||||
@ -156,10 +155,10 @@ checkKeyCompressed = do
|
||||
|
||||
checkMatchingAddress :: Assertion
|
||||
checkMatchingAddress = do
|
||||
assertBool "Key 1" $ Just addr1 == addrToString (pubKeyAddr pub1)
|
||||
assertBool "Key 2" $ Just addr2 == addrToString (pubKeyAddr pub2)
|
||||
assertBool "Key 1C" $ Just addr1C == addrToString (pubKeyAddr pub1C)
|
||||
assertBool "Key 2C" $ Just addr2C == addrToString (pubKeyAddr pub2C)
|
||||
assertBool "Key 1" $ Just addr1 == addrToString (pubKeyAddr btc pub1)
|
||||
assertBool "Key 2" $ Just addr2 == addrToString (pubKeyAddr btc pub2)
|
||||
assertBool "Key 1C" $ Just addr1C == addrToString (pubKeyAddr btc pub1C)
|
||||
assertBool "Key 2C" $ Just addr2C == addrToString (pubKeyAddr btc pub2C)
|
||||
|
||||
checkSignatures :: Hash256 -> Assertion
|
||||
checkSignatures h = do
|
50
test/Network/Haskoin/Json/Tests.hs
Normal file
50
test/Network/Haskoin/Json/Tests.hs
Normal file
@ -0,0 +1,50 @@
|
||||
module Network.Haskoin.Json.Tests
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Data.HashMap.Strict (singleton)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "serialize & de-serialize haskoin types to json" $ do
|
||||
it "encodes and decodes script output" $
|
||||
forAll (arbitraryScriptOutput net) testID
|
||||
it "encodes and decodes outpoint" $ forAll arbitraryOutPoint testID
|
||||
it "encodes and decodes address" $
|
||||
forAll (arbitraryAddress net) (testCustom (addrFromJSON net))
|
||||
it "encodes and decodes transaction" $ forAll (arbitraryTx net) testID
|
||||
it "encodes and decodes transaction hash" $
|
||||
forAll arbitraryTxHash testID
|
||||
it "encodes and decodes block hash" $ forAll arbitraryBlockHash testID
|
||||
it "encodes and decodes sighash" $ forAll arbitrarySigHash testID
|
||||
it "encodes and decodes siginput" $
|
||||
forAll (arbitrarySigInput net) (testID . fst)
|
||||
it "encodes and decodes public key" $
|
||||
forAll arbitraryPubKey (testID . snd)
|
||||
it "encodes and decodes compressed public key" $
|
||||
forAll arbitraryPubKeyC (testID . snd)
|
||||
it "encodes and decodes uncompressed public key" $
|
||||
forAll arbitraryPubKeyU (testID . snd)
|
||||
it "encodes and decodes extended private key" $
|
||||
forAll (arbitraryXPrvKey net) (testCustom (xPrvFromJSON net))
|
||||
it "encodes and decodes extended public key" $
|
||||
forAll (arbitraryXPubKey net) (testCustom (xPubFromJSON net) . snd)
|
||||
it "encodes and decodes derivation path" $
|
||||
forAll arbitraryDerivPath testID
|
||||
it "encodes and decodes parsed derivation path" $
|
||||
forAll arbitraryParsedPath testID
|
||||
|
||||
testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool
|
||||
testID x =
|
||||
(decode . encode) (singleton ("object" :: String) x) ==
|
||||
Just (singleton ("object" :: String) x)
|
||||
|
||||
testCustom :: (ToJSON a, Eq a) => (Value -> Parser a) -> a -> Bool
|
||||
testCustom f x = parseMaybe f (toJSON x) == Just x
|
@ -1,26 +1,23 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Network.Units (tests) where
|
||||
module Network.Haskoin.Network.Units (spec) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Serialize (encode)
|
||||
import Data.Word (Word32)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Serialize (encode)
|
||||
import Data.Word (Word32)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Network
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ -- Test cases come from bitcoind /src/test/bloom_tests.cpp
|
||||
testGroup "Bloom Filters"
|
||||
[ testCase "Bloom Filter Vector 1" bloomFilter1
|
||||
, testCase "Bloom Filter Vector 2" bloomFilter2
|
||||
, testCase "Bloom Filter Vector 3" bloomFilter3
|
||||
]
|
||||
]
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "bloom filters" $ do
|
||||
it "bloom filter vector 1" bloomFilter1
|
||||
it "bloom filter vector 2" bloomFilter2
|
||||
it "bloom filter vector 3" bloomFilter3
|
||||
|
||||
bloomFilter :: Word32 -> ByteString -> Assertion
|
||||
bloomFilter n x = do
|
||||
@ -55,7 +52,7 @@ bloomFilter3 =
|
||||
where
|
||||
f0 = bloomCreate 2 0.001 0 BloomUpdateAll
|
||||
f1 = bloomInsert f0 $ encode p
|
||||
f2 = bloomInsert f1 $ encode $ getAddrHash $ pubKeyAddr p
|
||||
k = fromJust $ fromWif "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C"
|
||||
f2 = bloomInsert f1 $ encode $ getAddrHash $ pubKeyAddr btc p
|
||||
k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C"
|
||||
p = derivePubKey k
|
||||
bs = fromJust $ decodeHex "038fc16b080000000000000001"
|
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Script.Spec where
|
||||
module Network.Haskoin.Script.Spec (spec) where
|
||||
|
||||
import Control.Monad
|
||||
import qualified Crypto.Secp256k1 as EC
|
||||
@ -15,6 +15,7 @@ import Data.Serialize
|
||||
import Data.String
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Script
|
||||
import Network.Haskoin.Test
|
||||
@ -24,59 +25,55 @@ import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Text.Read
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
standardSpec
|
||||
strictSigSpec
|
||||
scriptSpec
|
||||
sigHashSpec
|
||||
txSigHashSpec
|
||||
spec :: Network -> Spec
|
||||
spec net = do
|
||||
describe "scripts" $ do
|
||||
standardSpec net
|
||||
strictSigSpec net
|
||||
scriptSpec net
|
||||
txSigHashForkIdSpec net
|
||||
forkIdScriptSpec net
|
||||
describe "sighash" $ do
|
||||
sigHashSpec net
|
||||
txSigHashSpec net
|
||||
|
||||
forkIdSpec :: Spec
|
||||
forkIdSpec = do
|
||||
txSigHashForkIdSpec
|
||||
forkIdScriptSpec
|
||||
standardSpec :: Network -> Spec
|
||||
standardSpec net = do
|
||||
it "has intToScriptOp . scriptOpToInt identity" $
|
||||
property $
|
||||
forAll arbitraryIntScriptOp $ \i ->
|
||||
intToScriptOp <$> scriptOpToInt i `shouldBe` Right i
|
||||
it "has decodeOutput . encodeOutput identity" $
|
||||
property $
|
||||
forAll (arbitraryScriptOutput net) $ \so ->
|
||||
decodeOutput (encodeOutput so) `shouldBe` Right so
|
||||
it "has decodeInput . encodeOutput identity" $
|
||||
property $
|
||||
forAll arbitraryScriptInput $ \si ->
|
||||
decodeInput net (encodeInput si) `shouldBe` Right si
|
||||
it "can sort multisig scripts" $
|
||||
forAll arbitraryMSOutput $ \out ->
|
||||
map encode (getOutputMulSigKeys (sortMulSig out)) `shouldSatisfy` \xs ->
|
||||
xs == sort xs
|
||||
it "can decode inputs with empty signatures" $ do
|
||||
decodeInput net (Script [OP_0]) `shouldBe`
|
||||
Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||
decodeInput net (Script [opPushData ""]) `shouldBe`
|
||||
Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||
let pk =
|
||||
derivePubKey $
|
||||
makePrvKey $ fromJust $ EC.secKey $ BS.replicate 32 1
|
||||
decodeInput net (Script [OP_0, opPushData $ encode pk]) `shouldBe`
|
||||
Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
|
||||
decodeInput net (Script [OP_0, OP_0]) `shouldBe`
|
||||
Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
|
||||
decodeInput net (Script [OP_0, OP_0, OP_0, OP_0]) `shouldBe`
|
||||
Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))
|
||||
|
||||
standardSpec :: Spec
|
||||
standardSpec =
|
||||
describe "Network.Haskoin.Script.Standard" $ do
|
||||
it "has intToScriptOp . scriptOpToInt identity" $
|
||||
property $
|
||||
forAll arbitraryIntScriptOp $ \i ->
|
||||
intToScriptOp <$> scriptOpToInt i `shouldBe` Right i
|
||||
it "has decodeOutput . encodeOutput identity" $
|
||||
property $
|
||||
forAll arbitraryScriptOutput $ \so ->
|
||||
decodeOutput (encodeOutput so) `shouldBe` Right so
|
||||
it "has decodeInput . encodeOutput identity" $
|
||||
property $
|
||||
forAll arbitraryScriptInput $ \si ->
|
||||
decodeInput (encodeInput si) `shouldBe` Right si
|
||||
it "can sort multisig scripts" $
|
||||
forAll arbitraryMSOutput $ \out ->
|
||||
map encode (getOutputMulSigKeys (sortMulSig out))
|
||||
`shouldSatisfy`
|
||||
\xs -> xs == sort xs
|
||||
it "can decode inputs with empty signatures" $ do
|
||||
decodeInput (Script [OP_0]) `shouldBe`
|
||||
Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||
decodeInput (Script [opPushData ""]) `shouldBe`
|
||||
Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||
let pk =
|
||||
derivePubKey $
|
||||
makePrvKey $ fromJust $ EC.secKey $ BS.replicate 32 1
|
||||
decodeInput (Script [OP_0, opPushData $ encode pk]) `shouldBe`
|
||||
Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
|
||||
decodeInput (Script [OP_0, OP_0]) `shouldBe`
|
||||
Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
|
||||
decodeInput (Script [OP_0, OP_0, OP_0, OP_0]) `shouldBe`
|
||||
Right
|
||||
(RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))
|
||||
|
||||
scriptSpec :: Spec
|
||||
scriptSpec =
|
||||
describe "Network.Haskoin.Script Verifier" $
|
||||
it "Can verify standard scripts from script_tests.json file" $ do
|
||||
scriptSpec :: Network -> Spec
|
||||
scriptSpec net =
|
||||
when (getNetworkName net == "btc") $
|
||||
it "can verify standard scripts from script_tests.json file" $ do
|
||||
xs <- readTestFile "script_tests" :: IO [J.Value]
|
||||
let vectorsA =
|
||||
mapMaybe (J.decode . J.encode) xs :: [( String
|
||||
@ -91,7 +88,9 @@ scriptSpec =
|
||||
, String
|
||||
, String
|
||||
, String)]
|
||||
vectors = map (\(a,b,c,d,e) -> ([0],a,b,c,d,e)) vectorsA <> vectorsB
|
||||
vectors =
|
||||
map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA <>
|
||||
vectorsB
|
||||
length vectors `shouldBe` 86
|
||||
forM_ vectors $ \([val], siStr, soStr, flags, res, _)
|
||||
-- We can disable specific tests by adding a DISABLED flag in the data
|
||||
@ -108,6 +107,7 @@ scriptSpec =
|
||||
decodeOutputBS scriptPubKey
|
||||
ver =
|
||||
verifyStdInput
|
||||
net
|
||||
strict
|
||||
(spendTx scriptPubKey 0 scriptSig)
|
||||
0
|
||||
@ -115,12 +115,12 @@ scriptSpec =
|
||||
(val * 100000000)
|
||||
case res of
|
||||
"OK" -> ver `shouldBe` True
|
||||
_ -> ver `shouldBe` False
|
||||
_ -> ver `shouldBe` False
|
||||
|
||||
forkIdScriptSpec :: Spec
|
||||
forkIdScriptSpec =
|
||||
describe "Network.Haskoin.Script ForkID Verifier" $
|
||||
it "Can verify scripts from forkid_script_tests.json file" $ do
|
||||
forkIdScriptSpec :: Network -> Spec
|
||||
forkIdScriptSpec net =
|
||||
when (isJust (getSigHashForkId net)) $
|
||||
it "can verify scripts from forkid_script_tests.json file" $ do
|
||||
xs <- readTestFile "forkid_script_tests" :: IO [J.Value]
|
||||
let vectors =
|
||||
mapMaybe (J.decode . J.encode) xs :: [( [Word64]
|
||||
@ -128,7 +128,7 @@ forkIdScriptSpec =
|
||||
, String
|
||||
, String
|
||||
, String
|
||||
, String )]
|
||||
, String)]
|
||||
length vectors `shouldBe` 3
|
||||
forM_ vectors $ \([valBTC], siStr, soStr, _, res, _) -> do
|
||||
let val = valBTC * 100000000
|
||||
@ -139,6 +139,7 @@ forkIdScriptSpec =
|
||||
decodeOutputBS scriptPubKey
|
||||
ver =
|
||||
verifyStdInput
|
||||
net
|
||||
True -- Always strict
|
||||
(spendTx scriptPubKey val scriptSig)
|
||||
0
|
||||
@ -146,7 +147,7 @@ forkIdScriptSpec =
|
||||
val
|
||||
case res of
|
||||
"OK" -> ver `shouldBe` True
|
||||
_ -> ver `shouldBe` False
|
||||
_ -> ver `shouldBe` False
|
||||
|
||||
creditTx :: BS.ByteString -> Word64 -> Tx
|
||||
creditTx scriptPubKey val =
|
||||
@ -186,25 +187,25 @@ replaceToken str = case readMaybe $ "OP_" <> str of
|
||||
Just opcode -> "0x" <> cs (encodeHex $ encode (opcode :: ScriptOp))
|
||||
_ -> str
|
||||
|
||||
strictSigSpec :: Spec
|
||||
strictSigSpec =
|
||||
describe "Network.Haskoin.Script Strict" $ do
|
||||
strictSigSpec :: Network -> Spec
|
||||
strictSigSpec net =
|
||||
when (getNetworkName net == "btc") $ do
|
||||
it "can decode strict signatures" $ do
|
||||
xs <- readTestFile "sig_strict"
|
||||
let vectors = mapMaybe (decodeHex . cs) (xs :: [String])
|
||||
length vectors `shouldBe` 3
|
||||
forM_ vectors $ \sig ->
|
||||
decodeTxStrictSig sig `shouldSatisfy` isRight
|
||||
decodeTxStrictSig net sig `shouldSatisfy` isRight
|
||||
it "can detect non-strict signatures" $ do
|
||||
xs <- readTestFile "sig_nonstrict"
|
||||
let vectors = mapMaybe (decodeHex . cs) (xs :: [String])
|
||||
length vectors `shouldBe` 17
|
||||
forM_ vectors $ \sig ->
|
||||
decodeTxStrictSig sig `shouldSatisfy` isLeft
|
||||
decodeTxStrictSig net sig `shouldSatisfy` isLeft
|
||||
|
||||
txSigHashSpec :: Spec
|
||||
txSigHashSpec =
|
||||
describe "Network.Haskoin.Script txSigHash" $
|
||||
txSigHashSpec :: Network -> Spec
|
||||
txSigHashSpec net =
|
||||
when (getNetworkName net == "btc") $
|
||||
it "can produce valid sighashes from sighash.json test vectors" $ do
|
||||
xs <- readTestFile "sighash" :: IO [J.Value]
|
||||
let vectors =
|
||||
@ -223,11 +224,11 @@ txSigHashSpec =
|
||||
res =
|
||||
eitherToMaybe . decode . BS.reverse =<<
|
||||
decodeHex (cs resStr)
|
||||
Just (txSigHash tx s 0 i sh) `shouldBe` res
|
||||
Just (txSigHash net tx s 0 i sh) `shouldBe` res
|
||||
|
||||
txSigHashForkIdSpec :: Spec
|
||||
txSigHashForkIdSpec =
|
||||
describe "Network.Haskoin.Script txSigHashForkId" $
|
||||
txSigHashForkIdSpec :: Network -> Spec
|
||||
txSigHashForkIdSpec net =
|
||||
when (getNetworkName net == "btc") $
|
||||
it "can produce valid sighashes from forkid_sighash.json test vectors" $ do
|
||||
xs <- readTestFile "forkid_sighash" :: IO [J.Value]
|
||||
let vectors =
|
||||
@ -245,79 +246,77 @@ txSigHashForkIdSpec =
|
||||
eitherToMaybe . decode =<< decodeHex (cs scpStr)
|
||||
sh = fromIntegral shI
|
||||
res = eitherToMaybe . decode =<< decodeHex (cs resStr)
|
||||
Just (txSigHashForkId tx s val i sh) `shouldBe` res
|
||||
Just (txSigHashForkId net tx s val i sh) `shouldBe` res
|
||||
|
||||
sigHashSpec :: Spec
|
||||
sigHashSpec =
|
||||
describe "Network.Haskoin.Script.SigHash" $ do
|
||||
it "can read . show a SigHash" $
|
||||
property $
|
||||
forAll arbitrarySigHash $ \sh -> read (show sh) `shouldBe` sh
|
||||
it "can correctly show a SigHash" $ do
|
||||
show (0x00 :: SigHash) `shouldBe` "SigHash " <> show 0x00
|
||||
show (0x01 :: SigHash) `shouldBe` "SigHash " <> show 0x01
|
||||
show (0xff :: SigHash) `shouldBe` "SigHash " <> show 0xff
|
||||
show (0xabac3344 :: SigHash) `shouldBe` "SigHash " <>
|
||||
show 0xabac3344
|
||||
it "can add a forkid to a SigHash" $ do
|
||||
0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00
|
||||
0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff
|
||||
0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff
|
||||
0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff
|
||||
0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff
|
||||
0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001
|
||||
0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003
|
||||
it "can extract a forkid from a sighash" $ do
|
||||
sigHashGetForkId 0x00000000 `shouldBe` 0x00000000
|
||||
sigHashGetForkId 0x80000000 `shouldBe` 0x00800000
|
||||
sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff
|
||||
sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34
|
||||
it "can build some SigHash vectors" $ do
|
||||
sigHashAll `shouldBe` 0x01
|
||||
sigHashNone `shouldBe` 0x02
|
||||
sigHashSingle `shouldBe` 0x03
|
||||
setForkIdFlag sigHashAll `shouldBe` 0x41
|
||||
setAnyoneCanPayFlag sigHashAll `shouldBe` 0x81
|
||||
setAnyoneCanPayFlag (setForkIdFlag sigHashAll) `shouldBe` 0xc1
|
||||
it "can test the SigHash flags" $ do
|
||||
hasForkIdFlag sigHashAll `shouldBe` False
|
||||
hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True
|
||||
hasAnyoneCanPayFlag sigHashAll `shouldBe` False
|
||||
hasAnyoneCanPayFlag (setAnyoneCanPayFlag sigHashAll) `shouldBe` True
|
||||
isSigHashAll sigHashNone `shouldBe` False
|
||||
isSigHashAll sigHashAll `shouldBe` True
|
||||
isSigHashNone sigHashSingle `shouldBe` False
|
||||
isSigHashNone sigHashNone `shouldBe` True
|
||||
isSigHashSingle sigHashAll `shouldBe` False
|
||||
isSigHashSingle sigHashSingle `shouldBe` True
|
||||
isSigHashUnknown sigHashAll `shouldBe` False
|
||||
isSigHashUnknown sigHashNone `shouldBe` False
|
||||
isSigHashUnknown sigHashSingle `shouldBe` False
|
||||
isSigHashUnknown 0x00 `shouldBe` True
|
||||
isSigHashUnknown 0x04 `shouldBe` True
|
||||
it "can decodeTxLaxSig . encode a TxSignature" $
|
||||
property $
|
||||
forAll arbitraryTxSignature $ \(_, _, ts) ->
|
||||
decodeTxLaxSig (encodeTxSig ts) `shouldBe` Right ts
|
||||
sigHashSpec :: Network -> Spec
|
||||
sigHashSpec net = do
|
||||
it "can read . show" $
|
||||
property $ forAll arbitrarySigHash $ \sh -> read (show sh) `shouldBe` sh
|
||||
it "can correctly show" $ do
|
||||
show (0x00 :: SigHash) `shouldBe` "SigHash " <> show 0x00
|
||||
show (0x01 :: SigHash) `shouldBe` "SigHash " <> show 0x01
|
||||
show (0xff :: SigHash) `shouldBe` "SigHash " <> show 0xff
|
||||
show (0xabac3344 :: SigHash) `shouldBe` "SigHash " <> show 0xabac3344
|
||||
it "can add a forkid" $ do
|
||||
0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00
|
||||
0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff
|
||||
0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff
|
||||
0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff
|
||||
0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff
|
||||
0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001
|
||||
0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003
|
||||
it "can extract a forkid" $ do
|
||||
sigHashGetForkId 0x00000000 `shouldBe` 0x00000000
|
||||
sigHashGetForkId 0x80000000 `shouldBe` 0x00800000
|
||||
sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff
|
||||
sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34
|
||||
it "can build some vectors" $ do
|
||||
sigHashAll `shouldBe` 0x01
|
||||
sigHashNone `shouldBe` 0x02
|
||||
sigHashSingle `shouldBe` 0x03
|
||||
setForkIdFlag sigHashAll `shouldBe` 0x41
|
||||
setAnyoneCanPayFlag sigHashAll `shouldBe` 0x81
|
||||
setAnyoneCanPayFlag (setForkIdFlag sigHashAll) `shouldBe` 0xc1
|
||||
it "can test flags" $ do
|
||||
hasForkIdFlag sigHashAll `shouldBe` False
|
||||
hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True
|
||||
hasAnyoneCanPayFlag sigHashAll `shouldBe` False
|
||||
hasAnyoneCanPayFlag (setAnyoneCanPayFlag sigHashAll) `shouldBe` True
|
||||
isSigHashAll sigHashNone `shouldBe` False
|
||||
isSigHashAll sigHashAll `shouldBe` True
|
||||
isSigHashNone sigHashSingle `shouldBe` False
|
||||
isSigHashNone sigHashNone `shouldBe` True
|
||||
isSigHashSingle sigHashAll `shouldBe` False
|
||||
isSigHashSingle sigHashSingle `shouldBe` True
|
||||
isSigHashUnknown sigHashAll `shouldBe` False
|
||||
isSigHashUnknown sigHashNone `shouldBe` False
|
||||
isSigHashUnknown sigHashSingle `shouldBe` False
|
||||
isSigHashUnknown 0x00 `shouldBe` True
|
||||
isSigHashUnknown 0x04 `shouldBe` True
|
||||
it "can decodeTxLaxSig . encode a TxSignature" $
|
||||
property $
|
||||
forAll arbitraryTxSignature $ \(_, _, ts) ->
|
||||
decodeTxLaxSig (encodeTxSig ts) `shouldBe` Right ts
|
||||
when (getNetworkName net == "btc") $
|
||||
it "can decodeTxStrictSig . encode a TxSignature" $
|
||||
property $
|
||||
forAll arbitraryTxSignature $ \(_, _, ts@(TxSignature _ sh)) ->
|
||||
if isSigHashUnknown sh || hasForkIdFlag sh
|
||||
then decodeTxStrictSig (encodeTxSig ts) `shouldSatisfy`
|
||||
isLeft
|
||||
else decodeTxStrictSig (encodeTxSig ts) `shouldBe` Right ts
|
||||
it "can produce the sighash one" $
|
||||
property $
|
||||
forAll arbitraryTx $ forAll arbitraryScript . testSigHashOne
|
||||
property $
|
||||
forAll arbitraryTxSignature $ \(_, _, ts@(TxSignature _ sh)) ->
|
||||
if isSigHashUnknown sh || hasForkIdFlag sh
|
||||
then decodeTxStrictSig net (encodeTxSig ts) `shouldSatisfy`
|
||||
isLeft
|
||||
else decodeTxStrictSig net (encodeTxSig ts) `shouldBe` Right ts
|
||||
it "can produce the sighash one" $
|
||||
property $
|
||||
forAll (arbitraryTx net) $ forAll arbitraryScript . testSigHashOne net
|
||||
|
||||
testSigHashOne :: Tx -> Script -> Word64 -> Bool -> Property
|
||||
testSigHashOne tx s val acp =
|
||||
testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property
|
||||
testSigHashOne net tx s val acp =
|
||||
not (null $ txIn tx) ==>
|
||||
if length (txIn tx) > length (txOut tx)
|
||||
then res `shouldBe` one
|
||||
else res `shouldNotBe` one
|
||||
where
|
||||
res = txSigHash tx s val (length (txIn tx) - 1) (f sigHashSingle)
|
||||
res = txSigHash net tx s val (length (txIn tx) - 1) (f sigHashSingle)
|
||||
one = "0100000000000000000000000000000000000000000000000000000000000000"
|
||||
f =
|
||||
if acp
|
||||
@ -328,5 +327,5 @@ testSigHashOne tx s val acp =
|
||||
|
||||
readTestFile :: J.FromJSON a => FilePath -> IO a
|
||||
readTestFile fp = do
|
||||
bs <- BL.readFile $ "test/data/" <> fp <> ".json"
|
||||
bs <- BL.readFile $ "data/" <> fp <> ".json"
|
||||
maybe (error $ "Could not read test file " <> fp) return $ J.decode bs
|
@ -1,54 +1,44 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Script.Tests
|
||||
( tests
|
||||
, execScriptIO
|
||||
, testValid
|
||||
, testInvalid
|
||||
, runTests
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.Aeson as A
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy.Char8 as CL
|
||||
import Data.Char (ord)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe (catMaybes, isNothing)
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Aeson as A
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy.Char8 as CL
|
||||
import Data.Char (ord)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe (catMaybes, isNothing)
|
||||
import Data.Serialize
|
||||
import Data.Word
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Script
|
||||
import Network.Haskoin.Transaction
|
||||
import Numeric (readHex)
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.Framework.Runners.Console (defaultMainWithArgs)
|
||||
import qualified Test.HUnit as HUnit
|
||||
import Text.Read (readMaybe)
|
||||
import Numeric (readHex)
|
||||
import Test.Hspec
|
||||
import Test.HUnit as HUnit
|
||||
import Test.QuickCheck
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"Integer Types"
|
||||
[ testProperty "decodeInt . encodeInt Int" testEncodeInt
|
||||
, testProperty "decodeFullInt . encodeInt Int" testEncodeInt64
|
||||
, testProperty "cltvDecodeInt . encodeInt Int" testEncodeCltv
|
||||
, testProperty "decodeBool . encodeBool Bool" testEncodeBool
|
||||
]
|
||||
, testFile
|
||||
"Canonical Valid Script Test Cases"
|
||||
"test/data/script_valid.json"
|
||||
True
|
||||
, testFile
|
||||
"Canonical Invalid Script Test Cases"
|
||||
"test/data/script_invalid.json"
|
||||
False
|
||||
]
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "integer types" $ do
|
||||
it "decodeInt . encodeInt Int" $ property testEncodeInt
|
||||
it "decodeFullInt . encodeInt Int" $ property testEncodeInt64
|
||||
it "cltvDecodeInt . encodeInt Int" $ property testEncodeCltv
|
||||
it "decodeBool . encodeBool Bool" $ property testEncodeBool
|
||||
describe "script file tests" $ do
|
||||
it "runs all canonical valid scripts" $
|
||||
testFile "data/script_valid.json" True
|
||||
it "runs all canonical invalid scripts" $
|
||||
testFile "data/script_invalid.json" False
|
||||
|
||||
{- Script Evaluation Primitives -}
|
||||
|
||||
@ -146,30 +136,20 @@ parseScript scriptString = do
|
||||
parseOp = encodeBytes <$> readMaybe ("OP_" ++ tok)
|
||||
encodeBytes = BS.unpack . encode
|
||||
|
||||
testFile :: String -> String -> Bool -> Test
|
||||
testFile groupLabel path expected =
|
||||
buildTest $ do
|
||||
dat <- CL.readFile path
|
||||
testFile :: String -> Bool -> Assertion
|
||||
testFile path expected =
|
||||
do
|
||||
dat <- liftIO $ CL.readFile path
|
||||
case A.decode dat :: Maybe [[String]] of
|
||||
Nothing ->
|
||||
return $
|
||||
testCase groupLabel $
|
||||
HUnit.assertFailure $ "can't read test file " ++ path
|
||||
Nothing -> assertFailure $ "can't read test file " ++ path
|
||||
Just testDefs ->
|
||||
return $
|
||||
testGroup groupLabel $
|
||||
map parseTest $ filterPureComments testDefs
|
||||
mapM_ parseTest $ filterPureComments testDefs
|
||||
where
|
||||
parseTest :: [String] -> Test
|
||||
parseTest s =
|
||||
case testParts s of
|
||||
Nothing ->
|
||||
testCase "can't parse test case" $
|
||||
HUnit.assertFailure $ "json element " ++ show s
|
||||
Nothing -> assertFailure $ "json element " ++ show s
|
||||
Just (sig, pubKey, flags, l) -> makeTest l sig pubKey flags
|
||||
makeTest :: String -> String -> String -> String -> Test
|
||||
makeTest l sig pubKey flags =
|
||||
testCase label' $
|
||||
case (parseScript sig, parseScript pubKey) of
|
||||
(Left e, _) ->
|
||||
parseError $ "can't parse sig: " ++ show sig ++ " error: " ++ e
|
||||
@ -215,32 +195,6 @@ testParts l =
|
||||
else let [sig, pubKey, flags] = x
|
||||
in Just (sig, pubKey, flags, comment)
|
||||
|
||||
-- repl utils
|
||||
|
||||
execScriptIO :: String -> String -> String -> IO ()
|
||||
execScriptIO sig key flgs =
|
||||
case (parseScript sig, parseScript key) of
|
||||
(Left e, _) -> print $ "sig parse error: " ++ e
|
||||
(_, Left e) -> print $ "key parse error: " ++ e
|
||||
(Right scriptSig, Right scriptPubKey) ->
|
||||
case execScript
|
||||
scriptSig
|
||||
scriptPubKey
|
||||
rejectSignature
|
||||
(parseFlags flgs) of
|
||||
Left e -> putStrLn $ "error " ++ show e
|
||||
Right p -> do
|
||||
putStrLn "successful execution"
|
||||
C.putStrLn $ dumpStack $ runStack p
|
||||
|
||||
testValid :: Test
|
||||
testValid = testFile "Canonical Valid Script Test Cases"
|
||||
"test/data/script_valid.json" True
|
||||
|
||||
testInvalid :: Test
|
||||
testInvalid = testFile "Canonical Valid Script Test Cases"
|
||||
"test/data/script_invalid.json" False
|
||||
|
||||
-- | Maximum value of sequence number
|
||||
maxSeqNum :: Word32
|
||||
maxSeqNum = 0xffffffff -- Perhaps this should be moved to constants.
|
||||
@ -292,8 +246,4 @@ scriptPairTestExec scriptSig pubKey flags =
|
||||
let bsScriptSig = encode scriptSig
|
||||
bsPubKey = encode pubKey
|
||||
spendTx = buildSpendTx bsScriptSig (buildCreditTx bsPubKey)
|
||||
in verifySpend spendTx 0 pubKey 0 flags
|
||||
|
||||
runTests :: [Test] -> IO ()
|
||||
runTests ts = defaultMainWithArgs ts ["--hide-success"]
|
||||
|
||||
in verifySpend btc spendTx 0 pubKey 0 flags
|
@ -1,33 +1,32 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Script.Units (tests) where
|
||||
module Network.Haskoin.Script.Units (spec) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either (fromLeft, fromRight, isRight)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Serialize (decode)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either (fromLeft, fromRight, isRight)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Serialize (decode)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Script
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "Multi Signatures"
|
||||
(zipWith (curry mapMulSigVector) mulSigVectors [0..])
|
||||
, testGroup "Signature decoding"
|
||||
(zipWith (curry sigDecodeMap) scriptSigSignatures [0..])
|
||||
]
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "multi signatures" $
|
||||
sequence_ $ zipWith (curry mapMulSigVector) mulSigVectors [0 ..]
|
||||
describe "signature decoding" $
|
||||
sequence_ $ zipWith (curry sigDecodeMap) scriptSigSignatures [0 ..]
|
||||
|
||||
mapMulSigVector :: ((ByteString, ByteString), Int) -> Test.Framework.Test
|
||||
mapMulSigVector :: ((ByteString, ByteString), Int) -> Spec
|
||||
mapMulSigVector (v, i) =
|
||||
testCase name $ runMulSigVector v
|
||||
it name $ runMulSigVector v
|
||||
where
|
||||
name = "MultiSignature vector " ++ show i
|
||||
name = "check multisig vector " <> show i
|
||||
|
||||
runMulSigVector :: (ByteString, ByteString) -> Assertion
|
||||
runMulSigVector (a, ops) = assertBool " > MultiSig Vector" $ Just a == b
|
||||
runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b
|
||||
where
|
||||
s = do
|
||||
s <- decodeHex ops
|
||||
@ -35,11 +34,11 @@ runMulSigVector (a, ops) = assertBool " > MultiSig Vector" $ Just a == b
|
||||
b = do
|
||||
o <- s
|
||||
d <- eitherToMaybe $ decodeOutput o
|
||||
addrToString $ p2shAddr d
|
||||
addrToString $ p2shAddr btc d
|
||||
|
||||
sigDecodeMap :: (ByteString, Int) -> Test.Framework.Test
|
||||
sigDecodeMap :: (ByteString, Int) -> Spec
|
||||
sigDecodeMap (_, i) =
|
||||
testCase ("Signature " ++ show i) func
|
||||
it ("check signature " ++ show i) func
|
||||
where
|
||||
func = testSigDecode $ scriptSigSignatures !! i
|
||||
|
@ -1,66 +1,70 @@
|
||||
module Network.Haskoin.Transaction.Tests (tests) where
|
||||
module Network.Haskoin.Transaction.Tests (spec) where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Either (fromRight, isRight)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Either (fromRight, isRight)
|
||||
import Data.Maybe
|
||||
import Data.Serialize (encode)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word64)
|
||||
import Data.Serialize (encode)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word64)
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Script
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Transaction
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"Transaction tests"
|
||||
[ testProperty "decode . encode Txid" $
|
||||
spec :: Network -> Spec
|
||||
spec net =
|
||||
describe "transaction" $ do
|
||||
it "decode and encode txid" $
|
||||
property $
|
||||
forAll arbitraryTxHash $ \h -> hexToTxHash (txHashToHex h) == Just h
|
||||
, testProperty "From string transaction id" $
|
||||
it "from string transaction id" $
|
||||
property $
|
||||
forAll arbitraryTxHash $ \h -> fromString (cs $ txHashToHex h) == h
|
||||
]
|
||||
, testGroup
|
||||
"Building Transactions"
|
||||
[ testProperty "building address tx" $
|
||||
forAll arbitraryAddress $ forAll arbitrarySatoshi . testBuildAddrTx
|
||||
, testProperty "testing guessTxSize function" $
|
||||
forAll arbitraryAddrOnlyTxFull testGuessSize
|
||||
, testProperty "testing chooseCoins function" $
|
||||
forAll (listOf arbitrarySatoshi) testChooseCoins
|
||||
, testProperty "testing chooseMSCoins function" $
|
||||
it "building address tx" $
|
||||
property $
|
||||
forAll (arbitraryAddress net) $
|
||||
forAll (arbitrarySatoshi net) . testBuildAddrTx net
|
||||
it "guess transaction size" $
|
||||
property $ forAll (arbitraryAddrOnlyTxFull net) (testGuessSize net)
|
||||
it "choose coins" $
|
||||
property $ forAll (listOf (arbitrarySatoshi net)) testChooseCoins
|
||||
it "choose multisig coins" $
|
||||
property $
|
||||
forAll arbitraryMSParam $
|
||||
forAll (listOf arbitrarySatoshi) . testChooseMSCoins
|
||||
]
|
||||
, testGroup
|
||||
"Signing Transactions"
|
||||
[ testProperty "Sign and validate transactions" $
|
||||
forAll arbitrarySigningData testDetSignTx
|
||||
, testProperty "Merge partially signed transactions" $
|
||||
forAll arbitraryPartialTxs testMergeTx
|
||||
]
|
||||
]
|
||||
forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins
|
||||
it "sign and validate transaction" $
|
||||
property $ forAll (arbitrarySigningData net) (testDetSignTx net)
|
||||
it "merge partially signed transactions" $
|
||||
property $ forAll (arbitraryPartialTxs net) (testMergeTx net)
|
||||
|
||||
{- Building Transactions -}
|
||||
|
||||
testBuildAddrTx :: Address -> TestCoin -> Bool
|
||||
testBuildAddrTx a (TestCoin v) =
|
||||
testBuildAddrTx :: Network -> Address -> TestCoin -> Bool
|
||||
testBuildAddrTx net a (TestCoin v) =
|
||||
case a of
|
||||
PubKeyAddress h -> Right (PayPKHash h) == out
|
||||
ScriptAddress h -> Right (PayScriptHash h) == out
|
||||
PubKeyAddress h net -> Right (PayPKHash h) == out
|
||||
ScriptAddress h net -> Right (PayScriptHash h) == out
|
||||
where
|
||||
tx = buildAddrTx [] [(fromMaybe (error "Could not convert address to string") (addrToString a), v)]
|
||||
tx =
|
||||
buildAddrTx
|
||||
net
|
||||
[]
|
||||
[ ( fromMaybe
|
||||
(error "Could not convert address to string")
|
||||
(addrToString a)
|
||||
, v)
|
||||
]
|
||||
out =
|
||||
decodeOutputBS $
|
||||
scriptOutput $
|
||||
head $ txOut (fromRight (error "Could not build transaction") tx)
|
||||
|
||||
testGuessSize :: Tx -> Bool
|
||||
testGuessSize tx
|
||||
testGuessSize :: Network -> Tx -> Bool
|
||||
testGuessSize net tx
|
||||
-- We compute an upper bound but it should be close enough to the real size
|
||||
-- We give 2 bytes of slack on every signature (1 on r and 1 on s)
|
||||
= guess >= len && guess <= len + 2 * delta
|
||||
@ -71,7 +75,7 @@ testGuessSize tx
|
||||
ins = map f $ txIn tx
|
||||
f i =
|
||||
fromRight (error "Could not decode input") $
|
||||
decodeInputBS $ scriptInput i
|
||||
decodeInputBS net $ scriptInput i
|
||||
pki = length $ filter isSpendPKHash ins
|
||||
msi = concatMap shData ins
|
||||
shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)]
|
||||
@ -113,21 +117,21 @@ testChooseMSCoins (m, n) coins target byteFee nOut = nOut >= 0 ==>
|
||||
|
||||
{- Signing Transactions -}
|
||||
|
||||
testDetSignTx :: (Tx, [SigInput], [PrvKey]) -> Bool
|
||||
testDetSignTx (tx, sigis, prv) =
|
||||
not (verifyStdTx tx verData) &&
|
||||
not (verifyStdTx txSigP verData) && verifyStdTx txSigC verData
|
||||
testDetSignTx :: Network -> (Tx, [SigInput], [PrvKey]) -> Bool
|
||||
testDetSignTx net (tx, sigis, prv) =
|
||||
not (verifyStdTx net tx verData) &&
|
||||
not (verifyStdTx net txSigP verData) && verifyStdTx net txSigC verData
|
||||
where
|
||||
txSigP =
|
||||
fromRight (error "Could not decode transaction") $
|
||||
signTx tx sigis (tail prv)
|
||||
signTx net tx sigis (tail prv)
|
||||
txSigC =
|
||||
fromRight (error "Could not decode transaction") $
|
||||
signTx txSigP sigis [head prv]
|
||||
signTx net txSigP sigis [head prv]
|
||||
verData = map (\(SigInput s v o _ _) -> (s, v, o)) sigis
|
||||
|
||||
testMergeTx :: ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool
|
||||
testMergeTx (txs, os) = and
|
||||
testMergeTx :: Network -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool
|
||||
testMergeTx net (txs, os) = and
|
||||
[ isRight mergeRes
|
||||
, length (txIn mergedTx) == length os
|
||||
, if enoughSigs then isValid else not isValid
|
||||
@ -136,12 +140,12 @@ testMergeTx (txs, os) = and
|
||||
]
|
||||
where
|
||||
outs = map (\(so, val, op, _, _) -> (so, val, op)) os
|
||||
mergeRes = mergeTxs txs outs
|
||||
mergeRes = mergeTxs net txs outs
|
||||
mergedTx = fromRight (error "Could not merge") mergeRes
|
||||
isValid = verifyStdTx mergedTx outs
|
||||
isValid = verifyStdTx net mergedTx outs
|
||||
enoughSigs = all (\(m,c) -> c >= m) sigMap
|
||||
sigMap = map (\((_,_,_,m,_), inp) -> (m, sigCnt inp)) $ zip os $ txIn mergedTx
|
||||
sigCnt inp = case decodeInputBS $ scriptInput inp of
|
||||
sigCnt inp = case decodeInputBS net $ scriptInput inp of
|
||||
Right (RegularInput (SpendMulSig sigs)) -> length sigs
|
||||
Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs
|
||||
_ -> error "Invalid input script type"
|
@ -1,48 +1,48 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Network.Haskoin.Transaction.Units (tests, satoshiCoreTxTests) where
|
||||
module Network.Haskoin.Transaction.Units (spec) where
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson.Types
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either (fromLeft, fromRight, isLeft,
|
||||
isRight)
|
||||
import Data.List (groupBy)
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import Data.Serialize (decode, encode)
|
||||
import Data.Serialize.Get (getWord32le, runGet)
|
||||
import Data.Serialize.Put (putWord32le, runPut)
|
||||
import Data.String.Conversions (convertString)
|
||||
import qualified Data.Vector as V
|
||||
import Data.Word (Word32, Word64)
|
||||
import GHC.Exts (IsString (..))
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson.Types
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either (fromLeft, fromRight, isLeft,
|
||||
isRight)
|
||||
import Data.List (groupBy)
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import Data.Serialize (decode, encode)
|
||||
import Data.Serialize.Get (getWord32le, runGet)
|
||||
import Data.Serialize.Put (putWord32le, runPut)
|
||||
import Data.String.Conversions (convertString)
|
||||
import qualified Data.Vector as V
|
||||
import Data.Word (Word32, Word64)
|
||||
import GHC.Exts (IsString (..))
|
||||
import Network.Haskoin.Constants
|
||||
import Network.Haskoin.Script
|
||||
import Network.Haskoin.Transaction
|
||||
import Network.Haskoin.Util
|
||||
import Safe (readMay)
|
||||
import Test.Framework (Test, testGroup)
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
import Safe (readMay)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "Computing TxID from Tx"
|
||||
( zipWith (curry mapTxIDVec) txIDVec [0..] )
|
||||
, testGroup "Build PKHash Transaction (generated from bitcoind)"
|
||||
( zipWith (curry mapPKHashVec) pkHashVec [0..] )
|
||||
, testGroup "Verify transaction (bitcoind tx_valid.json)"
|
||||
( zipWith (curry mapVerifyVec) verifyVec [0..] )
|
||||
, testCase "" tEncodeSatoshiCoreScriptPubKey
|
||||
]
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "transaction unit tests" $ do
|
||||
it "compute txid from tx" $
|
||||
sequence_ $ zipWith (curry mapTxIDVec) txIDVec [0 ..]
|
||||
it "build pkhash transaction (generated from bitcoind)" $
|
||||
sequence_ $ zipWith (curry mapPKHashVec) pkHashVec [0 ..]
|
||||
it "verify transaction (bitcoind tx_valid.json)" $
|
||||
sequence_ $ zipWith (curry mapVerifyVec) verifyVec [0 ..]
|
||||
it "encode satoshi core script pubkey" tEncodeSatoshiCoreScriptPubKey
|
||||
satoshiCoreTxTests
|
||||
|
||||
mapTxIDVec :: ((ByteString, ByteString), Int) -> Test.Framework.Test
|
||||
mapTxIDVec (v,i) = testCase name $ runTxIDVec v
|
||||
where
|
||||
name = "Compute TxID " ++ show i
|
||||
mapTxIDVec :: ((ByteString, ByteString), Int) -> Assertion
|
||||
mapTxIDVec (v,i) = runTxIDVec v
|
||||
|
||||
runTxIDVec :: (ByteString, ByteString) -> Assertion
|
||||
runTxIDVec (tid, tx) = assertBool "TxID" $ txHashToHex (txHash txBS) == tid
|
||||
runTxIDVec (tid, tx) = assertBool "txid" $ txHashToHex (txHash txBS) == tid
|
||||
where
|
||||
txBS = fromJust $ either (const Nothing) return . decode =<< decodeHex tx
|
||||
|
||||
@ -63,9 +63,8 @@ txIDVec =
|
||||
]
|
||||
|
||||
mapPKHashVec :: (([(ByteString, Word32)], [(ByteString, Word64)], ByteString), Int)
|
||||
-> Test.Framework.Test
|
||||
mapPKHashVec (v, i) = testCase name $ runPKHashVec v
|
||||
where name = "Build PKHash Tx " ++ show i
|
||||
-> Assertion
|
||||
mapPKHashVec (v, i) = runPKHashVec v
|
||||
|
||||
runPKHashVec :: ([(ByteString, Word32)], [(ByteString, Word64)], ByteString) -> Assertion
|
||||
runPKHashVec (xs, ys, res) =
|
||||
@ -73,21 +72,20 @@ runPKHashVec (xs, ys, res) =
|
||||
where
|
||||
tx =
|
||||
fromRight (error "Could not decode transaction") $
|
||||
buildAddrTx (map f xs) ys
|
||||
buildAddrTx btc (map f xs) ys
|
||||
f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix
|
||||
|
||||
|
||||
mapVerifyVec :: (SatoshiCoreTxTest, Int)
|
||||
-> Test.Framework.Test
|
||||
mapVerifyVec (v@(SatoshiCoreTxTest d _ _), i) = testCase name $ runVerifyVec v i
|
||||
where name = "Verify Tx " ++ show i ++ ", about: " ++ d
|
||||
-> Assertion
|
||||
mapVerifyVec (v@(SatoshiCoreTxTest d _ _), i) = runVerifyVec v i
|
||||
|
||||
runVerifyVec :: SatoshiCoreTxTest -> Int -> Assertion
|
||||
runVerifyVec (SatoshiCoreTxTest _ is bsTx) i =
|
||||
assertBool name $ verifyStdTx tx outputsAndOutpoints
|
||||
assertBool name $ verifyStdTx btc tx outputsAndOutpoints
|
||||
where
|
||||
name =
|
||||
" > Verify transaction " ++ show i ++ "bsTx: " ++ convertString bsTx
|
||||
"verify transaction " ++ show i ++ "bsTx: " ++ convertString bsTx
|
||||
tx :: Tx
|
||||
tx = fromJust $ either (const Nothing) return . decode =<< decodeHex bsTx
|
||||
outputsAndOutpoints :: [(ScriptOutput, Word64, OutPoint)]
|
||||
@ -310,14 +308,12 @@ encodeSatoshiCoreScriptPubKey =
|
||||
Just i -> encodeHex . encode . intToScriptOp $ i
|
||||
Nothing -> error $ "encodeSatoshiCoreScriptPubKey: " ++ s
|
||||
|
||||
satoshiCoreTxTests :: IO [Test]
|
||||
satoshiCoreTxTests :: Spec
|
||||
satoshiCoreTxTests = do
|
||||
txVec <- satoshiCoreTxVec
|
||||
return
|
||||
[ testGroup
|
||||
"Verify transaction (bitcoind tx_valid.json) (using copied source json)"
|
||||
(map mapVerifyVec . filter isCurrentlyPassing $ zip txVec [0 ..])
|
||||
]
|
||||
it "verify transaction (bitcoind tx_valid.json) (using copied source json)" $ do
|
||||
txVec <- satoshiCoreTxVec
|
||||
sequence_ $
|
||||
map mapVerifyVec . filter isCurrentlyPassing $ zip txVec [0 ..]
|
||||
where
|
||||
passingTests = [0 .. 5] ++ [8] ++ [11 .. 13] ++ [16 .. 18] ++ [20] ++ [52]
|
||||
isCurrentlyPassing (_, testNum) = testNum `elem` passingTests
|
||||
@ -326,7 +322,7 @@ satoshiCoreTxTests = do
|
||||
type TestComment = String
|
||||
satoshiCoreTxVec :: IO [SatoshiCoreTxTest]
|
||||
satoshiCoreTxVec = do
|
||||
tx_validBS <- BL.readFile "test/data/tx_valid.json"
|
||||
tx_validBS <- BL.readFile "data/tx_valid.json"
|
||||
let testsAndComments =
|
||||
fromMaybe (error "satoshiCoreTxVec, couldn't decode json") .
|
||||
Aeson.decode $
|
||||
@ -348,7 +344,7 @@ satoshiCoreTxVec = do
|
||||
Data.List.groupBy
|
||||
(\x y -> (isLeft x && isLeft y) || (isRight x && isRight y))
|
||||
takePairs (a:b:xs) = (a, b) : takePairs xs
|
||||
takePairs _ = [] -- ugh, wish we were using a real parser.
|
||||
takePairs _ = [] -- ugh, wish we were using a real parser.
|
||||
includeDescriptions (descriptionLines, tests') =
|
||||
map updateDescription tests'
|
||||
where
|
@ -1,34 +1,26 @@
|
||||
module Network.Haskoin.Util.Tests (tests) where
|
||||
module Network.Haskoin.Util.Tests (spec) where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Either (fromLeft, fromRight,
|
||||
isLeft, isRight)
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (permutations)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Either (fromLeft, fromRight, isLeft, isRight)
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (permutations)
|
||||
import Data.Maybe
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Sequence as Seq
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"Utility functions"
|
||||
[ testProperty "bsToInteger . integerToBS" getPutInteger
|
||||
, testProperty "decodeHex . encodeHex" $ forAll arbitraryBS fromToHex
|
||||
, testProperty
|
||||
"compare updateIndex with Data.Sequence"
|
||||
testUpdateIndex
|
||||
, testProperty "matchTemplate" testMatchTemplate
|
||||
, testProperty
|
||||
"testing matchTemplate with two lists"
|
||||
testMatchTemplateLen
|
||||
, testProperty "Testing Either helper functions" testEither
|
||||
]
|
||||
]
|
||||
spec :: Spec
|
||||
spec =
|
||||
describe "utility functions" $ do
|
||||
it "bsToInteger . integerToBS" $ property getPutInteger
|
||||
it "decodeHex . encodeHex" $ property $ forAll arbitraryBS fromToHex
|
||||
it "compare updateIndex with Data.Sequence" $ property $ testUpdateIndex
|
||||
it "matchTemplate" $ property testMatchTemplate
|
||||
it "testing matchTemplate with two lists" $
|
||||
property testMatchTemplateLen
|
||||
it "either helper functions" $ property testEither
|
||||
|
||||
{- Various utilities -}
|
||||
|
71
test/Spec.hs
Normal file
71
test/Spec.hs
Normal file
@ -0,0 +1,71 @@
|
||||
import Network.Haskoin.Constants
|
||||
import Test.Hspec
|
||||
|
||||
-- Util tests
|
||||
import qualified Network.Haskoin.Util.Tests (spec)
|
||||
|
||||
-- Crypto tests
|
||||
import qualified Network.Haskoin.Crypto.Base58.Tests (spec)
|
||||
import qualified Network.Haskoin.Crypto.Base58.Units (spec)
|
||||
import qualified Network.Haskoin.Crypto.ECDSA.Tests (spec)
|
||||
import qualified Network.Haskoin.Crypto.ExtendedKeys.Tests (spec)
|
||||
import qualified Network.Haskoin.Crypto.ExtendedKeys.Units (spec)
|
||||
import qualified Network.Haskoin.Crypto.Hash.Tests (spec)
|
||||
import qualified Network.Haskoin.Crypto.Hash.Units (spec)
|
||||
import qualified Network.Haskoin.Crypto.Keys.Tests (spec)
|
||||
import qualified Network.Haskoin.Crypto.Mnemonic.Tests (spec)
|
||||
import qualified Network.Haskoin.Crypto.Mnemonic.Units (spec)
|
||||
import qualified Network.Haskoin.Crypto.Units (spec)
|
||||
|
||||
-- Network tests
|
||||
import qualified Network.Haskoin.Network.Units (spec)
|
||||
|
||||
-- Script tests
|
||||
import qualified Network.Haskoin.Script.Spec (spec)
|
||||
import qualified Network.Haskoin.Script.Tests (spec)
|
||||
import qualified Network.Haskoin.Script.Units (spec)
|
||||
|
||||
-- Transaction tests
|
||||
import qualified Network.Haskoin.Transaction.Tests (spec)
|
||||
import qualified Network.Haskoin.Transaction.Units (spec)
|
||||
|
||||
-- Block tests
|
||||
import qualified Network.Haskoin.Block.Spec (spec)
|
||||
import qualified Network.Haskoin.Block.Tests (spec)
|
||||
import qualified Network.Haskoin.Block.Units (spec)
|
||||
|
||||
-- Json tests
|
||||
import qualified Network.Haskoin.Json.Tests (spec)
|
||||
|
||||
-- Binary tests
|
||||
import qualified Network.Haskoin.Cereal.Tests (spec)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
hspec $ do
|
||||
Network.Haskoin.Script.Spec.spec btc
|
||||
Network.Haskoin.Script.Spec.spec bch
|
||||
Network.Haskoin.Block.Spec.spec bchRegTest
|
||||
Network.Haskoin.Block.Spec.spec btcRegTest
|
||||
Network.Haskoin.Block.Tests.spec btc
|
||||
Network.Haskoin.Cereal.Tests.spec btc
|
||||
Network.Haskoin.Crypto.Base58.Tests.spec btc
|
||||
Network.Haskoin.Crypto.ExtendedKeys.Tests.spec btc
|
||||
Network.Haskoin.Crypto.ExtendedKeys.Units.spec
|
||||
Network.Haskoin.Crypto.Keys.Tests.spec btc
|
||||
Network.Haskoin.Crypto.Units.spec
|
||||
Network.Haskoin.Json.Tests.spec btc
|
||||
Network.Haskoin.Network.Units.spec
|
||||
Network.Haskoin.Script.Tests.spec
|
||||
Network.Haskoin.Script.Units.spec
|
||||
Network.Haskoin.Block.Units.spec
|
||||
Network.Haskoin.Crypto.Base58.Units.spec
|
||||
Network.Haskoin.Crypto.ECDSA.Tests.spec btc
|
||||
Network.Haskoin.Crypto.Hash.Tests.spec
|
||||
Network.Haskoin.Crypto.Hash.Units.spec
|
||||
Network.Haskoin.Crypto.Mnemonic.Tests.spec
|
||||
Network.Haskoin.Crypto.Mnemonic.Units.spec
|
||||
Network.Haskoin.Transaction.Tests.spec btc
|
||||
Network.Haskoin.Transaction.Units.spec
|
||||
Network.Haskoin.Util.Tests.spec
|
||||
|
@ -1,8 +0,0 @@
|
||||
import Network.Haskoin.Constants
|
||||
import qualified Network.Haskoin.Script.Spec (forkIdSpec)
|
||||
import Test.Hspec
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
setBCH
|
||||
hspec Network.Haskoin.Script.Spec.forkIdSpec
|
@ -1,96 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
import Control.Monad.State.Strict
|
||||
import Network.Haskoin.Block
|
||||
import Network.Haskoin.Constants
|
||||
import Test.Framework as F
|
||||
import Test.Framework.Providers.HUnit (testCase)
|
||||
import Test.HUnit hiding (State)
|
||||
|
||||
myTime :: Timestamp
|
||||
myTime = 1499083075
|
||||
|
||||
withChain :: State HeaderMemory a -> a
|
||||
withChain f = evalState f initialChain
|
||||
|
||||
chain :: BlockHeaders m => BlockHeader -> Int -> m ()
|
||||
chain bh i = do
|
||||
bnsE <- connectBlocks myTime bhs
|
||||
either error (const $ return ()) bnsE
|
||||
where
|
||||
bhs = appendBlocks 6 bh i
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
setBTCregTest
|
||||
defaultMain [ testGroup "RegTest network" tests ]
|
||||
|
||||
tests :: [F.Test]
|
||||
tests =
|
||||
[ testCase "Get best block" bestBlock
|
||||
, testCase "Build a block locator" buildLocator
|
||||
, testCase "Split chain best block" splitBest
|
||||
]
|
||||
|
||||
bestBlock :: Assertion
|
||||
bestBlock =
|
||||
100 @=? nodeHeight bb
|
||||
where
|
||||
bb = withChain $ do
|
||||
chain genesisHeader 100
|
||||
getBestBlockHeader
|
||||
|
||||
buildLocator :: Assertion
|
||||
buildLocator =
|
||||
[100,99..90] ++ [88,84,76,60,28,0] @=? heights
|
||||
where
|
||||
heights = map nodeHeight loc
|
||||
loc = withChain $ do
|
||||
chain genesisHeader 100
|
||||
bb <- getBestBlockHeader
|
||||
blockLocatorNodes bb
|
||||
|
||||
splitBest :: Assertion
|
||||
splitBest =
|
||||
4035 @=? nodeHeight bb
|
||||
where
|
||||
bb = withChain $ splitChain >> getBestBlockHeader
|
||||
|
||||
-- 0 → → 2015 → → → → → → → 4031
|
||||
-- ↓
|
||||
-- → → 2035 → → → → → → 4035*
|
||||
-- ↓
|
||||
-- → → 2185
|
||||
splitChain :: State HeaderMemory ()
|
||||
splitChain = do
|
||||
start <- go 1 genesisHeader 2015
|
||||
e 2015 (head start)
|
||||
tail1 <- go 2 (nodeHeader $ head start) 2016
|
||||
e 4031 (head tail1)
|
||||
tail2 <- go 3 (nodeHeader $ head start) 20
|
||||
e 2035 (head tail2)
|
||||
tail3 <- go 4 (nodeHeader $ head tail2) 2000
|
||||
e 4035 (head tail3)
|
||||
tail4 <- go 5 (nodeHeader $ head tail2) 150
|
||||
e 2185 (head tail4)
|
||||
sp1 <- splitPoint (head tail1) (head tail3)
|
||||
unless (sp1 == head start) $
|
||||
error $
|
||||
"Split point wrong between blocks 4031 and 4035: " ++
|
||||
show (nodeHeight sp1)
|
||||
sp2 <- splitPoint (head tail4) (head tail3)
|
||||
unless (sp2 == head tail2) $
|
||||
error $
|
||||
"Split point wrong between blocks 2185 and 4035: " ++
|
||||
show (nodeHeight sp2)
|
||||
where
|
||||
e n bn =
|
||||
unless (nodeHeight bn == n) $
|
||||
error $
|
||||
"Node height " ++
|
||||
show (nodeHeight bn) ++ " of first chunk should be " ++ show n
|
||||
go seed start n = do
|
||||
let bhs = appendBlocks seed start n
|
||||
bnE <- connectBlocks myTime bhs
|
||||
case bnE of
|
||||
Right bn -> return bn
|
||||
Left ex -> error ex
|
@ -1,73 +0,0 @@
|
||||
import Network.Haskoin.Constants
|
||||
import Test.Framework
|
||||
import Test.Hspec
|
||||
|
||||
-- Util tests
|
||||
import qualified Network.Haskoin.Util.Tests (tests)
|
||||
|
||||
-- Crypto tests
|
||||
import qualified Network.Haskoin.Crypto.Base58.Tests (tests)
|
||||
import qualified Network.Haskoin.Crypto.Base58.Units (tests)
|
||||
import qualified Network.Haskoin.Crypto.ECDSA.Tests (tests)
|
||||
import qualified Network.Haskoin.Crypto.ExtendedKeys.Tests (tests)
|
||||
import qualified Network.Haskoin.Crypto.ExtendedKeys.Units (tests)
|
||||
import qualified Network.Haskoin.Crypto.Hash.Tests (tests)
|
||||
import qualified Network.Haskoin.Crypto.Hash.Units (tests)
|
||||
import qualified Network.Haskoin.Crypto.Keys.Tests (tests)
|
||||
import qualified Network.Haskoin.Crypto.Mnemonic.Tests (tests)
|
||||
import qualified Network.Haskoin.Crypto.Mnemonic.Units (tests)
|
||||
import qualified Network.Haskoin.Crypto.Units (tests)
|
||||
|
||||
-- Network tests
|
||||
import qualified Network.Haskoin.Network.Units (tests)
|
||||
|
||||
-- Script tests
|
||||
import qualified Network.Haskoin.Script.Spec (spec)
|
||||
import qualified Network.Haskoin.Script.Tests (tests)
|
||||
import qualified Network.Haskoin.Script.Units (tests)
|
||||
|
||||
-- Transaction tests
|
||||
import qualified Network.Haskoin.Transaction.Tests (tests)
|
||||
import qualified Network.Haskoin.Transaction.Units (satoshiCoreTxTests,
|
||||
tests)
|
||||
|
||||
-- Block tests
|
||||
import qualified Network.Haskoin.Block.Tests (tests)
|
||||
import qualified Network.Haskoin.Block.Units (tests)
|
||||
|
||||
-- Json tests
|
||||
import qualified Network.Haskoin.Json.Tests (tests)
|
||||
|
||||
-- Binary tests
|
||||
import qualified Network.Haskoin.Cereal.Tests (tests)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
setBTC
|
||||
hspec Network.Haskoin.Script.Spec.spec
|
||||
satoshiTxTests <- Network.Haskoin.Transaction.Units.satoshiCoreTxTests
|
||||
defaultMain
|
||||
( Network.Haskoin.Json.Tests.tests
|
||||
++ Network.Haskoin.Cereal.Tests.tests
|
||||
++ Network.Haskoin.Util.Tests.tests
|
||||
++ Network.Haskoin.Crypto.ECDSA.Tests.tests
|
||||
++ Network.Haskoin.Crypto.Base58.Tests.tests
|
||||
++ Network.Haskoin.Crypto.Base58.Units.tests
|
||||
++ Network.Haskoin.Crypto.Hash.Tests.tests
|
||||
++ Network.Haskoin.Crypto.Hash.Units.tests
|
||||
++ Network.Haskoin.Crypto.Keys.Tests.tests
|
||||
++ Network.Haskoin.Crypto.ExtendedKeys.Tests.tests
|
||||
++ Network.Haskoin.Crypto.ExtendedKeys.Units.tests
|
||||
++ Network.Haskoin.Crypto.Mnemonic.Tests.tests
|
||||
++ Network.Haskoin.Crypto.Mnemonic.Units.tests
|
||||
++ Network.Haskoin.Crypto.Units.tests
|
||||
++ Network.Haskoin.Network.Units.tests
|
||||
++ Network.Haskoin.Script.Tests.tests
|
||||
++ Network.Haskoin.Script.Units.tests
|
||||
++ Network.Haskoin.Transaction.Tests.tests
|
||||
++ Network.Haskoin.Transaction.Units.tests
|
||||
++ satoshiTxTests
|
||||
++ Network.Haskoin.Block.Tests.tests
|
||||
++ Network.Haskoin.Block.Units.tests
|
||||
)
|
||||
|
@ -1,73 +0,0 @@
|
||||
module Network.Haskoin.Cereal.Tests (tests) where
|
||||
|
||||
import Data.Serialize
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "Binary encoding and decoding of utility types"
|
||||
[ testProperty "ByteString" $ forAll arbitraryBS testId ]
|
||||
, testGroup "Binary encoding and decoding of hash types"
|
||||
[ testProperty "Hash160" $ forAll arbitraryHash160 testId
|
||||
, testProperty "Hash256" $ forAll arbitraryHash256 testId
|
||||
, testProperty "Hash512" $ forAll arbitraryHash512 testId
|
||||
]
|
||||
, testGroup "Binary encoding and decoding of crypto types"
|
||||
[ testProperty "Signature" $ forAll arbitrarySignature $ testId . lst3
|
||||
, testProperty "PubKey" $ forAll arbitraryPubKey $ testId . snd
|
||||
, testProperty "XPrvKey" $ forAll arbitraryXPrvKey testId
|
||||
, testProperty "XPubKey" $ forAll arbitraryXPubKey $ testId . snd
|
||||
]
|
||||
, testGroup "Binary encoding and decoding of protocol types"
|
||||
[ testProperty "VarInt" $ forAll arbitraryVarInt testId
|
||||
, testProperty "VarString" $ forAll arbitraryVarString testId
|
||||
, testProperty "NetworkAddress" $ forAll arbitraryNetworkAddress testId
|
||||
, testProperty "InvType" $ forAll arbitraryInvType testId
|
||||
, testProperty "InvVector" $ forAll arbitraryInvVector testId
|
||||
, testProperty "Inv" $ forAll arbitraryInv1 testId
|
||||
, testProperty "Version" $ forAll arbitraryVersion testId
|
||||
, testProperty "Addr" $ forAll arbitraryAddr1 testId
|
||||
, testProperty "Alert" $ forAll arbitraryAlert testId
|
||||
, testProperty "Reject" $ forAll arbitraryReject testId
|
||||
, testProperty "GetData" $ forAll arbitraryGetData testId
|
||||
, testProperty "NotFound" $ forAll arbitraryNotFound testId
|
||||
, testProperty "Ping" $ forAll arbitraryPing testId
|
||||
, testProperty "Pong" $ forAll arbitraryPong testId
|
||||
, testProperty "MessageCommand" $ forAll arbitraryMessageCommand testId
|
||||
, testProperty "MessageHeader" $ forAll arbitraryMessageHeader testId
|
||||
, testProperty "Message" $ forAll arbitraryMessage testId
|
||||
]
|
||||
, testGroup "Binary encoding and decoding of script types"
|
||||
[ testProperty "ScriptOp" $ forAll arbitraryScriptOp testId
|
||||
, testProperty "Script" $ forAll arbitraryScript testId
|
||||
]
|
||||
, testGroup "Binary encoding and decoding of transaction types"
|
||||
[ testProperty "TxIn" $ forAll arbitraryTxIn testId
|
||||
, testProperty "TxOut" $ forAll arbitraryTxOut testId
|
||||
, testProperty "OutPoint" $ forAll arbitraryOutPoint testId
|
||||
, testProperty "Tx" $ forAll arbitraryTx testId
|
||||
, testProperty "Tx" $ forAll arbitraryWitnessTx testId
|
||||
, testProperty "Tx" $ forAll arbitraryLegacyTx testId
|
||||
]
|
||||
, testGroup "Binary encoding and decoding of block types"
|
||||
[ testProperty "Block" $ forAll arbitraryBlock testId
|
||||
, testProperty "BlockHeader" $ forAll arbitraryBlockHeader testId
|
||||
, testProperty "GetBlocks" $ forAll arbitraryGetBlocks testId
|
||||
, testProperty "GetHeaders" $ forAll arbitraryGetHeaders testId
|
||||
, testProperty "Headers" $ forAll arbitraryHeaders testId
|
||||
, testProperty "MerkleBlock" $ forAll arbitraryMerkleBlock testId
|
||||
]
|
||||
, testGroup "Binary encoding and decoding of bloom types"
|
||||
[ testProperty "BloomFlags" $ forAll arbitraryBloomFlags testId
|
||||
, testProperty "BloomFilter" $ forAll arbitraryBloomFilter $ testId . lst3
|
||||
, testProperty "FilterLoad" $ forAll arbitraryFilterLoad testId
|
||||
, testProperty "FilterAdd" $ forAll arbitraryFilterAdd testId
|
||||
]
|
||||
]
|
||||
|
||||
testId :: (Serialize a, Eq a) => a -> Bool
|
||||
testId x = decode (encode x) == Right x
|
@ -1,31 +0,0 @@
|
||||
module Network.Haskoin.Crypto.Base58.Tests (tests) where
|
||||
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"Address and Base58"
|
||||
[ testProperty "decode58 . encode58 == id" $
|
||||
forAll arbitraryBS $ \bs ->
|
||||
decodeBase58 (encodeBase58 bs) == Just bs
|
||||
, testProperty "decode58Chk . encode58Chk == id" $
|
||||
forAll arbitraryBS $ \bs ->
|
||||
decodeBase58Check (encodeBase58Check bs) == Just bs
|
||||
, testProperty "stringToAddr . addrToString == id" $
|
||||
forAll arbitraryAddress $ \a ->
|
||||
(stringToAddr =<< addrToString a) == Just a
|
||||
, testProperty "Read/Show address" $
|
||||
forAll arbitraryAddress $ \a -> read (show a) == a
|
||||
, testProperty "From string address" $
|
||||
forAll arbitraryAddress $ \a ->
|
||||
fmap (fromString . cs) (addrToString a) == Just a
|
||||
]
|
||||
]
|
||||
|
@ -1,62 +0,0 @@
|
||||
module Network.Haskoin.Crypto.ExtendedKeys.Tests (tests) where
|
||||
|
||||
import Data.Bits ((.&.))
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word32)
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck (forAll)
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"HDW Extended Keys"
|
||||
[ testProperty "prvSubKey(k,c)*G = pubSubKey(k*G,c)" $
|
||||
forAll arbitraryXPrvKey pubKeyOfSubKeyIsSubKeyOfPubKey
|
||||
, testProperty "fromB58 . toB58 prvKey" $ forAll arbitraryXPrvKey $
|
||||
\k -> xPrvImport (xPrvExport k) == Just k
|
||||
, testProperty "fromB58 . toB58 pubKey" $ forAll arbitraryXPubKey $
|
||||
\(_, k) -> xPubImport (xPubExport k) == Just k
|
||||
]
|
||||
, testGroup
|
||||
"From/To strings"
|
||||
[ testProperty "Read/Show extended public key" $ forAll arbitraryXPubKey $
|
||||
\(_, k) -> read (show k) == k
|
||||
, testProperty "Read/Show extended private key" $ forAll arbitraryXPrvKey $
|
||||
\k -> read (show k) == k
|
||||
, testProperty "From string extended public key" $ forAll arbitraryXPubKey $
|
||||
\(_, k) -> fromString (cs $ xPubExport k) == k
|
||||
, testProperty "From string extended private key" $ forAll arbitraryXPrvKey $
|
||||
\k -> fromString (cs $ xPrvExport k) == k
|
||||
, testProperty "Read/Show derivation path" $ forAll arbitraryDerivPath $
|
||||
\p -> read (show p) == p
|
||||
, testProperty "Read/Show hard derivation path" $ forAll arbitraryHardPath $
|
||||
\p -> read (show p) == p
|
||||
, testProperty "Read/Show soft derivation path" $ forAll arbitrarySoftPath $
|
||||
\p -> read (show p) == p
|
||||
, testProperty "From string derivation path" $ forAll arbitraryDerivPath $
|
||||
\p -> fromString (cs $ pathToStr p) == p
|
||||
, testProperty "From string hard derivation path" $ forAll arbitraryHardPath $
|
||||
\p -> fromString (cs $ pathToStr p) == p
|
||||
, testProperty "From string soft derivation path" $ forAll arbitrarySoftPath $
|
||||
\p -> fromString (cs $ pathToStr p) == p
|
||||
, testProperty "listToPath . pathToList == id" $ forAll arbitraryDerivPath $
|
||||
\p -> listToPath (pathToList p) == p
|
||||
, testProperty "listToPath . pathToList == id (Hard)" $
|
||||
forAll arbitraryHardPath $ \p -> toHard (listToPath $ pathToList p) == Just p
|
||||
, testProperty "listToPath . pathToList == id (Soft)" $
|
||||
forAll arbitrarySoftPath $ \p -> toSoft (listToPath $ pathToList p) == Just p
|
||||
, testProperty "read . show == id (ParsedPath)" $
|
||||
forAll arbitraryParsedPath $ \p -> read (show p) == p
|
||||
]
|
||||
]
|
||||
|
||||
pubKeyOfSubKeyIsSubKeyOfPubKey :: XPrvKey -> Word32 -> Bool
|
||||
pubKeyOfSubKeyIsSubKeyOfPubKey k i =
|
||||
deriveXPubKey (prvSubKey k i') == pubSubKey (deriveXPubKey k) i'
|
||||
where
|
||||
i' = fromIntegral $ i .&. 0x7fffffff -- make it a public derivation
|
||||
|
@ -1,42 +0,0 @@
|
||||
module Network.Haskoin.Crypto.Hash.Tests (tests) where
|
||||
|
||||
import Data.Serialize (encode)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions
|
||||
import Network.Haskoin.Block
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util (encodeHex)
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup "Hash tests"
|
||||
[ testProperty "join512( split512(h) ) == h" $
|
||||
forAll arbitraryHash256 $ forAll arbitraryHash256 . joinSplit512
|
||||
, testProperty "decodeCompact . encodeCompact i == i" decEncCompact
|
||||
, testProperty "From string 64-byte hash" $ forAll arbitraryHash512 $
|
||||
\h -> fromString (cs $ encodeHex $ encode h) == h
|
||||
, testProperty "From string 32-byte hash" $ forAll arbitraryHash256 $
|
||||
\h -> fromString (cs $ encodeHex $ encode h) == h
|
||||
, testProperty "From string 20-byte hash" $ forAll arbitraryHash160 $
|
||||
\h -> fromString (cs $ encodeHex $ encode h) == h
|
||||
]
|
||||
]
|
||||
|
||||
joinSplit512 :: Hash256 -> Hash256 -> Bool
|
||||
joinSplit512 a b = split512 (join512 (a, b)) == (a, b)
|
||||
|
||||
-- After encoding and decoding, we may loose precision so the new result is >=
|
||||
-- to the old one.
|
||||
decEncCompact :: Integer -> Bool
|
||||
decEncCompact i
|
||||
-- Integer completely fits inside the mantisse
|
||||
| abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False)
|
||||
-- Otherwise precision will be lost and the decoded result will
|
||||
-- be smaller than the original number
|
||||
| i >= 0 = fst (decodeCompact (encodeCompact i)) < i
|
||||
| otherwise = fst (decodeCompact (encodeCompact i)) > i
|
||||
|
@ -1,120 +0,0 @@
|
||||
module Network.Haskoin.Crypto.Keys.Tests (tests) where
|
||||
|
||||
import qualified Crypto.Secp256k1 as EC
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Serialize (encode, runGet, runPut)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Haskoin.Crypto
|
||||
import Network.Haskoin.Test
|
||||
import Network.Haskoin.Util
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"PubKey Binary"
|
||||
[ testProperty "is public key canonical" $
|
||||
forAll arbitraryPubKey (isCanonicalPubKey . snd)
|
||||
, testProperty "makeKey . toKey" makeToKey
|
||||
, testProperty "makeKeyU . toKey" makeToKeyU
|
||||
]
|
||||
, testGroup
|
||||
"Key formats"
|
||||
[ testProperty "fromWif . toWif PrvKey" $
|
||||
forAll arbitraryPrvKey $ \pk -> fromWif (toWif pk) == Just pk
|
||||
, testProperty "constant 32-byte encoding PrvKey" $
|
||||
forAll arbitraryPrvKey binaryPrvKey
|
||||
]
|
||||
, testGroup
|
||||
"Key compression"
|
||||
[ testProperty "Compressed public key" testCompressed
|
||||
, testProperty "Uncompressed public key" testUnCompressed
|
||||
, testProperty "Compressed private key" testPrivateCompressed
|
||||
, testProperty "Uncompressed private key" testPrivateUnCompressed
|
||||
]
|
||||
, testGroup
|
||||
"From/To strings"
|
||||
[ testProperty "Read/Show public key" $
|
||||
forAll arbitraryPubKey $ \(_, k) -> read (show k) == k
|
||||
, testProperty "Read/Show compressed public key" $
|
||||
forAll arbitraryPubKeyC $ \(_, k) -> read (show k) == k
|
||||
, testProperty "Read/Show uncompressed public key" $
|
||||
forAll arbitraryPubKeyU $ \(_, k) -> read (show k) == k
|
||||
, testProperty "Read/Show private key" $
|
||||
forAll arbitraryPrvKey $ \k -> read (show k) == k
|
||||
, testProperty "Read/Show compressed private key" $
|
||||
forAll arbitraryPrvKeyC $ \k -> read (show k) == k
|
||||
, testProperty "Read/Show uncompressed private key" $
|
||||
forAll arbitraryPrvKeyU $ \k -> read (show k) == k
|
||||
, testProperty "From string public key" $
|
||||
forAll arbitraryPubKey $ \(_, k) ->
|
||||
fromString (cs . encodeHex $ encode k) == k
|
||||
, testProperty "From string compressed public key" $
|
||||
forAll arbitraryPubKeyC $ \(_, k) ->
|
||||
fromString (cs . encodeHex $ encode k) == k
|
||||
, testProperty "From string uncompressed public key" $
|
||||
forAll arbitraryPubKeyU $ \(_, k) ->
|
||||
fromString (cs . encodeHex $ encode k) == k
|
||||
, testProperty "From string private key" $
|
||||
forAll arbitraryPrvKey $ \k -> fromString (cs $ toWif k) == k
|
||||
, testProperty "From string compressed private key" $
|
||||
forAll arbitraryPrvKeyC $ \k -> fromString (cs $ toWif k) == k
|
||||
, testProperty "From string uncompressed private key" $
|
||||
forAll arbitraryPrvKeyU $ \k -> fromString (cs $ toWif k) == k
|
||||
]
|
||||
]
|
||||
|
||||
-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp
|
||||
-- from function IsCanonicalPubKey
|
||||
isCanonicalPubKey :: PubKey -> Bool
|
||||
isCanonicalPubKey p = not $
|
||||
-- Non-canonical public key: too short
|
||||
(BS.length bs < 33) ||
|
||||
-- Non-canonical public key: invalid length for uncompressed key
|
||||
(BS.index bs 0 == 4 && BS.length bs /= 65) ||
|
||||
-- Non-canonical public key: invalid length for compressed key
|
||||
(BS.index bs 0 `elem` [2,3] && BS.length bs /= 33) ||
|
||||
-- Non-canonical public key: compressed nor uncompressed
|
||||
(BS.index bs 0 `notElem` [2,3,4])
|
||||
where
|
||||
bs = encode p
|
||||
|
||||
makeToKey :: EC.SecKey -> Bool
|
||||
makeToKey i = prvKeySecKey (makePrvKey i) == i
|
||||
|
||||
makeToKeyU :: EC.SecKey -> Bool
|
||||
makeToKeyU i = prvKeySecKey (makePrvKeyU i) == i
|
||||
|
||||
{- Key formats -}
|
||||
|
||||
binaryPrvKey :: PrvKey -> Bool
|
||||
binaryPrvKey k =
|
||||
(Right k == runGet (prvKeyGetMonad f) (runPut $ prvKeyPutMonad k)) &&
|
||||
(Just k == decodePrvKey f (encodePrvKey k))
|
||||
where
|
||||
f = makePrvKeyG (prvKeyCompressed k)
|
||||
|
||||
{- Key Compression -}
|
||||
|
||||
testCompressed :: EC.SecKey -> Bool
|
||||
testCompressed n =
|
||||
pubKeyCompressed (derivePubKey $ makePrvKey n) &&
|
||||
pubKeyCompressed (derivePubKey $ makePrvKeyG True n)
|
||||
|
||||
testUnCompressed :: EC.SecKey -> Bool
|
||||
testUnCompressed n =
|
||||
not (pubKeyCompressed $ derivePubKey $ makePrvKeyG False n) &&
|
||||
not (pubKeyCompressed $ derivePubKey $ makePrvKeyU n)
|
||||
|
||||
testPrivateCompressed :: EC.SecKey -> Bool
|
||||
testPrivateCompressed n =
|
||||
prvKeyCompressed (makePrvKey n) &&
|
||||
prvKeyCompressed (makePrvKeyC n)
|
||||
|
||||
testPrivateUnCompressed :: EC.SecKey -> Bool
|
||||
testPrivateUnCompressed n =
|
||||
not (prvKeyCompressed $ makePrvKeyG False n) &&
|
||||
not (prvKeyCompressed $ makePrvKeyU n)
|
@ -1,35 +0,0 @@
|
||||
module Network.Haskoin.Json.Tests (tests) where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.HashMap.Strict (singleton)
|
||||
import Network.Haskoin.Test
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck
|
||||
|
||||
tests :: [Test]
|
||||
tests =
|
||||
[ testGroup
|
||||
"Serialize & de-serialize haskoin types to JSON"
|
||||
[ testProperty "ScriptOutput" $ forAll arbitraryScriptOutput testID
|
||||
, testProperty "OutPoint" $ forAll arbitraryOutPoint testID
|
||||
, testProperty "Address" $ forAll arbitraryAddress testID
|
||||
, testProperty "Tx" $ forAll arbitraryTx testID
|
||||
, testProperty "TxHash" $ forAll arbitraryTxHash testID
|
||||
, testProperty "BlockHash" $ forAll arbitraryBlockHash testID
|
||||
, testProperty "SigHash" $ forAll arbitrarySigHash testID
|
||||
, testProperty "SigInput" $ forAll arbitrarySigInput (testID . fst)
|
||||
, testProperty "PubKey" $ forAll arbitraryPubKey (testID . snd)
|
||||
, testProperty "PubKeyC" $ forAll arbitraryPubKeyC (testID . snd)
|
||||
, testProperty "PubKeyU" $ forAll arbitraryPubKeyU (testID . snd)
|
||||
, testProperty "XPrvKey" $ forAll arbitraryXPrvKey testID
|
||||
, testProperty "XPubKey" $ forAll arbitraryXPubKey (testID . snd)
|
||||
, testProperty "DerivPath" $ forAll arbitraryDerivPath testID
|
||||
, testProperty "ParsedPath" $ forAll arbitraryParsedPath testID
|
||||
]
|
||||
]
|
||||
|
||||
testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool
|
||||
testID x =
|
||||
(decode . encode) (singleton ("object" :: String) x) ==
|
||||
Just (singleton ("object" :: String) x)
|
Loading…
Reference in New Issue
Block a user