dns example

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

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)

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

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

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
+  entry $ bindMatch "hbs2:refchan:head:update" $ \syn -> do
-      [SignPubKeyLike rchan, StringLike headFile] -> 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)
+            pure (rchan, rch)
-                 <&> fromStringMay @(RefChanHeadBlock L4Proto)
-                 >>= orThrowUser "can't parse RefChanHeadBlock"
 
-        creds <- runKeymanClient $ loadCredentials rchan
+        [SignPubKeyLike rchan, ListVal syn] -> do
-                       >>= orThrowUser "can't load credentials"
+            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)
+      sto <- getStorage
-            >>= orThrowUser "can't post refchan head"
 
-        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
+    refchan <- createNewRefChan @c Nothing rch
-
+    pure $ mkSym (show $ pretty (AsBase58 refchan))
-    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
 
   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
+    entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \syn -> do
-      [SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
+
-        api <- getClientAPI @RefChanAPI @UNIX
+      (chan,lbs) <- case syn of
-        bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction"
+         [SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
-        void $ callService @RpcRefChanPropose api (rchan, bbox)
+          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)
 

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
+      (ppk, txx) <- MaybeT $ pure $ unboxSignedBox0 box
-      pure (P href txx)
+      pure (P1 ppk href txx)
 
 walkRefChanTx :: forall proto m . ( MonadIO m
                                   , HasClientAPI RefChanAPI proto m

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)]
+splitOpts :: forall c . IsContext c
-          -> [Syntax C]
+          => [(Id,Int)]
-          -> ([Syntax C], [Syntax C])
+          -> [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)

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