mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
37cf24c61d
commit
f2de0be662
|
|
@ -1,14 +1,23 @@
|
|||
module HBS2.Base58 where
|
||||
|
||||
import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alphabet(..))
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Char8 qualified as BS8
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.Word
|
||||
import Data.Char (ord)
|
||||
import Numeric
|
||||
|
||||
import Prettyprinter
|
||||
|
||||
newtype AsBase58 a = AsBase58 { unAsBase58 :: a }
|
||||
|
||||
newtype AsHex a = AsHex { unAsHex :: a }
|
||||
|
||||
newtype AsHexSparse a = AsHexSparse { unAsHexSparse :: a }
|
||||
|
||||
alphabet :: Alphabet
|
||||
alphabet = bitcoinAlphabet
|
||||
|
||||
|
|
@ -32,3 +41,29 @@ instance Pretty (AsBase58 LBS.ByteString) where
|
|||
instance Show (AsBase58 ByteString) where
|
||||
show (AsBase58 bs) = BS8.unpack $ toBase58 bs
|
||||
|
||||
|
||||
byteToHex :: Word8 -> String
|
||||
byteToHex byte = pad $ showHex byte ""
|
||||
where pad s = if length s < 2 then '0':s else s
|
||||
|
||||
byteStringToHex :: BS.ByteString -> String
|
||||
byteStringToHex bs = concatMap (byteToHex . fromIntegral) (BS.unpack bs)
|
||||
|
||||
instance Pretty (AsHexSparse ByteString) where
|
||||
pretty (AsHexSparse bs) = pretty $ unwords $ byteToHex <$> BS.unpack bs
|
||||
|
||||
instance Pretty (AsHexSparse LBS.ByteString) where
|
||||
pretty (AsHexSparse bs) = pretty $ unwords $ byteToHex <$> LBS.unpack bs
|
||||
|
||||
instance Pretty (AsHex ByteString) where
|
||||
pretty (AsHex bs) = pretty $ byteStringToHex bs
|
||||
|
||||
instance Pretty (AsHex LBS.ByteString) where
|
||||
pretty (AsHex bs) = pretty $ byteStringToHex (LBS.toStrict bs)
|
||||
|
||||
instance Show (AsHex ByteString) where
|
||||
show (AsHex bs) = byteStringToHex bs
|
||||
|
||||
instance Show (AsHex LBS.ByteString) where
|
||||
show (AsHex bs) = byteStringToHex (LBS.toStrict bs)
|
||||
|
||||
|
|
|
|||
|
|
@ -25,3 +25,6 @@ section = line <> line
|
|||
toStringANSI :: Doc AnsiStyle -> String
|
||||
toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc
|
||||
|
||||
|
||||
-- asHex ::
|
||||
|
||||
|
|
|
|||
|
|
@ -172,6 +172,54 @@ library
|
|||
other-modules:
|
||||
-- HBS2.System.Logger.Simple
|
||||
|
||||
|
||||
test-suite test
|
||||
import: shared-properties
|
||||
default-language: Haskell2010
|
||||
|
||||
other-modules:
|
||||
|
||||
-- other-extensions:
|
||||
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: test
|
||||
main-is: TestSuite.hs
|
||||
build-depends:
|
||||
base, hbs2-peer, hbs2-core
|
||||
, async
|
||||
, bytestring
|
||||
, cache
|
||||
, containers
|
||||
, directory
|
||||
, hashable
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, prettyprinter
|
||||
, QuickCheck
|
||||
, quickcheck-instances
|
||||
, random
|
||||
, safe
|
||||
, serialise
|
||||
, stm
|
||||
, streaming
|
||||
, tasty
|
||||
, tasty-quickcheck
|
||||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, transformers
|
||||
, uniplate
|
||||
, vector
|
||||
, saltine
|
||||
, simple-logger
|
||||
, string-conversions
|
||||
, filepath
|
||||
, temporary
|
||||
, unliftio
|
||||
, resourcet
|
||||
|
||||
|
||||
|
||||
|
||||
executable hbs2-peer
|
||||
import: shared-properties
|
||||
import: common-deps
|
||||
|
|
|
|||
|
|
@ -24,6 +24,8 @@ import Data.ByteString (ByteString)
|
|||
import Type.Reflection (someTypeRep)
|
||||
import Lens.Micro.Platform
|
||||
|
||||
|
||||
|
||||
newtype RefLogKey s = RefLogKey { fromRefLogKey :: PubKey 'Sign s }
|
||||
deriving stock Generic
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,107 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.OrDie
|
||||
import HBS2.Base58 as B58
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Peer.Proto.RefLog
|
||||
import HBS2.Net.Auth.Schema
|
||||
import HBS2.Misc.PrettyStuff
|
||||
|
||||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import Data.Maybe
|
||||
import Data.ByteString
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Codec.Serialise
|
||||
import Crypto.Saltine.Core.Sign qualified as Sign
|
||||
|
||||
|
||||
newtype W a = W a
|
||||
deriving stock Generic
|
||||
|
||||
instance Serialise a => Serialise (W a)
|
||||
|
||||
|
||||
newtype X a = X a
|
||||
deriving stock Generic
|
||||
|
||||
instance Serialise a => Serialise (X a)
|
||||
|
||||
newtype VersionedPubKey = VersionedPubKey { versionedPubKey :: ByteString }
|
||||
deriving stock (Show,Generic)
|
||||
|
||||
data RefLogRequestVersioned e =
|
||||
RefLogRequestVersioned
|
||||
{ refLogRequestVersioned :: VersionedPubKey
|
||||
}
|
||||
deriving stock (Show,Generic)
|
||||
|
||||
instance Serialise VersionedPubKey
|
||||
|
||||
instance Serialise (RefLogRequestVersioned e)
|
||||
|
||||
testVersionedKeysHashes :: IO ()
|
||||
testVersionedKeysHashes = do
|
||||
|
||||
keypart <- fromBase58 "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
|
||||
& orThrowUser "bad base58"
|
||||
<&> LBS.fromStrict
|
||||
|
||||
pk <- fromStringMay @(PubKey 'Sign HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
|
||||
& orThrowUser "key decode"
|
||||
|
||||
let pks = serialise pk
|
||||
|
||||
pks2 <- deserialiseOrFail @(PubKey 'Sign HBS2Basic) (pks <> "12345")
|
||||
& orThrowUser "key decode error"
|
||||
|
||||
let rfk = serialise (RefLogKey @HBS2Basic pk)
|
||||
let wrfk = serialise $ W (RefLogKey @HBS2Basic pk)
|
||||
let xrfk = serialise $ X (RefLogKey @HBS2Basic pk)
|
||||
|
||||
print $ pretty (AsHexSparse keypart)
|
||||
print $ pretty (AsHexSparse pks)
|
||||
print $ pretty (AsHexSparse rfk)
|
||||
print $ pretty (AsHexSparse wrfk)
|
||||
print $ pretty (AsHexSparse xrfk)
|
||||
|
||||
let req1 = RefLogRequest @L4Proto pk
|
||||
|
||||
let req2 = RefLogRequestVersioned @L4Proto ( VersionedPubKey (LBS.toStrict keypart <> "AAA") )
|
||||
|
||||
print $ yellow "okay"
|
||||
|
||||
let req1s = serialise req1
|
||||
let req2s = serialise req2
|
||||
|
||||
print $ pretty "---"
|
||||
|
||||
print $ pretty (AsHexSparse req1s)
|
||||
print $ pretty (AsHexSparse req2s)
|
||||
|
||||
rq0 <- deserialiseOrFail @(RefLogRequestVersioned L4Proto) req1s
|
||||
& orThrowUser "failed simple -> versioned"
|
||||
|
||||
rq1 <- deserialiseOrFail @(RefLogRequest L4Proto) req2s
|
||||
& orThrowUser "failed versioned -> simple"
|
||||
|
||||
print $ viaShow rq0
|
||||
print $ viaShow req1
|
||||
|
||||
print $ viaShow rq1
|
||||
|
||||
pure ()
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
defaultMain $
|
||||
testGroup "root"
|
||||
[
|
||||
testCase "testVersionedKeys" testVersionedKeysHashes
|
||||
]
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue