wip

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)
+

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 ::
+

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

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
 

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
+      ]
+
+
+