wip

hbs2-core/lib/HBS2/Refs/Linear.hs

@@ -22,15 +22,14 @@ import Data.ByteString.Lazy qualified as LBS
 import Data.Maybe
 import Data.Set qualified as Set
 
-modifyLinearRef :: forall e st block.
+modifyLinearRef :: forall e.
     ( Signatures e
     , Serialise (Signature e)
     , Serialise (PubKey 'Sign e)
     , Eq (PubKey 'Sign e)
-    , Block block ~ LBS.ByteString
+    , Block LBS.ByteString ~ LBS.ByteString
-    , Storage (st HbSync) HbSync block IO
     )
-  => st HbSync
+  => AnyStorage
   -> PeerCredentials e   -- owner keyring
   -> Hash HbSync         -- channel id
   -> (Maybe (Hash HbSync) -> IO (Hash HbSync))
@@ -76,15 +75,14 @@ verifyLinearMutableRefSigned pk lref = do
   where
     dat = (LBS.toStrict . serialise) (lmrefSignedRef lref)
 
-tryUpdateLinearRef :: forall e st block.
+tryUpdateLinearRef :: forall e.
     ( Signatures e
     , Serialise (Signature e)
     , Serialise (PubKey 'Sign e)
     , Eq (PubKey 'Sign e)
-    , Block block ~ LBS.ByteString
+    , Block LBS.ByteString ~ LBS.ByteString
-    , Storage (st HbSync) HbSync block IO
     )
-  => st HbSync
+  => AnyStorage
   -> Hash HbSync                -- channel id
   -> Signed SignatureVerified (MutableRef e 'LinearRef)
   -> IO Bool
@@ -112,15 +110,14 @@ tryUpdateLinearRef ss chh vlref = do
           pure True
       else (pure False)
 
-modifyNodeLinearRefList :: forall e st block.
+modifyNodeLinearRefList :: forall e.
     ( Signatures e
     , Serialise (Signature e)
     , Serialise (PubKey 'Sign e)
     , Eq (PubKey 'Sign e)
-    , Block block ~ LBS.ByteString
+    , Block LBS.ByteString ~ LBS.ByteString
-    , Storage (st HbSync) HbSync block IO
     )
-    => st HbSync -> PeerCredentials e -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO ()
+    => AnyStorage -> PeerCredentials e -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO ()
 modifyNodeLinearRefList ss kr chh f =
     modifyLinearRef ss kr chh \mh -> do
         v <- case mh of
@@ -130,15 +127,14 @@ modifyNodeLinearRefList ss kr chh f =
         (putBlock ss . serialise) (f v)
             `orDie` "can not put new node channel list block"
 
-readNodeLinearRefList :: forall e st block.
+readNodeLinearRefList :: forall e.
     ( Signatures e
     , Serialise (Signature e)
     , Serialise (PubKey 'Sign e)
     , Eq (PubKey 'Sign e)
-    , Block block ~ LBS.ByteString
+    , Block LBS.ByteString ~ LBS.ByteString
-    , Storage (st HbSync) HbSync block IO
     )
-    => st HbSync -> PubKey 'Sign e -> IO [Hash HbSync]
+    => AnyStorage -> PubKey 'Sign e -> IO [Hash HbSync]
 readNodeLinearRefList ss pk = do
     -- полученный хэш будет хэшем ссылки на список референсов ноды
     lrh :: h <- pure $ (hashObject . serialise) (nodeLinearRefsRef @e pk)
@@ -151,15 +147,14 @@ readNodeLinearRefList ss pk = do
           fromMaybe mempty . ((either (const Nothing) Just . deserialiseOrFail) =<<)
               <$> getBlock ss (lrefVal ref)
 
-nodeRefListAdd :: forall e st block.
+nodeRefListAdd :: forall e.
     ( Signatures e
     , Serialise (Signature e)
     , Serialise (PubKey 'Sign e)
     , Eq (PubKey 'Sign e)
-    , Block block ~ LBS.ByteString
+    , Block LBS.ByteString ~ LBS.ByteString
-    , Storage (st HbSync) HbSync block IO
     )
-    => st HbSync -> PeerCredentials e -> Hash HbSync -> IO ()
+    => AnyStorage -> PeerCredentials e -> Hash HbSync -> IO ()
 nodeRefListAdd ss nodeCred chh = do
   -- полученный хэш будет хэшем ссылки на список референсов ноды
   lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @e (_peerSignPk nodeCred))

hbs2-peer/app/PeerMain.hs

@@ -26,6 +26,7 @@ import HBS2.Net.Proto.Sessions
 import HBS2.OrDie
 import HBS2.Prelude.Plated
 import HBS2.Refs.Linear
+import HBS2.Storage
 import HBS2.Storage.Simple
 
 import HBS2.System.Logger.Simple hiding (info)
@@ -367,11 +368,6 @@ mkLRefAdapter :: forall e st block m .
     , Serialise (Signature e)
     , Serialise (PubKey 'Sign e)
     , Eq (PubKey 'Sign e)
-    -- , Block block ~ LBS.ByteString
-    -- , Storage (st HbSync) HbSync block IO
-    -- ( m ~ LRefI e (CredentialsM e (ResponseM e (PeerM e IO)))
-    -- , Pretty (Peer e)
-    -- , Block ByteString ~ ByteString
     )
     => m (LRefI e (CredentialsM e (ResponseM e m)))
 mkLRefAdapter = do

hbs2/Main.hs

@@ -15,6 +15,7 @@ import HBS2.OrDie
 import HBS2.Prelude
 import HBS2.Prelude.Plated
 import HBS2.Refs.Linear
+import HBS2.Storage
 import HBS2.Storage.Simple
 import HBS2.Storage.Simple.Extra
 
@@ -320,33 +321,33 @@ runDumpACB inFile = do
 ---
 
 runNewLRef :: FilePath -> FilePath -> Text -> SimpleStorage HbSync -> IO ()
-runNewLRef nf uf refName ss = do
+runNewLRef nf uf refName (AnyStorage -> st) = do
   hPrint stderr $ "adding a new channel ref" <+> pretty nf <+> pretty uf
-  nodeCred <- (parseCredentials . AsCredFile <$> BS.readFile nf)
+  nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf)
       `orDie` "bad node keyring file"
-  ownerCred <- (parseCredentials @[Hash HbSync] . AsCredFile <$> BS.readFile uf)
+  ownerCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile uf)
       `orDie` "bad ref owner keyring file"
   -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred
   -- Это тоже перенести в Refs.hs ?
-  chh <- (putBlock ss . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData)
+  chh <- (putBlock st . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData)
       `orDie` "can not put channel genesis block"
-  nodeRefListAdd ss nodeCred chh
+  nodeRefListAdd st nodeCred chh
 
 runListLRef :: FilePath -> SimpleStorage HbSync -> IO ()
-runListLRef nf ss = do
+runListLRef nf (AnyStorage -> st) = do
   hPrint stderr $ "listing node channels" <+> pretty nf
   nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf)
       `orDie` "bad node keyring file"
-  hs :: [Hash HbSync] <- readNodeLinearRefList ss (_peerSignPk nodeCred)
+  hs :: [Hash HbSync] <- readNodeLinearRefList @UDP st (_peerSignPk nodeCred)
   forM_ hs \chh -> do
       putStrLn ""
       print $ pretty chh
-      mg <- (mdeserialiseMay @(RefGenesis [Hash HbSync]) <$> getBlock ss chh)
+      mg <- (mdeserialiseMay @(RefGenesis [Hash HbSync]) <$> getBlock st chh)
       forM_ mg \g -> do
           print $ "owner:" <+> viaShow (refOwner g)
           print $ "title:" <+> viaShow (refName g)
           print $ "meta:" <+> viaShow (refMeta g)
-      simpleReadLinkRaw ss chh >>= \case
+      readLinkRaw st chh >>= \case
           Nothing -> do
               print $ "empty"
           Just refvalraw -> do
@@ -357,9 +358,9 @@ runListLRef nf ss = do
               print $ "val: " <+> pretty (lrefVal ref)
 
 runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO ()
-runGetLRef refh ss = do
+runGetLRef refh (AnyStorage -> st) = do
     hPrint stderr $ "getting ref value" <+> pretty refh
-    refvalraw <- readLinkRaw ss refh
+    refvalraw <- readLinkRaw st refh
         `orDie` "error reading ref val"
     LinearMutableRefSigned _ ref
         <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw)
@@ -368,11 +369,11 @@ runGetLRef refh ss = do
     print $ pretty (lrefVal ref)
 
 runUpdateLRef :: FilePath -> Hash HbSync -> Hash HbSync -> SimpleStorage HbSync -> IO ()
-runUpdateLRef uf refh valh ss = do
+runUpdateLRef uf refh valh (AnyStorage -> st) = do
   hPrint stderr $ "updating channel" <+> pretty refh <+> "with value" <+> pretty valh
   ownerCred <- (parseCredentials @[Hash HbSync] . AsCredFile <$> BS.readFile uf)
       `orDie` "bad ref owner keyring file"
-  modifyLinearRef ss ownerCred refh \_ -> pure valh
+  modifyLinearRef st ownerCred refh \_ -> pure valh
 
 ---
 

hbs2/hbs2.cabal

@@ -55,6 +55,7 @@ common shared-properties
                      , TupleSections
                      , TypeApplications
                      , TypeFamilies
+                     , ViewPatterns
 
 
 executable hbs2