wip, fixed metadata extraction method

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

@@ -13,9 +13,11 @@ import HBS2.Peer.RPC.API.RefLog
 import HBS2.Peer.RPC.API.LWWRef
 
 import HBS2.Peer.Proto hiding (request)
+import HBS2.Peer.Proto.LWWRef
 import HBS2.Base58
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.Schema()
+import HBS2.Data.Types.SignedBox
 
 import HBS2.KeyMan.Keys.Direct
 import HBS2.KeyMan.App.Types
@@ -86,17 +88,17 @@ lwwRefEntries = do
         so <- detectRPC `orDie` "rpc not found"
         api <- ContT $ withRPC2 @LWWRefAPI  @UNIX so
         what <- callService @RpcLWWRefGet api ref
-                  >>= orThrowUser "can't get reflog"
+                  >>= orThrowUser "can't get lwwref value"
         pure $ mkStr (show $ pretty what)
 
     _ -> throwIO (BadFormException @C nil)
 
 
   entry $ bindMatch "hbs2:lwwref:update" $ \case
-    [StringLike puks, HashLike what] -> do
+    [StringLike puks, HashLike new] -> do
 
       flip runContT pure do
-        puk <- orThrowUser "bad lwwref key" (fromStringMay @(PubKey 'Sign 'HBS2Basic) puks)
+        puk <- orThrowUser "bad lwwref key" (fromStringMay  puks)
         so <- detectRPC `orDie` "rpc not found"
         api <- ContT $ withRPC2 @LWWRefAPI  @UNIX so
 
@@ -105,11 +107,21 @@ lwwRefEntries = do
                                  >>= orThrowUser "can't load credentials"
                      pure ( view peerSignSk  creds, view peerSignPk creds )
 
+        what <- callService @RpcLWWRefGet api puk
+                  >>= orThrowUser "can't get lwwref value"
 
-        error "YAY!"
-        -- what <- callService @RpcLWWRefGet api ref
-        --           >>= orThrowUser "can't get reflog"
-        -- pure $ mkStr (show $ pretty what)
+        sno' <- case what of
+                 Nothing    -> pure 0
+                 Just lwwv  -> pure (lwwSeq lwwv)
+
+        let sno =  succ sno'
+
+        let box =  makeSignedBox pk sk (LWWRef sno new Nothing)
+
+        callService @RpcLWWRefUpdate api box
+          >>= orThrowUser "lww ref update error"
+
+        pure nil
 
     _ -> throwIO (BadFormException @C nil)
 

hbs2-peer/app/HttpWorker.hs

@@ -34,11 +34,14 @@ import Data.Either
 import Codec.Serialise (deserialiseOrFail)
 import Data.Aeson (object, (.=))
 import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Text qualified as Text
 import Control.Monad.Reader
 import Lens.Micro.Platform (view)
 import System.FilePath
 import Control.Monad.Except
+import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Cont
+import Data.Coerce
 
 import UnliftIO (async)
 
@@ -46,11 +49,29 @@ import UnliftIO (async)
 
 -- TODO: introduce-http-of-off-feature
 
-extractMetadataHash :: Hash HbSync -> LBS.ByteString -> Maybe (Hash HbSync)
-extractMetadataHash what blob =
-  case tryDetect what blob of
-     MerkleAnn (MTreeAnn {_mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption}) -> Just h
-     _ -> Nothing
+extractMetadataHash :: MonadIO  m
+                    => AnyStorage
+                    -> HashRef
+                    -> m (Maybe [Syntax C])
+
+extractMetadataHash sto what = runMaybeT do
+
+  blob <- getBlock sto (coerce what)
+            >>= toMPlus
+
+  case tryDetect (coerce what) blob of
+     MerkleAnn (MTreeAnn {_mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption}) -> do
+
+        getBlock sto h
+          >>= toMPlus
+          <&> LBS8.unpack
+          <&> fromRight mempty . parseTop
+
+
+     MerkleAnn (MTreeAnn {_mtaMeta = ShortMetadata txt, _mtaCrypt = NullEncryption}) -> do
+       parseTop (Text.unpack txt) & toMPlus
+
+     _ -> mzero
 
 orElse :: m r -> Maybe a -> ContT r m a
 orElse a mb = ContT $ maybe1 mb a
@@ -174,15 +195,10 @@ httpWorker (PeerConfig syn) pmeta e = do
 
 getTreeHash :: AnyStorage -> HashRef -> ActionM ()
 getTreeHash sto what' = void $ flip runContT pure do
-  blob <- liftIO (getBlock sto what)
+
+  meta <- extractMetadataHash sto what'
             >>= orElse (status status404)
 
-  mh <- orElse (status status404) (extractMetadataHash what blob)
-
-  meta <- lift (getBlock sto mh) >>= orElse (status status404)
-             <&> LBS8.unpack
-             <&> fromRight mempty . parseTop
-
   let tp = headDef "application/octet-stream"
            [ show (pretty w)
            | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta