mirror of https://github.com/voidlizard/hbs2
105 lines
2.9 KiB
Haskell
105 lines
2.9 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
module HBS2.CLI.Run.Internal
|
|
( module HBS2.CLI.Run.Internal
|
|
, module SC
|
|
) where
|
|
|
|
import HBS2.CLI.Prelude
|
|
|
|
import HBS2.OrDie
|
|
import HBS2.Base58
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Storage
|
|
import HBS2.Peer.CLI.Detect
|
|
import HBS2.Peer.RPC.Client.Unix
|
|
import HBS2.Peer.RPC.API.Peer
|
|
import HBS2.Peer.RPC.API.Storage
|
|
import HBS2.Peer.RPC.Client.StorageClient
|
|
|
|
import Data.Config.Suckless.Script qualified as SC
|
|
import Data.Config.Suckless.Script hiding (internalEntries)
|
|
|
|
import Data.ByteString.Char8 qualified as BS8
|
|
import Data.Text qualified as Text
|
|
|
|
pattern HashLike:: forall {c} . HashRef -> Syntax c
|
|
pattern HashLike x <- (
|
|
\case
|
|
StringLike s -> fromStringMay @HashRef s
|
|
_ -> Nothing
|
|
-> Just x )
|
|
|
|
pattern SignPubKeyLike :: forall {c} . (PubKey 'Sign 'HBS2Basic) -> Syntax c
|
|
pattern SignPubKeyLike x <- (
|
|
\case
|
|
StringLike s -> fromStringMay s
|
|
_ -> Nothing
|
|
-> Just x )
|
|
|
|
internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
|
|
internalEntries = do
|
|
SC.internalEntries
|
|
|
|
entry $ bindMatch "blob:base58" $ \case
|
|
[LitStrVal t] -> do
|
|
bs <- pure (Text.unpack t & BS8.pack & fromBase58)
|
|
`orDie` "invalid base58"
|
|
<&> BS8.unpack
|
|
|
|
pure (mkForm "blob" [mkStr @c bs])
|
|
|
|
_ -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
let decodeB58 t = do
|
|
pure (Text.unpack t & BS8.pack & fromBase58)
|
|
`orDie` "invalid base58"
|
|
|
|
let decodeAndOut t = do
|
|
liftIO $ BS8.putStr =<< decodeB58 t
|
|
|
|
entry $ bindMatch "base58:encode" $ \case
|
|
[LitStrVal t] -> do
|
|
let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
|
|
pure (mkForm "blob:base58" [mkStr @c s])
|
|
|
|
[ListVal [SymbolVal "blob", LitStrVal t]] -> do
|
|
let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack
|
|
pure (mkForm "blob:base58" [mkStr @c s])
|
|
|
|
e -> throwIO (BadFormException @c nil)
|
|
|
|
entry $ bindMatch "base58:decode" $ \case
|
|
|
|
[ListVal [SymbolVal "blob:base58", LitStrVal t]] -> do
|
|
s <- decodeB58 t <&> BS8.unpack
|
|
pure $ mkForm "blob" [mkStr @c s]
|
|
|
|
e -> throwIO (BadFormException @c nil)
|
|
|
|
entry $ bindMatch "base58:put" $ nil_ $ \case
|
|
[ListVal [SymbolVal "blob:base58", LitStrVal t]] ->
|
|
decodeAndOut t
|
|
|
|
[LitStrVal t] -> decodeAndOut t
|
|
|
|
e -> throwIO (BadFormException @c nil)
|
|
|
|
|
|
instance MonadUnliftIO m => HasStorage (RunM c m) where
|
|
getStorage = do
|
|
so <- detectRPC `orDie` "hbs2-peer not found"
|
|
withRPC2 @StorageAPI @UNIX so $ \caller -> do
|
|
pure $ AnyStorage (StorageClient caller)
|
|
|
|
withPeerStorage :: (IsContext c, MonadUnliftIO m) => (AnyStorage -> RunM c m a) -> RunM c m a
|
|
withPeerStorage m = do
|
|
so <- detectRPC `orDie` "hbs2-peer not found"
|
|
|
|
withRPC2 @StorageAPI @UNIX so $ \caller -> do
|
|
let sto = AnyStorage (StorageClient caller)
|
|
m sto
|
|
|
|
|