wip

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -51,6 +51,8 @@ instance (IsKey HbSync, Key HbSync ~ Hash HbSync, Block ByteString ~ ByteString)
   getBlock (AnyStorage s) = getBlock s
   getChunk (AnyStorage s) = getChunk s
   hasBlock (AnyStorage s) = hasBlock s
+  writeLinkRaw (AnyStorage s) = writeLinkRaw s
+  readLinkRaw (AnyStorage s) = readLinkRaw s
 
 data AnyMessage enc e = AnyMessage !Integer !(Encoded e)
                        deriving stock (Generic)

hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs

@@ -2,8 +2,8 @@
 {-# Language UndecidableInstances #-}
 module HBS2.Net.Proto.RefLinear where
 
+-- import HBS2.Actors.Peer
 import HBS2.Data.Types.Refs
-import HBS2.Events
 import HBS2.Hash
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto

hbs2-core/lib/HBS2/Prelude.hs

@@ -4,7 +4,6 @@ module HBS2.Prelude
   , MonadIO(..)
   , void, guard, when, unless
   , maybe1
-  , orExcept
   , Hashable
   , lift
   , AsFileName(..)
@@ -23,7 +22,6 @@ import Safe
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad (void,guard,when,unless)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except
 
 import Data.Function
 import Data.Char qualified as Char
@@ -57,6 +55,3 @@ class ToByteString a where
 
 class FromByteString a where
   fromByteString :: ByteString -> Maybe a
-
-orExcept :: Monad m => m (Maybe a) -> e -> ExceptT e m a
-orExcept mev msg = ExceptT $ maybe (Left msg) Right <$> mev

hbs2-core/lib/HBS2/Storage.hs

@@ -47,7 +47,9 @@ class ( Monad m
 
   -- listBlocks :: a -> ( Key block -> m () ) -> m ()
 
+  writeLinkRaw :: a -> Key h -> Block block -> m (Maybe (Key h))
 
+  readLinkRaw :: a -> Key h -> m (Maybe (Block block))
 
 calcChunks :: forall a b . (Integral a, Integral b)
            => Integer  -- | block size
@@ -57,6 +59,3 @@ calcChunks :: forall a b . (Integral a, Integral b)
 calcChunks s1 s2 = fmap (over _1 fromIntegral . over _2 fromIntegral)  chu
   where
     chu = fmap (,s2) (takeWhile (<s1) $ iterate (+s2) 0)
-
-
-

hbs2-peer/app/PeerMain.hs

@@ -8,6 +8,7 @@ module Main where
 import HBS2.Actors.Peer
 import HBS2.Base58
 import HBS2.Clock
+import HBS2.Data.Types.Refs
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
@@ -43,10 +44,12 @@ import Data.Foldable (for_)
 import Data.Maybe
 import Crypto.Saltine (sodiumInit)
 import Data.Function
+import Codec.Serialise (deserialiseOrFail)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception as Exception
 import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy qualified as LBS
 import Data.List qualified  as L
@@ -597,24 +600,28 @@ runPeer opts = Exception.handle myException $ do
                             ANNLREF h -> do
                               debug $ "got annlref rpc" <+> pretty h
                               sto <- getStorage
-                              -- mbsize <- liftIO $ hasBlock sto h  -- FIXME:
 
-                              -- FIXME: get by hash h value AnnounceLinearRef(LinearMutableRefSigned{})
+                              void $ runMaybeT do
 
-                              -- maybe1 mbsize (pure ()) $ \size -> do
+                                  refvalraw <- MaybeT $ (liftIO $ readLinkRaw sto h)
-                              --   debug "send multicast annlref"
+                                    `orLogError` "error reading ref val"
+                                  slref@(LinearMutableRefSigned _ ref) <- MaybeT $
+                                      pure ((either (const Nothing) Just
+                                           . deserialiseOrFail @(Signed SignaturePresent (MutableRef e 'LinearRef))) refvalraw)
+                                      `orLogError` "can not parse channel ref"
 
-                              --   no <- peerNonce @e
+                                  let annlref :: AnnLRef UDP
-                              --   let annInfo = BlockAnnlrefInfo 0 NoBlockInfoMeta size h  -- FIXME:
+                                      annlref = AnnLRef @e h slref
-                              --   let annlref = BlockAnnlref @e no annInfo  -- FIXME:
 
-                              --   request localMulticast annlref
+                                  lift do
 
-                              --   liftIO $ withPeerM env do
+                                      debug "send multicast annlref"
-                              --     forKnownPeers $ \p _ -> do
+                                      request localMulticast annlref
-                              --       debug $ "send single-cast annlrefs" <+> pretty p
+
-                              --       request @e p annlref
+                                      withPeerM env do
-                              undefined
+                                        forKnownPeers $ \p _ -> do
+                                          debug $ "send single-cast annlrefs" <+> pretty p
+                                          request @e p annlref
 
                             CHECK nonce pa h -> do
                               pip <- fromPeerAddr @e pa
@@ -754,6 +761,8 @@ runPeer opts = Exception.handle myException $ do
 
   simpleStorageStop s
 
+orLogError :: MonadIO m => m (Maybe a) -> String -> m (Maybe a)
+orLogError ma msg = maybe (err msg >> pure Nothing) (pure . Just) =<< ma
 
 
 emitToPeer :: ( MonadIO m

hbs2-storage-simple/lib/HBS2/Storage/Simple.hs

@@ -308,6 +308,7 @@ spawnAndWait s act = do
 simpleWriteLinkRaw :: forall h . ( IsSimpleStorageKey h
                                  , Hashed h LBS.ByteString
                                  , ToByteString (AsBase58 (Hash h))
+                                 , FromByteString (AsBase58 (Hash h))
                                  )
                    => SimpleStorage h
                    -> Hash h
@@ -323,32 +324,17 @@ simpleWriteLinkRaw ss h lbs = do
       BS.writeFile fnr (toByteString (AsBase58 r))
       pure h
 
-simpleReadLinkRaw :: IsKey h
+simpleReadLinkRaw :: ( IsKey h
-                  => SimpleStorage h
-                  -> Hash h
-                  -> IO (Maybe LBS.ByteString)
-
-simpleReadLinkRaw ss hash = do
-  let fn = simpleRefFileName ss hash
-  rs <- spawnAndWait ss $ do
-    r <- tryJust (guard . isDoesNotExistError) (LBS.readFile fn)
-    case r of
-      Right bs -> pure (Just bs)
-      Left  _  -> pure Nothing
-
-  pure $ fromMaybe Nothing rs
-
-
-simpleReadLinkVal :: ( IsKey h
                      , IsSimpleStorageKey h
                      , Hashed h LBS.ByteString
+                     , ToByteString (AsBase58 (Hash h))
                      , FromByteString (AsBase58 (Hash h))
                      )
                   => SimpleStorage h
                   -> Hash h
                   -> IO (Maybe LBS.ByteString)
 
-simpleReadLinkVal ss hash = do
+simpleReadLinkRaw ss hash = do
   let fn = simpleRefFileName ss hash
   rs <- spawnAndWait ss $ do
     r <- tryJust (guard . isDoesNotExistError) (BS.readFile fn)
@@ -366,6 +352,8 @@ instance ( MonadIO m, IsKey hash
          , Key hash ~ Hash hash
          , IsSimpleStorageKey hash
          , Block LBS.ByteString ~ LBS.ByteString
+         , ToByteString (AsBase58 (Hash hash))
+         , FromByteString (AsBase58 (Hash hash))
          )
   => Storage (SimpleStorage hash) hash LBS.ByteString m where
 
@@ -379,6 +367,6 @@ instance ( MonadIO m, IsKey hash
 
   hasBlock s k = liftIO $ simpleBlockExists s k
 
+  writeLinkRaw s key lbs = liftIO $ simpleWriteLinkRaw s key lbs
 
-
+  readLinkRaw s key = liftIO $ simpleReadLinkRaw s key
-

hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs

@@ -1,6 +1,7 @@
 {-# Language UndecidableInstances #-}
 module HBS2.Storage.Simple.Extra where
 
+import HBS2.Base58
 import HBS2.Merkle
 import HBS2.Hash
 import HBS2.Prelude
@@ -23,7 +24,12 @@ pieces :: Integral a => a
 pieces = 1024
 
 class SimpleStorageExtra a  where
-  putAsMerkle :: forall h . (IsSimpleStorageKey h, Hashed h ByteString) => SimpleStorage h -> a -> IO MerkleHash
+  putAsMerkle :: forall h .
+      (IsSimpleStorageKey h, Hashed h ByteString
+      , ToByteString (AsBase58 (Hash h))
+      , FromByteString (AsBase58 (Hash h))
+      )
+      => SimpleStorage h -> a -> IO MerkleHash
 
 readChunked :: MonadIO m => Handle -> Int -> S.Stream (S.Of ByteString) m ()
 readChunked handle size = fuu

hbs2/Main.hs

@@ -359,7 +359,7 @@ runListLRef nf ss = do
           print $ "owner:" <+> viaShow (refOwner g)
           print $ "title:" <+> viaShow (refName g)
           print $ "meta:" <+> viaShow (refMeta g)
-      simpleReadLinkVal ss chh >>= \case
+      simpleReadLinkRaw ss chh >>= \case
           Nothing -> do
               print $ "empty"
           Just refvalraw -> do
@@ -375,7 +375,7 @@ readNodeLinearRefList ss pk = do
     -- полученный хэш будет хэшем ссылки на список референсов ноды
     lrh :: Hash HbSync <- pure do
         (hashObject . serialise) (nodeLinearRefsRef @e pk)
-    simpleReadLinkVal ss lrh >>= \case
+    simpleReadLinkRaw ss lrh >>= \case
       Nothing -> pure []
       Just refvalraw -> do
           LinearMutableRefSigned _ ref
@@ -394,7 +394,7 @@ modifyLinearRef ss kr chh modIO = do
       `orDie` "can not read channel ref genesis"
     when (refOwner g /= _peerSignPk kr) do
       (pure Nothing) `orDie` "channel ref owner does not match genesis owner"
-    mrefvalraw <- simpleReadLinkVal ss chh
+    mrefvalraw <- simpleReadLinkRaw ss chh
     lmr <- case mrefvalraw of
         Nothing -> do
             val <- modIO Nothing
@@ -419,20 +419,14 @@ modifyLinearRef ss kr chh modIO = do
       `orDie` "can not write link"
     pure ()
 
--- FIXME: make polymorphic, move to storage
-getLRef :: forall e.
-    (Serialise (Signature e))
-    => SimpleStorage HbSync -> Hash HbSync -> IO (Either String (Signed SignaturePresent (MutableRef e 'LinearRef)))
-getLRef ss refh = runExceptT do
-    refvalraw <- simpleReadLinkVal ss refh
-        `orExcept` "error reading ref val"
-    pure (deserialiseMay @(Signed SignaturePresent (MutableRef e 'LinearRef)) refvalraw)
-        `orExcept` "can not parse channel ref"
-
 runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO ()
 runGetLRef refh ss = do
     hPrint stderr $ "getting ref value" <+> pretty refh
-    LinearMutableRefSigned _ ref <- getLRef @UDP ss refh `orDie` "getLRef"
+    refvalraw <- readLinkRaw ss refh
+        `orDie` "error reading ref val"
+    LinearMutableRefSigned _ ref
+        <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw)
+        `orDie` "can not parse channel ref"
     hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref)
     print $ pretty (lrefVal ref)