diff --git a/examples/dns-example-1/dns.ss b/examples/dns-example-1/dns.ss new file mode 100644 index 00000000..d586f737 --- /dev/null +++ b/examples/dns-example-1/dns.ss @@ -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) + ) +) + + diff --git a/fixme-new/lib/Fixme/Run/Internal.hs b/fixme-new/lib/Fixme/Run/Internal.hs index f28553ce..20eaa4ad 100644 --- a/fixme-new/lib/Fixme/Run/Internal.hs +++ b/fixme-new/lib/Fixme/Run/Internal.hs @@ -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) diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index 4a509705..09fc27fc 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -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 diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/RefChan.hs new file mode 100644 index 00000000..a4aff46d --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/RefChan.hs @@ -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 + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs index 16cddd63..415acc4f 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -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,30 +138,40 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr _ -> throwIO (BadFormException @c nil) - entry $ bindMatch "hbs2:refchan:head:update" $ \case - [SignPubKeyLike rchan, StringLike headFile] -> do + entry $ bindMatch "hbs2:refchan:head:update" $ \syn -> do - sto <- getStorage + (rchan, rch) <- case syn of + [SignPubKeyLike rchan, StringLike headFile] -> do - rchanApi <- getClientAPI @RefChanAPI @UNIX + rch <- liftIO (readFile headFile) + <&> fromStringMay @(RefChanHeadBlock L4Proto) + >>= orThrowUser "can't parse RefChanHeadBlock" - rch <- liftIO (readFile headFile) - <&> fromStringMay @(RefChanHeadBlock L4Proto) - >>= orThrowUser "can't parse RefChanHeadBlock" + pure (rchan, rch) - creds <- runKeymanClient $ loadCredentials rchan - >>= orThrowUser "can't load credentials" + [SignPubKeyLike rchan, ListVal syn] -> do + rch <- fromStringMay @(RefChanHeadBlock L4Proto) (show $ vcat (fmap pretty syn)) + & orThrowUser "can't parse RefChanHeadBlock" - let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch + pure (rchan, rch) - href <- writeAsMerkle sto (serialise box) + _ -> throwIO (BadFormException @c nil) - callService @RpcRefChanHeadPost rchanApi (HashRef href) - >>= orThrowUser "can't post refchan head" + sto <- getStorage - pure nil + rchanApi <- getClientAPI @RefChanAPI @UNIX - _ -> throwIO (BadFormException @c nil) + creds <- runKeymanClient $ loadCredentials rchan + >>= orThrowUser "can't load credentials" + + let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch + + href <- writeAsMerkle sto (serialise box) + + callService @RpcRefChanHeadPost rchanApi (HashRef href) + >>= orThrowUser "can't post refchan head" + + pure nil entry $ bindMatch "hbs2:refchan:get" $ \case @@ -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 "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_ $ \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) + 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) - _ -> throwIO (BadFormException @c nil) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs index c6e15b7a..4341659a 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs @@ -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 diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs index 36ef918d..9ef372e7 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script.hs @@ -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) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index d30fb76c..0470b3a4 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -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