wip

.hbs2-git/manifest

@@ -1,5 +1,6 @@
 title: "hbs2 project repo"
 author: "Dmitry Zuikov"
 public: yes
+brief: "HBS2: P2P CAS and protocol framework"
 
 Project description TBD

hbs2-core/lib/HBS2/Net/Auth/Schema.hs

@@ -5,7 +5,7 @@ module HBS2.Net.Auth.Schema
   , module HBS2.Net.Proto.Types
   ) where
 
-import HBS2.Prelude
+import HBS2.Prelude.Plated
 import HBS2.OrDie
 import HBS2.Net.Proto.Types
 import HBS2.Hash
@@ -22,7 +22,8 @@ import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString (ByteString)
 import Data.ByteArray ( convert)
 
-data HBS2Basic
+data HBS2Basic = HBS2Basic
+                 deriving stock Data
 
 type instance Encryption L4Proto = HBS2Basic
 

hbs2-git/hbs2-git-oracle/app/Main.hs

@@ -6,15 +6,16 @@ import HBS2.Git.Oracle.Run
 
 import Options.Applicative as O
 
+
+type PKS = PubKey 'Sign HBS2Basic
+
+data RunMode =
+    RunIndex PKS
+  | RunDump
+
 main :: IO ()
 main = do
-  let parser = runApp
+  let parser = hsubparser ( pRunIndexCmd <> pRunDumpCmd )
-                <$>  flag False True (    long "serve"
-                        <> short 's'
-                        <> help "serve"
-                     )
-                <*> option pkey ( long "refchan" <> short 'r' <> help "refchan to post" )
-                <*> option pkey ( long "author"  <> short 'a' <> help "author" )
 
   join $ execParser (O.info (parser <**> helper)
               ( fullDesc
@@ -22,21 +23,36 @@ main = do
              <> header "hbs2-git-oracle"))
 
   where
-    pkey = maybeReader fromStringMay
+    pkey = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic))
+
+    pRunIndexCmd = command "index" ( O.info pRunIndex (progDesc "run index")  )
+
+    pRunIndex = do
+      chan   <- option pkey ( long "refchan" <> short 'r' <> help "refchan to post" )
+      author <- option pkey ( long "author"  <> short 'a' <> help "author" )
+      pure $ runApp chan (RunIndex author)
+
+    pRunDumpCmd = command "dump" ( O.info pRunDump (progDesc "run index")  )
+    pRunDump = do
+      chan   <- option pkey ( long "refchan" <> short 'r' <> help "refchan to post" )
+      pure $ runApp chan RunDump
+
+
 
 runApp :: MonadUnliftIO m
-       => Bool
+       => RefChanId L4Proto
-       -> RefChanId L4Proto
+       -> RunMode
-       -> RefChanAuthor L4Proto
        -> m ()
-runApp _ rchan author = do
+runApp chan mode = do
 
   setLogging @DEBUG  (toStderr . logPrefix "[debug] ")
   setLogging @WARN   (toStderr . logPrefix "[warn]  ")
   setLogging @ERROR  (toStderr . logPrefix "[error] ")
   setLogging @NOTICE (toStderr . logPrefix "[debug] ")
 
-  runWithOracleEnv rchan author runOracle
+  runWithOracleEnv chan $ case mode of
+    RunIndex a  -> runOracleIndex a
+    RunDump{}   -> runDump
 
   `finally` do
       setLoggingOff @DEBUG

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/App.hs

@@ -17,7 +17,7 @@ import Codec.Serialise
 data OracleEnv =
   OracleEnv
   { _refchanId     :: RefChanId L4Proto
-  , _refchanAuthor :: RefChanAuthor L4Proto
+  -- , _refchanAuthor :: RefChanAuthor L4Proto
   , _peerAPI       :: ServiceCaller PeerAPI UNIX
   , _reflogAPI     :: ServiceCaller RefLogAPI UNIX
   , _refchanAPI    :: ServiceCaller RefChanAPI UNIX
@@ -39,10 +39,10 @@ newtype Oracle m a =
 
 runWithOracleEnv ::  MonadUnliftIO m
                  => RefChanId L4Proto
-                 -> RefChanAuthor L4Proto
+                 -- -> RefChanAuthor L4Proto
                  -> Oracle m ()
                  -> m ()
-runWithOracleEnv rchan author m = do
+runWithOracleEnv rchan m = do
 
   soname <- detectRPC
                `orDie` "can't locate rpc"
@@ -58,7 +58,7 @@ runWithOracleEnv rchan author m = do
   let sto = AnyStorage (StorageClient storageAPI)
 
   env <- pure $ OracleEnv rchan
-                          author
+                          -- author
                           peerAPI
                           reflogAPI
                           refchanAPI

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs

@@ -23,6 +23,7 @@ import Control.Monad.Trans.Maybe
 import Data.Coerce
 import Data.Ord
 import Data.Text qualified as Text
+import Data.HashMap.Strict qualified as HM
 import Control.Monad.Trans.Except
 import Data.List
 import Data.ByteString.Lazy qualified as LBS
@@ -30,13 +31,16 @@ import Safe
 
 {- HLINT ignore "Functor law" -}
 
+deriving instance Data (RefLogKey HBS2Basic)
+deriving instance Data (LWWRefKey HBS2Basic)
+
 data GitRepoRefFact =
   GitRepoFact1
   { gitLwwRef :: LWWRefKey HBS2Basic
   , gitLwwSeq :: Word64
   , gitRefLog :: RefLogKey HBS2Basic
   }
-  deriving stock (Generic)
+  deriving stock (Generic,Data)
 
 data GitRepoHeadFact =
   GitRepoHeadFact1
@@ -45,13 +49,13 @@ data GitRepoHeadFact =
   , gitRepoBrief     :: Text
   , gitRepoEncrypted :: Bool
   }
-  deriving stock (Generic)
+  deriving stock (Generic,Data)
 
 
 data GitRepoFacts =
       GitRepoRefFact  GitRepoRefFact
     | GitRepoHeadFact HashRef GitRepoHeadFact
-    deriving stock (Generic)
+    deriving stock (Generic,Data)
 
 
 instance Serialise GitRepoRefFact
@@ -60,7 +64,7 @@ instance Serialise GitRepoFacts
 
 instance Pretty GitRepoFacts  where
   pretty (GitRepoRefFact x)    = pretty x
-  pretty (GitRepoHeadFact _ x) = pretty x
+  pretty (GitRepoHeadFact ha x) = pretty ("gitrpoheadfact",ha,x)
 
 instance Pretty GitRepoRefFact where
   pretty (GitRepoFact1{..}) =
@@ -71,9 +75,10 @@ instance Pretty GitRepoHeadFact where
     parens ( "gitrepoheadfact1" <+>  hsep [pretty gitRepoHeadRef])
 
 
-runOracle :: forall m  . MonadUnliftIO m
+runOracleIndex :: forall m  . MonadUnliftIO m
-          => Oracle m ()
+               => PubKey 'Sign HBS2Basic
-runOracle = do
+               -> Oracle m ()
+runOracleIndex auPk = do
   debug "hbs2-git-oracle"
 
   debug "list all git references from peer"
@@ -141,7 +146,6 @@ runOracle = do
 
   rchanAPI <- asks _refchanAPI
   chan  <- asks _refchanId
-  auPk  <- asks _refchanAuthor
 
   auCreds <- runKeymanClient do
               loadCredentials auPk >>= orThrowUser "can't load credentials"
@@ -154,3 +158,66 @@ runOracle = do
     void $ callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) rchanAPI (chan, box)
     debug $ "posted tx" <+> pretty (hashObject @HbSync (serialise f))
 
+
+runDump :: forall m  . MonadUnliftIO m
+        => Oracle m ()
+runDump = do
+  chan <- asks _refchanId
+  rchanAPI <- asks _refchanAPI
+  sto      <- asks _storage
+
+  void $ runMaybeT do
+
+    rv <- lift (callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) rchanAPI chan)
+            >>= toMPlus >>= toMPlus
+
+    liftIO $ print $ pretty rv
+
+    facts <- S.toList_ do
+      walkMerkle @[HashRef] (fromHashRef rv) (getBlock sto) $ \case
+        Left{} -> pure ()
+        Right txs -> do
+          for_ txs $ \htx -> void $ runMaybeT do
+            getBlock sto (fromHashRef htx)
+             >>= toMPlus
+             <&> deserialiseOrFail @(RefChanUpdate L4Proto)
+             >>= toMPlus
+             >>= \case
+                   Propose _ box -> pure box
+                   _             -> mzero
+             <&> unboxSignedBox0
+             >>= toMPlus
+             <&> snd
+             >>= \(ProposeTran _ box) -> toMPlus (unboxSignedBox0 box)
+             <&> snd
+             <&> deserialiseOrFail @GitRepoFacts . LBS.fromStrict
+             >>= toMPlus
+             >>= lift . S.yield
+
+    let rf  = [ (HashRef (hashObject $ serialise f), f)
+              | f@GitRepoFact1{} <-  universeBi facts
+              ] & HM.fromListWith (\v1 v2 -> if gitLwwSeq v1 > gitLwwSeq v2 then v1 else v2)
+
+
+    let rhf = [ (h,f) | (GitRepoHeadFact h f) <- universeBi facts ]
+              & HM.fromList
+
+    for_ (HM.toList rf) $ \(k, GitRepoFact1{..}) -> do
+      let d = HM.lookup k rhf
+      let nm    = maybe "" gitRepoName d
+      let brief = maybe "" gitRepoBrief d
+      liftIO $ print $ "repo"
+                  <+> pretty gitLwwRef
+                  <+> pretty nm
+                  <+> pretty brief
+      pure ()
+
+    -- let rhf = [ (h,f) | (GitRepoHeadFact h f) <- universeBi facts ]
+
+    -- lift do
+    --   for_ rf $ \f -> do
+    --     liftIO $ print $ pretty (hashObject @HbSync (serialise f), f)
+
+    --   for_ rhf $ \(h,f) -> do
+    --     liftIO $ print $ pretty (h, f)
+

hbs2-peer/app/Browser/Root.hs

@@ -117,7 +117,6 @@ browserRootPage syn = rootPage do
             p_ (toHtml s)
 
 
-
 channelPage :: Monad m => RefChanId L4Proto -> HtmlT m ()
 channelPage chan = rootPage $ pure ()