From f2de0be6623701b3c6d18761afce1db9ff5ef638 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Tue, 12 Mar 2024 07:14:11 +0300 Subject: [PATCH] wip --- hbs2-core/lib/HBS2/Base58.hs | 37 +++++++- hbs2-git/lib/HBS2Git/PrettyStuff.hs | 3 + hbs2-peer/hbs2-peer.cabal | 48 +++++++++++ hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs | 2 + hbs2-peer/test/TestSuite.hs | 107 ++++++++++++++++++++++++ 5 files changed, 196 insertions(+), 1 deletion(-) create mode 100644 hbs2-peer/test/TestSuite.hs diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index 5ba1e000..db41a17b 100644 --- a/hbs2-core/lib/HBS2/Base58.hs +++ b/hbs2-core/lib/HBS2/Base58.hs @@ -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) + diff --git a/hbs2-git/lib/HBS2Git/PrettyStuff.hs b/hbs2-git/lib/HBS2Git/PrettyStuff.hs index 688dee5a..f3f4570b 100644 --- a/hbs2-git/lib/HBS2Git/PrettyStuff.hs +++ b/hbs2-git/lib/HBS2Git/PrettyStuff.hs @@ -25,3 +25,6 @@ section = line <> line toStringANSI :: Doc AnsiStyle -> String toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc + +-- asHex :: + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 45259898..ede78366 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs index 68e0139b..31f6503c 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs @@ -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 diff --git a/hbs2-peer/test/TestSuite.hs b/hbs2-peer/test/TestSuite.hs new file mode 100644 index 00000000..d0208a39 --- /dev/null +++ b/hbs2-peer/test/TestSuite.hs @@ -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 + ] + + +