mirror of https://github.com/voidlizard/hbs2
dns example
This commit is contained in:
voidlizard
parent
ed7f18154f
commit
978478f753
|
|
@ -0,0 +1,82 @@
|
|||
|
||||
;; all key ids are PUBLIC
|
||||
|
||||
(define hosts
|
||||
;; host-id sign-key encrypt-key
|
||||
`[
|
||||
(minime 4Z1ebkksoiZ9j4vZE9jnghxPDmc1ihXdNC6cX39phkLD
|
||||
9Fp8Y5c9Fp612sjby3bL8P3SnUjjK2bz4F38nmVASpzb)
|
||||
|
||||
(expert CxJaFMBykhTdUiXxgdWF2pjxV5cWtw3yjDozNniUYRRC
|
||||
Hg6XD19KGQrVjMYrCNeuaGfhTn7BCCUGR8c3brSWnzQi)
|
||||
|
||||
(minipig 44onTKSrAjXQ42Ahu6Z8d5X35g23pTTbSgRudNow9ZEn
|
||||
D17PC8RGELG2wvTUoeAVhZvpf5R2txQHdwtYxGAJ9M1h)
|
||||
|
||||
]
|
||||
)
|
||||
|
||||
(define (sign-key host)
|
||||
(str (nth 1 (assoc host hosts))))
|
||||
|
||||
(define (encrypt-key host)
|
||||
(str (nth 2 (assoc host hosts))))
|
||||
|
||||
(define my-refchan-head
|
||||
`[
|
||||
|
||||
(version 2)
|
||||
(quorum 1)
|
||||
(wait 10)
|
||||
(peer "CVDMz8BiSvRsgWNbJ4u9vRwXthN8LoF8XbbbjoL2cNFd" 1)
|
||||
(peer "5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb" 1)
|
||||
(peer "J8dFP5TbUQxUpVbVqZ3NKKPwrhvUCTQKC6xrVWUGkrR6" 1)
|
||||
(author ,(sign-key minime))
|
||||
(author ,(sign-key expert))
|
||||
(author ,(sign-key minipig))
|
||||
|
||||
(reader ,(encrypt-key minime))
|
||||
(reader ,(encrypt-key expert))
|
||||
(reader ,(encrypt-key minipig))
|
||||
]
|
||||
)
|
||||
|
||||
(define (create-refchan)
|
||||
[hbs2:refchan:create my-refchan-head]
|
||||
)
|
||||
|
||||
;; created once by create-refchan
|
||||
(define REFCHAN :Aze8PNNexhfz629UfaE79oyRW8Rf7fTGSVoJW4qD95Z7)
|
||||
|
||||
(define (update-refchan)
|
||||
[hbs2:refchan:head:update REFCHAN my-refchan-head]
|
||||
)
|
||||
|
||||
(define (create:name:update host)
|
||||
(begin
|
||||
(local pk (sign-key host))
|
||||
(local tx (hbs2:refchan:tx:raw:create pk [unwords :name host]))
|
||||
tx
|
||||
)
|
||||
)
|
||||
|
||||
(define (post:name:update refchan host)
|
||||
(begin
|
||||
(local tx (create:name:update host))
|
||||
(hbs2:refchan:tx:propose refchan tx)
|
||||
)
|
||||
)
|
||||
|
||||
(define (state:get)
|
||||
(begin
|
||||
(local self [sym [car [cdr [car [ grep peer-key [hbs2:peer:poke] ]]]]])
|
||||
(local txs (grep :propose (hbs2:refchan:tx:raw:list REFCHAN)))
|
||||
(local (hostname e) (car (cdr (car (top:string (bytes:decode [nth 4 _1]))))) )
|
||||
(local peers (call:proc hbs2-peer do peer-info))
|
||||
peers
|
||||
; self
|
||||
; (map [fn 1 [list [nth 2 _1] [hostname _1] ]] txs)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -698,7 +698,7 @@ refchanImport = do
|
|||
|
||||
A _ -> none
|
||||
|
||||
P orig (ProposeTran _ box) -> void $ runMaybeT do
|
||||
P1 ppk orig (ProposeTran _ box) -> void $ runMaybeT do
|
||||
(_, bs) <- unboxSignedBox0 box & toMPlus
|
||||
|
||||
AnnotatedHashRef sn href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
|
||||
|
|
|
|||
|
|
@ -109,6 +109,7 @@ library
|
|||
HBS2.CLI.Run.Internal.GroupKey
|
||||
HBS2.CLI.Run.Internal.Merkle
|
||||
HBS2.CLI.Run.Internal.KeyMan
|
||||
HBS2.CLI.Run.Internal.RefChan
|
||||
HBS2.CLI.Run.GroupKey
|
||||
HBS2.CLI.Run.KeyMan
|
||||
HBS2.CLI.Run.Keyring
|
||||
|
|
|
|||
|
|
@ -0,0 +1,61 @@
|
|||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.CLI.Run.Internal.RefChan (createNewRefChan) where
|
||||
|
||||
import HBS2.CLI.Prelude hiding (mapMaybe)
|
||||
import HBS2.CLI.Run.Internal
|
||||
import HBS2.CLI.Run.Internal.KeyMan
|
||||
|
||||
import HBS2.Peer.Proto.RefChan
|
||||
import HBS2.Storage
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Auth.Schema()
|
||||
import HBS2.Data.Types.SignedBox
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Storage.Operations.Class
|
||||
import HBS2.KeyMan.Keys.Direct
|
||||
|
||||
import HBS2.Peer.RPC.Client.Unix
|
||||
import HBS2.Peer.RPC.Client
|
||||
import HBS2.Peer.RPC.API.Storage
|
||||
import HBS2.Peer.RPC.API.Peer
|
||||
import HBS2.Peer.RPC.API.RefChan
|
||||
|
||||
import Lens.Micro.Platform
|
||||
|
||||
createNewRefChan :: forall c m . ( IsContext c
|
||||
, MonadUnliftIO m
|
||||
, Exception (BadFormException c)
|
||||
, HasClientAPI RefChanAPI UNIX m
|
||||
, HasClientAPI StorageAPI UNIX m
|
||||
, HasClientAPI PeerAPI UNIX m
|
||||
, HasStorage m
|
||||
)
|
||||
=> Maybe (PubKey Sign HBS2Basic)
|
||||
-> RefChanHeadBlock L4Proto
|
||||
-> m (PubKey Sign HBS2Basic)
|
||||
|
||||
createNewRefChan mbk rch = do
|
||||
|
||||
peerApi <- getClientAPI @PeerAPI @UNIX
|
||||
rchanApi <- getClientAPI @RefChanAPI @UNIX
|
||||
sto <- getStorage
|
||||
|
||||
refchan <- maybe1 mbk (keymanNewCredentials (Just "refchan") 0) pure
|
||||
|
||||
creds <- runKeymanClientRO $ loadCredentials refchan
|
||||
>>= orThrowUser "can't load credentials"
|
||||
|
||||
let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch
|
||||
|
||||
href <- writeAsMerkle sto (serialise box)
|
||||
|
||||
--FIXME: timeout-hardcode
|
||||
callService @RpcPollAdd peerApi (refchan, "refchan", 17)
|
||||
>>= orThrowUser "can't subscribe to refchan"
|
||||
|
||||
callService @RpcRefChanHeadPost rchanApi (HashRef href)
|
||||
>>= orThrowUser "can't post refchan head"
|
||||
|
||||
pure refchan
|
||||
|
||||
|
||||
|
|
@ -6,6 +6,8 @@ module HBS2.CLI.Run.RefChan
|
|||
import HBS2.CLI.Prelude
|
||||
import HBS2.CLI.Run.Internal
|
||||
import HBS2.CLI.Run.Internal.KeyMan
|
||||
import HBS2.CLI.Run.Internal.RefChan
|
||||
|
||||
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
|
@ -23,7 +25,8 @@ import HBS2.Storage.Operations.ByteString
|
|||
-- import HBS2.Events
|
||||
-- import HBS2.Peer.Proto.Peer
|
||||
-- import HBS2.Net.Proto.Sessions
|
||||
-- import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Data.Detect
|
||||
-- import HBS2.Data.Types.SignedBox
|
||||
-- import HBS2.Storage
|
||||
|
||||
|
|
@ -45,13 +48,17 @@ import Data.HashMap.Strict qualified as HM
|
|||
import Data.HashSet qualified as HS
|
||||
import Data.Coerce
|
||||
import Control.Monad.Trans.Cont
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Except
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.ByteString.Char8 qualified as BS8
|
||||
import Data.Text qualified as Text
|
||||
import Codec.Serialise
|
||||
import Control.Concurrent.STM qualified as STM
|
||||
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
refchanEntries :: forall c m . ( IsContext c
|
||||
, MonadUnliftIO m
|
||||
|
|
@ -131,17 +138,29 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
|
|||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "hbs2:refchan:head:update" $ \case
|
||||
entry $ bindMatch "hbs2:refchan:head:update" $ \syn -> do
|
||||
|
||||
(rchan, rch) <- case syn of
|
||||
[SignPubKeyLike rchan, StringLike headFile] -> do
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
rchanApi <- getClientAPI @RefChanAPI @UNIX
|
||||
|
||||
rch <- liftIO (readFile headFile)
|
||||
<&> fromStringMay @(RefChanHeadBlock L4Proto)
|
||||
>>= orThrowUser "can't parse RefChanHeadBlock"
|
||||
|
||||
pure (rchan, rch)
|
||||
|
||||
[SignPubKeyLike rchan, ListVal syn] -> do
|
||||
rch <- fromStringMay @(RefChanHeadBlock L4Proto) (show $ vcat (fmap pretty syn))
|
||||
& orThrowUser "can't parse RefChanHeadBlock"
|
||||
|
||||
pure (rchan, rch)
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
rchanApi <- getClientAPI @RefChanAPI @UNIX
|
||||
|
||||
creds <- runKeymanClient $ loadCredentials rchan
|
||||
>>= orThrowUser "can't load credentials"
|
||||
|
||||
|
|
@ -154,8 +173,6 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
|
|||
|
||||
pure nil
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:refchan:get" $ \case
|
||||
[SignPubKeyLike rchan] -> do
|
||||
|
|
@ -169,13 +186,17 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
|
|||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:refchan:create" $ \syn -> do
|
||||
|
||||
peerApi <- getClientAPI @PeerAPI @UNIX
|
||||
rchanApi <- getClientAPI @RefChanAPI @UNIX
|
||||
sto <- getStorage
|
||||
|
||||
rch <- case syn of
|
||||
|
||||
[ListVal es] -> do
|
||||
fromStringMay @(RefChanHeadBlock L4Proto) (show $ vcat (fmap pretty es))
|
||||
& orThrowUser "Invalid refchan head syntax"
|
||||
|
||||
[StringLike headFile] -> do
|
||||
liftIO (readFile headFile)
|
||||
<&> fromStringMay @(RefChanHeadBlock L4Proto)
|
||||
|
|
@ -199,25 +220,8 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
|
|||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
refchan <- keymanNewCredentials (Just "refchan") 0
|
||||
|
||||
creds <- runKeymanClient $ loadCredentials refchan
|
||||
>>= orThrowUser "can't load credentials"
|
||||
|
||||
let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch
|
||||
|
||||
href <- writeAsMerkle sto (serialise box)
|
||||
|
||||
callService @RpcPollAdd peerApi (refchan, "refchan", 17)
|
||||
>>= orThrowUser "can't subscribe to refchan"
|
||||
|
||||
callService @RpcRefChanHeadPost rchanApi (HashRef href)
|
||||
>>= orThrowUser "can't post refchan head"
|
||||
|
||||
let r = mkStr @c $ show $ "; refchan " <+> pretty (AsBase58 refchan) <> line
|
||||
<> pretty rch
|
||||
|
||||
pure r
|
||||
refchan <- createNewRefChan @c Nothing rch
|
||||
pure $ mkSym (show $ pretty (AsBase58 refchan))
|
||||
|
||||
brief "prints refchan head example"
|
||||
$ returns "nil" mempty
|
||||
|
|
@ -310,19 +314,92 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
|
|||
sto <- getStorage
|
||||
void $ hasBlock sto (fromHashRef hash) `orDie` "no block found"
|
||||
let lbs = AnnotatedHashRef Nothing hash & serialise
|
||||
creds <- runKeymanClient $ loadCredentials signpk >>= orThrowUser "can't find credentials"
|
||||
creds <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials"
|
||||
let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
|
||||
pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)]
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
brief "posts Propose transaction to the refchan" $
|
||||
args [arg "string" "refchan", arg "blob" "signed-box"] $
|
||||
entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \case
|
||||
[SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
|
||||
api <- getClientAPI @RefChanAPI @UNIX
|
||||
bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction"
|
||||
void $ callService @RpcRefChanPropose api (rchan, bbox)
|
||||
|
||||
brief "creates RefChanUpdate/SeqRef transaction for refchan" $
|
||||
args [arg "string" "sign-key", arg "string" "payload-tree-hash", arg "(-t int)?" "seqno"] $
|
||||
entry $ bindMatch "hbs2:refchan:tx:seqref:create" $ \syn -> do
|
||||
now <- liftIO $ getPOSIXTime <&> round
|
||||
let (opts, argz) = splitOpts [("-s",1)] syn
|
||||
let s = headDef now [ x | MatchOption "-n" (LitIntVal x) <- opts]
|
||||
case opts of
|
||||
[SignPubKeyLike signpk, HashLike hash] -> do
|
||||
sto <- getStorage
|
||||
void $ hasBlock sto (fromHashRef hash) `orDie` "no block found"
|
||||
let lbs = SequentialRef s (AnnotatedHashRef Nothing hash) & serialise
|
||||
creds <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials"
|
||||
let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
|
||||
pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)]
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
brief "creates RefChanUpdate/Raw transaction for refchan" $
|
||||
args [arg "string" "sign-key", arg "string" "data"] $
|
||||
entry $ bindMatch "hbs2:refchan:tx:raw:create" $ \syn -> do
|
||||
case syn of
|
||||
[SignPubKeyLike signpk, StringLike x] -> do
|
||||
let lbs = LBS8.pack x & serialise
|
||||
creds <- runKeymanClientRO $ loadCredentials signpk >>= orThrowUser "can't find credentials"
|
||||
let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
|
||||
mkOpaque @c box
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:refchan:tx:raw:list" $ \case
|
||||
[SignPubKeyLike rchan] -> lift do
|
||||
|
||||
q <- newTQueueIO
|
||||
|
||||
walkRefChanTx @UNIX (const $ pure True) rchan $ \txh u -> do
|
||||
|
||||
case u of
|
||||
|
||||
A (AcceptTran (Just ts) self what) -> do
|
||||
let tx = fromIntegral ts :: Integer
|
||||
let hs = show $ pretty self
|
||||
let they = show $ pretty what
|
||||
let x = mkForm @c "accept" [ mkSym hs, mkInt tx, mkSym they ]
|
||||
atomically $ writeTQueue q x
|
||||
|
||||
A _ -> none
|
||||
|
||||
P1 ppk h (ProposeTran _ box) -> void $ runMaybeT do
|
||||
(pk, bs) <- unboxSignedBox0 box & toMPlus
|
||||
bss <- deserialiseOrFail @LBS.ByteString (LBS.fromStrict bs) & toMPlus
|
||||
e <- mkOpaque bss
|
||||
let hs = show $ pretty h
|
||||
let ppks = show (pretty (AsBase58 ppk))
|
||||
let pks = show (pretty (AsBase58 pk))
|
||||
let x = mkForm @c "propose" [ mkSym hs, mkSym ppks, mkSym pks, e ]
|
||||
atomically $ writeTQueue q x
|
||||
|
||||
P0{} -> none
|
||||
|
||||
mkList <$> atomically (STM.flushTQueue q)
|
||||
|
||||
e -> throwIO (BadFormException @c (mkList e))
|
||||
|
||||
brief "posts Propose transaction to the refchan" $
|
||||
args [arg "string" "refchan", arg "blob" "signed-box"] $
|
||||
entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \syn -> do
|
||||
|
||||
(chan,lbs) <- case syn of
|
||||
[SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
|
||||
bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction"
|
||||
pure (rchan, bbox)
|
||||
|
||||
[SignPubKeyLike rchan, MatchOpaqueVal @_ @LBS.ByteString lbs] -> do
|
||||
pure (rchan, lbs)
|
||||
|
||||
_ -> throwIO (BadFormException @c (mkList syn))
|
||||
|
||||
api <- getClientAPI @RefChanAPI @UNIX
|
||||
box <- deserialiseOrFail lbs & orThrowUser "invalid box"
|
||||
void $ callService @RpcRefChanPropose api (chan, box)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# Language PatternSynonyms #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
module HBS2.Peer.RPC.Client.RefChan where
|
||||
|
||||
|
|
@ -134,10 +136,16 @@ instance Monad m => HasClientAPI RefChanAPI proto (ReaderT (RScanEnv proto) m) w
|
|||
getClientAPI = asks rchanAPI
|
||||
|
||||
data RefChanUpdateUnpacked e =
|
||||
A (AcceptTran e) | P HashRef (ProposeTran e)
|
||||
A (AcceptTran e)
|
||||
| P0 HashRef (ProposeTran e)
|
||||
| P1 (PubKey Sign (Encryption e)) HashRef (ProposeTran e)
|
||||
|
||||
deriving stock (Generic)
|
||||
|
||||
{-# COMPLETE A,P #-}
|
||||
{-# COMPLETE A,P,P1 #-}
|
||||
|
||||
pattern P :: HashRef -> ProposeTran e -> RefChanUpdateUnpacked e
|
||||
pattern P h p <- P1 _ h p
|
||||
|
||||
unpackRefChanUpdate :: forall e . ForRefChans e
|
||||
=> HashRef
|
||||
|
|
@ -154,8 +162,8 @@ unpackRefChanUpdate href lbs = runIdentity $ runMaybeT do
|
|||
pure (A txx)
|
||||
|
||||
Propose _ box -> do
|
||||
(_, txx) <- MaybeT $ pure $ unboxSignedBox0 box
|
||||
pure (P href txx)
|
||||
(ppk, txx) <- MaybeT $ pure $ unboxSignedBox0 box
|
||||
pure (P1 ppk href txx)
|
||||
|
||||
walkRefChanTx :: forall proto m . ( MonadIO m
|
||||
, HasClientAPI RefChanAPI proto m
|
||||
|
|
|
|||
|
|
@ -56,9 +56,10 @@ pattern MatchOption n e <- ListVal [SymbolVal n, e]
|
|||
pattern MatchFlag :: forall {c} . Id -> Syntax c
|
||||
pattern MatchFlag n <- ListVal [SymbolVal n]
|
||||
|
||||
splitOpts :: [(Id,Int)]
|
||||
-> [Syntax C]
|
||||
-> ([Syntax C], [Syntax C])
|
||||
splitOpts :: forall c . IsContext c
|
||||
=> [(Id,Int)]
|
||||
-> [Syntax c]
|
||||
-> ([Syntax c], [Syntax c])
|
||||
|
||||
splitOpts def opts' = flip fix (mempty, opts) $ \go -> \case
|
||||
(acc, []) -> acc
|
||||
|
|
@ -67,7 +68,7 @@ splitOpts def opts' = flip fix (mempty, opts) $ \go -> \case
|
|||
Nothing -> go ((o, a <> [r]), rs)
|
||||
Just n -> do
|
||||
let (w, rest) = List.splitAt n rs
|
||||
let result = mkList @C ( r : w )
|
||||
let result = mkList @c ( r : w )
|
||||
go ( (o <> [result], a), rest )
|
||||
( (o,a), r : rs ) -> do
|
||||
go ((o, a <> [r]), rs)
|
||||
|
|
|
|||
|
|
@ -1523,6 +1523,13 @@ internalEntries = do
|
|||
liftIO TIO.getContents
|
||||
<&> either (const nil) (mkList . fmap fixContext) . parseTop
|
||||
|
||||
|
||||
entry $ bindMatch "top:string" $ \case
|
||||
[TextLike s] -> do
|
||||
pure $ either (const nil) (mkList . fmap fixContext) (parseTop s)
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindMatch "top:file" $ \case
|
||||
[StringLike fn] -> do
|
||||
liftIO $ TIO.readFile fn
|
||||
|
|
|
|||
Loading…
Reference in New Issue