wip

.envrc

@@ -1 +1,5 @@
+if [ -f .envrc.local ]; then
+  source_env .envrc.local
+fi
+
 use flake

.hbs2-git/.gitignore

@@ -0,0 +1 @@
+./state.db

.hbs2-git/manifest

@@ -0,0 +1,5 @@
+title: "hbs2 project repo"
+author: "Dmitry Zuikov"
+public: yes
+
+Project description TBD

Makefile

@@ -8,13 +8,15 @@ MAKEFLAGS += --no-builtin-rules
 GHC_VERSION := 9.4.8
 BIN_DIR := ./bin
 BINS := \
-  hbs2              \
-  hbs2-peer         \
-  hbs2-reposync     \
-  hbs2-keyman       \
-	hbs2-git-reposync \
-  git-remote-hbs2   \
-  git-hbs2          \
+  hbs2               \
+  hbs2-peer          \
+  hbs2-keyman        \
+	hbs2-git-reposync  \
+	hbs2-git-subscribe \
+  git-remote-hbs2    \
+  git-hbs2           \
+  git-remote-hbs21   \
+  git-hbs21          \
 
 ifeq ($(origin .RECIPEPREFIX), undefined)
   $(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)

docs/papers/Makefile

@@ -1,15 +1,33 @@
-all: hbs2-git-problem hbs2-git-new-repo
+REV:=$(shell git rev-parse --short HEAD)
+
+define make_target
+$(basename $(1))-$(REV)$(suffix $(1))
+endef
+
+
+all: hbs2-git-problem hbs2-git-new-repo hbs2-git-doc
 
 .PHONY: all clean
 
 %.pdf: %.tex
 	xelatex $<
 	xelatex $<
+	cp $@ $(call make_target,$@)
 
 hbs2-git-problem: hbs2-git-problem.pdf
 
 hbs2-git-new-repo: hbs2-git-new-repo.pdf
 
+hbs2-git-doc: hbs2-git-doc-0.24.1.pdf
+
+publish-hbs2-git-doc: hbs2-git-doc-0.24.1.pdf
+	$(eval TARGET := $(call make_target,$<))
+	$(eval HASH := $(shell hbs2 metadata create --hash --auto $(TARGET)))
+	@echo Updating $(HBS2GITDOCLWW) $(HASH)
+	hbs2-peer lwwref update -v $(HASH) $(HBS2GITDOCLWW)
+
+publish: publish-hbs2-git-doc
+
 clean:
 	rm -f *.aux *.log *.nav *.out *.snm *.vrb *.toc *.pdf
 

docs/todo/rpc-slow.txt

@@ -0,0 +1,5 @@
+FIXME: git-fetch-push-slow
+  Кажется, тормозит за счёт сканирования меркл-деревьев на предмет
+  missed blocks.
+
+  Надо бы сделать какой-то кэш/фильтры для ускорения вопроса.

flake.nix

@@ -37,6 +37,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-qblf"
      "hbs2-keyman"
      "hbs2-share"
+     "hbs21-git"
     ];
   in
  haskell-flake-utils.lib.simpleCabalProject2flake {
@@ -60,6 +61,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-keyman" = "./hbs2-keyman";
      "hbs2-share"  = "./hbs2-share";
      "hbs2-git"    = "./hbs2-git";
+     "hbs21-git"   = "./hbs21-git";
      "hbs2-git-reposync"   = "./hbs2-git-reposync";
    };
 
@@ -101,6 +103,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
             hoogle
             htags
             text-icu
+            magic
             pkgs.icu72
             pkgs.openssl
             weeder

hbs2-core/hbs2-core.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-core
-version:            0.1.1.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-core/lib/HBS2/Actors/Peer.hs

@@ -405,7 +405,7 @@ runPeerM :: forall e m . ( MonadIO m
 runPeerM env f  = do
 
   let de = view envDeferred env
-  as <- liftIO $ replicateM 8 $ async $ runPipeline de
+  as <- liftIO $ replicateM 32 $ async $ runPipeline de
 
   sw <- liftIO $ async $ forever $ withPeerM env $ do
           pause defSweepTimeout

hbs2-core/lib/HBS2/Base58.hs

@@ -1,14 +1,23 @@
 module HBS2.Base58 where
 
 import Data.ByteString.Base58 (encodeBase58, bitcoinAlphabet, decodeBase58,Alphabet(..))
+import Data.ByteString  qualified as BS
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Char8 (ByteString)
-import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.Word
+import Data.Char (ord)
+import Numeric
 
 import Prettyprinter
 
 newtype AsBase58 a = AsBase58 { unAsBase58 :: a }
 
+newtype AsHex a = AsHex { unAsHex :: a }
+
+newtype AsHexSparse a = AsHexSparse { unAsHexSparse :: a }
+
 alphabet :: Alphabet
 alphabet = bitcoinAlphabet
 
@@ -32,3 +41,29 @@ instance Pretty (AsBase58 LBS.ByteString) where
 instance Show (AsBase58 ByteString) where
   show (AsBase58 bs) = BS8.unpack $ toBase58 bs
 
+
+byteToHex :: Word8 -> String
+byteToHex byte = pad $ showHex byte ""
+  where pad s = if length s < 2 then '0':s else s
+
+byteStringToHex :: BS.ByteString -> String
+byteStringToHex bs = concatMap (byteToHex . fromIntegral) (BS.unpack bs)
+
+instance Pretty (AsHexSparse ByteString) where
+  pretty (AsHexSparse bs) = pretty $ unwords $ byteToHex <$> BS.unpack bs
+
+instance Pretty (AsHexSparse LBS.ByteString) where
+  pretty (AsHexSparse bs) = pretty $ unwords $ byteToHex <$> LBS.unpack bs
+
+instance Pretty (AsHex ByteString) where
+  pretty (AsHex bs) = pretty $ byteStringToHex bs
+
+instance Pretty (AsHex LBS.ByteString) where
+  pretty (AsHex bs) = pretty $ byteStringToHex (LBS.toStrict bs)
+
+instance Show (AsHex ByteString) where
+  show (AsHex bs) = byteStringToHex bs
+
+instance Show (AsHex LBS.ByteString) where
+  show (AsHex bs) = byteStringToHex (LBS.toStrict bs)
+

hbs2-git-reposync/hbs2-git-reposync.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-git-reposync
-version:            0.1.0.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-git/lib/HBS2Git/PrettyStuff.hs

@@ -25,3 +25,6 @@ section = line <> line
 toStringANSI :: Doc AnsiStyle -> String
 toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc
 
+
+-- asHex ::
+

hbs2-keyman/hbs2-keyman.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-keyman
-version:            0.1.0.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-peer/app/Brains.hs

@@ -38,6 +38,8 @@ import Data.Cache qualified as Cache
 import Data.Either
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HashMap
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HashSet
 import Data.List qualified as List
 import Data.Maybe
 import Data.Text qualified as Text
@@ -82,6 +84,7 @@ data BasicBrains e =
   , _brainsCommit       :: TQueue CommitCmd
   , _brainsDelDownload  :: TQueue (Hash HbSync)
   , _brainsSizeCache    :: Cache (Peer e, Hash HbSync) Integer
+  , _brainsPolled       :: TVar (HashSet (PubKey 'Sign (Encryption e), String))
   }
 
 makeLenses 'BasicBrains
@@ -96,6 +99,7 @@ cleanupPostponed b h =  do
 instance ( Hashable (Peer e)
          , Pretty (Peer e), Pretty (PeerAddr e)
          , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
+         , Hashable (PubKey 'Sign (Encryption e))
          , e ~ L4Proto
          , ForRefChans e
          ) => HasBrains e (BasicBrains e) where
@@ -103,14 +107,14 @@ instance ( Hashable (Peer e)
   onClientTCPConnected br pa@(L4Address proto _) ssid = do
     debug $ "BRAINS: onClientTCPConnected" <+> pretty proto <+> pretty pa <+> pretty ssid
     updateOP br $ insertClientTCP br pa ssid
-    commitNow br True
+    commitNow br False
 
   getClientTCP br = liftIO (selectClientTCP br)
 
   setActiveTCPSessions br ssids = do
     trace $ "BRAINS: setActiveTCPSessions" <+> pretty ssids
     updateOP br $ updateTCPSessions br ssids
-    commitNow br True
+    commitNow br False
 
   listTCPPexCandidates = liftIO . selectTCPPexCandidates
 
@@ -134,7 +138,7 @@ instance ( Hashable (Peer e)
         forM_ ps $ \pip -> do
           pa <- toPeerAddr pip
           insertKnownPeer br pa
-    commitNow br True
+    commitNow br False
 
   onBlockSize b p h size = do
     liftIO $ Cache.insert (_brainsSizeCache b) (p,h) size
@@ -217,15 +221,15 @@ instance ( Hashable (Peer e)
 
   addPolledRef brains r s i = do
 
+    liftIO $ atomically $ modifyTVar (_brainsPolled brains) (HashSet.insert (r,s))
+
     updateOP brains $ do
       let conn = view brainsDb brains
       liftIO $ execute conn sql (show $ pretty (AsBase58 r), s, i)
 
-    commitNow brains True
-
     where
       sql = [qc|
-      insert into statedb.poll (ref,type,interval)
+      insert into {poll_table} (ref,type,interval)
       values (?,?,?)
       on conflict do update set interval = excluded.interval
       |]
@@ -236,7 +240,7 @@ instance ( Hashable (Peer e)
       liftIO $ execute conn sql (Only (show $ pretty (AsBase58 r)))
     where
       sql = [qc|
-      delete from statedb.poll
+      delete from {poll_table}
       where ref = ?
       |]
 
@@ -245,22 +249,34 @@ instance ( Hashable (Peer e)
       let conn = view brainsDb brains
       case mtp of
         Nothing -> postprocess <$>
-          query_ conn [qc|select ref, type, interval from statedb.poll|]
+          query_ conn [qc|select ref, type, interval from {poll_table}|]
 
         Just tp -> postprocess <$>
-          query conn [qc|select ref, type, interval from statedb.poll where type = ?|] (Only tp)
+          query conn [qc|select ref, type, interval from {poll_table} where type = ?|] (Only tp)
     where
       postprocess = mapMaybe (\(r,t,i) -> (,t,i) <$> fromStringMay r )
 
-  isPolledRef brains ref = do
-    liftIO do
-      let conn = view brainsDb brains
-      query @_ @(Only Int) conn [qc|
-        select 1 from statedb.poll
-        where ref = ?
-        limit 1
-      |] ( Only ( show $ pretty (AsBase58 ref) ) )
-        <&> isJust . listToMaybe
+  isPolledRef brains tp ref = do
+
+    cached <- liftIO $ readTVarIO (_brainsPolled brains) <&> HashSet.member (ref,tp)
+
+    if cached then
+      pure True
+    else do
+
+      r <- liftIO do
+              let conn = view brainsDb brains
+              query @_ @(Only Int) conn [qc|
+                select 1 from {poll_table}
+                where ref = ? and type = ?
+                limit 1
+              |] ( show $ pretty (AsBase58 ref), tp )
+                <&> isJust . listToMaybe
+
+      when r do
+        liftIO $ atomically $ modifyTVar (_brainsPolled brains) (HashSet.insert (ref,tp))
+
+      pure r
 
   setSeen brains w ts = do
     utc <- liftIO getCurrentTime <&> addUTCTime ts
@@ -718,6 +734,8 @@ insertPexInfo br peers = liftIO do
     |] (Only (show $ pretty p))
 
 
+{- HLINT ignore "Functor law" -}
+
 selectPexInfo :: forall e . (e ~ L4Proto)
               => BasicBrains e
               -> IO [PeerAddr e]
@@ -730,8 +748,23 @@ selectPexInfo br = liftIO do
   |] <&> fmap (fromStringMay . fromOnly)
      <&> catMaybes
 
+tableExists :: Connection -> Maybe String -> String -> IO Bool
+tableExists conn prefix' tableName = do
+  let sql = [qc|
+     SELECT name FROM {prefix}.sqlite_master WHERE type='table' AND name=?
+  |]
+  r <- query conn sql (Only tableName) :: IO [Only String]
+  pure $ not $ null r
+
+  where
+    prefix = fromMaybe "main" prefix'
+
+
 -- FIXME: eventually-close-db
-newBasicBrains :: forall e m . (Hashable (Peer e), MonadIO m)
+newBasicBrains :: forall e m . ( Hashable (Peer e)
+                               , Hashable (PubKey 'Sign (Encryption e))
+                               , MonadIO m
+                               )
                => PeerConfig
                -> m (BasicBrains e)
 
@@ -836,14 +869,26 @@ newBasicBrains cfg = liftIO do
     )
   |]
 
-  execute_ conn [qc|
-    create table if not exists statedb.poll
-    ( ref      text not null
-    , type     text not null
-    , interval int not null
-    , primary key (ref)
-    )
-  |]
+  poll_1 <- tableExists conn (Just "statedb") "poll_1"
+  poll_0 <- tableExists conn (Just "statedb") "poll"
+
+  unless poll_1 do
+    debug $ red "BRAINS: CREATE poll_1"
+    execute_ conn [qc|
+      create table if not exists statedb.poll_1
+      ( ref      text not null
+      , type     text not null
+      , interval int not null
+      , primary key (ref,type)
+      )
+    |]
+
+    when poll_0 do
+      debug $ red "BRAINS: FILL poll_1"
+      execute_ conn [qc|
+        insert into statedb.poll_1 (ref,type,interval)
+        select ref,type,interval from statedb.poll;
+      |]
 
   execute_ conn [qc|
     create table if not exists peer_asymmkey
@@ -872,13 +917,17 @@ newBasicBrains cfg = liftIO do
               <*> newTQueueIO
               <*> newTQueueIO
               <*> Cache.newCache (Just (toTimeSpec (1200:: Timeout 'Seconds)))
-
+              <*> newTVarIO mempty
 
 data PeerDownloadsDelOnStart
 
 instance Monad m => HasCfgKey PeerDownloadsDelOnStart b m where
   key = "downloads-del-on-start"
 
+{- HLINT ignore "Use camelCase" -}
+poll_table :: String
+poll_table = "statedb.poll_1"
+
 runBasicBrains :: forall e m . ( e ~ L4Proto
                                , MonadUnliftIO m
                                , ForRefChans e
@@ -931,7 +980,7 @@ runBasicBrains cfg brains = do
   when (delDowns == FeatureOn ) do
     debug $ yellow "CLEAN ALL DOWNLOADS"
     updateOP brains (delAllDownloads brains)
-    commitNow brains True
+    commitNow brains False
 
   let polls = catMaybes (
        [ (tp,n,) <$> fromStringMay @(PubKey 'Sign (Encryption e)) (Text.unpack ref)
@@ -945,7 +994,7 @@ runBasicBrains cfg brains = do
       updateOP brains $ do
         let conn = view brainsDb brains
         liftIO $ execute conn [qc|
-          insert into statedb.poll (ref,type,interval)
+          insert into {poll_table} (ref,type,interval)
           values (?,?,?)
           on conflict do update set interval = excluded.interval
           |] (show $ pretty (AsBase58 x), show $ pretty t, mi)

hbs2-peer/app/CLI/Common.hs

@@ -1,10 +1,12 @@
 {-# Language TemplateHaskell #-}
 module CLI.Common where
 
+import HBS2.Prelude
 import HBS2.Clock
 import HBS2.Net.Messaging.Unix
 import HBS2.Net.Proto
 import HBS2.Net.Proto.Service
+import HBS2.Net.Auth.Schema
 
 import PeerConfig
 
@@ -58,3 +60,6 @@ pRpcCommon :: Parser RPCOpt
 pRpcCommon = do
   RPCOpt <$> optional confOpt
          <*> optional rpcOpt
+
+pPubKey :: ReadM (PubKey 'Sign HBS2Basic)
+pPubKey = maybeReader fromStringMay

hbs2-peer/app/CLI/LWWRef.hs

@@ -0,0 +1,76 @@
+module CLI.LWWRef where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Net.Proto.Service
+import HBS2.Net.Auth.Credentials
+import HBS2.Data.Types.SignedBox
+import HBS2.Net.Auth.Schema
+import HBS2.Peer.Proto.LWWRef
+
+import HBS2.Peer.RPC.API.LWWRef
+import HBS2.KeyMan.Keys.Direct
+
+import CLI.Common
+import RPC2()
+import PeerLogger hiding (info)
+
+import System.Exit
+
+import Options.Applicative
+import Data.Word
+import Lens.Micro.Platform
+
+pLwwRef :: Parser (IO ())
+pLwwRef = hsubparser (   command "fetch"  (info pLwwRefFetch  (progDesc "fetch lwwref"))
+                      <> command "get"    (info pLwwRefGet    (progDesc "get lwwref"))
+                      <> command "update" (info pLwwRefUpdate (progDesc "update lwwref"))
+                     )
+pLwwRefFetch :: Parser (IO ())
+pLwwRefFetch = do
+  rpc <- pRpcCommon
+  ref <- strArgument (metavar "LWWREF")
+  pure $ withMyRPC @LWWRefAPI rpc $ \caller -> do
+    callService @RpcLWWRefFetch caller ref >>= \case
+      Left e  -> err (viaShow e) >> exitFailure
+      Right{} -> pure ()
+
+lwwRef :: ReadM (LWWRefKey HBS2Basic)
+lwwRef = maybeReader (fromStringMay @(LWWRefKey HBS2Basic))
+
+pLwwRefGet :: Parser (IO ())
+pLwwRefGet = do
+  rpc <- pRpcCommon
+  ref <- strArgument (metavar "LWWREF")
+  pure $ withMyRPC @LWWRefAPI rpc $ \caller -> do
+    callService @RpcLWWRefGet caller ref >>= \case
+      Left e  -> err (viaShow e) >> exitFailure
+      Right r -> print $ pretty r
+
+pLwwRefUpdate :: Parser (IO ())
+pLwwRefUpdate = do
+  rpc <- pRpcCommon
+  puk <- argument pPubKey (metavar "LWWREF")
+  seq' <- optional $ option @Word64 auto (short 's' <> long "seq" <> help "seqno" <>metavar "SEQ")
+  val <- option (maybeReader fromStringMay) (short 'v' <> long "value" <> help "value" <> metavar "VALUE")
+  pure $ withMyRPC @LWWRefAPI rpc $ \caller -> do
+
+
+    (sk,pk) <- liftIO $ runKeymanClient do
+                 creds  <- loadCredentials puk >>= orThrowUser "can't load credentials"
+                 pure ( view peerSignSk  creds, view peerSignPk creds )
+
+    seq <- case seq' of
+             Just v -> pure v
+             Nothing -> do
+               let ref = LWWRefKey puk
+               callService @RpcLWWRefGet caller ref >>= \case
+                 Left e  -> err (viaShow e) >> exitFailure
+                 Right Nothing -> err ("not found value for" <+> pretty ref) >> exitFailure
+                 Right (Just r) -> pure $ succ (lwwSeq r)
+
+    let box =  makeSignedBox @L4Proto pk sk (LWWRef @L4Proto seq val Nothing)
+    callService @RpcLWWRefUpdate caller box >>= \case
+      Left e  -> err (viaShow e) >> exitFailure
+      Right r -> print $ pretty r
+

hbs2-peer/app/HttpWorker.hs

@@ -2,29 +2,59 @@
 module HttpWorker where
 
 import HBS2.Prelude
+import HBS2.Hash
 import HBS2.Actors.Peer
 import HBS2.Storage
+import HBS2.Data.Detect
 import HBS2.Data.Types.Refs
-import HBS2.Merkle (AnnMetaData)
+import HBS2.Merkle
 import HBS2.Peer.Proto
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Net.Auth.Schema
+import HBS2.Data.Types.SignedBox
 import HBS2.Events
+import HBS2.Storage.Operations.ByteString
 
 import PeerTypes
 import PeerConfig
 import RefLog ( doRefLogBroadCast )
 
+import Data.Config.Suckless
+
 import Data.ByteString.Lazy qualified as LBS
 import Network.HTTP.Types.Status
 import Network.Wai.Middleware.RequestLogger
 import Text.InterpolatedString.Perl6 (qc)
 import Web.Scotty
+
+import Data.ByteString.Builder (byteString, Builder)
+
+import Control.Concurrent
+import Data.Either
 import Codec.Serialise (deserialiseOrFail)
 import Data.Aeson (object, (.=))
+import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Control.Monad.Reader
 import Lens.Micro.Platform (view)
+import System.FilePath
+import Control.Monad.Except
+import Control.Monad.Trans.Cont
+
+import UnliftIO (async)
+
+{- HLINT ignore "Functor law" -}
 
 -- 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
+
+orElse :: m r -> Maybe a -> ContT r m a
+orElse a mb = ContT $ maybe1 mb a
+
 httpWorker :: forall e s m . ( MyPeer e
                              , MonadIO m
                              , HasStorage m
@@ -32,6 +62,7 @@ httpWorker :: forall e s m . ( MyPeer e
                              , s ~ Encryption e
                              , m ~ PeerM e IO
                              , e ~ L4Proto
+                             -- , ForLWWRefProto e
                              ) => PeerConfig -> AnnMetaData -> DownloadEnv e -> m ()
 
 httpWorker (PeerConfig syn) pmeta e = do
@@ -45,7 +76,11 @@ httpWorker (PeerConfig syn) pmeta e = do
     scotty port $ do
       middleware logStdout
 
+      defaultHandler $ const do
+        status status500
+
       get "/size/:hash" do
+
         what <- param @String "hash" <&> fromString
         size <- liftIO $ hasBlock sto what
         case size of
@@ -53,6 +88,73 @@ httpWorker (PeerConfig syn) pmeta e = do
           Just n -> do
             json n
 
+      -- TODO: key-to-disable-tree-streaming
+
+      get "/ref/:key" do
+
+        void $ flip runContT pure do
+          what <- lift (param @String "key" <&> fromStringMay @(LWWRefKey HBS2Basic))
+                    >>= orElse (status status404)
+
+          rv <- getRef sto what
+                  >>= orElse (status status404)
+                  >>= getBlock sto
+                  >>= orElse (status status404)
+                  <&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef e) e)
+                  >>= orElse (status status404)
+                  <&> unboxSignedBox0 @(LWWRef e)
+                  >>= orElse (status status404)
+                  <&> lwwValue . snd
+
+          lift $ redirect [qc|/tree/{pretty rv}|]
+
+      get "/tree/:hash" do
+        what <- param @String "hash" <&> fromString
+
+        void $ flip runContT pure do
+
+          callCC $ \exit -> do
+
+            blob <- liftIO (getBlock 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
+                     ]
+
+            let fn = headMay
+                     [ show (pretty w)
+                     | ListVal [SymbolVal "file-name:", LitStrVal w] <- meta
+                     ]
+
+            -- liftIO $ print $ pretty meta
+
+            case fn of
+              Just x | takeExtension x == ".html" -> pure  ()
+                     | otherwise -> lift $ do
+                         addHeader "content-disposition" [qc|attachment; filename="{x}"|]
+
+              _ -> pure ()
+
+            lift $ addHeader "content-type" (fromString tp)
+
+            elbs <- lift $ runExceptT $ readFromMerkle sto (SimpleKey what)
+
+            case elbs of
+              Left{} -> lift $ status status404
+              Right lbs -> lift do
+                stream $ \write flush -> do
+                  for_ (LBS.toChunks lbs) $ \chunk -> do
+                    write $ byteString chunk
+                  flush
+
       get "/cat/:hash" do
         what <- param @String "hash" <&> fromString
         blob <- liftIO $ getBlock sto what

hbs2-peer/app/LWWRef.hs

@@ -0,0 +1,52 @@
+module LWWRef where
+
+import HBS2.Prelude.Plated
+import HBS2.Actors.Peer
+import HBS2.Data.Types.Refs
+import HBS2.Net.Proto
+import HBS2.Base58
+import HBS2.Storage
+import HBS2.Storage.Operations.Missed
+import HBS2.Hash
+import HBS2.Peer.Proto
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Net.Auth.Credentials
+
+import HBS2.Misc.PrettyStuff
+
+import Brains
+import PeerConfig
+import PeerTypes
+
+import Control.Monad
+import UnliftIO
+import Lens.Micro.Platform
+
+{- HLINT ignore "Functor law" -}
+
+lwwRefWorker :: forall e s m . ( MonadIO m
+                               , MonadUnliftIO m
+                               , MyPeer e
+                               , HasStorage m
+                               , Sessions e (KnownPeer e) m
+                               , HasGossip e (LWWRefProto e) m
+                               , Signatures s
+                               , s ~ Encryption e
+                               , IsRefPubKey s
+                               )
+             => PeerConfig
+             -> SomeBrains e
+             -> m ()
+
+lwwRefWorker conf brains = do
+
+   let listRefs = listPolledRefs @e brains (Just "lwwref")
+                   <&> fmap (\(a,_,b) -> (a,b))
+                   <&> fmap (over _2 ( (*60) . fromIntegral) )
+
+   polling (Polling 5 5) listRefs $ \ref -> do
+    debug $ yellow "POLLING LWWREF" <+> pretty (AsBase58 ref)
+    gossip (LWWRefProto1 @e (LWWProtoGet (LWWRefKey ref)))
+
+
+

hbs2-peer/app/PeerMain.hs

@@ -16,6 +16,7 @@ import HBS2.Data.Types.Refs
 import HBS2.Data.Types.SignedBox
 import HBS2.Data.Types
 import HBS2.Net.Auth.Credentials
+import HBS2.Net.Auth.Schema()
 import HBS2.Net.IP.Addr
 import HBS2.Net.Messaging.UDP
 import HBS2.Net.Messaging.TCP
@@ -47,11 +48,13 @@ import Bootstrap
 import CheckMetrics
 import RefLog qualified
 import RefLog (reflogWorker)
+import LWWRef (lwwRefWorker)
 import HttpWorker
 import DispatchProxy
 import PeerMeta
 import CLI.Common
 import CLI.RefChan
+import CLI.LWWRef
 import RefChan
 import RefChanNotifyLog
 import Fetch (fetchHash)
@@ -65,9 +68,12 @@ import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.API.Peer
 import HBS2.Peer.RPC.API.RefLog
 import HBS2.Peer.RPC.API.RefChan
+import HBS2.Peer.RPC.API.LWWRef
 import HBS2.Peer.Notify
 import HBS2.Peer.RPC.Client.StorageClient
 
+import HBS2.Peer.Proto.LWWRef.Internal
+
 import RPC2(RPC2Context(..))
 
 import Codec.Serialise as Serialise
@@ -120,7 +126,7 @@ instance Exception GoAgainException
 
 -- TODO: write-workers-to-config
 defStorageThreads :: Integral a => a
-defStorageThreads = 2
+defStorageThreads = 4
 
 defLocalMulticast :: String
 defLocalMulticast = "239.192.152.145:10153"
@@ -233,6 +239,7 @@ runCLI = do
                 <> command "fetch"     (info pFetch (progDesc "fetch block"))
                 <> command "reflog"    (info pRefLog (progDesc "reflog commands"))
                 <> command "refchan"   (info pRefChan (progDesc "refchan commands"))
+                <> command "lwwref"    (info pLwwRef (progDesc "lwwref commands"))
                 <> command "peers"     (info pPeers (progDesc "show known peers"))
                 <> command "pexinfo"   (info pPexInfo (progDesc "show pex"))
                 <> command "download"  (info pDownload  (progDesc "download management"))
@@ -450,7 +457,6 @@ runCLI = do
                        <> command "del" (info  pPollDel (progDesc "del poller" ))
                        )
 
-
     pPollAdd = do
       rpc <- pRpcCommon
       r <- argument refP (metavar "REF")
@@ -614,6 +620,8 @@ respawn opts =
 runPeer :: forall e s . ( e ~ L4Proto
                         , FromStringMaybe (PeerAddr e)
                         , s ~ Encryption e
+                        -- , ForLWWRefProto e
+                        -- , Serialise (PubKey 'Sign (Encryption e))
                         , HasStorage (PeerM e IO)
                         )=> PeerOpts -> IO ()
 
@@ -812,7 +820,7 @@ runPeer opts = Exception.handle (\e -> myException e
   let refChanAdapter =
         RefChanAdapter
         { refChanOnHead = refChanOnHeadFn rce
-        , refChanSubscribed = isPolledRef @e brains
+        , refChanSubscribed = isPolledRef @e brains "refchan"
         , refChanWriteTran = refChanWriteTranFn rce
         , refChanValidatePropose = refChanValidateTranFn @e rce
 
@@ -996,6 +1004,10 @@ runPeer opts = Exception.handle (\e -> myException e
                                             err $ red "Exception" <+> "in thread" <+> pretty t <+> viaShow e
                                             liftIO $ throwTo myself GoAgainException
 
+
+              let lwwRefProtoA = lwwRefProto (LWWRefProtoAdapter { lwwFetchBlock = download })
+                   where download h = withPeerM env $ withDownload denv (addDownload Nothing h)
+
               flip runContT pure do
 
                 peerThread "local multicast" $ forever $ do
@@ -1029,6 +1041,8 @@ runPeer opts = Exception.handle (\e -> myException e
 
                 peerThread "refChanNotifyLogWorker" (refChanNotifyLogWorker @e conf (SomeBrains brains))
 
+                peerThread "lwwRefWorker" (lwwRefWorker @e conf (SomeBrains brains))
+
                 liftIO $ withPeerM penv do
                   runProto @e
                     [ makeResponse (blockSizeProto blk (downloadOnBlockSize denv) onNoBlock)
@@ -1043,6 +1057,8 @@ runPeer opts = Exception.handle (\e -> myException e
                     , makeResponse (refChanUpdateProto False pc refChanAdapter)
                     , makeResponse (refChanRequestProto False refChanAdapter)
                     , makeResponse (refChanNotifyProto False refChanAdapter)
+                    -- TODO: change-all-to-authorized
+                    , makeResponse ((authorized . subscribed (SomeBrains brains)) lwwRefProtoA)
                     ]
 
 
@@ -1147,15 +1163,16 @@ runPeer opts = Exception.handle (\e -> myException e
     envrl <- newNotifyEnvServer @(RefLogEvents L4Proto) refLogNotifySource
     w1 <- asyncLinked $ runNotifyWorkerServer env
     w2 <- asyncLinked $ runNotifyWorkerServer envrl
-    runProto @UNIX
+    wws <- replicateM 1 $ async $ runProto @UNIX
       [ makeResponse (makeServer @PeerAPI)
       , makeResponse (makeServer @RefLogAPI)
       , makeResponse (makeServer @RefChanAPI)
       , makeResponse (makeServer @StorageAPI)
+      , makeResponse (makeServer @LWWRefAPI)
       , makeResponse (makeNotifyServer @(RefChanEvents L4Proto) env)
       , makeResponse (makeNotifyServer @(RefLogEvents L4Proto) envrl)
       ]
-    mapM_ wait [w1,w2]
+    mapM_ wait (w1 : w2 : wws )
 
   void $ waitAnyCancel $ w <> [ loop
                               , m1

hbs2-peer/app/PeerTypes.hs

@@ -3,6 +3,7 @@
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language MultiWayIf #-}
+{-# Language FunctionalDependencies #-}
 module PeerTypes
   ( module PeerTypes
   , module PeerLogger
@@ -13,6 +14,8 @@ module PeerTypes
 import HBS2.Polling
 import HBS2.Actors.Peer
 import HBS2.Clock
+import HBS2.Net.Auth.Schema
+import HBS2.Net.Auth.Credentials
 import HBS2.Data.Types.SignedBox
 import HBS2.Data.Types.Peer
 import HBS2.Data.Types.Refs
@@ -24,6 +27,7 @@ import HBS2.Net.IP.Addr
 import HBS2.Net.Proto
 import HBS2.Peer.Proto.Peer
 import HBS2.Peer.Proto.BlockInfo
+import HBS2.Peer.Proto.LWWRef
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
@@ -481,4 +485,40 @@ simpleBlockAnnounce size h = do
     pure $ BlockAnnounce @e no annInfo
 
 
+class IsPolledKey e proto | proto -> e where
+  getPolledKey :: proto -> (String, PubKey 'Sign (Encryption e))
+
+instance IsPolledKey e (LWWRefProto e) where
+  getPolledKey = \case
+    LWWRefProto1 (LWWProtoGet (LWWRefKey k)) -> (tp,k)
+    LWWRefProto1 (LWWProtoSet (LWWRefKey k) _) -> (tp,k)
+    where tp = "lwwref"
+
+subscribed :: forall e proto m . ( MonadIO  m
+                                 , IsPolledKey e proto
+                                 , Request e proto m
+                                 , Response e proto m
+                                 )
+
+           => SomeBrains e
+           -> (proto -> m ())
+           -> proto
+           -> m ()
+
+subscribed brains f req = do
+  let (tp,ref) = getPolledKey req
+  polled <- isPolledRef @e brains tp ref
+  when polled $ f req
+
+authorized :: forall e proto m . ( MonadIO m
+                                 , Request e proto m
+                                 , Response e proto m
+                                 , Sessions e (KnownPeer e) m
+                                 )
+           => (proto -> m ()) -> proto -> m ()
+authorized f req = do
+  p <- thatPeer @proto
+  auth <- find (KnownPeerKey p) id <&> isJust
+  when auth (f req)
+
 

hbs2-peer/app/RPC2.hs

@@ -2,10 +2,12 @@ module RPC2
   ( module RPC2.Peer
   , module RPC2.RefLog
   , module RPC2.RefChan
+  , module RPC2.LWWRef
   ) where
 
 
 import RPC2.Peer
 import RPC2.RefLog
 import RPC2.RefChan
+import RPC2.LWWRef
 

hbs2-peer/app/RPC2/LWWRef.hs

@@ -0,0 +1,77 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
+module RPC2.LWWRef where
+
+
+import HBS2.Peer.Prelude
+
+import HBS2.Actors.Peer
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Peer.Proto.LWWRef.Internal
+import HBS2.Storage
+import HBS2.Net.Messaging.Unix
+import HBS2.Misc.PrettyStuff
+
+import PeerTypes
+
+import HBS2.Peer.RPC.Internal.Types
+import HBS2.Peer.RPC.API.LWWRef
+
+import Lens.Micro.Platform
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
+
+type LWWRefContext m = (MonadIO m, HasRpcContext LWWRefAPI RPC2Context m)
+
+instance (Monad m)
+  => HasRpcContext LWWRefAPI RPC2Context (ResponseM UNIX (ReaderT RPC2Context m)) where
+  getRpcContext = lift ask
+
+instance (LWWRefContext m) => HandleMethod m RpcLWWRefGet where
+
+  handleMethod key = do
+    co <- getRpcContext @LWWRefAPI
+    debug "rpc.LWWRefContext"
+
+    let penv = rpcPeerEnv co
+    liftIO $ withPeerM penv $ do
+      sto <- getStorage
+      runMaybeT do
+        rv <- getRef sto key >>= toMPlus
+        val <- getBlock sto rv >>= toMPlus
+                <&> unboxSignedBox @(LWWRef L4Proto) @L4Proto
+                >>= toMPlus
+
+        pure $ snd val
+
+instance LWWRefContext m => HandleMethod m RpcLWWRefFetch where
+
+  handleMethod key = do
+    co <- getRpcContext @LWWRefAPI
+    debug $ green "rpc.LWWRefFetch" <+> pretty key
+
+    let penv = rpcPeerEnv co
+    liftIO $ withPeerM penv $ do
+      gossip (LWWRefProto1 @L4Proto (LWWProtoGet key))
+
+instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where
+
+  handleMethod box = do
+    co <- getRpcContext @LWWRefAPI
+    debug "rpc.LWWRefUpdate"
+
+    let penv = rpcPeerEnv co
+
+    let nada = LWWRefProtoAdapter dontHandle
+
+    void $ runMaybeT do
+      (puk, _) <- unboxSignedBox0 box & toMPlus
+
+      liftIO $ withPeerM penv do
+        me <- ownPeer @L4Proto
+        runResponseM me $ do
+          lwwRefProto nada (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box))
+
+

hbs2-peer/app/RPC2/Poll.hs

@@ -24,7 +24,9 @@ instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcP
   handleMethod (r,t,i) = do
     brains <- getRpcContext @PeerAPI <&> rpcBrains
     debug $ "rpc.pollAdd"
-    addPolledRef @L4Proto brains r t i
+    polled <- isPolledRef @L4Proto brains t r
+    unless polled do
+      addPolledRef @L4Proto brains r t i
 
 instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPollDel where
 

hbs2-peer/app/RefLog.hs

@@ -65,7 +65,7 @@ mkRefLogRequestAdapter :: forall e s m . ( MonadIO m
           => SomeBrains e -> m (RefLogRequestI e (ResponseM e m ))
 mkRefLogRequestAdapter brains = do
   sto <- getStorage
-  pure $ RefLogRequestI (doOnRefLogRequest brains sto) dontHandle (isPolledRef @e brains)
+  pure $ RefLogRequestI (doOnRefLogRequest brains sto) dontHandle (isPolledRef @e brains "reflog")
 
 doOnRefLogRequest :: forall e s m . ( MonadIO m
                                     , MyPeer e
@@ -78,10 +78,10 @@ doOnRefLogRequest :: forall e s m . ( MonadIO m
                    -> m (Maybe (Hash HbSync))
 
 doOnRefLogRequest brains sto (_,pk) = runMaybeT do
-  isPolledRef @e brains pk >>= guard
+  isPolledRef @e brains "reflog" pk >>= guard
   ref <- liftIO $ getRef sto (RefLogKey @s pk)
   when (isNothing ref) do
-    warn $ "missed reflog value" <+> pretty ref
+    warn $ "missed reflog value" <+> pretty (RefLogKey @s pk)
   toMPlus ref
 
 data RefLogWorkerAdapter e =
@@ -150,7 +150,7 @@ reflogWorker conf brains adapter = do
   subscribe @e RefLogUpdateEvKey $ \(RefLogUpdateEvData (reflog,v, mpip)) -> do
     trace $ "reflog worker.got refupdate" <+> pretty (AsBase58 reflog)
 
-    polled <- isPolledRef @e brains reflog
+    polled <- isPolledRef @e brains "reflog" reflog
     buddy <- maybe1 mpip (pure False) $ \pip -> do
                 pa <- toPeerAddr @e pip
                 acceptAnnouncesFromPeer @e conf pa

hbs2-peer/hbs2-peer.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-peer
-version:            0.1.0.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause
@@ -69,6 +69,7 @@ common common-deps
         , warp
         , http-conduit
         , http-types
+        , wai
         , wai-extra
         , unliftio
         , unliftio-core
@@ -157,11 +158,14 @@ library
       HBS2.Peer.Proto.RefChan.RefChanNotify
       HBS2.Peer.Proto.RefChan.RefChanUpdate
       HBS2.Peer.Proto.AnyRef
+      HBS2.Peer.Proto.LWWRef
+      HBS2.Peer.Proto.LWWRef.Internal
 
       HBS2.Peer.RPC.Class
       HBS2.Peer.RPC.API.Peer
       HBS2.Peer.RPC.API.RefLog
       HBS2.Peer.RPC.API.RefChan
+      HBS2.Peer.RPC.API.LWWRef
       HBS2.Peer.RPC.API.Storage
       HBS2.Peer.RPC.Client.Unix
       HBS2.Peer.RPC.Client.StorageClient
@@ -172,6 +176,54 @@ library
     other-modules:
       -- HBS2.System.Logger.Simple
 
+
+test-suite test
+    import:           shared-properties
+    default-language: Haskell2010
+
+    other-modules:
+
+    -- other-extensions:
+
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          TestSuite.hs
+    build-depends:
+          base, hbs2-peer, hbs2-core
+        , async
+        , bytestring
+        , cache
+        , containers
+        , directory
+        , hashable
+        , microlens-platform
+        , mtl
+        , prettyprinter
+        , QuickCheck
+        , quickcheck-instances
+        , random
+        , safe
+        , serialise
+        , stm
+        , streaming
+        , tasty
+        , tasty-quickcheck
+        , tasty-hunit
+        , tasty-quickcheck
+        , transformers
+        , uniplate
+        , vector
+        , saltine
+        , simple-logger
+        , string-conversions
+        , filepath
+        , temporary
+        , unliftio
+        , resourcet
+
+
+
+
 executable hbs2-peer
     import:           shared-properties
     import:           common-deps
@@ -207,18 +259,21 @@ executable hbs2-peer
                     , RPC2.Downloads
                     , RPC2.RefLog
                     , RPC2.RefChan
+                    , RPC2.LWWRef
                     , PeerTypes
                     , PeerLogger
                     , PeerConfig
                     , RefLog
                     , RefChan
                     , RefChanNotifyLog
+                    , LWWRef
                     , CheckMetrics
                     , HttpWorker
                     , Brains
                     , DispatchProxy
                     , CLI.Common
                     , CLI.RefChan
+                    , CLI.LWWRef
 
                     , Paths_hbs2_peer
 

hbs2-peer/lib/HBS2/Peer/Brains.hs

@@ -18,8 +18,8 @@ class HasBrains e a where
   listPolledRefs :: MonadIO m => a -> Maybe String -> m [(PubKey 'Sign (Encryption e), String, Int)]
   listPolledRefs _ _  = pure mempty
 
-  isPolledRef :: MonadIO m => a -> PubKey 'Sign (Encryption e) -> m Bool
-  isPolledRef _ _ = pure False
+  isPolledRef :: MonadIO m => a -> String -> PubKey 'Sign (Encryption e) -> m Bool
+  isPolledRef _ _ _ = pure False
 
   delPolledRef :: MonadIO m => a -> PubKey 'Sign (Encryption e) -> m ()
   delPolledRef _ _ = pure ()

hbs2-peer/lib/HBS2/Peer/Proto.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
 module HBS2.Peer.Proto
   ( module HBS2.Peer.Proto.PeerMeta
   , module HBS2.Peer.Proto.BlockAnnounce
@@ -27,6 +28,7 @@ import HBS2.Peer.Proto.PeerExchange
 import HBS2.Peer.Proto.RefLog
 import HBS2.Peer.Proto.RefChan hiding (Notify)
 import HBS2.Peer.Proto.AnyRef
+import HBS2.Peer.Proto.LWWRef
 
 import HBS2.Actors.Peer.Types
 import HBS2.Net.Messaging.Unix (UNIX)
@@ -146,6 +148,12 @@ instance HasProtocol L4Proto (RefChanNotify L4Proto) where
   -- возьмем пока 10 секунд
   requestPeriodLim = NoLimit
 
+instance ForLWWRefProto L4Proto => HasProtocol L4Proto (LWWRefProto L4Proto) where
+  type instance ProtocolId (LWWRefProto L4Proto) = 12001
+  type instance Encoded L4Proto = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
+  requestPeriodLim = ReqLimPerMessage 1
 
 instance Serialise (RefChanValidate UNIX) => HasProtocol UNIX (RefChanValidate UNIX) where
   type instance ProtocolId (RefChanValidate UNIX) = 0xFFFA0001

hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs

@@ -0,0 +1,139 @@
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Peer.Proto.LWWRef where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Base58
+import HBS2.Storage
+import HBS2.Hash
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Types
+import HBS2.Data.Types.SignedBox
+import HBS2.Data.Types.Refs
+import HBS2.Net.Proto.Types
+import HBS2.Net.Auth.Schema()
+
+import Data.ByteString (ByteString)
+import Data.Hashable hiding (Hashed)
+import Data.Maybe
+import Data.Word
+import Control.Monad.Trans.Maybe
+import Control.Monad.Except
+import Codec.Serialise
+
+data LWWRefProtoReq e =
+    LWWProtoGet (LWWRefKey (Encryption e))
+  | LWWProtoSet (LWWRefKey (Encryption e)) (SignedBox (LWWRef e) e)
+  deriving stock Generic
+
+
+data LWWRefProto e =
+  LWWRefProto1 (LWWRefProtoReq e)
+  deriving stock (Generic)
+
+data LWWRef e =
+  LWWRef
+  { lwwSeq      :: Word64
+  , lwwValue    :: HashRef
+  , lwwProof    :: Maybe HashRef
+  }
+  deriving stock (Generic)
+
+
+type ForLWWRefProto e = (ForSignedBox e, Serialise (LWWRefKey (Encryption e)))
+
+instance ForLWWRefProto e => Serialise (LWWRefProtoReq e)
+instance ForLWWRefProto e => Serialise (LWWRefProto e)
+instance ForLWWRefProto e => Serialise (LWWRef e)
+
+newtype LWWRefKey s =
+  LWWRefKey
+  { fromLwwRefKey :: PubKey 'Sign s
+  }
+  deriving stock (Generic)
+
+
+instance RefMetaData (LWWRefKey s)
+
+deriving stock instance IsRefPubKey s => Eq (LWWRefKey s)
+
+instance IsRefPubKey e => Serialise (LWWRefKey e)
+
+instance IsRefPubKey s => Hashable (LWWRefKey s) where
+  hashWithSalt s k = hashWithSalt s (hashObject @HbSync k)
+
+instance IsRefPubKey s => Hashed HbSync (LWWRefKey s) where
+  hashObject (LWWRefKey pk) = hashObject ("lwwrefkey|" <> serialise pk)
+
+instance IsRefPubKey s => FromStringMaybe (LWWRefKey s) where
+  fromStringMay s = LWWRefKey <$> fromStringMay s
+
+instance IsRefPubKey s =>  IsString (LWWRefKey s) where
+  fromString s = fromMaybe (error "bad public key base58") (fromStringMay s)
+
+instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (AsBase58 (LWWRefKey s)) where
+  pretty (AsBase58 (LWWRefKey k)) = pretty (AsBase58 k)
+
+instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (LWWRefKey s) where
+  pretty (LWWRefKey k) = pretty (AsBase58 k)
+
+
+instance Pretty (LWWRef e) where
+  pretty (LWWRef{..}) = parens ( "lwwref" <> line
+                          <> indent 2 ( seqno <> line <> val <> line <> proof)
+                        )
+    where
+      seqno = parens ( "seq" <+> pretty lwwSeq )
+      val   = parens ( "value" <+> dquotes (pretty lwwValue) )
+      proof | isNothing lwwProof = mempty
+            | otherwise = parens ( "proof" <+> pretty lwwProof)
+
+
+data ReadLWWRefError =
+    ReadLWWStorageError
+  | ReadLWWFormatError
+  | ReadLWWSignatureError
+  deriving stock (Show,Typeable)
+
+readLWWRef :: forall e s m . ( MonadIO m
+                             , MonadError ReadLWWRefError m
+                             , Encryption e ~ s
+                             , ForLWWRefProto e
+                             , Signatures s
+                             , IsRefPubKey s
+                             )
+           => AnyStorage
+           -> LWWRefKey s
+           -> m (Maybe (LWWRef e))
+
+readLWWRef sto key = runMaybeT do
+  getRef sto key
+    >>= toMPlus
+    >>= getBlock sto
+    >>= toMPlus
+    <&> deserialiseOrFail @(SignedBox (LWWRef e) e)
+    >>= orThrowError ReadLWWFormatError
+    <&> unboxSignedBox0
+    >>= orThrowError ReadLWWSignatureError
+    <&> snd
+
+updateLWWRef :: forall s e m . ( Encryption e ~ s
+                               , ForLWWRefProto e
+                               , MonadIO m
+                               , Signatures s
+                               , IsRefPubKey s
+                               )
+             => AnyStorage
+             -> LWWRefKey s
+             -> PrivKey 'Sign s
+             -> LWWRef e
+             -> m (Maybe HashRef)
+
+updateLWWRef sto k sk v = do
+  let box = makeSignedBox @e (fromLwwRefKey k) sk v
+  runMaybeT do
+    hx <- putBlock sto (serialise box) >>= toMPlus
+    updateRef sto k hx
+    pure (HashRef hx)
+

hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs

@@ -0,0 +1,117 @@
+module HBS2.Peer.Proto.LWWRef.Internal
+  ( module HBS2.Peer.Proto.LWWRef.Internal
+  , module HBS2.Peer.Proto.LWWRef
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Data.Types.SignedBox
+import HBS2.Storage
+
+import HBS2.Hash
+import HBS2.Clock
+import HBS2.Net.Proto
+import HBS2.Net.Auth.Credentials
+import HBS2.Base58
+import HBS2.Events
+import HBS2.Actors.Peer.Types
+import HBS2.Peer.Proto.Peer
+import HBS2.Net.Proto.Sessions
+import HBS2.Data.Types.Refs
+import HBS2.Misc.PrettyStuff
+import HBS2.System.Logger.Simple
+
+import Codec.Serialise
+import Control.Monad
+import Control.Monad.Trans.Maybe
+import Data.Maybe
+
+{- HLINT ignore "Functor law" -}
+
+
+data LWWRefProtoAdapter e m =
+  LWWRefProtoAdapter
+  { lwwFetchBlock :: Hash HbSync -> m ()
+  }
+
+lwwRefProto :: forall e s m proto . ( MonadIO m
+                                    , ForLWWRefProto e
+                                    , Request e proto m
+                                    , Response e proto m
+                                    , HasDeferred proto e m
+                                    , HasGossip e (LWWRefProto e) m
+                                    , HasStorage m
+                                    , IsPeerAddr e m
+                                    , Pretty (Peer e)
+                                    , Sessions e (KnownPeer e) m
+                                    , Signatures s
+                                    , Pretty (AsBase58 (PubKey 'Sign s))
+                                    , s ~ Encryption e
+                                    , proto ~ LWWRefProto e
+                                    )
+                  => LWWRefProtoAdapter e m
+                  -> LWWRefProto e -> m ()
+
+lwwRefProto adapter pkt@(LWWRefProto1 req) = do
+  debug $ yellow "lwwRefProto"
+
+  case req of
+    LWWProtoGet key -> deferred @proto $ void $ runMaybeT do
+      sto <- getStorage
+
+      ref <- getRef sto key   >>= toMPlus
+
+      box <- getBlock sto ref
+                 >>= toMPlus
+                 <&> deserialiseOrFail
+                 >>= toMPlus
+
+      lift $ response (LWWRefProto1 (LWWProtoSet @e key box))
+
+    LWWProtoSet key box -> void $ runMaybeT do
+
+      (puk, lww) <- MaybeT $ pure $ unboxSignedBox0 box
+
+      guard ( puk == fromLwwRefKey key )
+
+      deferred @proto do
+
+        sto <- getStorage
+
+        let bs = serialise box
+        let h0  = hashObject @HbSync bs
+
+        new <- hasBlock sto h0 <&> isNothing
+
+        when new do
+          lift $ gossip pkt
+
+        lift $ lwwFetchBlock adapter (fromHashRef (lwwValue lww))
+
+        getRef sto key >>= \case
+          Nothing -> do
+            h <- enqueueBlock sto bs >>= toMPlus
+            updateRef sto key h
+
+          Just rv -> do
+            blk' <- getBlock sto rv
+            maybe1 blk' (forcedUpdateLwwRef sto key bs) $ \blk -> do
+
+              let lww0 = deserialiseOrFail @(SignedBox (LWWRef e) e) blk
+                             & either (const Nothing) Just
+                             >>= unboxSignedBox0
+                             <&> snd
+
+              let seq0  = lwwSeq <$> lww0
+              let lwwv0 = lwwValue <$> lww0
+
+              when (    Just (lwwSeq lww) > seq0
+                    || (Just (lwwSeq lww) == seq0 && Just (lwwValue lww) > lwwv0)
+                   ) do
+                forcedUpdateLwwRef sto key (serialise box)
+
+    where
+      forcedUpdateLwwRef sto key bs = do
+        h' <- enqueueBlock sto bs
+        forM_ h' $ updateRef sto key
+

hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs

@@ -24,6 +24,8 @@ import Data.ByteString (ByteString)
 import Type.Reflection (someTypeRep)
 import Lens.Micro.Platform
 
+
+
 newtype RefLogKey s = RefLogKey { fromRefLogKey :: PubKey 'Sign s }
                       deriving stock Generic
 

hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs

@@ -0,0 +1,40 @@
+module HBS2.Peer.RPC.API.LWWRef where
+
+import HBS2.Peer.Prelude
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Data.Types.SignedBox
+import HBS2.Net.Messaging.Unix
+import HBS2.Data.Types.Refs (HashRef(..))
+import HBS2.Net.Proto.Service
+import HBS2.Peer.Proto.RefLog (RefLogUpdate)
+
+import Data.ByteString.Lazy (ByteString)
+import Codec.Serialise
+
+data RpcLWWRefGet
+data RpcLWWRefUpdate
+data RpcLWWRefFetch
+
+type LWWRefAPI = '[ RpcLWWRefGet    -- may be done via storage
+                  , RpcLWWRefUpdate --
+                  , RpcLWWRefFetch  --
+                  ]
+
+instance HasProtocol UNIX  (ServiceProto LWWRefAPI UNIX) where
+  type instance ProtocolId (ServiceProto LWWRefAPI UNIX) = 16267229472009458342
+  type instance Encoded UNIX = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
+
+type instance Input RpcLWWRefGet   = LWWRefKey HBS2Basic
+type instance Output RpcLWWRefGet  = Maybe (LWWRef L4Proto)
+
+type instance Input RpcLWWRefFetch   = LWWRefKey HBS2Basic
+type instance Output RpcLWWRefFetch  = ()
+
+type instance Input RpcLWWRefUpdate = SignedBox (LWWRef L4Proto) L4Proto
+type instance Output RpcLWWRefUpdate = ()
+
+
+
+

hbs2-peer/test/TestSuite.hs

@@ -0,0 +1,107 @@
+module Main where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Base58 as B58
+import HBS2.Hash
+import HBS2.Net.Proto.Types
+import HBS2.Peer.Proto.RefLog
+import HBS2.Net.Auth.Schema
+import HBS2.Misc.PrettyStuff
+
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Data.Maybe
+import Data.ByteString
+import Data.ByteString.Lazy qualified as LBS
+import Codec.Serialise
+import Crypto.Saltine.Core.Sign qualified as Sign
+
+
+newtype W a = W a
+              deriving stock Generic
+
+instance Serialise a => Serialise (W a)
+
+
+newtype X a = X a
+              deriving stock Generic
+
+instance Serialise a => Serialise (X a)
+
+newtype VersionedPubKey = VersionedPubKey { versionedPubKey :: ByteString }
+                          deriving stock (Show,Generic)
+
+data RefLogRequestVersioned e =
+  RefLogRequestVersioned
+  { refLogRequestVersioned :: VersionedPubKey
+  }
+  deriving stock (Show,Generic)
+
+instance Serialise VersionedPubKey
+
+instance Serialise (RefLogRequestVersioned e)
+
+testVersionedKeysHashes :: IO ()
+testVersionedKeysHashes = do
+
+  keypart <- fromBase58 "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
+               & orThrowUser "bad base58"
+               <&> LBS.fromStrict
+
+  pk <- fromStringMay @(PubKey 'Sign HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
+          & orThrowUser "key decode"
+
+  let pks = serialise pk
+
+  pks2 <- deserialiseOrFail @(PubKey 'Sign HBS2Basic) (pks <> "12345")
+           & orThrowUser "key decode error"
+
+  let rfk = serialise (RefLogKey @HBS2Basic pk)
+  let wrfk = serialise $ W (RefLogKey @HBS2Basic pk)
+  let xrfk = serialise $ X (RefLogKey @HBS2Basic pk)
+
+  print $ pretty (AsHexSparse keypart)
+  print $ pretty (AsHexSparse pks)
+  print $ pretty (AsHexSparse rfk)
+  print $ pretty (AsHexSparse wrfk)
+  print $ pretty (AsHexSparse xrfk)
+
+  let req1 = RefLogRequest @L4Proto pk
+
+  let req2 = RefLogRequestVersioned @L4Proto ( VersionedPubKey (LBS.toStrict keypart <> "AAA") )
+
+  print $ yellow "okay"
+
+  let req1s = serialise req1
+  let req2s = serialise req2
+
+  print $ pretty "---"
+
+  print $ pretty (AsHexSparse req1s)
+  print $ pretty (AsHexSparse req2s)
+
+  rq0 <- deserialiseOrFail @(RefLogRequestVersioned L4Proto) req1s
+           & orThrowUser "failed simple -> versioned"
+
+  rq1 <- deserialiseOrFail @(RefLogRequest L4Proto) req2s
+           & orThrowUser "failed versioned -> simple"
+
+  print $ viaShow rq0
+  print $ viaShow req1
+
+  print $ viaShow rq1
+
+  pure ()
+
+main :: IO ()
+main =
+  defaultMain $
+    testGroup "root"
+      [
+        testCase "testVersionedKeys" testVersionedKeysHashes
+      ]
+
+
+

hbs2-share/hbs2-share.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-share
-version:            0.1.0.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2-storage-simple/hbs2-storage-simple.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-storage-simple
-version:            0.1.0.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause

hbs2/Main.hs

@@ -22,11 +22,12 @@ import HBS2.Storage.Simple.Extra
 import HBS2.Data.Bundle
 import HBS2.OrDie
 import HBS2.Version
+import HBS2.Misc.PrettyStuff
 import Paths_hbs2 qualified as Pkg
 
 import HBS2.KeyMan.Keys.Direct
 
-import HBS2.System.Logger.Simple hiding (info)
+import HBS2.System.Logger.Simple.ANSI hiding (info)
 
 import Data.Config.Suckless
 
@@ -36,11 +37,13 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Resource
+import Control.Monad.Trans.Cont
 import Crypto.Saltine.Core.Box qualified as Encrypt
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString qualified as BS
 import Data.ByteArray.Hash (SipHash(..), SipKey(..))
 import Data.ByteArray.Hash qualified as BA
@@ -54,9 +57,15 @@ import Options.Applicative
 import Streaming.Prelude qualified as S
 import Streaming.ByteString qualified as SB
 import System.Directory
+import System.FilePath
 import System.Exit qualified as Exit
 import System.IO qualified as IO
 import System.IO.Temp (emptySystemTempFile)
+
+import Magic.Data
+import Magic.Init       (magicLoadDefault,magicOpen)
+import Magic.Operations (magicFile)
+
 import UnliftIO
 
 tracePrefix :: SetLoggerEntry
@@ -75,6 +84,9 @@ noticePrefix :: SetLoggerEntry
 noticePrefix = logPrefix "[notice] " . toStderr
 
 
+data MetadataMethod = MetaDataAuto FilePath
+                      deriving stock (Eq,Generic,Show)
+
 newtype CommonOpts =
   CommonOpts
   { _coPref :: Maybe StoragePrefix
@@ -221,6 +233,11 @@ runCat opts ss = do
             Left hx  -> err $ "missed block" <+> pretty hx
             Right hr -> print $ vcat (fmap pretty hr)
 
+        MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do
+          bs <- runExceptT (readFromMerkle (AnyStorage ss) (SimpleKey mhash))
+                   >>= orThrowUser "can't read/decode tree"
+          LBS.putStr bs
+
         MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
           keyring <- case uniLastMay @OptKeyringFile opts of
                        Just krf -> do
@@ -487,6 +504,7 @@ main = join . customExecParser (prefs showHelpOnError) $
     parser ::  Parser (IO ())
     parser = hsubparser (  command "store"           (info pStore (progDesc "store block"))
                         <> command "cat"             (info pCat (progDesc "cat block"))
+                        <> command "metadata"        (info pMetadata (progDesc "tree metadata manipulation"))
                         <> command "hash"            (info pHash (progDesc "calculates hash"))
                         <> command "fsck"            (info pFsck (progDesc "check storage constistency"))
                         <> command "deps"            (info pDeps (progDesc "print dependencies"))
@@ -535,6 +553,79 @@ main = join . customExecParser (prefs showHelpOnError) $
       pure $ withStore o $ runCat
           $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile) raw
 
+    pMetadata = hsubparser ( command "dump" (info pMetadataDump (progDesc "dump metadata"))
+                           <> command "create" (info pMetadataCreate (progDesc "create tree with metadata"))
+                           )
+
+    pMetadataDump = do
+      o <- common
+      h <- argument (maybeReader (fromStringMay @HashRef)) (metavar "HASH") <&> fromHashRef
+      pure $ flip runContT pure do
+        sto <- ContT (withStore o)
+
+        void $ runMaybeT do
+          bs <- getBlock sto h >>= toMPlus
+          case tryDetect h bs of
+            MerkleAnn (MTreeAnn { _mtaMeta = AnnHashRef mh } ) -> do
+
+              bs <- getBlock sto mh
+                       `orDie` "cant' read metadata"
+
+              liftIO $ LBS.putStr bs
+
+            _ -> exitFailure
+
+    pMetadataCreate = do
+      o <- common
+      how <- MetaDataAuto <$> strOption ( long "auto" <> metavar "FILENAME" <> help "automatic metadata from file name")
+      dry <- flag False True (long "dry" <> short 'n' <> help "don't write to storage")
+      hOnly <- flag False True (long "hash" <> short 'H' <> help "merely print hash")
+
+      pure $ flip runContT pure do
+
+        sto <- ContT $ withStore o
+
+        void $ runMaybeT do
+
+          case how of
+            MetaDataAuto fn -> do
+
+              meta <- liftIO do
+                        magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding]
+                        magicLoadDefault magic
+                        mime <- magicFile magic fn
+
+                        pure [ "file-name:" <+> dquotes (pretty $ takeFileName fn)
+                             , "mime-type:" <+> dquotes (pretty mime)
+                             ]
+
+              let s = LBS8.pack $ show $ vcat meta
+
+              unless hOnly do
+                liftIO $ LBS8.putStrLn s
+                liftIO $ LBS8.putStrLn ""
+
+              guard (not dry)
+
+              mth <- putBlock sto s >>= toMPlus
+
+              bs <- liftIO $ LBS.readFile fn
+
+              root <- writeAsMerkle sto bs
+
+              mt <- getBlock sto root `orDie` "can't read merkle tree just written"
+                      <&> deserialiseOrFail @(MTree [HashRef])
+                      >>= orThrowUser "corrupted merkle tree -- should never happen"
+
+              delBlock sto root
+
+              let mtann = MTreeAnn (AnnHashRef mth) NullEncryption mt
+
+              hnew <- putBlock sto (serialise mtann)
+                        `orDie` "can't write merkle tree"
+
+              liftIO $ print $ pretty hnew
+
     pGroupKey = pGroupKeySymm
 
     pGroupKeySymm = hsubparser (  command "gen" (info pGroupKeySymmGen (progDesc "generate") )

hbs2/hbs2.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2
-version:            0.1.0.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause
@@ -79,6 +79,7 @@ executable hbs2
                     , filepath
                     , hashable
                     , interpolatedstring-perl6
+                    , magic
                     , memory
                     , microlens-platform
                     , mtl

hbs21-git/git-hbs2-subscribe/Main.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Main where
+
+import HBS2.Git.Client.Prelude hiding (info)
+import HBS2.Git.Client.App hiding (_progress, _storage, _peerAPI, _lwwAPI, _refLogAPI)
+import HBS2.Git.Client.Progress
+import HBS2.Git.Client.Import
+import HBS2.Git.Client.RefLog
+import HBS2.Peer.CLI.Detect
+
+import Options.Applicative
+import Data.Semigroup ((<>))
+
+main :: IO ()
+main = do
+  let parser = subscribe
+                <$> optional (strOption
+                    ( long "socket"
+                   <> short 's'
+                   <> metavar "SOCKET"
+                   <> help "Socket file path"))
+                <*> argument pLww (metavar "LWWREF")
+  join $ execParser (info (parser <**> helper)
+              ( fullDesc
+             <> progDesc "Parse command line arguments"
+             <> header "Command line arguments parsing example"))
+
+
+  where
+    pLww :: ReadM (LWWRefKey HBS2Basic)
+    pLww = maybeReader fromStringMay
+
+
+data MyStuff =
+  MyStuff
+  { _peerAPI   :: ServiceCaller PeerAPI UNIX
+  , _lwwAPI    :: ServiceCaller LWWRefAPI UNIX
+  , _refLogAPI :: ServiceCaller RefLogAPI UNIX
+  , _storage   :: AnyStorage
+  , _progress  :: AnyProgress
+  }
+
+newtype MyApp m a = MyApp {  fromMyApp :: ReaderT MyStuff m a }
+                    deriving newtype ( Functor
+                                     , Applicative
+                                     , Monad
+                                     , MonadIO
+                                     , MonadUnliftIO
+                                     , MonadThrow
+                                     , MonadReader MyStuff
+                                     )
+
+instance Monad m => HasProgressIndicator  (MyApp m) where
+  getProgressIndicator = asks _progress
+
+instance Monad m => HasStorage (MyApp m) where
+  getStorage = asks _storage
+
+instance Monad m => HasAPI PeerAPI UNIX (MyApp m) where
+  getAPI = asks _peerAPI
+
+instance Monad m => HasAPI LWWRefAPI UNIX (MyApp m) where
+  getAPI = asks _lwwAPI
+
+instance Monad m => HasAPI RefLogAPI UNIX (MyApp m) where
+  getAPI = asks _refLogAPI
+
+subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey HBS2Basic  -> m ()
+subscribe soname' ref = do
+
+  soname <- maybe1 soname' detectRPC (pure.Just) `orDie` "can't locate rpc"
+
+  flip runContT pure do
+
+    client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+                >>= orThrowUser ("can't connect to" <+> pretty soname)
+
+    q <- lift newProgressQ
+    let ip = AnyProgress q
+
+    void $ ContT $ withAsync $ runMessagingUnix client
+    void $ ContT $ withAsync $ drawProgress q
+
+    peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+    refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+    storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+    lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
+
+    let sto = AnyStorage (StorageClient storageAPI)
+
+    let endpoints = [ Endpoint @UNIX  peerAPI
+                    , Endpoint @UNIX  refLogAPI
+                    , Endpoint @UNIX  lwwAPI
+                    , Endpoint @UNIX  storageAPI
+                    ]
+
+    void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+
+    let app = MyStuff peerAPI lwwAPI refLogAPI sto ip
+
+    lift $ flip runReaderT app  $ fromMyApp do
+      merelySubscribeRepo ref
+
+      onProgress ip ImportAllDone
+
+      hFlush stdout
+      hFlush stderr
+
+  pure ()
+

hbs21-git/git-hbs21/Main.hs

@@ -0,0 +1,219 @@
+{-# Language UndecidableInstances #-}
+module Main where
+
+import HBS2.Git.Client.Prelude hiding (info)
+import HBS2.Git.Client.App
+import HBS2.Git.Client.Export
+import HBS2.Git.Client.Import
+import HBS2.Git.Client.State
+
+import HBS2.Git.Data.RefLog
+import HBS2.Git.Local.CLI qualified as Git
+import HBS2.Git.Data.Tx qualified as TX
+import HBS2.Git.Data.Tx (RepoHead(..))
+import HBS2.Git.Data.LWWBlock
+import HBS2.Git.Data.GK
+
+import HBS2.Storage.Operations.ByteString
+
+import Options.Applicative as O
+import Data.ByteString.Lazy qualified as LBS
+
+import System.Exit
+
+globalOptions :: Parser [GitOption]
+globalOptions = do
+
+  t <- flag [] [GitTrace]
+           (  long "trace" <> short 't' <> help "allow trace"
+           )
+
+  d <- flag [] [GitDebug]
+           (  long "debug" <> short 'd' <> help "allow debug"
+           )
+
+  pure (t <> d)
+
+commands :: GitPerks m => Parser (GitCLI m ())
+commands =
+  hsubparser (  command "export"  (info pExport  (progDesc "export repo to hbs2-git"))
+             <> command "import" (info pImport  (progDesc "import repo from reflog"))
+             <> command "key"    (info pKey     (progDesc "key management"))
+             <> command "tools"  (info pTools   (progDesc "misc tools"))
+             )
+
+
+pRefLogId :: ReadM RefLogId
+pRefLogId = maybeReader (fromStringMay @RefLogId)
+
+
+pLwwKey :: ReadM (LWWRefKey HBS2Basic)
+pLwwKey = maybeReader fromStringMay
+
+pHashRef :: ReadM HashRef
+pHashRef = maybeReader (fromStringMay @HashRef)
+
+pInit :: GitPerks m => Parser (GitCLI m ())
+pInit = do
+  pure runDefault
+
+
+pExport :: GitPerks m => Parser (GitCLI m ())
+pExport = do
+
+  puk <- argument pLwwKey (metavar "REFLOG-KEY")
+
+  et <- flag ExportInc ExportNew
+           (  long "new" <> help "new is usable to export to a new empty reflog"
+           )
+
+  enc <- flag' ExportPublic (long "public" <> help "create unencrypted reflog")
+          <|>
+          ( ExportPrivate <$>
+                strOption (long "encrypted" <> help "create encrypted reflog"
+                                            <> metavar "GROUP-KEY-FILE")
+          )
+
+  pure do
+    git <- Git.findGitDir >>= orThrowUser "not a git dir"
+    notice (green "git dir" <+> pretty git <+> pretty (AsBase58 puk))
+
+    env <- ask
+
+    withGitEnv ( env & set gitApplyHeads False & set gitExportType et & set gitExportEnc enc) do
+      unless (et == ExportNew) do
+        importRepoWait puk
+
+      export puk mempty
+
+pImport :: GitPerks m => Parser (GitCLI m ())
+pImport = do
+  puk <- argument pLwwKey (metavar "LWWREF")
+
+  pure do
+    git <- Git.findGitDir >>= orThrowUser "not a git dir"
+    importRepoWait puk
+
+pTools :: GitPerks m => Parser (GitCLI m ())
+pTools = hsubparser (  command "dump-pack" (info pDumpPack (progDesc "dump hbs2 git pack"))
+                    <> command "show-ref" (info pShowRef (progDesc "show current references"))
+                    <> command "show-remotes" (info pShowLww (progDesc "show current remotes (hbs2 references)"))
+                    )
+
+
+data DumpOpt = DumpInfoOnly | DumpObjects | DumpPack
+
+pDumpPack :: GitPerks m => Parser (GitCLI m ())
+pDumpPack = do
+  what <- dumpInfoOnly <|> dumpObjects <|> dumpPack
+  pure do
+    co <- liftIO LBS.getContents
+
+    (idSize,idVer,sidx,pack) <- TX.unpackPackMay co
+                                  & orThrowUser "can't unpack the bundle"
+
+    case what of
+      DumpInfoOnly -> do
+        liftIO $ print $ pretty "version:"    <+> pretty idVer  <> line
+                             <> "index size:" <+> pretty idSize <> line
+                             <> "objects:"    <+> pretty (length sidx)
+      DumpObjects -> do
+        liftIO $ print $ vcat (fmap pretty sidx)
+
+      DumpPack -> do
+        liftIO $ LBS.putStr pack
+
+  where
+    dumpInfoOnly = flag DumpInfoOnly DumpInfoOnly
+                      ( long "info-only" )
+
+    dumpObjects = flag DumpObjects DumpObjects
+                      ( long "objects" )
+
+    dumpPack = flag DumpPack DumpPack
+                      ( long "pack" )
+
+
+pShowLww :: GitPerks m => Parser (GitCLI m ())
+pShowLww = pure do
+  items <- withState selectAllLww
+  liftIO $ print $ vcat (fmap fmt items)
+  where
+    fmt (l,n,k) = fill 4 (pretty n) <+> fill 32 (pretty l) <+> fill 32 (pretty (AsBase58 k))
+
+pShowRef :: GitPerks m => Parser (GitCLI m ())
+pShowRef = do
+  pure do
+    sto <- asks _storage
+    void $ runMaybeT do
+
+      tx  <- withState do
+               selectMaxAppliedTx >>= lift  . toMPlus <&> fst
+
+      rh <- TX.readRepoHeadFromTx sto tx >>= toMPlus
+
+      liftIO $ print $ vcat (fmap formatRef (_repoHeadRefs rh))
+
+
+pKey :: GitPerks m => Parser (GitCLI m ())
+pKey = hsubparser (  command "show"   (info pKeyShow  (progDesc "show current key"))
+                  <> command "update" (info pKeyUpdate (progDesc "update current key"))
+                  )
+        <|> pKeyShow
+
+pKeyShow :: GitPerks m => Parser (GitCLI m ())
+pKeyShow = do
+  full <- flag False True (long "full" <> help "show full key info")
+  pure do
+    sto <- asks _storage
+    void $ runMaybeT do
+
+      tx  <- withState do
+               selectMaxAppliedTx >>= lift  . toMPlus <&> fst
+
+      rh <- TX.readRepoHeadFromTx sto tx
+               >>= toMPlus
+
+      gkh <- toMPlus (_repoHeadGK0 rh)
+
+      if not full then do
+        liftIO $ print $ pretty gkh
+      else do
+        gk <- runExceptT (readGK0 sto gkh) >>= toMPlus
+        liftIO $ print $ ";; group key" <+> pretty gkh <> line <> line <> pretty gk
+
+pKeyUpdate :: GitPerks m => Parser (GitCLI m ())
+pKeyUpdate = do
+  rlog <- argument pRefLogId (metavar "REFLOG-KEY")
+  fn <- strArgument (metavar "GROUP-KEY-FILE")
+  pure do
+    gk <- loadGK0FromFile  fn
+            `orDie` "can not load group key or invalid format"
+
+    sto <- asks _storage
+
+    gh <- writeAsMerkle sto (serialise gk) <&> HashRef
+
+    added <- withState $ runMaybeT do
+                (tx,_) <- lift selectMaxAppliedTx >>= toMPlus
+                lift do
+                  insertNewGK0 rlog tx gh
+                  commitAll
+                  pure gh
+
+    case added of
+      Nothing -> liftIO $ putStrLn "not added" >> exitFailure
+      Just x  -> liftIO $ print $ pretty x
+
+main :: IO ()
+main = do
+  (o, action) <- customExecParser (prefs showHelpOnError) $
+                      O.info (liftA2 (,) globalOptions commands <**> helper)
+                        ( fullDesc
+                           <> header "hbs2-git"
+                           <> progDesc "hbs2-git"
+                        )
+
+  runGitCLI o action
+
+

hbs21-git/git-remote-hbs21/Main.hs

@@ -0,0 +1,215 @@
+module Main where
+
+import Prelude hiding (getLine)
+
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Client.App
+import HBS2.Git.Client.Import
+import HBS2.Git.Client.Export
+import HBS2.Git.Client.State
+import HBS2.Git.Client.Progress
+import HBS2.Git.Client.Config
+import HBS2.Git.Data.RefLog
+import HBS2.Git.Data.Tx qualified as TX
+import HBS2.Git.Data.Tx (RepoHead(..))
+import HBS2.Git.Data.LWWBlock
+
+import HBS2.System.Dir
+
+import Control.Concurrent.STM qualified as STM
+import System.Posix.Signals
+import System.Environment
+import System.IO (hPutStrLn)
+import System.IO qualified as IO
+import System.Exit qualified as Exit
+
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Attoparsec.ByteString.Char8 hiding (try)
+import Data.Attoparsec.ByteString.Char8 qualified as Atto
+import Data.Maybe
+import Data.HashMap.Strict qualified as HM
+import Data.List qualified as L
+import Text.InterpolatedString.Perl6 (qc)
+import System.Exit hiding (die)
+
+{- HLINT ignore "Use isEOF" -}
+{- HLINT ignore "Use putStrLn" -}
+
+done :: MonadIO m => m Bool
+done = hIsEOF stdin
+
+getLine :: MonadIO m => m String
+getLine = liftIO IO.getLine
+
+sendLine :: MonadIO m => String -> m ()
+sendLine = liftIO . IO.putStrLn
+
+die :: (MonadIO m, Pretty a) => a -> m b
+die s = liftIO $ Exit.die (show $ pretty s)
+
+parseURL :: String -> Maybe (LWWRefKey HBS2Basic)
+parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
+  where
+    p = do
+      void $ string "hbs21://" <|> string "hbs2://"
+
+      Atto.takeWhile1 (`elem` getAlphabet)
+       <&> BS8.unpack
+       <&> fromStringMay @(LWWRefKey HBS2Basic)
+       >>= maybe (fail "invalid reflog key") pure
+
+parsePush :: String -> Maybe (Maybe GitRef, GitRef)
+parsePush s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s)
+  where
+    gitref = fromString @GitRef . BS8.unpack
+    p = do
+      a <- optional (Atto.takeWhile1 (/= ':')) <&> fmap gitref
+      char ':'
+      b <- Atto.takeWhile1 (const True) <&> gitref
+      pure (a,b)
+
+data S =
+    Plain
+  | Push
+  deriving stock (Eq,Ord,Show,Enum)
+
+
+{- HLINT ignore "Functor law" -}
+main :: IO ()
+main = do
+  hSetBuffering stdin  LineBuffering
+  hSetBuffering stdout LineBuffering
+
+  void $ installHandler sigPIPE Ignore Nothing
+
+  args <- getArgs
+
+  (remote, puk) <- case args of
+                     [s, u] ->
+                        (s,) <$> pure (parseURL u)
+                                  `orDie` show ("invalid reflog" <+> pretty u)
+
+                     _ -> die "bad args"
+
+  runGitCLI mempty $ do
+
+    env <- ask
+
+    flip runContT pure do
+
+      lift $ withGitEnv (env & set gitApplyHeads False) do
+
+        debug $ red "run" <+> pretty args
+
+        sto <- asks _storage
+        ip <- asks _progress
+
+        importRepoWait puk
+          `catch` (\(_ :: ImportRefLogNotFound) -> do
+                      onProgress ip ImportAllDone
+                      let url = headMay (catMaybes [ parseURL a | a <- args]) <&> AsBase58
+                      pause @'Seconds 0.25
+                      liftIO $ hFlush stderr
+                      liftIO $ hPutDoc stderr $ ""
+                                  <> ul (yellow "Reference" <+> pretty url <+>  yellow "is not available yet.") <> line
+                                  <> "If you sure it's a new one -- make sure you've added the key to hbs2-keyman and then run"
+                                  <> line <> line
+                                  <> "hbs2-keyman update" <> line <> line
+                                  <> "git" <+> pretty hbs2Name <+> "export --new" <+> pretty url <> line <> line
+                                  <> "to init the reflog first." <> line
+                                  <> "Pushing to an existing reflog as a new one may cause unwanted data duplication." <> line
+                                  <> line
+                                  <> "Note: what ever pushed -- can not be unpushed" <> line
+                                  <> "If it's not a new reflog --- just wait until it became available"
+                      liftIO exitFailure
+                  )
+          `catch` ( \(ImportTxApplyError h) -> do
+                      onProgress ip ImportAllDone
+                      pause @'Seconds 0.25
+                      liftIO $ hFlush stderr
+                      liftIO $ hPutDoc stderr $ red "Can not apply tx" <+>  pretty h <> line <> line
+                                      <> "It means you don't have a key do decrypt this tx or the data is not completely downloaded yet"
+                                      <> line
+
+                      liftIO exitFailure
+                  )
+
+        void $ runExceptT do
+
+            tpush <- newTQueueIO -- @(GitRef, Maybe GitHash)
+
+            flip fix Plain $ \next s -> do
+
+              eof <- done
+
+              when eof $ pure ()
+
+              cmd <- ExceptT (try @_ @IOError (getLine <&> words))
+
+              debug $ "C:" <+> pretty cmd
+
+              case cmd of
+
+                [] | s == Plain -> do
+                  onProgress ip (ImportSetQuiet True)
+                  pure ()
+
+                [] | s == Push -> do
+                       refs <- atomically (STM.flushTQueue tpush)
+                                 <&> HM.toList . HM.fromList
+
+                       importRepoWait puk
+                       export puk refs
+                       sendLine ""
+                       next Plain
+
+                ["capabilities"] -> do
+                  debug $ "send capabilities"
+                  sendLine "push"
+                  sendLine "fetch"
+                  sendLine ""
+                  next Plain
+
+                ("list" : _) -> do
+
+
+                    r'  <- runMaybeT $ withState do
+                            tx <- selectMaxAppliedTx >>= lift  . toMPlus <&> fst
+
+                            rh <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus
+                            pure (_repoHeadRefs rh)
+
+                    let r = fromMaybe mempty r'
+
+                    forM_ (fmap (show . formatRef) r) sendLine
+
+                    sendLine ""
+
+                    next Plain
+
+                ("push" : pargs : _ ) -> do
+                  (fromRef, toRef) <- orThrowUser "can't parse push" (parsePush pargs)
+
+                  r <- readProcess (setStderr closed $ shell [qc|git rev-parse {pretty $ fromRef}|])
+                        <&> headDef "" . LBS8.words . view _2
+                        <&> fromStringMay @GitHash . LBS8.unpack
+
+                  let val = const r =<< fromRef
+
+                  atomically $ writeTQueue tpush (toRef, val)
+
+                  sendLine [qc|ok {pretty toRef}|]
+                  next Push
+
+                _ -> next Plain
+
+              pure ()
+
+  `finally` liftIO do
+    hPutStrLn stdout "" >> hFlush stdout
+    -- notice $ red "BYE"
+    hPutStrLn stderr ""
+
+
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs

@@ -0,0 +1,203 @@
+module HBS2.Git.Client.App
+  ( module HBS2.Git.Client.App
+  , module HBS2.Git.Client.App.Types
+  ) where
+
+import HBS2.Git.Client.Prelude hiding (info)
+import HBS2.Git.Client.App.Types
+import HBS2.Git.Client.Config
+import HBS2.Git.Client.Progress
+import HBS2.Git.Client.State
+
+import HBS2.Git.Data.Tx
+
+import HBS2.Git.Local.CLI
+
+import HBS2.System.Dir
+
+import Data.Maybe
+import System.Environment
+import System.IO (hPutStr)
+import Data.Vector qualified as V
+import Data.Vector ((!))
+
+drawProgress :: MonadUnliftIO m => ProgressQ -> m ()
+drawProgress (ProgressQ q) = do
+
+  let spin = V.fromList ["--","\\","|","/"]
+  let l = V.length spin
+  i <- newTVarIO 0
+
+  tl <- newTVarIO =<< getTimeCoarse
+
+  let updateSpinner = do
+        atomically  $ modifyTVar i succ
+
+  let getSpinner = do
+        j <- readTVarIO i <&> (`mod` l)
+        pure $ spin ! j
+
+  let
+    limit :: MonadIO m => Timeout 'Seconds -> m () -> m ()
+    limit dt m = do
+       t0  <- readTVarIO tl
+       now <- getTimeCoarse
+       when (expired dt (now - t0)) do
+        atomically $ writeTVar tl now
+        m
+
+  let loop = do
+        flip fix False \next quiet -> do
+
+          let put s | quiet = pure ()
+                    | otherwise = putStatus s
+
+          ev <- atomically $ readTQueue q
+
+          case ev of
+            ImportIdle -> do
+              next quiet
+
+            ImportSetQuiet qq -> do
+              put ""
+              next qq
+
+            ImportWaitLWW n lww -> do
+              limit 0.25 $ put ("wait lwwref" <+> pretty lww <+> pretty n)
+              next quiet
+
+            ImportRefLogStart puk -> do
+              put ("wait reflog" <+> pretty (AsBase58 puk))
+              next quiet
+
+            ImportRefLogDone puk Nothing -> do
+              updateSpinner
+              c <- getSpinner
+              put ("wait reflog" <+> pretty (AsBase58 puk) <+> pretty c)
+              next quiet
+
+            ImportRefLogDone _ (Just h) -> do
+              put ("reflog value" <+> pretty h)
+              next quiet
+
+            ImportWaitTx h -> do
+              updateSpinner
+              c <- getSpinner
+              put ("wait tx data" <+> pretty h <+> pretty c)
+              next quiet
+
+            ImportScanTx h -> do
+              put ("scan tx" <+> pretty h)
+              next quiet
+
+            ImportApplyTx h -> do
+              put ("apply tx" <+> pretty h)
+              next quiet
+
+            ImportApplyTxError h s -> do
+              limit 0.25 $ put $ red ("failed" <+> pretty s) <+> pretty h
+              next quiet
+
+            ImportReadBundleChunk meta (Progress s _) -> do
+              let h = bundleHash meta
+              let e = if bundleEncrypted meta then yellow "@" else ""
+              limit 0.5 $ put $ "read pack" <+> e <> pretty h <+> pretty s
+              next quiet
+
+            ExportWriteObject (Progress s _) -> do
+              limit 0.5 $ put $ "write object" <+> pretty s
+              next quiet
+
+            ImportAllDone -> do
+              put "\n"
+
+  loop
+    `finally` do
+      putStatus ""
+
+  where
+    putStatus :: MonadUnliftIO m => Doc AnsiStyle -> m ()
+    putStatus s = do
+      liftIO $ hPutStr stderr $ toStringANSI $ "\r" <> fill 80 "" <> "\r" <> pretty (take 74 (toStringANSI s))
+      liftIO $ hFlush stderr
+
+runGitCLI :: (GitPerks m) => [GitOption] -> GitCLI m a -> m a
+runGitCLI o m = do
+
+  soname <- runExceptT getSocketName
+              >>= orThrowUser "no rpc socket"
+
+  flip runContT pure do
+
+    client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
+                >>= orThrowUser ("can't connect to" <+> pretty soname)
+
+    void $ ContT $ withAsync $ runMessagingUnix client
+
+    peerAPI    <- makeServiceCaller @PeerAPI (fromString soname)
+    refLogAPI  <- makeServiceCaller @RefLogAPI (fromString soname)
+    storageAPI <- makeServiceCaller @StorageAPI (fromString soname)
+    lwwAPI     <- makeServiceCaller @LWWRefAPI (fromString soname)
+
+    let endpoints = [ Endpoint @UNIX  peerAPI
+                    , Endpoint @UNIX  refLogAPI
+                    , Endpoint @UNIX  lwwAPI
+                    , Endpoint @UNIX  storageAPI
+                    ]
+
+    void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
+
+    conf <- lift $ readConfig True
+
+    git <- gitDir
+              >>= orThrowUser "git dir not set"
+              >>= canonicalizePath
+
+    q <- lift newProgressQ
+    let ip = AnyProgress q
+
+    cpath <- lift getConfigDir
+
+    progress <- ContT $ withAsync (drawProgress q)
+
+    env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI lwwAPI storageAPI
+    lift $ runReaderT setupLogging env
+    lift $ withGitEnv env (evolveDB >> m)
+      `finally` do
+        onProgress ip ImportAllDone
+        cancel progress
+        shutDownLogging
+
+runDefault :: GitPerks m => GitCLI m ()
+runDefault = do
+  pure ()
+
+setupLogging :: (GitPerks m, HasGitOpts m) => m ()
+setupLogging = do
+
+  traceEnv <- liftIO $ lookupEnv "HBS2TRACE" <&> isJust
+
+  setLogging @INFO   defLog
+  setLogging @ERROR  (logPrefix "" . toStderr)
+  setLogging @WARN   (logPrefix "" . toStderr)
+  setLogging @NOTICE (logPrefix "" . toStderr)
+
+  dbg <- debugEnabled
+
+  when (dbg || traceEnv) do
+    setLogging @DEBUG  (logPrefix "" . toStderr)
+
+  trc <- traceEnabled
+
+  when (trc || traceEnv) do
+    setLogging @TRACE  (logPrefix "" . toStderr)
+
+shutDownLogging :: MonadUnliftIO m => m ()
+shutDownLogging  = do
+  setLoggingOff @INFO
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+  setLoggingOff @DEBUG
+  setLoggingOff @TRACE
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs

@@ -0,0 +1,168 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language UndecidableInstances #-}
+module HBS2.Git.Client.App.Types
+  ( module HBS2.Git.Client.App.Types
+  , module HBS2.Git.Client.App.Types.GitEnv
+  , module HBS2.Git.Local
+  , module Data.Config.Suckless
+  , module Control.Monad.Catch
+  ) where
+
+import HBS2.Git.Client.Prelude hiding (info)
+import HBS2.Git.Client.Progress
+import HBS2.Git.Local
+import HBS2.Git.Client.App.Types.GitEnv
+
+import HBS2.Git.Data.Tx
+import HBS2.Git.Data.GK
+
+import HBS2.KeyMan.Keys.Direct
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Storage.Operations.ByteString
+import HBS2.System.Dir
+
+import Data.Config.Suckless
+import Control.Monad.Catch (MonadThrow(..))
+import DBPipe.SQLite
+import Data.HashMap.Strict qualified as HM
+import Data.Maybe
+import Data.Word
+
+type Epoch = Word64
+
+data GitOption = GitTrace
+               | GitDebug
+               | GitExport ExportType
+               | GitEnc ExportEncryption
+               | GitDontApplyHeads
+               deriving stock (Eq,Ord)
+
+
+
+newtype GitCLI m a = GitCLI { fromGitCLI :: ReaderT GitEnv m a }
+                     deriving newtype ( Applicative
+                                      , Functor
+                                      , Monad
+                                      , MonadIO
+                                      , MonadUnliftIO
+                                      , MonadTrans
+                                      , MonadReader GitEnv
+                                      , MonadThrow
+                                      )
+
+-- type GitPerks m = ( MonadUnliftIO m, MonadThrow m )
+type GitPerks m = ( MonadUnliftIO m )
+
+instance Monad m => HasProgressIndicator (GitCLI m) where
+  getProgressIndicator = asks _progress
+
+instance Monad m => HasStorage (GitCLI m) where
+  getStorage = asks _storage
+
+instance Monad m => HasAPI PeerAPI UNIX (GitCLI m) where
+  getAPI = asks _peerAPI
+
+instance Monad m => HasAPI LWWRefAPI UNIX (GitCLI m) where
+  getAPI = asks _lwwRefAPI
+
+instance Monad m => HasAPI RefLogAPI UNIX (GitCLI m) where
+  getAPI = asks _refLogAPI
+
+instance MonadReader GitEnv m => HasAPI RefLogAPI UNIX (ExceptT e m) where
+  getAPI = asks _refLogAPI
+
+instance MonadReader GitEnv m => HasAPI LWWRefAPI UNIX (ExceptT e m) where
+  getAPI = asks _lwwRefAPI
+
+instance MonadReader GitEnv m => HasAPI PeerAPI UNIX (ExceptT e m) where
+  getAPI = asks _peerAPI
+
+newGitEnv :: GitPerks m
+          => AnyProgress
+          -> [GitOption]
+          -> FilePath
+          -> FilePath
+          -> Config
+          -> ServiceCaller PeerAPI UNIX
+          -> ServiceCaller RefLogAPI UNIX
+          -> ServiceCaller LWWRefAPI UNIX
+          -> ServiceCaller StorageAPI UNIX
+          -> m GitEnv
+
+newGitEnv p opts path cpath conf peer reflog lww sto = do
+  let dbfile  = cpath </> "state.db"
+  let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) }
+  db <- newDBPipeEnv dOpt dbfile
+  cache <- newTVarIO mempty
+  pure $ GitEnv
+           traceOpt
+           debugOpt
+           applyHeadsOpt
+           exportType
+           exportEnc
+           path
+           cpath
+           conf
+           peer
+           reflog
+           lww
+           (AnyStorage (StorageClient sto))
+           db
+           p
+           cache
+  where
+    traceOpt = GitTrace `elem` opts
+    debugOpt = GitDebug `elem` opts
+    applyHeadsOpt = GitDontApplyHeads `notElem` opts
+    -- FIXME: from-options
+    exportType = lastDef ExportInc [ t | GitExport t <- opts ]
+    exportEnc  = lastDef ExportPublic [ t | GitEnc t <- opts ]
+
+withGitEnv :: GitPerks m => GitEnv -> GitCLI m a ->  m a
+withGitEnv env m = runReaderT (fromGitCLI m) env
+
+instance (GitPerks m, MonadReader GitEnv m) => GroupKeyOperations m where
+
+  -- FIXME: may-be-faster
+  loadKeyrings gkh = do
+
+    sto <- asks _storage
+    cache <- asks _keyringCache
+
+    let k = gkh
+
+    ke <- readTVarIO cache <&> HM.lookup k
+
+    case ke of
+      Just es -> pure es
+      Nothing -> do
+
+        rcpt <- fromMaybe mempty <$> runMaybeT do
+                  runExceptT (readGK0 sto gkh)
+                      >>= toMPlus
+                      <&> HM.keys . recipients
+
+        es <- runKeymanClient $ do
+          loadKeyRingEntries rcpt
+            <&> fmap snd
+
+        atomically $ modifyTVar cache (HM.insert k es)
+        pure es
+
+  openGroupKey gk = runMaybeT do
+    ke' <- lift $ runKeymanClient do
+            loadKeyRingEntries (HM.keys $ recipients gk)
+             <&> headMay
+
+    (_, KeyringEntry{..}) <- toMPlus ke'
+
+    toMPlus $ lookupGroupKey _krSk _krPk gk
+
+class HasGitOpts m where
+  debugEnabled :: m Bool
+  traceEnabled :: m Bool
+
+instance MonadReader GitEnv m => HasGitOpts m where
+  debugEnabled = asks _gitDebugEnabled
+  traceEnabled = asks _gitTraceEnabled
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs

@@ -0,0 +1,53 @@
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+module HBS2.Git.Client.App.Types.GitEnv where
+
+import HBS2.Git.Client.Prelude hiding (info)
+
+import HBS2.Git.Client.Progress
+
+import HBS2.Net.Auth.GroupKeySymm
+
+import Data.Config.Suckless
+import DBPipe.SQLite
+import Data.HashMap.Strict (HashMap)
+
+data ExportType = ExportNew
+                | ExportFork HashRef
+                | ExportInc
+                  deriving stock (Eq,Ord,Generic,Show)
+
+data ExportEncryption =
+    ExportPublic
+  | ExportPrivate FilePath
+  deriving stock (Eq,Ord,Generic,Show)
+
+type Config = [Syntax C]
+
+class Monad m => HasProgressIndicator m where
+  getProgressIndicator :: m AnyProgress
+
+class HasAPI api proto m where
+  getAPI :: m (ServiceCaller api proto)
+
+data GitEnv =
+  GitEnv
+  { _gitTraceEnabled :: Bool
+  , _gitDebugEnabled :: Bool
+  , _gitApplyHeads   :: Bool
+  , _gitExportType   :: ExportType
+  , _gitExportEnc    :: ExportEncryption
+  , _gitPath         :: FilePath
+  , _configPath      :: FilePath
+  , _config          :: Config
+  , _peerAPI         :: ServiceCaller PeerAPI UNIX
+  , _refLogAPI       :: ServiceCaller RefLogAPI UNIX
+  , _lwwRefAPI       :: ServiceCaller LWWRefAPI UNIX
+  , _storage         :: AnyStorage -- ServiceCaller StorageAPI UNIX
+  , _db              :: DBPipeEnv
+  , _progress        :: AnyProgress
+  , _keyringCache    :: TVar (HashMap HashRef [KeyringEntry HBS2Basic])
+  }
+
+
+makeLenses 'GitEnv

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs

@@ -0,0 +1,89 @@
+module HBS2.Git.Client.Config (getConfigDir, readConfig, getManifest, hbs2Name) where
+
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Client.App.Types
+
+import HBS2.System.Dir
+import HBS2.Git.Local.CLI
+
+import Data.List qualified as L
+import Data.Text qualified as Text
+import Data.Either
+import Text.InterpolatedString.Perl6 (qc)
+
+
+data ConfigDirNotFound = ConfigDirNotFound
+                         deriving stock (Show,Typeable,Generic)
+
+instance HasErrorStatus ConfigDirNotFound where
+  getStatus = const Failed
+
+instance Exception ConfigDirNotFound
+
+hbs2Name :: String
+hbs2Name = "hbs21"
+
+getConfigDir :: GitPerks m => m FilePath
+getConfigDir = do
+  git <- gitDir >>= orThrow ConfigDirNotFound
+
+  let p = splitDirectories git & reverse
+
+  if headMay p == Just ".git" then
+    pure $ joinPath $ reverse (".hbs2-git" : drop 1 p)
+  else do
+    pure $ git </> ".hbs2-git"
+
+getManifest :: GitPerks m => m (Text, Text, Maybe Text)
+getManifest = do
+  dir <- getConfigDir
+  let mf = dir </> "manifest"
+
+  let defname = takeFileName (takeDirectory dir) & Text.pack
+  let defbrief = "n/a"
+
+  content <- liftIO (try @_ @IOException $ readFile mf)
+               <&> fromRight ""
+
+  let txt = if L.null content then Nothing else Just (Text.pack content)
+
+  -- FIXME: size-hardcode
+  let header  = lines (take 1024 content)
+                   & takeWhile ( not . L.null )
+                   & unlines
+                   & parseTop
+                   & fromRight mempty
+
+  let name = lastDef defname [ n | ListVal [ SymbolVal "name:", LitStrVal n ] <- header ]
+  let brief = lastDef defbrief [ n | ListVal [ SymbolVal "brief:", LitStrVal n ] <- header ]
+
+  pure (name,brief,txt)
+
+readConfig :: (GitPerks m) => Bool -> m Config
+readConfig canTouch = do
+{- HLINT ignore "Functor law" -}
+  confPath <- getConfigDir
+  let confRoot = confPath </> "config"
+
+  when canTouch do
+
+    here <- doesPathExist confRoot
+
+    unless here do
+      mkdir confPath
+      liftIO $ writeFile confRoot defConf
+
+  try @_ @SomeException (liftIO (readFile confRoot))
+    <&> fromRight mempty
+    <&> parseTop
+    <&> fromRight mempty
+
+
+defConf :: String
+defConf = [qc|;; hbs2-git config file
+; those branches will be replicated by default
+export include "refs/heads/master"
+export include "refs/heads/main"
+export exclude "refs/heads/*"
+export tags
+|]

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs

@@ -0,0 +1,342 @@
+module HBS2.Git.Client.Export (export) where
+
+
+import HBS2.Git.Client.Prelude hiding (info)
+import HBS2.Git.Client.App.Types
+import HBS2.Git.Client.Config
+import HBS2.Git.Client.RefLog
+import HBS2.Git.Client.State
+import HBS2.Git.Client.Progress
+
+import HBS2.Git.Data.RefLog
+import HBS2.Git.Data.Tx
+import HBS2.Git.Data.LWWBlock
+import HBS2.Git.Data.GK
+
+import HBS2.Git.Local.CLI
+
+import HBS2.KeyMan.Keys.Direct
+
+import HBS2.OrDie
+import HBS2.Storage.Operations.ByteString
+import HBS2.System.Dir
+
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Text qualified as Text
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Builder as B
+import Data.HashSet qualified as HashSet
+import Data.HashMap.Strict qualified as HashMap
+import Data.Maybe
+import Data.List qualified as L
+import Data.Ord (comparing)
+import Data.Either
+
+data ExportError = ExportUnsupportedOperation
+                 | ExportBundleCreateError
+                   deriving stock (Show,Typeable)
+
+instance Exception ExportError
+
+instance HasErrorStatus ExportError where
+  getStatus = \case
+    ExportUnsupportedOperation -> Failed
+    ExportBundleCreateError -> Failed
+
+instance ToFilePath (GitRef, GitHash) where
+  toFilePath (g, r) = show (pretty g)
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
+filterPat :: ToFilePath a =>  [FilePattern] -> [FilePattern] -> [a] -> [a]
+filterPat inc excl refs = filter check refs
+  where
+    check r = i || not e
+     where
+       e = not $ L.null $ catMaybes [ match p (toFilePath r) | p <- excl ]
+       i = not $ L.null $ catMaybes [ match p (toFilePath r) | p <- inc  ]
+
+refsForExport :: (MonadReader GitEnv m, MonadIO m) => [(GitRef, Maybe GitHash)] -> m [(GitRef,GitHash)]
+
+refsForExport forPushL = do
+{- HLINT ignore "Functor law" -}
+
+  conf <- asks _config
+  path <- asks _gitPath
+
+  let tags = headDef mempty [ "--tags" :: String | (ListVal [SymbolVal "export", SymbolVal "tags"] ) <- conf]
+
+  let incl = [ Text.unpack p
+             | (ListVal [SymbolVal "export", SymbolVal "include", LitStrVal p]) <- conf
+             ]
+
+  let excl = [ Text.unpack p
+             | (ListVal [SymbolVal "export", SymbolVal "exclude", LitStrVal p]) <- conf
+             ]
+
+  let forPush = [ (k,v) | (k, Just v) <- forPushL ] & HashMap.fromList
+
+  let deleted = [ k | (k, Nothing) <- forPushL ] & HashSet.fromList
+
+  debug $ red "CONF" <> pretty path <> line <> indent 2 (vcat (fmap pretty conf))
+
+  let cmd = [qc|git --git-dir={path} show-ref {tags} --heads --head|]
+
+  debug $ red "CMD" <+> pretty cmd
+  debug $ "FILTERS" <+> pretty (incl, excl)
+  debug $ red "DELETED" <+> pretty (HashSet.toList deleted)
+  debug $ red "FOR-PUSH" <+> pretty (HashMap.toList forPush)
+
+  -- мы экспортируем всегда HEAD что бы правильно работал git clone
+  -- поэтому мы экспортируем и текущий бранч тоже
+  -- даже если он запрещён фильтрами
+
+  currentBranch <- gitRunCommand [qc|git --git-dir={path} symbolic-ref HEAD|]
+                     >>= orThrowUser "can't read HEAD 1"
+                     <&> GitRef . BS8.strip . LBS8.toStrict
+
+  currentVal <- gitRunCommand [qc|git --git-dir={path} rev-parse {pretty currentBranch}|]
+                  >>= orThrowUser "can't read HEAD 2"
+                  <&> (BS8.unpack . BS8.strip . LBS8.toStrict)
+                  <&> fromStringMay @GitHash
+                  >>= orThrowUser "invalid git hash for HEAD"
+
+  gitRunCommand cmd
+    >>= orThrowUser ("can't read git repo" <+> pretty path)
+    <&> LBS8.lines
+    <&> fmap LBS8.words
+    <&> mapMaybe \case
+         [val,name] -> (GitRef (LBS8.toStrict name),) <$> fromStringMay @GitHash (LBS8.unpack val)
+         _          -> Nothing
+    <&> filterPat incl excl
+    <&> HashMap.fromList
+    <&> HashMap.filterWithKey (\k _ -> not (HashSet.member k deleted))
+    <&> mappend forPush
+    <&> mappend (HashMap.singleton currentBranch currentVal)
+    <&> HashMap.toList
+    <&> L.sortBy orderRefs
+
+  where
+    orderRefs (GitRef "HEAD", _) _ = LT
+    orderRefs _ (GitRef "HEAD", _) = GT
+    orderRefs x y = comparing fst x y
+
+loadNewGK0 :: (MonadIO m, MonadReader GitEnv m)
+           => RefLogId
+           -> Maybe HashRef
+           -> m (Maybe (HashRef,Epoch))
+
+loadNewGK0 r = \case
+  Nothing -> storeNewGK0
+
+  Just tx0 -> do
+    href <- storeNewGK0
+    withState do
+      for_ href (insertNewGK0 r tx0 . fst)
+      commitAll
+
+    withState $ selectNewGK0 r
+
+storeNewGK0 :: (MonadIO m, MonadReader GitEnv m) => m (Maybe (HashRef,Epoch))
+storeNewGK0 = do
+  sto <- asks _storage
+  enc <- asks _gitExportEnc
+  runMaybeT do
+    gkf <- headMay [ f | ExportPrivate f <- [enc] ] & toMPlus
+    gk <- loadGK0FromFile gkf >>= toMPlus
+    epoch <- getEpoch
+    writeAsMerkle sto (serialise gk) <&> HashRef <&> (,epoch)
+
+export :: ( GitPerks m
+          , MonadReader GitEnv m
+          , GroupKeyOperations m
+          , HasAPI PeerAPI UNIX m
+          )
+       => LWWRefKey HBS2Basic
+       -> [(GitRef,Maybe GitHash)]
+       -> m ()
+export key refs  = do
+
+  git <- asks _gitPath
+  sto <- asks _storage
+  new <- asks _gitExportType <&> (== ExportNew)
+  reflog <- asks _refLogAPI
+  ip <- asks _progress
+
+  subscribeLWWRef key
+
+  (lww, LWWBlockData{..}) <- waitOrInitLWWRef
+
+  let puk0 = fromLwwRefKey key
+
+  debug $ red $ pretty $ AsBase58 lwwRefLogPubKey
+
+  (sk0,pk0) <- liftIO $ runKeymanClient do
+                creds <- loadCredentials puk0
+                             >>= orThrowUser ("can't load credentials" <+> pretty (AsBase58 puk0))
+                pure ( view peerSignSk  creds, view peerSignPk creds )
+
+  (puk,sk) <- derivedKey @HBS2Basic @'Sign lwwRefSeed sk0
+
+  subscribeRefLog puk
+
+  myrefs <- refsForExport refs
+
+  let myrefsKey = L.sortOn fst myrefs & serialise & hashObject @HbSync & HashRef
+
+  flip runContT pure do
+    callCC \exit -> do
+
+
+      tx0 <- getLastAppliedTx
+
+      rh0 <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus )
+
+      (name,brief,mf) <- lift getManifest
+
+      gk0new0 <- loadNewGK0 puk tx0
+
+      let gk0old = _repoHeadGK0 =<< rh0
+
+      mbTxTime0 <- runMaybeT $ toMPlus tx0
+                                >>= withState .selectTxForRefLog puk
+                                >>= toMPlus
+
+      -- смотрим, какое время ключа для данного рефлога, т.к. голова-то
+      -- может быть одна, а вот рефлоги -- разные
+      -- если мы успели --- то накатываем свой ключ.
+      -- если нет -- придется повторить
+      let gk0new = if (snd <$> gk0new0) > (snd <$> mbTxTime0) then
+                     fst <$> gk0new0
+                   else
+                     gk0old
+
+      let gk0 = gk0new <|> gk0old
+
+      repohead <- makeRepoHeadSimple name brief mf gk0 myrefs
+
+      let oldRefs = maybe mempty _repoHeadRefs rh0
+
+      trace $ "TX0" <+> pretty  tx0
+
+      bss <- maybe (pure mempty) txBundles tx0
+
+      objs <- lift enumAllGitObjects
+                >>= withState . filterM (notInTx tx0)
+
+      when (null objs && not new && oldRefs == myrefs) do
+        exit ()
+
+      debug $ red "REFS-FOR-EXPORT:" <+> pretty myrefs
+
+      done <- withState (selectBundleByKey puk myrefsKey)
+
+      out <-
+        if isJust done && not new then do
+          pure []
+
+        else do
+
+          p <- ContT $ withGitPack
+
+          for_ (zip [1..] objs) $ \(n,o) -> do
+            onProgress ip (ExportWriteObject (Progress n Nothing))
+            liftIO $ LBS8.hPutStrLn (getStdin p) (LBS8.pack $ show $ pretty o)
+
+          code <- hFlush (getStdin p) >> hClose (getStdin p) >> getExitCode p
+
+          let idx = serialise objs
+          let size = B.word32BE (fromIntegral $ LBS.length idx)
+          let hdr  = B.word32BE 1
+          pack <- liftIO $ LBS.hGetContents (getStdout p)
+          let out = B.toLazyByteString ( size <> hdr <> B.lazyByteString idx <> B.lazyByteString pack )
+          pure [out]
+
+      rank <- getEpoch <&> fromIntegral
+
+      let rw = gk0new /= gk0old
+
+      debug $ red "MAKE TX" <+> pretty rw <+> pretty gk0old <+> "->" <+> pretty gk0new
+
+      tx <- lift $ makeTx sto rw rank puk (const $ pure (Just sk)) repohead bss out
+
+      r <- lift $ race (pause @'Seconds 1) (callService @RpcRefLogPost reflog tx)
+             >>= orThrowUser "hbs2-peer rpc timeout"
+
+      when (isLeft r) $ exit ()
+
+      void $ runMaybeT do
+        (_,_,bh) <- unpackTx tx
+        withState (insertBundleKey puk myrefsKey bh)
+
+  where
+
+    findSK pk = liftIO $ runKeymanClient $ runMaybeT do
+        creds  <- lift (loadCredentials pk) >>= toMPlus
+        pure (view peerSignSk creds)
+
+    waitOrInitLWWRef  = do
+      sto <- asks _storage
+      new <- asks _gitExportType <&> (== ExportNew)
+
+      flip fix 3 $ \next n -> do
+               blk <- readLWWBlock sto key
+
+               case blk of
+                Just x -> pure x
+
+                Nothing | new && n > 0 -> do
+                  _ <- runExceptT (initLWWRef sto Nothing findSK key)
+                        >>= either ( throwIO . userError . show ) pure
+
+                  next (pred n)
+
+                        | otherwise -> do
+                  -- FIXME: detailed-error-description
+                  orThrowUser "lwwref not available" Nothing
+
+
+    notInTx Nothing _ = pure True
+    notInTx (Just tx0) obj = not <$> isObjectInTx tx0 obj
+
+    getLastAppliedTx = runMaybeT do
+      (tx0,_) <- withState selectMaxAppliedTx
+                    >>= toMPlus
+      pure tx0
+
+    txBundles tx0 = withDef =<< runMaybeT do
+
+      new <- asks _gitExportType <&> (== ExportNew)
+      sto <- asks _storage
+
+      txbody  <- runExceptT (readTx sto tx0)
+                   >>= orThrowUser ("missed blocks for tx" <+> pretty tx0)
+
+      let bref = view _4 txbody
+
+      readBundleRefs sto bref
+        >>= orThrowUser ("missed blocks for tx" <+> pretty tx0)
+
+      where
+        withDef Nothing = pure mempty
+        withDef (Just x) = pure x
+
+enumAllGitObjects :: (GitPerks m, MonadReader GitEnv m) => m [GitHash]
+enumAllGitObjects = do
+  path <- asks _gitPath
+  let rcmd = [qc|git --git-dir {path} cat-file --batch-check='%(objectname)'  --batch-all-objects|]
+  (_, out, _) <- liftIO $ readProcess (shell rcmd)
+  pure $ LBS8.lines out & mapMaybe (fromStringMay @GitHash . LBS8.unpack)
+
+
+withGitPack ::  (GitPerks m, MonadReader GitEnv m) => (Process Handle Handle () -> m a) -> m a
+withGitPack action = do
+  fp <- asks _gitPath
+  let cmd = "git"
+  let args = ["--git-dir", fp, "pack-objects", "--stdout", "-q"]
+  let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
+  p <- startProcess config
+  action p
+
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs

@@ -0,0 +1,394 @@
+module HBS2.Git.Client.Import where
+
+import HBS2.Git.Client.Prelude hiding (info)
+import HBS2.Git.Client.App.Types
+import HBS2.Git.Client.State
+import HBS2.Git.Client.RefLog
+import HBS2.Git.Client.Progress
+
+import HBS2.Git.Data.RefLog
+import HBS2.Git.Data.Tx
+import HBS2.Git.Data.LWWBlock
+
+import Data.ByteString.Lazy qualified as LBS
+
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Text.InterpolatedString.Perl6 (qc)
+import Streaming.Prelude qualified as S
+import System.IO (hPrint)
+import Data.Maybe
+
+data ImportRefLogNotFound = ImportRefLogNotFound
+                            deriving stock (Typeable,Show)
+
+instance Exception ImportRefLogNotFound
+
+
+data ImportTxApplyError = ImportTxApplyError HashRef
+                          deriving stock (Typeable,Show)
+
+
+instance Exception ImportTxApplyError
+
+
+data ImportTxError =
+    ImportTxReadError HashRef
+  | ImportOpError OperationError
+  | ImportUnbundleError HashRef
+  | ImportMissed HashRef
+  deriving stock (Typeable)
+
+instance Show ImportTxError where
+  show (ImportTxReadError h) = [qc|ImportTxError {pretty h}|]
+  show (ImportOpError o) = show o
+  show (ImportUnbundleError h) = [qc|ImportUnbundleError {pretty h}|]
+  show (ImportMissed h) = [qc|ImportMissed {pretty h}|]
+
+instance Exception ImportTxError
+
+data IState =
+    IWaitLWWBlock Int
+  | IWaitRefLog Int RefLogId
+  | IScanRefLog RefLogId HashRef
+  | IApplyTx HashRef
+  | IExit
+
+
+-- class
+
+merelySubscribeRepo :: forall e s m . ( GitPerks m
+                                      , HasStorage m
+                                      , HasProgressIndicator m
+                                      , HasAPI PeerAPI UNIX m
+                                      , HasAPI LWWRefAPI UNIX m
+                                      , HasAPI RefLogAPI UNIX m
+                                      , e ~ L4Proto
+                                      , s ~ Encryption e
+                                      )
+                    => LWWRefKey HBS2Basic
+                    -> m (Maybe (PubKey 'Sign s))
+merelySubscribeRepo lwwKey = do
+
+  ip  <- getProgressIndicator
+  sto <- getStorage
+
+  subscribeLWWRef lwwKey
+  fetchLWWRef lwwKey
+
+  r <- flip fix (IWaitLWWBlock 10) $ \next -> \case
+
+    IWaitLWWBlock w | w <= 0 -> do
+      throwIO ImportRefLogNotFound
+
+    IWaitLWWBlock w -> do
+      onProgress ip (ImportWaitLWW w lwwKey)
+      lww <- readLWWBlock sto lwwKey
+
+      case lww of
+        Nothing -> do
+          pause @'Seconds 2
+          fetchLWWRef lwwKey
+          next (IWaitLWWBlock (pred w))
+
+        Just (_, LWWBlockData{..}) -> do
+          void $ try @_ @SomeException (getRefLogMerkle lwwRefLogPubKey)
+          subscribeRefLog lwwRefLogPubKey
+          pause @'Seconds 0.25
+          pure $ Just lwwRefLogPubKey
+
+    _ -> pure Nothing
+
+  onProgress ip ImportAllDone
+  pure r
+
+importRepoWait :: ( GitPerks m
+                  , MonadReader GitEnv m
+                  , HasAPI PeerAPI UNIX m
+                  , HasAPI LWWRefAPI UNIX m
+                  , HasAPI RefLogAPI UNIX m
+                  )
+               => LWWRefKey HBS2Basic
+               -> m ()
+
+importRepoWait lwwKey = do
+
+  env <- ask
+
+  ip  <- asks _progress
+  sto <- asks _storage
+
+  meet <- newTVarIO (mempty :: HashMap HashRef Int)
+
+  subscribeLWWRef lwwKey
+
+  fetchLWWRef lwwKey
+
+  flip fix (IWaitLWWBlock 20) $ \next -> \case
+
+    IWaitLWWBlock w | w <= 0 -> do
+      throwIO ImportRefLogNotFound
+
+    IWaitLWWBlock w -> do
+      onProgress ip (ImportWaitLWW w lwwKey)
+      lww <- readLWWBlock sto lwwKey
+
+      case lww of
+        Nothing -> do
+          pause @'Seconds 2
+          fetchLWWRef lwwKey
+          next (IWaitLWWBlock (pred w))
+
+        Just (LWWRef{..}, LWWBlockData{..}) -> do
+
+          withState do
+            insertLww lwwKey lwwSeq lwwRefLogPubKey
+
+          void $ try @_ @SomeException (getRefLogMerkle lwwRefLogPubKey)
+          subscribeRefLog lwwRefLogPubKey
+          pause @'Seconds 0.25
+          getRefLogMerkle lwwRefLogPubKey
+          next (IWaitRefLog 20 lwwRefLogPubKey)
+
+    IWaitRefLog w puk | w <= 0 -> do
+      throwIO ImportRefLogNotFound
+
+    IWaitRefLog w puk -> do
+      onProgress ip (ImportRefLogStart puk)
+      try @_ @SomeException (getRefLogMerkle puk) >>= \case
+        Left _ -> do
+          onProgress ip (ImportRefLogDone puk Nothing)
+          pause @'Seconds 2
+          next (IWaitRefLog (pred w) puk)
+
+        Right Nothing -> do
+          onProgress ip (ImportRefLogDone puk Nothing)
+          pause @'Seconds 2
+          next (IWaitRefLog (pred w) puk)
+
+        Right (Just h) -> do
+          onProgress ip (ImportRefLogDone puk (Just h))
+          next (IScanRefLog puk h)
+
+    IScanRefLog puk h -> do
+      scanRefLog puk h
+      withState (selectMaxSeqTxNotDone puk) >>= \case
+        Just tx -> next (IApplyTx tx)
+        Nothing -> do
+          hasAnyTx <- withState existsAnyTxDone
+
+          if hasAnyTx then -- existing repo, is' a fetch
+             next IExit
+          else do
+            void $ race (pause @'Seconds 10) do
+                    forever do
+                      onProgress ip (ImportWaitTx h)
+                      pause @'Seconds 0.25
+
+            next (IScanRefLog puk h)
+
+    IApplyTx h -> do
+      onProgress ip (ImportApplyTx h)
+
+      r <- runExceptT (applyTx h)
+             `catch` \case
+               ImportUnbundleError{}  -> pure (Left IncompleteData)
+               _ -> throwIO (userError "tx apply / state read error")
+
+
+      case r of
+
+        Left MissedBlockError -> do
+          next =<< repeatOrExit
+
+        Left IncompleteData -> do
+          atomically $ modifyTVar meet (HM.insertWith (+) h 1)
+          onProgress ip (ImportApplyTxError h (Just "read/decrypt"))
+          attempts <- readTVarIO meet <&> fromMaybe 0 . HM.lookup h
+
+          when (attempts >= 10 ) do
+            throwIO (ImportTxApplyError h)
+
+          next =<< repeatOrExit
+
+        Left e  -> do
+          err (line <> red (viaShow e))
+          throwIO (userError "tx apply / state read error")
+
+        Right{} -> next IExit
+
+    IExit -> do
+      onProgress ip (ImportSetQuiet True)
+      onProgress ip ImportAllDone
+
+
+  where
+    repeatOrExit = do
+      hasAnyTx <- withState existsAnyTxDone
+      if hasAnyTx then do
+        pure IExit
+      else do
+        pause @'Seconds 2
+        pure (IWaitLWWBlock 5)
+
+scanRefLog :: (GitPerks m, MonadReader GitEnv m)
+           => RefLogId
+           -> HashRef
+           -> m ()
+
+scanRefLog puk rv = do
+  sto <- asks _storage
+  ip   <- asks _progress
+  env  <- ask
+
+  txs <- S.toList_ $ do
+            walkMerkle @[HashRef] (fromHashRef rv) (getBlock sto) $ \case
+              Left he   -> do
+                err $ red "missed block" <+> pretty he
+
+              Right hxs -> do
+                for_ hxs $ \htx -> do
+                  here <- lift (withState (existsTx htx))
+                  unless here (S.yield htx)
+
+  tx <- liftIO $ S.toList_ $ do
+           for_ txs $ \tx -> do
+             onProgress ip (ImportScanTx tx)
+             runExceptT (readTx sto tx <&> (tx,))
+               >>= either (const none) S.yield
+
+  withState $ transactional do
+    for_ tx $ \(th,(n,rhh,rh,bundleh)) -> do
+      -- notice $ red "TX" <+> pretty th <+> pretty n
+      insertTx puk th n rhh bundleh
+
+
+applyTx :: (GitPerks m, MonadReader GitEnv m, MonadError OperationError m)
+        => HashRef
+        -> m ()
+
+applyTx h = do
+  sto <- asks _storage
+  (n,rhh,r,bunh) <- readTx sto h
+
+  bundles <- readBundleRefs sto bunh
+                >>= orThrowError IncompleteData
+
+  trace $ red "applyTx" <+> pretty h <+> pretty h <+> pretty bundles
+
+  withState $ transactional do
+
+    applyBundles r bundles
+
+    app <- lift $ asks (view gitApplyHeads)
+
+    when app do
+      lift $ applyHeads r
+
+    insertTxDone h
+
+  where
+
+    applyHeads rh = do
+
+      let refs = _repoHeadRefs rh
+
+      withGitFastImport $ \ps -> do
+        let psin = getStdin ps
+
+        for_ refs $ \(r,v) -> do
+          unless (r == GitRef "HEAD") do
+            liftIO $ hPrint psin $
+              "reset" <+> pretty r <> line <> "from" <+> pretty v <> line
+
+        hClose psin
+        code <- waitExitCode ps
+
+        trace $ red "git fast-import status" <+> viaShow code
+        pure ()
+
+    applyBundles r bundles = do
+      env <- lift ask
+      sto <- lift $ asks _storage
+      ip  <- lift $ asks _progress
+
+      -- withState $ do
+      for_ (zip [0..] bundles) $ \(n,bu) -> do
+
+        insertTxBundle h n bu
+
+        here <- existsBundleDone bu
+
+        unless here do
+
+          BundleWithMeta meta bytes <- lift (runExceptT $ readBundle sto r bu)
+                                          >>=  orThrow (ImportUnbundleError bu)
+
+          (_,_,idx,lbs) <- unpackPackMay bytes
+                             &  orThrow (ImportUnbundleError bu)
+
+          trace $ red "reading bundle" <+> pretty bu -- <+> pretty (LBS.length lbs)
+
+          for_ idx $ \i -> do
+            insertBundleObject bu i
+
+          let chunks = LBS.toChunks lbs
+
+          void $ liftIO $ withGitEnv env $ withGitUnpack $ \p -> do
+             let pstdin = getStdin p
+             for_ (zip [1..] chunks) $ \(i,chu) -> do
+               onProgress ip (ImportReadBundleChunk meta (Progress i Nothing))
+               liftIO $ LBS.hPutStr pstdin (LBS.fromStrict chu)
+
+             hFlush pstdin >> hClose pstdin
+
+             code <- waitExitCode p
+
+             trace $ "unpack objects done:" <+> viaShow code
+
+          insertBundleDone bu
+
+
+withGitFastImport :: (MonadUnliftIO m, MonadReader GitEnv m)
+                  => (Process Handle Handle () -> m a)
+                  -> m ()
+withGitFastImport action = do
+  fp <- asks _gitPath
+  let cmd = "git"
+  let args = ["--git-dir", fp, "fast-import"]
+  -- let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
+
+  trc <- asks traceEnabled >>= \case
+                True -> pure id
+                False -> pure $ setStdout closed . setStderr closed
+
+  let pconfig = setStdin createPipe $ setStdout createPipe $ trc $ proc cmd args
+  p <- startProcess pconfig
+  void $ action p
+  stopProcess p
+
+withGitUnpack :: (MonadUnliftIO m, MonadReader GitEnv m)
+               =>  (Process Handle Handle () -> m a) -> m a
+withGitUnpack action = do
+  fp <- asks _gitPath
+  let cmd = "git"
+  let args = ["--git-dir", fp, "unpack-objects", "-q"]
+
+  trc <- asks traceEnabled >>= \case
+                True -> pure id
+                False -> pure $ setStdout closed . setStderr closed
+
+  let pconfig = setStdin createPipe $ setStdout createPipe $ trc $ proc cmd args
+  p <- startProcess pconfig
+  action p
+
+
+gitPrune :: (MonadUnliftIO m, MonadReader GitEnv m)
+         => m ()
+gitPrune = do
+ fp <- asks _gitPath
+ let cmd = [qc|git --git-dir={fp} prune|]
+ runProcess_ (shell cmd & setStderr closed & setStdout closed)
+ pure ()
+
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs

@@ -0,0 +1,92 @@
+module HBS2.Git.Client.Prelude
+  ( module HBS2.Prelude.Plated
+  , module HBS2.Base58
+  , module HBS2.Clock
+  , module HBS2.Hash
+  , module HBS2.Data.Types.Refs
+  , module HBS2.Net.Auth.Credentials
+  , module HBS2.Merkle
+  , module HBS2.Storage
+  , module HBS2.Net.Messaging.Unix
+  , module HBS2.OrDie
+  , module HBS2.Misc.PrettyStuff
+  , module HBS2.System.Logger.Simple.ANSI
+
+  -- peer
+  , module HBS2.Net.Proto.Service
+  , module HBS2.Peer.Proto.LWWRef
+  , module HBS2.Peer.RPC.API.Peer
+  , module HBS2.Peer.RPC.API.RefLog
+  , module HBS2.Peer.RPC.API.LWWRef
+  , module HBS2.Peer.RPC.API.Storage
+  , module HBS2.Peer.RPC.Client.StorageClient
+
+  , module Control.Applicative
+  , module Control.Monad.Reader
+  , module Control.Monad.Trans.Cont
+  , module Control.Monad.Trans.Maybe
+  , module System.Process.Typed
+  , module Control.Monad.Except
+  , module Lens.Micro.Platform
+  , module UnliftIO
+
+  , getSocketName
+  , formatRef
+  , deserialiseOrFail
+  ) where
+
+import HBS2.Prelude.Plated hiding (at)
+import HBS2.Base58
+import HBS2.Clock
+
+import HBS2.Peer.Proto
+
+import HBS2.Hash
+import HBS2.Data.Types.Refs
+import HBS2.Net.Auth.Credentials
+import HBS2.Merkle
+import HBS2.Storage
+import HBS2.OrDie
+import HBS2.Misc.PrettyStuff
+import HBS2.System.Logger.Simple.ANSI
+
+import HBS2.Net.Messaging.Unix
+import HBS2.Net.Proto.Service
+
+import HBS2.Peer.Proto.LWWRef
+import HBS2.Peer.RPC.API.Peer
+import HBS2.Peer.RPC.API.RefLog
+import HBS2.Peer.RPC.API.LWWRef
+import HBS2.Peer.RPC.API.Storage
+import HBS2.Peer.RPC.Client.StorageClient
+
+import HBS2.Peer.CLI.Detect
+
+import Control.Applicative
+import Control.Monad.Trans.Cont
+import Control.Monad.Reader
+import Control.Monad.Except
+import Control.Exception
+import Control.Monad.Trans.Maybe
+import UnliftIO
+import System.Process.Typed
+import Lens.Micro.Platform
+import Codec.Serialise
+
+data RPCNotFoundError = RPCNotFoundError
+                        deriving stock (Show,Typeable)
+
+
+instance Exception RPCNotFoundError
+
+instance HasErrorStatus RPCNotFoundError where
+  getStatus = const Failed
+
+getSocketName :: forall m . (MonadUnliftIO m, MonadError RPCNotFoundError m) => m FilePath
+getSocketName = do
+  detectRPC >>= maybe (throwError RPCNotFoundError) pure
+
+
+formatRef :: (Pretty a1, Pretty a2) => (a1, a2) -> Doc ann
+formatRef (r,h) = pretty h <+> pretty r
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs

@@ -0,0 +1,55 @@
+{-# Language TemplateHaskell #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Git.Client.Progress where
+
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Data.RefLog
+import HBS2.Git.Data.LWWBlock
+
+import HBS2.Git.Data.Tx
+
+data Progress a =
+  Progress
+  { _progressState :: a
+  , _progressTotal :: Maybe a
+  }
+  deriving (Eq,Generic)
+
+makeLenses 'Progress
+
+class HasProgress a where
+  onProgress :: MonadIO m => a -> ProgressEvent -> m ()
+
+data ProgressEvent =
+    ImportIdle
+  | ImportWaitLWW Int (LWWRefKey HBS2Basic)
+  | ImportRefLogStart RefLogId
+  | ImportRefLogDone  RefLogId (Maybe HashRef)
+  | ImportWaitTx HashRef
+  | ImportScanTx HashRef
+  | ImportApplyTx HashRef
+  | ImportApplyTxError HashRef (Maybe String)
+  | ImportReadBundleChunk BundleMeta (Progress Int)
+  | ImportSetQuiet Bool
+  | ImportAllDone
+  | ExportWriteObject (Progress Int)
+
+
+data AnyProgress = forall a . HasProgress a => AnyProgress a
+
+instance HasProgress AnyProgress where
+  onProgress (AnyProgress e) = onProgress e
+
+instance HasProgress () where
+  onProgress _ _ = pure ()
+
+newtype ProgressQ = ProgressQ (TQueue ProgressEvent)
+
+instance HasProgress ProgressQ where
+  onProgress (ProgressQ q) ev = atomically (writeTQueue q ev)
+
+newProgressQ :: MonadUnliftIO m => m ProgressQ
+newProgressQ = ProgressQ <$> newTQueueIO
+
+
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs

@@ -0,0 +1,54 @@
+module HBS2.Git.Client.RefLog
+  ( module HBS2.Git.Client.RefLog
+  , module HBS2.Peer.Proto.RefLog
+  ) where
+
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Client.App.Types
+import HBS2.Git.Data.RefLog
+import HBS2.Git.Data.LWWBlock
+import HBS2.Peer.Proto.RefLog
+
+data RefLogRequestTimeout = RefLogRequestTimeout
+                            deriving (Show,Typeable)
+
+data RefLogRequestError = RefLogRequestError
+                            deriving (Show,Typeable)
+
+instance Exception RefLogRequestTimeout
+
+instance Exception RefLogRequestError
+
+doSomeRandomShit :: HasAPI PeerAPI UNIX m => m ()
+doSomeRandomShit = error "FUCK"
+
+subscribeRefLog :: forall m .(GitPerks m, HasAPI PeerAPI UNIX m) => RefLogId -> m ()
+subscribeRefLog puk = do
+  api <- getAPI @PeerAPI @UNIX
+  void $ callService @RpcPollAdd api (puk, "reflog", 13)
+
+subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
+subscribeLWWRef puk = do
+  api <- getAPI @PeerAPI @UNIX
+  void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17)
+
+fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey HBS2Basic -> m ()
+fetchLWWRef key = do
+  api <- getAPI @LWWRefAPI @UNIX
+  void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key)
+
+getRefLogMerkle :: forall m . (GitPerks m, HasAPI RefLogAPI UNIX m) => RefLogId -> m (Maybe HashRef)
+getRefLogMerkle puk = do
+
+  api <- getAPI @RefLogAPI @UNIX
+
+  void $ race (pause @'Seconds 1) (callService @RpcRefLogFetch api puk)
+          >>= orThrow RefLogRequestTimeout
+          >>= orThrow RefLogRequestError
+
+  race (pause @'Seconds 1) (callService @RpcRefLogGet api puk)
+    >>= orThrow RefLogRequestTimeout
+    >>= orThrow RefLogRequestError
+
+
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs

@@ -0,0 +1,382 @@
+{-# Language UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module HBS2.Git.Client.State
+  ( module HBS2.Git.Client.State
+  , transactional
+  , commitAll
+  ) where
+
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Client.App.Types
+import HBS2.Git.Client.Config
+
+import HBS2.Peer.Proto.RefLog
+
+import HBS2.Git.Data.RefLog
+import HBS2.Git.Data.LWWBlock
+
+import DBPipe.SQLite
+import Data.Maybe
+import Data.List qualified as List
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Word
+
+newtype Base58Field a = Base58Field { fromBase58Field :: a }
+                        deriving stock (Eq,Ord,Generic)
+
+instance Pretty (AsBase58 a) => ToField (Base58Field a) where
+  toField (Base58Field x) = toField @String (show $ pretty (AsBase58 x))
+
+instance IsString a => FromField (Base58Field a) where
+  fromField = fmap (Base58Field . fromString) . fromField @String
+
+instance FromField (RefLogKey HBS2Basic) where
+  fromField = fmap fromString . fromField @String
+
+instance ToField HashRef where
+  toField h = toField @String (show $ pretty h)
+
+instance FromField HashRef where
+  fromField = fmap fromString . fromField @String
+
+instance ToField GitHash where
+  toField h = toField (show $ pretty h)
+
+instance ToField GitRef where
+  toField h = toField (show $ pretty h)
+
+instance FromField GitRef where
+  fromField = fmap fromString . fromField @String
+
+instance FromField GitHash where
+  fromField = fmap fromString . fromField @String
+
+instance FromField (LWWRefKey HBS2Basic) where
+  fromField = fmap fromString . fromField @String
+
+createStateDir :: (GitPerks m, MonadReader GitEnv m)  => m ()
+createStateDir = do
+  void $ readConfig True
+
+initState :: (GitPerks m, MonadReader GitEnv m) => m ()
+initState = do
+  createStateDir
+  evolveDB
+
+class WithState m a where
+  withState :: DBPipeM m a -> m a
+
+instance (MonadIO m, MonadReader GitEnv m) => WithState m a where
+  withState action = do
+    env <-  asks _db
+    withDB env action
+
+
+evolveDB :: (GitPerks m, MonadReader GitEnv m) => m ()
+evolveDB = withState do
+  createTxTable
+  createTxDoneTable
+  createTxBundleTable
+  createBundleDoneTable
+  createBundleKeyTable
+  createBundleObjectTable
+  createNewGK0Table
+  createLwwTable
+  commitAll
+
+createTxTable :: MonadIO m => DBPipeM m ()
+createTxTable = do
+  ddl [qc|
+create table if not exists tx
+  ( reflog   text not null
+  , tx       text not null
+  , seq      int not null
+  , head     text not null
+  , bundle   text not null
+  , primary key (reflog,tx)
+  )
+  |]
+
+  ddl [qc|
+CREATE INDEX IF NOT EXISTS idx_tx_seq ON tx(seq)
+  |]
+
+
+createTxDoneTable :: MonadIO m => DBPipeM m ()
+createTxDoneTable = do
+  ddl [qc|
+create table if not exists txdone
+  ( tx text not null primary key
+  )
+  |]
+
+createBundleDoneTable :: MonadIO m => DBPipeM m ()
+createBundleDoneTable = do
+  ddl [qc|
+create table if not exists bundledone
+  ( hash text primary key
+  )
+  |]
+
+createBundleKeyTable :: MonadIO m => DBPipeM m ()
+
+createBundleKeyTable = do
+  ddl [qc|
+create table if not exists bundlekey
+  ( reflog text not null
+  , key text not null
+  , bundle text not null
+  , primary key (reflog, key)
+  )
+  |]
+
+
+createTxBundleTable :: MonadIO m => DBPipeM m ()
+createTxBundleTable = do
+  ddl [qc|
+create table if not exists txbundle
+  ( tx text not null
+  , num integer not null
+  , bundle text not null
+  , primary key (tx, num)
+  )
+  |]
+
+createBundleObjectTable :: MonadIO m => DBPipeM m ()
+createBundleObjectTable = do
+  ddl [qc|
+create table if not exists bundleobject
+  ( bundle text not null
+  , object text not null
+  , primary key (bundle, object)
+  )
+  |]
+
+createNewGK0Table :: MonadIO m => DBPipeM m ()
+createNewGK0Table = do
+  ddl [qc|
+create table if not exists newgk0
+  ( reflog     text not null
+  , tx         text not null
+  , ts         int  not null default (strftime('%s','now'))
+  , gk0        text not null
+  , primary key (reflog,tx)
+  )
+  |]
+
+
+createLwwTable :: MonadIO m => DBPipeM m ()
+createLwwTable = do
+  ddl [qc|
+create table if not exists lww
+  ( hash      text not null
+  , seq       int not null
+  , reflog    text not null
+  , primary key (hash,seq,reflog)
+  )
+  |]
+
+
+existsTx :: MonadIO m => HashRef -> DBPipeM m Bool
+existsTx txHash = do
+  select @(Only Bool) [qc|
+SELECT true FROM tx WHERE tx = ? LIMIT 1
+  |] (Only txHash)
+  <&> not . List.null
+
+insertTx :: MonadIO m
+         => RefLogId
+         -> HashRef
+         -> Integer
+         -> HashRef
+         -> HashRef
+         -> DBPipeM m ()
+insertTx puk tx sn h bundle = do
+  insert [qc|
+insert into tx (reflog,tx,seq,head,bundle)
+values (?,?,?,?,?)
+on conflict (reflog,tx) do nothing
+  |] (Base58Field puk,tx,sn,h,bundle)
+
+
+selectTxForRefLog :: MonadIO m
+                  => RefLogId
+                  -> HashRef
+                  -> DBPipeM m (Maybe (HashRef, Epoch))
+selectTxForRefLog puk tx = do
+  select [qc|
+  select head,seq
+  from tx where reflog = ? and tx = ?
+  limit 1
+  |] (Base58Field puk, tx) <&> listToMaybe
+
+selectTxHead :: MonadIO m => HashRef -> DBPipeM m (Maybe HashRef)
+selectTxHead txHash = do
+  result <- select [qc|
+select head from tx where TX = ? limit 1
+  |] (Only txHash)
+  pure $ listToMaybe $ fmap fromOnly result
+
+selectMaxTxSeq :: MonadIO m => RefLogId -> DBPipeM m Integer
+selectMaxTxSeq puk = do
+  select [qc|
+select max(seq) as seq from tx where reflog = ?
+  |] (Only (Base58Field puk))
+    <&> maybe 0 fromOnly . listToMaybe
+
+insertTxDone :: MonadIO m => HashRef -> DBPipeM m ()
+insertTxDone txHash = do
+  insert [qc|
+INSERT INTO txdone (tx) VALUES (?)
+ON CONFLICT (tx) DO NOTHING
+  |] (Only txHash)
+
+
+existsTxDone :: MonadIO m => HashRef -> DBPipeM m Bool
+existsTxDone txHash = do
+  select @(Only Bool) [qc|
+SELECT true FROM txdone WHERE tx = ? LIMIT 1
+  |] (Only txHash)
+  <&> not . null
+
+existsAnyTxDone :: MonadIO m => DBPipeM m Bool
+existsAnyTxDone = do
+  select_ @_ @(Only (Maybe Bool)) [qc|
+SELECT true FROM txdone LIMIT 1
+  |] <&> not . null
+
+selectMaxSeqTxNotDone :: MonadIO m => RefLogId -> DBPipeM m (Maybe HashRef)
+selectMaxSeqTxNotDone puk = do
+  select [qc|
+WITH MaxDoneSeq AS (
+  SELECT MAX(tx.seq) as maxSeq
+  FROM tx
+  JOIN txdone ON tx.tx = txdone.tx
+  WHERE tx.reflog = ?
+),
+FilteredTx AS (
+  SELECT tx.tx, tx.seq
+  FROM tx
+  LEFT JOIN txdone ON tx.tx = txdone.tx
+  WHERE tx.reflog = ? AND txdone.tx IS NULL
+)
+SELECT ft.tx FROM FilteredTx ft
+JOIN MaxDoneSeq mds ON ft.seq > COALESCE(mds.maxSeq, 0)
+ORDER BY ft.seq DESC
+LIMIT 1
+  |] (Base58Field puk, Base58Field puk)
+  <&> listToMaybe . fmap fromOnly
+
+
+selectMaxAppliedTx :: MonadIO m => DBPipeM m (Maybe (HashRef, Integer))
+selectMaxAppliedTx = do
+  select [qc|
+SELECT t.tx, t.seq FROM txdone d JOIN tx t ON d.tx = t.tx ORDER BY t.seq DESC LIMIT 1
+  |] ()
+  <&> listToMaybe
+
+insertBundleDone :: MonadIO m => HashRef -> DBPipeM m ()
+insertBundleDone hashRef = do
+  insert [qc|
+INSERT INTO bundledone (hash) VALUES (?)
+ON CONFLICT (hash) DO NOTHING
+  |] (Only hashRef)
+
+existsBundleDone :: MonadIO m => HashRef -> DBPipeM m Bool
+existsBundleDone hashRef = do
+  select @(Only Bool) [qc|
+SELECT true FROM bundledone WHERE hash = ? LIMIT 1
+  |] (Only hashRef)
+  <&> not . null
+
+
+insertBundleKey :: MonadIO m => RefLogId -> HashRef -> HashRef -> DBPipeM m ()
+insertBundleKey reflogId keyHash bundleHash = do
+  insert [qc|
+INSERT INTO bundlekey (reflog, key, bundle) VALUES (?, ?, ?)
+ON CONFLICT (reflog,key) DO NOTHING
+  |] (Base58Field reflogId, keyHash, bundleHash)
+
+selectBundleByKey :: MonadIO m => RefLogId -> HashRef -> DBPipeM m (Maybe HashRef)
+selectBundleByKey reflogId keyHash = do
+  select [qc|
+SELECT bundle FROM bundlekey WHERE reflog = ? AND key = ? LIMIT 1
+  |] (Base58Field reflogId, keyHash)
+  <&> listToMaybe . fmap fromOnly
+
+insertTxBundle :: MonadIO m => HashRef -> Int -> HashRef -> DBPipeM m ()
+insertTxBundle tx num bundleHash = do
+  insert [qc|
+INSERT INTO txbundle (tx, num, bundle) VALUES (?, ?, ?)
+ON CONFLICT (tx, num) DO UPDATE SET bundle = EXCLUDED.bundle
+  |] (tx, num, bundleHash)
+
+insertBundleObject :: MonadIO m => HashRef -> GitHash -> DBPipeM m ()
+insertBundleObject bundle object = do
+  insert [qc|
+insert into bundleobject (bundle, object) values (?, ?)
+on conflict (bundle, object) do nothing
+  |] (bundle, object)
+
+
+selectBundleObjects :: MonadIO m => HashRef -> DBPipeM m [GitHash]
+selectBundleObjects bundle = do
+  select [qc|
+select object from bundleobject where bundle = ?
+  |] (Only bundle)
+  <&> fmap fromOnly
+
+
+selectObjectsForTx:: MonadIO m => HashRef -> DBPipeM m [GitHash]
+selectObjectsForTx txHash = do
+  select [qc|
+select distinct bundleobject.object
+from txbundle
+join bundleobject on txbundle.bundle = bundleobject.bundle
+where txbundle.tx = ?
+  |] (Only txHash) <&> fmap fromOnly
+
+
+isObjectInTx :: MonadIO m => HashRef -> GitHash -> DBPipeM m Bool
+isObjectInTx txHash objectHash = do
+  result <- select @(Only Int) [qc|
+select 1
+from txbundle
+join bundleobject on txbundle.bundle = bundleobject.bundle
+where txbundle.tx = ? and bundleobject.object = ?
+limit 1
+  |] (txHash, objectHash)
+  pure $ not (null result)
+
+
+insertNewGK0 :: MonadIO m => RefLogId -> HashRef -> HashRef -> DBPipeM m ()
+insertNewGK0 reflog tx gk0 = do
+  insert [qc|
+insert into newgk0 (reflog, tx, gk0) values (?, ?, ?)
+on conflict (reflog,tx) do update set gk0 = excluded.gk0
+  |] (Base58Field reflog, tx, gk0)
+
+selectNewGK0 :: MonadIO m => RefLogId -> DBPipeM m (Maybe (HashRef,Epoch))
+selectNewGK0 reflog = do
+  select [qc|
+select gk0, ts
+from newgk0 g
+where g.reflog = ?
+order by ts desc
+limit 1
+  |] (Only (Base58Field reflog)) <&> listToMaybe
+
+
+insertLww :: MonadIO m => LWWRefKey HBS2Basic -> Word64 -> RefLogId -> DBPipeM m ()
+insertLww lww snum reflog = do
+  insert [qc|
+INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?)
+ON CONFLICT (hash,seq,reflog) DO NOTHING
+  |] (Base58Field lww, snum, Base58Field reflog)
+
+selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey HBS2Basic, Word64, RefLogId)]
+selectAllLww = do
+  select_  [qc|
+SELECT hash, seq, reflog FROM lww
+  |] <&> fmap (over _3 (fromRefLogKey @HBS2Basic))
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs

@@ -0,0 +1,26 @@
+module HBS2.Git.Data.GK where
+
+import HBS2.Git.Client.Prelude
+
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Storage.Operations.ByteString
+
+import Data.ByteString.Lazy qualified as LBS
+
+type GK0 = GroupKey 'Symm HBS2Basic
+
+readGK0 :: (MonadIO m, MonadError OperationError m) => AnyStorage -> HashRef -> m GK0
+readGK0 sto h = do
+  runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h)))
+   >>= orThrowError MissedBlockError
+   <&> deserialiseOrFail @GK0
+   >>= orThrowError UnsupportedFormat
+
+loadGK0FromFile :: MonadIO m => FilePath -> m (Maybe GK0)
+loadGK0FromFile fp = runMaybeT do
+
+  content <- liftIO (try @_ @IOError (LBS.readFile fp))
+               >>= toMPlus
+
+  toMPlus $ parseGroupKey @HBS2Basic (AsGroupKeyFile  content)
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs

@@ -0,0 +1,142 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module HBS2.Git.Data.LWWBlock
+  ( module HBS2.Git.Data.LWWBlock
+  , module HBS2.Peer.Proto.LWWRef
+  , HBS2Basic
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+import HBS2.Net.Proto.Types
+import HBS2.Data.Types.Refs
+import HBS2.Data.Types.SignedBox
+import HBS2.Net.Auth.Schema()
+import HBS2.Net.Auth.Credentials
+import HBS2.Storage
+import HBS2.Peer.Proto.LWWRef
+
+import Data.Word
+import Codec.Serialise
+import System.Random
+
+import Control.Exception
+import Control.Monad.Except
+import Control.Monad.Trans.Maybe
+
+-- NOTE: on-lww-block-data
+--   HKDF ( SK(LWWRef) , lwwRefNonce ) ==> SK( RefLog )
+--   lwwRefLogPubKey ==  PK ( SK (RefLog ) )
+--
+--   LWWBlock is required to make repo reference "stable",
+--   i.e. it should remains the same even if the structure
+--   of repository has been changed or it was, say, "trimmed".
+--
+--   Therefore, there is the root key and the LWWRef, pointing
+--   to a block, which contains actual seed data for the "current"
+--   repo and it's possible to support permanent reference (LWWRef)
+--   to a repo, while it's actual structure may be changed
+--   (hbs2-git repo structure changes or garbage collecting (removing old
+--   transactions, etc).
+--
+--   (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX])
+--
+
+data LWWBlockData e =
+  LWWBlockData
+  { lwwRefSeed       :: Word64
+  , lwwRefLogPubKey  :: PubKey 'Sign (Encryption e)
+  }
+  deriving stock Generic
+
+data LWWBlock e =
+  LWWBlock1 { lwwBlockData :: LWWBlockData e }
+  deriving stock Generic
+
+instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlockData e)
+instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlock e)
+
+
+data LWWBlockOpError =
+    LWWBlockOpSkNotAvail
+  | LWWBlockOpStorageError
+  | LWWBlockOpSomeError
+  deriving stock (Show,Typeable,Generic)
+
+instance Exception LWWBlockOpError
+
+{- HLINT ignore "Functor law" -}
+
+readLWWBlock :: forall e s m . ( MonadIO m
+                               , Signatures s
+                               , s ~ Encryption e
+                               , ForLWWRefProto e
+                               , IsRefPubKey s
+                               , e ~ L4Proto
+                               )
+             => AnyStorage
+             -> LWWRefKey s
+             -> m (Maybe (LWWRef e, LWWBlockData e))
+
+readLWWBlock sto k = runMaybeT do
+
+  w@LWWRef{..} <- runExceptT (readLWWRef @e sto k)
+                  >>= toMPlus
+                  >>= toMPlus
+
+  getBlock sto (fromHashRef lwwValue)
+    >>= toMPlus
+    <&> deserialiseOrFail @(LWWBlock e)
+    >>= toMPlus
+    <&> lwwBlockData
+    <&> (w,)
+
+initLWWRef :: forall e s m . ( MonadIO m
+                             , MonadError LWWBlockOpError m
+                             , IsRefPubKey s
+                             , ForSignedBox e
+                             , HasDerivedKey s 'Sign Word64 m
+                             , s ~ Encryption e
+                             , Signatures s
+                             , e ~ L4Proto
+                             )
+           => AnyStorage
+           -> Maybe Word64
+           -> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) )
+           -> LWWRefKey s
+           -> m HashRef
+initLWWRef sto seed' findSk lwwKey  = do
+  -- let k0 = fromLwwRefKey lww
+  seed   <- maybe1 seed' randomIO pure
+
+  let pk0 = fromLwwRefKey lwwKey
+  sk0 <- findSk pk0
+           >>= orThrowError LWWBlockOpSkNotAvail
+
+  lww0 <- runMaybeT do
+            getRef sto lwwKey >>= toMPlus
+              >>= getBlock sto >>= toMPlus
+              <&> deserialiseOrFail @(SignedBox (LWWRef e) e)
+              >>= toMPlus
+              <&> unboxSignedBox0
+              >>= toMPlus
+              <&> snd
+
+  (pk1, _) <- derivedKey @s @'Sign seed sk0
+
+  let newLwwData = LWWBlock1 (LWWBlockData @e seed pk1)
+
+  hx <- putBlock sto (serialise newLwwData)
+          >>= orThrowError LWWBlockOpStorageError
+          <&> HashRef
+
+  let lww :: LWWRef e
+      lww = LWWRef { lwwSeq = succ (maybe 0 lwwSeq lww0)
+                   , lwwValue = hx
+                   , lwwProof = Nothing
+                   }
+
+  updateLWWRef @s sto lwwKey sk0 lww
+    >>= orThrowError LWWBlockOpStorageError
+
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs

@@ -0,0 +1,7 @@
+module HBS2.Git.Data.RefLog where
+
+import HBS2.Git.Client.Prelude
+
+type RefLogId = PubKey 'Sign HBS2Basic
+
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs

@@ -0,0 +1,381 @@
+module HBS2.Git.Data.Tx
+  ( module HBS2.Git.Data.Tx
+  , OperationError(..)
+  ) where
+
+import HBS2.Git.Client.Prelude
+import HBS2.Git.Data.RefLog
+
+import HBS2.Defaults
+import HBS2.Data.Detect
+import HBS2.KeyMan.Keys.Direct
+import HBS2.Peer.Proto
+import HBS2.Net.Auth.GroupKeySymm
+import HBS2.Net.Auth.Credentials
+import HBS2.Storage.Operations.ByteString
+import HBS2.Storage.Operations.Missed
+
+import HBS2.Git.Data.GK
+
+import HBS2.Git.Local
+
+
+import Data.Maybe
+import Data.Either
+import Data.Word
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString (ByteString)
+import Streaming.Prelude qualified as S
+import Data.Binary.Get
+import Data.ByteArray.Hash (SipHash(..), SipKey(..))
+import Data.ByteArray.Hash qualified as BA
+import Data.HashMap.Strict qualified as HM
+
+type Rank = Integer
+
+
+type LBS = LBS.ByteString
+
+type RepoTx = RefLogUpdate L4Proto
+
+data RepoHeadType = RepoHeadType1
+                    deriving stock (Enum,Generic)
+
+data RepoHeadExt = RepoHeadExt
+                   deriving stock Generic
+
+data RepoHead =
+  RepoHeadSimple
+  { _repoHeadType   :: RepoHeadType
+  , _repoHeadTime   :: Word64
+  , _repoHeadGK0    :: Maybe HashRef
+  , _repoHeadName   :: Text
+  , _repoHeadBrief  :: Text
+  , _repoManifest   :: Maybe Text
+  , _repoHeadRefs   :: [(GitRef, GitHash)]
+  , _repoHeadExt    :: [RepoHeadExt]
+  }
+  deriving stock (Generic)
+
+
+instance Serialise RepoHeadType
+instance Serialise RepoHeadExt
+instance Serialise RepoHead
+
+data TxKeyringNotFound = TxKeyringNotFound
+                         deriving stock (Show, Typeable, Generic)
+
+instance Exception TxKeyringNotFound
+
+class GroupKeyOperations m where
+  openGroupKey :: GK0 -> m (Maybe GroupSecret)
+  loadKeyrings :: HashRef -> m [KeyringEntry HBS2Basic]
+
+makeRepoHeadSimple :: MonadIO m
+                   => Text
+                   -> Text
+                   -> Maybe Text
+                   -> Maybe HashRef
+                   -> [(GitRef, GitHash)]
+                   -> m RepoHead
+makeRepoHeadSimple name brief manifest gk refs = do
+  t <- getEpoch
+  pure $ RepoHeadSimple RepoHeadType1 t gk name brief manifest refs mempty
+
+writeRepoHead :: MonadUnliftIO  m => AnyStorage -> RepoHead -> m HashRef
+writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef
+
+makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic)
+       => AnyStorage
+       -> Bool   -- ^ rewrite bundle merkle tree with new gk0
+       -> Rank   -- ^ tx rank
+       -> RefLogId
+       -> ( PubKey 'Sign s -> m (Maybe (PrivKey 'Sign s) ) )
+       -> RepoHead
+       -> [HashRef]
+       -> [LBS]
+       -> m RepoTx
+
+makeTx sto rewrite r puk findSk rh prev lbss = do
+
+  let rfk = RefLogKey @HBS2Basic puk
+
+  privk <- findSk puk
+             >>= orThrow TxKeyringNotFound
+
+  -- FIXME: delete-on-fail
+  headRef <- writeRepoHead sto rh
+
+  writeEnv <- newWriteBundleEnv sto rh
+
+  cRefs <- for lbss (writeBundle writeEnv)
+
+  let newBundles0 = prev <> cRefs
+
+  newBundles <- do
+    if not rewrite then do
+      pure newBundles0
+    else do
+      for newBundles0 \bh -> do
+
+        blk <- getBlock sto (fromHashRef bh)
+                 >>= orThrow StorageError
+
+        case tryDetect (fromHashRef bh) blk of
+
+          Merkle{} -> do
+            bs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef bh)))
+                     >>= either throwIO pure
+
+            trace $ "encrypt existed block" <+> pretty bh
+            writeBundle writeEnv bs
+
+          MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm2 o gkh nonce}) -> do
+
+            gk <- runExceptT (readGK0 sto (HashRef gkh))
+                    >>= orThrow (GroupKeyNotFound 4)
+
+            gks <- openGroupKey gk
+                     >>= orThrow (GroupKeyNotFound 5)
+
+            debug $ "update GK0 for existed block" <+> pretty bh
+            let rcpt = HM.keys (recipients (wbeGk0 writeEnv))
+            gk1 <- generateGroupKey @HBS2Basic (Just gks) rcpt
+
+            gk1h <- writeAsMerkle sto (serialise gk1)
+
+            let newCrypt = EncryptGroupNaClSymm2 o gk1h nonce
+            let newTreeBlock = ann { _mtaCrypt = newCrypt }
+
+            newTree <- enqueueBlock sto (serialise newTreeBlock)
+                         >>= orThrow StorageError
+
+            pure (HashRef newTree)
+
+          _ -> throwIO UnsupportedFormat
+
+  let pt = toPTree (MaxSize defHashListChunk) (MaxNum 256) newBundles
+
+  me <- makeMerkle 0 pt $ \(_,_,bss) -> do
+          void $ putBlock sto bss
+
+  let meRef = HashRef me
+
+  -- TODO: post-real-rank-for-tx
+  let tx = SequentialRef r (AnnotatedHashRef (Just headRef) meRef)
+            & serialise
+            & LBS.toStrict
+
+  makeRefLogUpdate @L4Proto @HBS2Basic puk privk tx
+
+
+unpackTx :: MonadIO m
+         => RefLogUpdate L4Proto
+         -> m (Integer, HashRef, HashRef)
+
+unpackTx tx = do
+
+  sr <- deserialiseOrFail @SequentialRef (LBS.fromStrict (view refLogUpdData tx))
+          & orThrow UnsupportedFormat
+
+  case sr of
+   SequentialRef n (AnnotatedHashRef (Just rhh) blkh) -> pure (n,rhh,blkh)
+   _ -> throwIO UnsupportedFormat
+
+readTx :: (MonadIO m, MonadError OperationError m)
+       => AnyStorage
+       -> HashRef
+       -> m (Integer, HashRef, RepoHead, HashRef)
+
+readTx sto href = do
+
+  tx <- getBlock sto (fromHashRef href)
+           >>= orThrowError MissedBlockError
+           <&> deserialiseOrFail @(RefLogUpdate L4Proto)
+           >>= orThrowError UnsupportedFormat
+
+  (n,rhh,blkh) <- unpackTx tx
+
+  rh <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef rhh)))
+          >>= orThrowError IncompleteData
+          <&> deserialiseOrFail @RepoHead
+          >>= orThrowError UnsupportedFormat
+
+  missed <- S.head_ (findMissedBlocks2 sto blkh) <&> isJust
+
+  when missed do
+    throwError IncompleteData
+
+  pure (n, rhh, rh, blkh)
+
+
+readRepoHeadFromTx :: MonadIO m
+       => AnyStorage
+       -> HashRef
+       -> m (Maybe RepoHead)
+
+readRepoHeadFromTx sto href = runMaybeT do
+
+  tx <- getBlock sto (fromHashRef href) >>= toMPlus
+           <&> deserialiseOrFail @(RefLogUpdate L4Proto)
+           >>= toMPlus
+
+  (n,rhh,_) <- unpackTx tx
+
+  runExceptT (readFromMerkle sto (SimpleKey (fromHashRef rhh)))
+    >>= toMPlus
+    <&> deserialiseOrFail @RepoHead
+    >>= toMPlus
+
+
+data BundleMeta =
+  BundleMeta
+  { bundleHash      :: HashRef
+  , bundleEncrypted :: Bool
+  }
+  deriving stock (Show,Generic)
+
+data BundleWithMeta =
+  BundleWithMeta
+  { bundleMeta   :: BundleMeta
+  , bundlebBytes :: LBS
+  }
+  deriving stock (Generic)
+
+readBundle :: (MonadIO m, MonadError OperationError m, GroupKeyOperations m)
+           => AnyStorage
+           -> RepoHead
+           -> HashRef
+           -> m BundleWithMeta
+readBundle sto rh ref = do
+
+  obj <- getBlock sto (fromHashRef ref)
+            >>= orThrow MissedBlockError
+
+  let q = tryDetect (fromHashRef ref) obj
+
+  case q of
+    Merkle t -> do
+      let meta = BundleMeta ref False
+      BundleWithMeta meta <$>
+        readFromMerkle sto (SimpleKey key)
+
+    MerkleAnn (MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
+      ke <- loadKeyrings (HashRef gkh)
+      let meta = BundleMeta ref True
+      BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS ke key)
+
+    _ -> throwError UnsupportedFormat
+
+  where
+    key = fromHashRef ref
+
+readBundleRefs :: (MonadIO m)
+               => AnyStorage
+               -> HashRef
+               -> m (Either [HashRef] [HashRef])
+
+readBundleRefs sto bunh = do
+  r <- S.toList_ $
+      walkMerkle @[HashRef] (fromHashRef bunh) (getBlock sto) $ \case
+        Left h -> S.yield (Left h)
+        Right ( bundles :: [HashRef] ) -> do
+          mapM_ (S.yield . Right) bundles
+
+  let missed = lefts r
+
+  if not (null missed) then do
+    pure (Left (fmap HashRef missed))
+  else do
+    pure (Right $ rights r)
+
+
+type GitPack = LBS.ByteString
+type UnpackedBundle = (Word32, Word32, [GitHash], GitPack)
+
+unpackPackMay :: LBS.ByteString -> Maybe UnpackedBundle
+unpackPackMay co = result $ flip runGetOrFail co do
+    w <- getWord32be
+    v <- getWord32be
+    idx <- lookAheadE (getLazyByteString (fromIntegral w) <&> deserialiseOrFail @[GitHash])
+              >>= either (fail.show) pure
+    pack <- getRemainingLazyByteString
+    pure (w,v,idx,pack)
+
+  where
+    result = \case
+      Left{} -> Nothing
+      Right (_,_,r) -> Just r
+
+
+
+data WriteBundleEnv =
+  WriteBundleEnvPlain
+  { wbeHead :: RepoHead
+  , wbeStorage :: AnyStorage
+  }
+  | WriteBundleEnvEnc
+    { wbeSk1     :: SipKey
+    , wbeSk2     :: SipKey
+    , wbeHead    :: RepoHead
+    , wbeGk0     :: GK0
+    , wbeGks     :: GroupSecret
+    , wbeStorage :: AnyStorage
+    }
+
+newWriteBundleEnv :: (MonadIO m, GroupKeyOperations m) => AnyStorage -> RepoHead -> m WriteBundleEnv
+newWriteBundleEnv sto rh = case _repoHeadGK0 rh of
+  Nothing -> do
+    pure $ WriteBundleEnvPlain rh sto
+
+  Just gk0h -> do
+
+    gk0 <- runExceptT (readGK0 sto gk0h)
+            >>= either throwIO pure
+
+    gks <- openGroupKey gk0
+              >>= orThrow (GroupKeyNotFound 3)
+
+    pure $ WriteBundleEnvEnc
+           { wbeSk1     = SipKey 2716370006254639645 507093936407764973
+           , wbeSk2     = SipKey 9209704780415729085 272090086441077315
+           , wbeHead    = rh
+           , wbeGk0     = gk0
+           , wbeGks     = gks
+           , wbeStorage = sto
+           }
+
+makeNonceForBundle :: Monad m => WriteBundleEnv -> LBS.ByteString -> m ByteString
+makeNonceForBundle env lbs = do
+  let piece = ( LBS.take (fromIntegral defBlockSize * 2) lbs
+                <> serialise (wbeHead env)
+              ) & hashObject @HbSync & serialise & LBS.drop 1 & LBS.toStrict
+  pure piece
+
+writeBundle :: MonadIO m => WriteBundleEnv -> LBS.ByteString -> m HashRef
+writeBundle env lbs = do
+
+  case env of
+    WriteBundleEnvPlain{..} -> do
+      writeAsMerkle wbeStorage lbs <&> HashRef
+
+    WriteBundleEnvEnc{..} -> do
+      let bsStream = readChunkedBS lbs defBlockSize
+
+      nonce <- makeNonceForBundle env lbs
+
+      let (SipHash a) = BA.sipHash wbeSk1 nonce
+      let (SipHash b) = BA.sipHash wbeSk2 nonce
+
+      let source = ToEncryptSymmBS wbeGks
+                                   (Right wbeGk0)
+                                   nonce
+                                   bsStream
+                                   NoMetaData
+                                   (Just (EncryptGroupNaClSymmBlockSIP (a,b)))
+
+      th <- runExceptT (writeAsMerkle wbeStorage source)
+              >>= orThrow StorageError
+
+      pure $ HashRef th
+

hbs21-git/hbs2-git-client-lib/HBS2/Git/Local.hs

@@ -0,0 +1,68 @@
+module HBS2.Git.Local where
+
+import HBS2.Prelude.Plated
+
+import Data.ByteString.Base16 qualified as B16
+import Text.InterpolatedString.Perl6 (qc)
+import Data.ByteString.Char8 qualified as BS
+import Data.ByteString.Char8 (ByteString)
+import Codec.Serialise
+
+
+data SHA1 = SHA1
+            deriving stock(Eq,Ord,Data,Generic)
+
+newtype GitHash = GitHash ByteString
+                  deriving stock (Eq,Ord,Data,Generic,Show)
+                  deriving newtype Hashable
+
+instance Serialise GitHash
+
+instance IsString GitHash where
+  fromString s = GitHash (B16.decodeLenient (BS.pack s))
+
+instance FromStringMaybe GitHash where
+  fromStringMay s = either (const Nothing) (pure . GitHash) (B16.decode bs)
+    where
+      bs = BS.pack s
+
+instance Pretty GitHash where
+  pretty (GitHash s) = pretty @String [qc|{B16.encode s}|]
+
+
+newtype GitRef = GitRef { unGitRef :: ByteString }
+                 deriving stock (Eq,Ord,Data,Generic,Show)
+                 deriving newtype (IsString,Monoid,Semigroup,Hashable)
+
+instance Serialise GitRef
+
+mkGitRef :: ByteString -> GitRef
+mkGitRef = GitRef
+
+instance Pretty GitRef where
+  pretty (GitRef x) = pretty @String [qc|{x}|]
+
+data GitObjectType = Commit | Tree | Blob
+                     deriving stock (Eq,Ord,Show,Generic)
+
+instance Serialise GitObjectType
+
+instance IsString GitObjectType where
+  fromString = \case
+    "commit" -> Commit
+    "tree"   -> Tree
+    "blob"   -> Blob
+    x        -> error [qc|invalid git object type {x}|]
+
+instance FromStringMaybe GitObjectType where
+  fromStringMay = \case
+    "commit" -> Just Commit
+    "tree"   -> Just Tree
+    "blob"   -> Just Blob
+    _        -> Nothing
+
+instance Pretty GitObjectType where
+  pretty = \case
+    Commit -> pretty @String "commit"
+    Tree   -> pretty @String "tree"
+    Blob   -> pretty @String "blob"

hbs21-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs

@@ -0,0 +1,66 @@
+module HBS2.Git.Local.CLI where
+
+import HBS2.Prelude
+
+import System.FilePath
+import HBS2.System.Dir
+
+import System.Environment hiding (setEnv)
+
+import Control.Monad.Trans.Maybe
+import Control.Applicative
+import System.Process.Typed
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Text.InterpolatedString.Perl6 (qc)
+
+findGitDir :: MonadIO m => m (Maybe FilePath)
+findGitDir = findGitDir' =<< pwd
+  where
+    findGitDir' dir = do
+      let gd = dir </> ".git"
+      exists <- liftIO $ doesDirectoryExist gd
+      if exists
+        then return $ Just gd
+        else let parentDir = takeDirectory dir
+             in if parentDir == dir -- we've reached the root directory
+                   then return Nothing
+                   else findGitDir' parentDir
+
+checkIsBare :: MonadIO m => Maybe FilePath -> m Bool
+checkIsBare fp = do
+
+  let wd = maybe id setWorkingDir fp
+
+  (code,s,_)  <- readProcess ( shell [qc|git config --local core.bare|]
+                                & setStderr closed & wd
+                             )
+
+  case (code, LBS8.words s) of
+    (ExitSuccess, "true" : _)  -> pure True
+    _ -> pure False
+
+gitDir :: MonadIO m => m (Maybe FilePath)
+gitDir = runMaybeT do
+  byEnv <- liftIO $ lookupEnv "GIT_DIR"
+  byDir <- findGitDir
+
+  byBare <- checkIsBare Nothing >>= \case
+              True  -> pwd >>= expandPath <&> Just
+              False -> pure Nothing
+
+  toMPlus (byEnv <|> byDir <|> byBare)
+
+
+gitRunCommand :: MonadIO m
+              => String
+              -> m (Either ExitCode ByteString)
+
+gitRunCommand cmd = do
+  let procCfg = setStdin closed $ setStderr closed $ shell cmd
+  (code, out, _) <- readProcess procCfg
+  case code of
+    ExitSuccess -> pure (Right out)
+    e           -> pure (Left e)
+
+

hbs21-git/hbs21-git.cabal

@@ -0,0 +1,170 @@
+cabal-version:      3.0
+name:               hbs21-git
+version:            0.24.1.0
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+maintainer:         dzuikov@gmail.com
+-- copyright:
+category:           System
+build-type:         Simple
+-- extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common shared-properties
+  ghc-options:
+        -Wall
+        -fno-warn-type-defaults
+        -threaded
+        -rtsopts
+        -O2
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+  default-language: GHC2021
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , QuasiQuotes
+                     , RecordWildCards
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+
+
+  build-depends:
+        hbs2-core
+      , hbs2-peer
+      , hbs2-storage-simple
+      , hbs2-keyman
+      , db-pipe
+      , suckless-conf
+
+      , attoparsec
+      , atomic-write
+      , bytestring
+      , binary
+      , containers
+      , directory
+      , exceptions
+      , filepath
+      , filepattern
+      , interpolatedstring-perl6
+      , memory
+      , microlens-platform
+      , mtl
+      , safe
+      , serialise
+      , streaming
+      , stm
+      , text
+      , time
+      , timeit
+      , transformers
+      , typed-process
+      , unordered-containers
+      , unliftio
+      , unliftio-core
+      , zlib
+      , prettyprinter
+      , prettyprinter-ansi-terminal
+      , random
+      , vector
+      , unix
+
+
+library hbs2-git-client-lib
+    import:           shared-properties
+
+    exposed-modules:
+      HBS2.Git.Local
+      HBS2.Git.Local.CLI
+
+      HBS2.Git.Data.Tx
+      HBS2.Git.Data.GK
+      HBS2.Git.Data.RefLog
+      HBS2.Git.Data.LWWBlock
+
+      HBS2.Git.Client.Prelude
+      HBS2.Git.Client.App.Types
+      HBS2.Git.Client.App.Types.GitEnv
+      HBS2.Git.Client.App
+      HBS2.Git.Client.Config
+      HBS2.Git.Client.State
+      HBS2.Git.Client.RefLog
+      HBS2.Git.Client.Export
+      HBS2.Git.Client.Import
+      HBS2.Git.Client.Progress
+
+    build-depends:    base
+                    , base16-bytestring
+                    , binary
+                    , unix
+
+    hs-source-dirs:   hbs2-git-client-lib
+
+
+executable hbs2-git-subscribe
+    import:           shared-properties
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base, hbs2-git-client-lib
+        , binary
+        , vector
+        , optparse-applicative
+
+    hs-source-dirs:   git-hbs2-subscribe
+    default-language: GHC2021
+
+executable git-hbs21
+    import:           shared-properties
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base, hbs2-git-client-lib
+        , binary
+        , vector
+        , optparse-applicative
+
+    hs-source-dirs:   git-hbs21
+    default-language: GHC2021
+
+
+executable git-remote-hbs21
+    import:           shared-properties
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base, hbs2-git-client-lib
+        , binary
+        , vector
+        , optparse-applicative
+
+    hs-source-dirs:   git-remote-hbs21
+    default-language: GHC2021
+
+

nix/peer/flake.lock

@@ -295,17 +295,16 @@
         "suckless-conf": "suckless-conf_2"
       },
       "locked": {
-        "lastModified": 1709273510,
-        "narHash": "sha256-wyerw00pnZq64wQGg+azHnLWzDz4C7PvBqCK3U5ejRI=",
-        "ref": "totally-new-download",
-        "rev": "a6e955aa611c3f9485976ce7eba33570a43f2eb7",
-        "revCount": 1036,
+        "lastModified": 1710646368,
+        "narHash": "sha256-0ayUFjOSX4UqSRBbLJeqPMBAn+qSAlFRoICVABliF80=",
+        "ref": "lwwrepo",
+        "rev": "16b5b6220a4be96e30c65f34d631445c28676feb",
+        "revCount": 1002,
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       },
       "original": {
-        "ref": "totally-new-download",
-        "rev": "a6e955aa611c3f9485976ce7eba33570a43f2eb7",
+        "ref": "lwwrepo",
         "type": "git",
         "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
       }

nix/peer/flake.nix

@@ -7,7 +7,7 @@
     extra-container.url = "github:erikarvstedt/extra-container";
     nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
     hbs2.url =
-      "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?ref=totally-new-download&rev=a6e955aa611c3f9485976ce7eba33570a43f2eb7";
+      "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?ref=lwwrepo";
     hbs2.inputs.nixpkgs.follows = "nixpkgs";
 
     home-manager.url = "github:nix-community/home-manager";

nix/peer/shitty-net.sh

@@ -0,0 +1,6 @@
+NIC=ve-hbs2-test
+
+sudo tc qdisc del dev $NIC root
+sudo tc qdisc add dev $NIC root netem delay 200ms 40ms loss 1%
+sudo tc -s qdisc ls dev $NIC
+