wip

hbs2-cli/app/Main.hs

@@ -11,6 +11,7 @@ import HBS2.CLI.Run.Sigil
 import HBS2.CLI.Run.MetaData
 import HBS2.CLI.Run.Peer
 import HBS2.CLI.Run.RefLog
+import HBS2.CLI.Run.LWWRef
 
 import HBS2.Peer.RPC.Client.Unix
 
@@ -78,6 +79,7 @@ main = do
         metaDataEntries
         peerEntries
         reflogEntries
+        lwwRefEntries
 
         entry $ bindMatch "help" $ nil_ $ \syn -> do
 
@@ -103,11 +105,11 @@ main = do
     [ListVal [SymbolVal "stdin"]] -> do
       what <- getContents
                 >>= either (error.show) pure . parseTop
-      void $ run dict what
+      run dict what >>= eatNil display
 
     [] -> do
       void $ run dict [mkForm  "help" []]
 
     _ -> do
-      void $ run dict cli
+      run dict cli >>= eatNil display
 

hbs2-cli/hbs2-cli.cabal

@@ -112,6 +112,7 @@ library
       HBS2.CLI.Run.MetaData
       HBS2.CLI.Run.Peer
       HBS2.CLI.Run.RefLog
+      HBS2.CLI.Run.LWWRef
       HBS2.CLI.Run.Sigil
 
       HBS2.CLI.Run.Help

hbs2-cli/lib/HBS2/CLI/Run/Internal.hs

@@ -38,6 +38,8 @@ pattern StringLikeList e <- (stringLikeList -> e)
 pattern BlobLike :: forall {c} . ByteString -> Syntax c
 pattern BlobLike s <- (blobLike -> Just s)
 
+pattern Nil :: forall {c} . Syntax c
+pattern Nil <- ListVal []
 
 class Display a where
   display :: MonadIO m => a -> m ()
@@ -104,6 +106,11 @@ isFalse = \case
     ListVal [] -> True
     _ -> False
 
+eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()
+eatNil f = \case
+  Nil -> pure ()
+  x   -> void $ f x
+
 class IsContext c => MkInt c s where
   mkInt :: s -> Syntax c
 
@@ -462,6 +469,18 @@ internalEntries = do
       let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
       pure $ mkForm "dict" wat
 
+    entry $ bindMatch "iterate" $ nil_ $ \syn -> do
+      case syn of
+        [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
+          mapM_ (apply @c fn . List.singleton) rs
+
+        [Lambda decl body,  ListVal args]  -> do
+          mapM_ (applyLambda decl body . List.singleton) args
+
+        _ -> do
+          throwIO (BadFormException @C nil)
+
+
     entry $ bindMatch "map" $ \syn -> do
       case syn of
         [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do

hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs

@@ -0,0 +1,109 @@
+module HBS2.CLI.Run.LWWRef where
+
+import HBS2.CLI.Prelude
+import HBS2.CLI.Run.Internal
+import HBS2.CLI.Run.Internal.KeyMan
+
+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.RefLog
+import HBS2.Peer.RPC.API.LWWRef
+
+import HBS2.Peer.Proto hiding (request)
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.KeyMan.App.Types
+
+import Codec.Serialise
+import Data.Coerce
+import Data.Either
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text.Encoding qualified as TE
+import Data.Text qualified as Text
+import Control.Monad.Trans.Cont
+
+
+lwwRefEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM  c m ()
+lwwRefEntries = do
+
+  entry $ bindMatch "hbs2:lwwref:create" $ \case
+    [] -> do
+      reflog <- keymanNewCredentials (Just "lwwref") 0
+
+      flip runContT pure do
+        so <- detectRPC `orDie` "rpc not found"
+        api <- ContT $ withRPC2 @PeerAPI  @UNIX so
+        void $ callService @RpcPollAdd api (reflog, "lwwref", 31)
+        pure $ mkStr (show $ pretty (AsBase58 reflog))
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  -- entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case
+  --   [StringLike puk, StringLike hash] -> do
+  --     flip runContT pure do
+  --       reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+  --       sto <- ContT withPeerStorage
+  --       hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
+  --       void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
+  --       let sref = AnnotatedHashRef Nothing hashref
+  --       rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
+  --       pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+  --   _ -> throwIO (BadFormException @C nil)
+
+
+  -- entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case
+  --   [BlobLike blob] -> do
+  --     so <- detectRPC `orDie` "no rpc found"
+  --     withRPC2 @RefLogAPI so $ \caller -> do
+  --       wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob)
+  --               & orThrowUser "invalid tx"
+  --       void $ callService @RpcRefLogPost caller wtf
+
+  --   _ -> throwIO (BadFormException @C nil)
+
+  -- entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case
+  --   [StringLike puk, LitIntVal sn, StringLike hash] -> do
+  --     flip runContT pure do
+  --       reflog <- orThrowUser "bad reflog key" (fromStringMay puk)
+  --       sto <- ContT withPeerStorage
+  --       hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash)
+  --       void $ hasBlock sto (fromHashRef hashref) `orDie` "no block"
+  --       let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref)
+  --       rlu <- lift $ mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise
+  --       pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+  --   _ -> throwIO (BadFormException @C nil)
+
+  -- entry $ bindMatch "hbs2:reflog:tx:create-raw" $ \case
+  --   [SymbolVal "stdin", StringLike rlo] -> do
+  --     reflog <- orThrowUser "bad reflog" (fromStringMay rlo)
+
+  --     rlu <- mkRefLogUpdateFrom reflog ( liftIO BS.getContents )
+  --               <&> serialise
+
+  --     pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+  --   [LitStrVal s, StringLike rlo] -> do
+  --     reflog <- orThrowUser "bad reflog" (fromStringMay rlo)
+
+  --     rlu <- mkRefLogUpdateFrom reflog ( pure (BS8.pack (Text.unpack s)) )
+  --              <&> serialise
+
+  --     pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)]
+
+  --   _ -> throwIO (BadFormException @C nil)
+
+
+

hbs2-cli/lib/HBS2/CLI/Run/Peer.hs

@@ -11,6 +11,7 @@ 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.LWWRef
 import HBS2.Net.Auth.Schema()
 
 import Data.List qualified as L
@@ -22,7 +23,6 @@ import Lens.Micro.Platform
 
 {- HLINT ignore "Functor law" -}
 
-
 putTextLit :: forall c m . (IsContext c, MonadUnliftIO m)
            => AnyStorage
            -> Text
@@ -112,7 +112,6 @@ peerEntries = do
 
     _ -> throwIO (BadFormException @C nil)
 
-
   entry $ bindMatch "hbs2:peer:reflog:fetch" $ \case
     [StringLike puk] -> do
       flip runContT pure do
@@ -134,3 +133,43 @@ peerEntries = do
         pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
 
     _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:peer:lwwref:list" $ \case
+    [] -> do
+      flip runContT pure do
+        so <- detectRPC `orDie` "rpc not found"
+        api <- ContT $ withRPC2 @PeerAPI @UNIX so
+        r <- callService @RpcPollList2 api (Just "lwwref", Nothing)
+               >>= orThrowUser "can't get lwwref list"
+        pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:peer:lwwref:fetch" $ \case
+    [StringLike puk] -> do
+      flip runContT pure do
+        lww <- orThrowUser "bad reflog key" (fromStringMay puk)
+        so <- detectRPC `orDie` "rpc not found"
+        api <- ContT $ withRPC2 @LWWRefAPI @UNIX so
+        void $ callService @RpcLWWRefFetch api lww
+        pure $ mkStr "okay"
+
+    _ -> throwIO (BadFormException @C nil)
+
+
+  entry $ bindMatch "hbs2:peer:lwwref:get" $ \case
+    [StringLike puk] -> do
+
+      flip runContT pure do
+        ref <- orThrowUser "bad reflog key" (fromStringMay puk)
+        so <- detectRPC `orDie` "rpc not found"
+        api <- ContT $ withRPC2 @LWWRefAPI  @UNIX so
+        what <- callService @RpcLWWRefGet api ref
+                  >>= orThrowUser "can't get reflog"
+        pure $ mkStr (show $ pretty what)
+
+    _ -> throwIO (BadFormException @C nil)
+
+