diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 12924058..16895891 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs index 4dbd8a2a..1215f397 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index f99645dc..601e6f41 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index 60c4b830..f0c6c729 100644 --- a/hbs2-core/lib/HBS2/Storage.hs +++ b/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 ( 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 - -- debug "send multicast annlref" + refvalraw <- MaybeT $ (liftIO $ readLinkRaw sto h) + `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 annInfo = BlockAnnlrefInfo 0 NoBlockInfoMeta size h -- FIXME: - -- let annlref = BlockAnnlref @e no annInfo -- FIXME: + let annlref :: AnnLRef UDP + annlref = AnnLRef @e h slref - -- request localMulticast annlref + lift do - -- liftIO $ withPeerM env do - -- forKnownPeers $ \p _ -> do - -- debug $ "send single-cast annlrefs" <+> pretty p - -- request @e p annlref - undefined + debug "send multicast annlref" + request localMulticast annlref + + withPeerM env do + 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 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 2568336f..10a0f203 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/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 - => 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 +simpleReadLinkRaw :: ( 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 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs index b09b9204..658f48b8 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple/Extra.hs +++ b/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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index dbf25ee0..09af43a5 100644 --- a/hbs2/Main.hs +++ b/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)