mirror of https://github.com/voidlizard/hbs2
137 lines
3.9 KiB
Haskell
137 lines
3.9 KiB
Haskell
{-# Language ViewPatterns #-}
|
|
{-# Language PatternSynonyms #-}
|
|
module HBS2.CLI.Run.Peer where
|
|
|
|
import HBS2.CLI.Prelude
|
|
import HBS2.CLI.Run.Internal
|
|
|
|
import HBS2.Hash
|
|
import HBS2.Base58
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Storage
|
|
import HBS2.Peer.RPC.Client
|
|
import HBS2.Peer.CLI.Detect
|
|
import HBS2.Peer.RPC.Client.Unix
|
|
import HBS2.Peer.RPC.API.Peer
|
|
import HBS2.Peer.RPC.API.RefLog
|
|
import HBS2.Peer.RPC.API.Storage
|
|
import HBS2.Peer.RPC.API.LWWRef
|
|
import HBS2.Net.Auth.Schema()
|
|
|
|
import Data.List qualified as L
|
|
import Data.Maybe
|
|
import Control.Monad.Trans.Cont
|
|
import Data.Text qualified as Text
|
|
import Data.ByteString qualified as BS
|
|
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Lens.Micro.Platform
|
|
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
putTextLit :: forall c m . (IsContext c, MonadUnliftIO m)
|
|
=> AnyStorage
|
|
-> Text
|
|
-> RunM c m (Syntax c)
|
|
|
|
putTextLit sto s = do
|
|
h <- putBlock sto (LBS8.pack (Text.unpack s))
|
|
`orDie` "can't store block"
|
|
<&> HashRef
|
|
|
|
pure (mkStr @c (show $ pretty h))
|
|
|
|
peerEntries :: forall c m . ( IsContext c
|
|
, MonadUnliftIO m
|
|
, HasClientAPI PeerAPI UNIX m
|
|
, HasClientAPI StorageAPI UNIX m
|
|
, HasStorage m
|
|
, Exception (BadFormException c)
|
|
) => MakeDictM c m ()
|
|
peerEntries = do
|
|
|
|
entry $ bindMatch "hbs2:peer:detect" $ \case
|
|
_ -> detectRPC <&> maybe (nil @c) mkStr
|
|
|
|
entry $ bindMatch "hbs2:peer:storage:block:get" $ \case
|
|
[StringLike s] -> do
|
|
flip runContT pure do
|
|
|
|
sto <- getStorage
|
|
ha <- pure (fromStringMay @HashRef s)
|
|
`orDie` "invalid hash"
|
|
|
|
lbs <- getBlock sto (fromHashRef ha)
|
|
`orDie` show ("missed-block" <+> pretty ha)
|
|
|
|
pure $ mkForm "blob" [mkStr (LBS8.unpack lbs)]
|
|
|
|
_ -> throwIO $ BadFormException @c nil
|
|
|
|
entry $ bindMatch "hbs2:peer:storage:block:size" $ \case
|
|
[HashLike ha] -> do
|
|
flip runContT pure do
|
|
sto <- getStorage
|
|
mbsz <- hasBlock sto (fromHashRef ha)
|
|
pure $ maybe (mkSym "no-block") mkInt mbsz
|
|
|
|
_ -> throwIO $ BadFormException @c nil
|
|
|
|
-- stores *small* block
|
|
entry $ bindMatch "hbs2:peer:storage:block:put" $ \case
|
|
|
|
[isOpaqueOf @LBS.ByteString -> Just lbs] -> do
|
|
sto <- getStorage
|
|
(putBlock sto lbs <&> fmap (mkSym . show . pretty . HashRef) )
|
|
>>= orThrowUser "storage error"
|
|
|
|
[isOpaqueOf @BS.ByteString -> Just bs] -> do
|
|
sto <- getStorage
|
|
(putBlock sto (LBS.fromStrict bs) <&> fmap (mkSym . show . pretty . HashRef) )
|
|
>>= orThrowUser "storage error"
|
|
|
|
-- FIXME: deprecate-this
|
|
[ListVal [SymbolVal "blob", LitStrVal s]] -> do
|
|
flip runContT pure do
|
|
sto <- getStorage
|
|
lift $ putTextLit sto s
|
|
|
|
[LitStrVal s] -> do
|
|
flip runContT pure do
|
|
sto <- getStorage
|
|
lift $ putTextLit sto s
|
|
|
|
[] -> do
|
|
bs <- liftIO BS.getContents
|
|
sto <- getStorage
|
|
putBlock sto (LBS.fromStrict bs) >>= \case
|
|
Nothing -> pure nil
|
|
Just h -> pure $ mkSym (show $ pretty $ HashRef h)
|
|
|
|
e -> throwIO $ BadFormException @c (mkList e)
|
|
|
|
brief "checks if peer available"
|
|
$ noArgs
|
|
$ returns "dict" "dictionary of peer attributes"
|
|
$ examples [qc|
|
|
(hbs2:peer:poke)
|
|
(
|
|
(peer-key: "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3")
|
|
(udp: "0.0.0.0:7354")
|
|
(tcp: "tcp://0.0.0.0:3001")
|
|
(local-multicast: "239.192.152.145:10153")
|
|
(rpc: "/tmp/hbs2-rpc.socket")
|
|
(http-port: 5000))
|
|
|]
|
|
$ entry $ bindMatch "hbs2:peer:poke" $ \case
|
|
_ -> do
|
|
api <- getClientAPI @PeerAPI @UNIX
|
|
callRpcWaitMay @RpcPoke (TimeoutSec 1) api ()
|
|
<&> fromMaybe ""
|
|
<&> parseTop
|
|
<&> either (const nil) (mkList . fmap fixContext)
|
|
|
|
|