voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Sergey Ivanov 2023-03-05 02:06:34 +04:00
parent 192d7472c1
commit beb3015a53
8 changed files with 50 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
hbs2-core/lib/HBS2/Actors/Peer.hs
View File

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

2
hbs2-core/lib/HBS2/Net/Proto/RefLinear.hs
View File

@ -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

5
hbs2-core/lib/HBS2/Prelude.hs
View File

@ -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

5
hbs2-core/lib/HBS2/Storage.hs
View File

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

35
hbs2-peer/app/PeerMain.hs
View File

@ -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
-- 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

28
hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
View File

@ -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

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

@ -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

22
hbs2/Main.hs
View File

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