hbs-git alpha

.fixme/log

@@ -192,6 +192,7 @@ fixme-del "Dm4CR9h8by"
 fixme-del "6kJiYeBxJc"
 fixme-del "AVwBiXMqRH"
 fixme-set "workflow" "test" "8ekvvQ3zUt"
+fixme-merged "6byezx8CYS" "Fhd4kAQhhw"
 fixme-set "workflow" "test" "5SBPCqrCZc"
 fixme-set "workflow" "backlog" "EqmR2Tmbqq"
 fixme-set "assigned" "fastpok" "2RE7qwfYkA"
@@ -269,6 +270,8 @@ fixme-del "WeoK4yaz16"
 (fixme-set "workflow" "backlog" "8ruNVLwUcC")
 
 (fixme-set "workflow" "test" "2RE7qwfYkA")
+(fixme-set "assigned" "fastpok" "AnAHoFeqF1")
 (fixme-set "assigned" "fastpok" "Da2nChoaL9")
 (fixme-set "assigned" "fastpok" "5RbVNm9SRz")
 fixme-del "6byezx8CYS"
+(fixme-set "workflow" "test" "9sUkKcnxUA")

docs/devlog.md

@@ -1,4 +1,61 @@
 
+## 2023-03-23
+
+Думали, что UDP не работает. А он еще как работает.
+
+Отлаживаем pusp, wip92
+
+NOTE: subscribe-reflog-format
+
+  ;; subscribe: fetch reflog value on start
+
+  poll-default reflog 10 ;; time in minutes
+
+  ;; говорит, что надо опрашивать ссылку раз в указанный период
+  ;; в минутах
+
+  poll reflog 1 "2YNGdnDBnciF1Kgmx1EZTjKUp1h5pvYAjrHoApbArpeX"
+  poll reflog 2 "4qjsu7y5umqfFQG978nEUZCHJwd1ZSKrNT5Z74G7tbdo"
+
+  ; говорит, что мы в принципе слушаем ссылку такую-то
+  subscribe reflog "2YNGdnDBnciF1Kgmx1EZTjKUp1h5pvYAjrHoApbArpeX"
+  subscribe reflog "95mSAkUqyrkM47eBu6jXnHZW97nxARKZfuKpj4vxR8rF"
+  subscribe reflog "4qjsu7y5umqfFQG978nEUZCHJwd1ZSKrNT5Z74G7tbdo"
+  subscribe reflog "74Kxc6kYCnjuXg7ridb28gE4n2vzSaKEm9MZNqd9ACV9"
+
+  ; слушать все рефлоги
+  subscribe reflog *
+
+  ; реализовать подписку на рефлоги только от такого-то пира!
+  ; subscribe reflog from-peer XXX
+
+
+FIXME: asap-storage-fails-investigation
+  Появляются блоки с размером 0 и правильным
+  названием (соответствует хэшу). Видимо,
+  каким-то образом не успевают записаться.
+  Необходимо проверить storage под нагрузкой
+  раз, реализовать более устойчивый к ошибкам
+  алгоритм записи - два, проверить его оверхед
+  относительно основного сторейджа - три.
+  Так же надо реализовать какой-то метод контроля
+  целостности и стратегию при обнаружении ошибок:
+  например, отдельный процесс, который берёт случайный
+  блок, читает его, если хэш расходится, то:
+  1) сигнализирует об ошибке 3) удаляет?? 4) отправляет
+  скачиваться и помечает блок, как к перезаписи.
+
+## 2023-03-22
+
+Или нет затыков? wip91
+Какие-то затыки. wip26
+
+FIXME: ошибка-десереализации-при-удалении-бранча
+
+  [root@hbs2-test:~/hbs2]# git fetch
+  git-remote-hbs2: DeserialiseFailure 0 "end of input
+
+
 ## 2023-03-21
 
 TODO: hbs2-peer-poll-reflog
@@ -61,6 +118,66 @@ FIXME: THAT-PEER-IS-JERK-issue
  В третьих - как в этой ситуации перестать бомбить себя и пира.
 
 
+
+TODO: hbs2-fetch-reflog-does-not-work
+  Похоже, что проигрывание транзакций не вызывает
+  скачивание зависимостей.
+
+TODO: hbs2-peer-poll-reflog
+ poll-reflog-default - стартует процесс,
+ который с заданной периодичностью (или дефолтной)
+ запрашивает рефлог у всех, кого знает.
+
+TODO: hbs2-peer-subscribe-reflog
+ Опция, subscribe-reflog
+ Если включена, пир слушает данный reflog.
+ Если * - то слушаются все рефлоги.
+ Если reflog-from-peer "peer" reflog"  - делает так,
+ кто рефлог X принимается только от данного пира.
+ Если * - то все рефлоги от пира.
+
+FIXME: невнятно-ругается-когда-выключен-http
+  невнятно ругается, когда выключен http у
+  hbs2-peer. нужно отчётливо говорить, что включите
+  http.
+
+FIXME: ASAP-hardcoded-master-when-no-master
+
+  Как видно ниже -- в исходном репозитории нет бранча master,
+  однако, операция чтения ссылки его вернула, отсюда поломан git clone.
+  Решение: надо проверять, что этот бранч существует, если его нет ---
+  то брать один из бранчей, которые есть в конфиге и существуют, иначе те,
+  котрые существуют
+
+  [trace] head read: GKqqzjz3wr81hDf6gjYXLLp49PuUqwtcUqSNwMpwim4C
+  [===========================================] 100%
+  [trace] sendLn "@refs/heads/master HEAD"
+  [trace] sendLn "97bed303895cd4200b53230ba9c244215aa80beb refs/heads/hbs2-git"
+  [trace] got reflog (3, 6e1bQr8mvzn5xbdfRRtEiZJq8xDb58Tyz52hvKvoLNCK)
+  [trace] ABOUT TO UPDATE HEAD
+  [trace] [fetch, 0000000000000000000000000000000000000000, refs/heads/master]
+  [trace] fetch 0000000000000000000000000000000000000000 refs/heads/master
+  [trace] [fetch, 97bed303895cd4200b53230ba9c244215aa80beb, refs/heads/hbs2-git]
+  [trace] fetch 97bed303895cd4200b53230ba9c244215aa80beb refs/heads/hbs2-git
+  [trace] []
+  [trace] dbPath: /home/dmz/.local/share/hbs2-git/4qjsu7y5umqfFQG978nEUZCHJwd1ZSKrNT5Z74G7tbdo
+  [trace] updateLocalState 4qjsu7y5umqfFQG978nEUZCHJwd1ZSKrNT5Z74G7tbdo
+  [trace] hbs2 reflog get 4qjsu7y5umqfFQG978nEUZCHJwd1ZSKrNT5Z74G7tbdo
+  [trace] "FcctCWH8hTESQmnb8ozCmXhKW1SXzLbmY9ocCyU1TxEr\n"
+  [trace] FcctCWH8hTESQmnb8ozCmXhKW1SXzLbmY9ocCyU1TxEr
+  warning: remote HEAD refers to nonexistent ref, unable to checkout
+
+  [dmz@expert:~/tmp]$ hbs2 cat GKqqzjz3wr81hDf6gjYXLLp49PuUqwtcUqSNwMpwim4C
+  @refs/heads/master HEAD
+  97bed303895cd4200b53230ba9c244215aa80beb refs/heads/hbs2-git
+
+FIXME: THAT-PEER-IS-JERK-issue
+ Повторяется ситуация, когда приходит пакет с размером 0.
+ Надо, во первых, понять почему.
+ Во вторых - как с этим бороться.
+ В третьих - как в этой ситуации перестать бомбить себя и пира.
+
+
 Тест git push 6
 
 ## 2023-03-20
@@ -80,6 +197,15 @@ TODO: reflog-state-request
 
 TODO: git-new-repo-convenience-function
 
+## 2023-03-19
+
+FIXME: broken-commit-object-file-disaster
+ see 13CuHGmVHfdr2VAzmnMkQV4kZa8kSM2HEoSb8dUVLSQV
+
+FIXME: ASAP-fix-download-log
+   8e72fbff5c395fa6d1dab02dde7eea887bdca274
+
+
 ## 2023-02-28
 
 TODO: hbs2-git

docs/drafts/pep-04-01.txt

@@ -0,0 +1,117 @@
+
+Простые ссылки
+==============
+
+Модель данных
+-------------
+
+```
+  value:
+    seqnum    ; монотонно возрастающее число на каждый update
+    prev      ; предыдущее значение блока | ничего
+    nonce     ; некое произвольное значение
+    value     ; значение ссылки ( hashref )
+    acb       ; ( hashref) ссылка на ACB
+    metadata  ; отсутствие | ссылка ( hashref ) | короткая строка
+    key       ; публичный ключ, создавший, обновивший ссылку
+
+  sign      ; подпись (TBD) - возьмем, что это подпись всего пакета, тогда
+            ; у нас ссылка разбивается на две части - value и signature
+
+```
+
+
+Операции
+--------
+
+Создать ссылку
+~~~~~~~~~~~~~~
+
+Пользователь предоставлет заполненную/подписанную структуру (см. выше).
+От неё вычисляется хэш и сама структура в сериализованном виде помещается
+в хранилища, а файл в пространстве имён refs указывает на сериализованный блок
+данной структуры.
+
+Условия:
+
+  1. seqnum == 0
+  2. prev == отсутствие значения
+  3. key принадлежит ACB.root
+
+
+Обновить ссылку
+~~~~~~~~~~~~~~~
+
+Команда протокола / API / RPC
+
+Условия:
+
+  1. seqnum = prev.seqnum + 1
+  2. key принадлежит ACB.owners
+  3. Если current.acb /= prev.ACB, то ключ принадлежит root
+
+Сериализованное значение блока записывается в storage,
+ключ в refs устанавливается на хэш этого блока.
+
+
+Получить значение ссылки
+~~~~~~~~~~~~~~~~~~~~~~~~
+
+Узел запрашивает значение ссылки у другого узла.
+
+Если seq полученного значения больше, чем известное
+нам, и ссылка валидируется --- то установить собственное
+значение ссылки в полученное.
+
+Если нет --- то оставить всё как есть.
+
+
+Анонс ссылки
+~~~~~~~~~~~~
+
+Сообщение, что ссылка X имеет значение Y.
+
+Узел получает значение Y, далее валидирует его
+аналогично разделу "Получить значение ссылки".
+
+
+Проверка подписи
+~~~~~~~~~~~~~~~~
+
+1. Сериализуем value
+2. Проверяем подпись
+
+
+Добавление ссылки в список ссылок пира
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+В соответствии с настройками, пир принимает
+обновление ссылки или нет от другого пира.
+
+Возможно, он принимает только существующие
+ссылки, но не создаёт новые.
+
+Валидированная ссылка помещается в storage,
+ref/value обновляется.
+
+Периодически перестраивается merkle tree
+всех ссылок, каждый лист в этом дереве
+--- указатель на блок (ссылка, значение ссылки).
+
+Данное дерево может быть получено путём обхода каталога
+refs, либо же может всегда поддерживаться в
+актуальном состоянии.
+
+Получение списка ссылок пира
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Пир посылает другому пиру запрос на получение
+всех ссылок.
+
+Пир отвечает адресом merkle tree указанной структуры
+данных (merkle tree, где каждый лист - это пара
+(ссылка/значение).
+
+
+
+

flake.nix

@@ -38,7 +38,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-peer"
      "hbs2-core"
      "hbs2-storage-simple"
-     "hbs2-tests"
+     "hbs2-git"
    ];
 
    packageDirs = {
@@ -70,6 +70,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
 
    shellExtBuildInputs = {pkgs}: with pkgs;  [
      haskellPackages.haskell-language-server
+     haskellPackages.cbor-tool
      pkg-config
      inputs.hspup.packages.${pkgs.system}.default
      inputs.fixme.packages.${pkgs.system}.default

hbs2-core/hbs2-core.cabal

@@ -94,6 +94,7 @@ library
                     , HBS2.Net.Proto.PeerAnnounce
                     , HBS2.Net.Proto.PeerExchange
                     , HBS2.Net.Proto.Sessions
+                    , HBS2.Net.Proto.RefLog
                     , HBS2.Net.Proto.Types
                     , HBS2.OrDie
                     , HBS2.Prelude

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

@@ -42,7 +42,9 @@ import Codec.Serialise (serialise, deserialiseOrFail)
 import Prettyprinter hiding (pipe)
 
 
-data AnyStorage = forall zu . (Block ByteString ~ ByteString, Storage zu HbSync ByteString IO) => AnyStorage zu
+data AnyStorage = forall zu . ( Block ByteString ~ ByteString
+                              , Storage zu HbSync ByteString IO
+                              ) => AnyStorage zu
 
 instance (IsKey HbSync, Key HbSync ~ Hash HbSync, Block ByteString ~ ByteString) => Storage AnyStorage HbSync ByteString IO where
 
@@ -51,6 +53,8 @@ instance (IsKey HbSync, Key HbSync ~ Hash HbSync, Block ByteString ~ ByteString)
   getBlock (AnyStorage s) = getBlock s
   getChunk (AnyStorage s) = getChunk s
   hasBlock (AnyStorage s) = hasBlock s
+  updateRef (AnyStorage s) = updateRef s
+  getRef (AnyStorage s) = getRef s
 
 data AnyMessage enc e = AnyMessage !Integer !(Encoded e)
                        deriving stock (Generic)

hbs2-core/lib/HBS2/Data/Detect.hs

@@ -14,16 +14,18 @@ import Data.Functor
 data BlobType =  Merkle (Hash HbSync)
                | MerkleAnn (MTreeAnn [HashRef])
                | AnnRef (Hash HbSync)
+               | SeqRef SequentialRef
                | Blob (Hash HbSync)
                deriving (Show,Data)
 
 
 tryDetect :: Hash HbSync -> ByteString -> BlobType
-tryDetect hash obj = rights [mbAnn, mbLink, mbMerkle] & headDef orBlob
+tryDetect hash obj = rights [mbAnn, mbLink, mbMerkle, mbSeq] & headDef orBlob
 
   where
     mbLink   = deserialiseOrFail @AnnotatedHashRef obj >> pure (AnnRef hash)
     mbMerkle = deserialiseOrFail @(MTree [HashRef]) obj >> pure (Merkle hash)
-    mbAnn   = deserialiseOrFail obj <&> MerkleAnn
+    mbSeq    = deserialiseOrFail @SequentialRef obj <&> SeqRef
+    mbAnn    = deserialiseOrFail obj <&> MerkleAnn
     orBlob   = Blob hash
 

hbs2-core/lib/HBS2/Data/Types/Refs.hs

@@ -17,9 +17,11 @@ import Data.Functor.Identity
 import Data.String(IsString)
 import GHC.Generics
 import Prettyprinter
+import Data.Hashable hiding (Hashed)
+import Data.Maybe (fromMaybe)
 
 newtype HashRef = HashRef { fromHashRef :: Hash HbSync }
-                  deriving newtype (Eq,Ord,IsString,Pretty)
+                  deriving newtype (Eq,Ord,IsString,Pretty,Hashable)
                   deriving stock (Data,Generic,Show)
 
 
@@ -48,16 +50,18 @@ data HashRefType =
   deriving stock (Data,Show,Generic)
 
 data AnnotatedHashRef =
-  AnnotatedHashRef (Maybe HashRefPrevState) HashRefType
+  AnnotatedHashRef (Maybe HashRef) HashRef
   deriving stock (Data,Show,Generic)
 
+data SequentialRef =
+  SequentialRef Integer AnnotatedHashRef
+  deriving stock (Data,Show,Generic)
 
 instance Serialise AnnotatedHashRef
+instance Serialise SequentialRef
 instance Serialise HashRef
 instance Serialise HashRefMetadata
 instance Serialise HashRefObject
-instance Serialise HashRefPrevState
-instance Serialise HashRefType
 
 ---
 
@@ -131,3 +135,29 @@ nodeLinearRefsRef pk = RefGenesis
   , refName = "List of node linear refs"
   , refMeta = NoMetaData
   }
+
+
+newtype RefLogKey e = RefLogKey (PubKey 'Sign e)
+
+deriving stock instance Eq (PubKey 'Sign e) => Eq (RefLogKey e)
+
+instance (Eq (PubKey 'Sign e), Serialise (PubKey 'Sign e)) => Hashable (RefLogKey e) where
+  hashWithSalt s k = hashWithSalt s (hashObject @HbSync k)
+
+instance Serialise (PubKey 'Sign e) => Hashed HbSync (RefLogKey e) where
+  hashObject (RefLogKey pk) = hashObject ("reflogkey|" <> serialise pk)
+
+instance FromStringMaybe (PubKey 'Sign e) => FromStringMaybe (RefLogKey e) where
+  fromStringMay s = RefLogKey <$> fromStringMay s
+
+instance FromStringMaybe (PubKey 'Sign e) =>  IsString (RefLogKey e) where
+  fromString s = fromMaybe (error "bad public key base58") (fromStringMay s)
+
+
+instance Pretty (AsBase58 (PubKey 'Sign e) ) => Pretty (AsBase58 (RefLogKey e)) where
+  pretty (AsBase58 (RefLogKey k)) = pretty (AsBase58 k)
+
+instance Pretty (AsBase58 (PubKey 'Sign e) ) => Pretty (RefLogKey e) where
+  pretty (RefLogKey k) = pretty (AsBase58 k)
+
+

hbs2-core/lib/HBS2/Merkle.hs

@@ -194,3 +194,4 @@ walkMerkleTree :: (Serialise (MTree a), Monad m)
 walkMerkleTree tree flookup sink = case tree of
     (MLeaf s)   -> sink (Right s)
     (MNode _ hashes) -> forM_ hashes \h -> walkMerkle h flookup sink
+

hbs2-core/lib/HBS2/Net/Proto/Definition.hs

@@ -9,6 +9,7 @@ module HBS2.Net.Proto.Definition
 import HBS2.Clock
 import HBS2.Defaults
 import HBS2.Merkle
+import HBS2.Hash
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Messaging.UDP
 import HBS2.Net.Proto
@@ -18,6 +19,7 @@ import HBS2.Net.Proto.BlockInfo
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerAnnounce
 import HBS2.Net.Proto.PeerExchange
+import HBS2.Net.Proto.RefLog
 import HBS2.Prelude
 
 import Data.Functor
@@ -93,6 +95,22 @@ instance HasProtocol UDP (PeerExchange UDP) where
   decode = either (const Nothing) Just . deserialiseOrFail
   encode = serialise
 
+instance HasProtocol UDP (RefLogUpdate UDP) where
+  type instance ProtocolId (RefLogUpdate UDP) = 7
+  type instance Encoded UDP = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
+
+  requestPeriodLim = ReqLimPerMessage 600
+
+instance HasProtocol UDP (RefLogRequest UDP) where
+  type instance ProtocolId (RefLogRequest UDP) = 8
+  type instance Encoded UDP = ByteString
+  decode = either (const Nothing) Just . deserialiseOrFail
+  encode = serialise
+
+  -- FIXME: real-period
+  requestPeriodLim = ReqLimPerMessage 1
 
 instance Expires (SessionKey UDP (BlockInfo UDP)) where
   expiresIn _ = Just defCookieTimeoutSec
@@ -128,6 +146,12 @@ instance MonadIO m => HasNonces (PeerExchange UDP) m where
     n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
     pure $ BS.take 32 n
 
+instance MonadIO m => HasNonces (RefLogUpdate UDP) m where
+  type instance Nonce (RefLogUpdate UDP) = BS.ByteString
+  newNonce = do
+    n <- liftIO ( Crypto.newNonce <&> Crypto.encode )
+    pure $ BS.take 32 n
+
 instance MonadIO m => HasNonces () m where
   type instance Nonce () = BS.ByteString
   newNonce = do
@@ -146,5 +170,6 @@ instance Signatures MerkleEncryptionType where
   makeSign = Sign.signDetached
   verifySign = Sign.signVerifyDetached
 
-
+instance Hashed HbSync Sign.PublicKey where
+  hashObject pk = hashObject (Crypto.encode pk)
 

hbs2-core/lib/HBS2/Net/Proto/RefLog.hs

@@ -0,0 +1,206 @@
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# Language TemplateHaskell #-}
+module HBS2.Net.Proto.RefLog where
+
+import HBS2.Prelude.Plated
+import HBS2.Hash
+import HBS2.Clock
+import HBS2.Net.Proto
+import HBS2.Net.Auth.Credentials
+import HBS2.Base58
+import HBS2.Events
+import HBS2.Net.Proto.Peer
+import HBS2.Net.Proto.Sessions
+
+import HBS2.System.Logger.Simple
+
+import Data.Maybe
+import Data.Hashable
+import Data.ByteString (ByteString)
+import Type.Reflection (someTypeRep)
+import Lens.Micro.Platform
+
+data RefLogRequest e =
+    RefLogRequest  (PubKey 'Sign e)
+  | RefLogResponse (PubKey 'Sign e) (Hash HbSync)
+  deriving stock (Generic)
+
+data RefLogUpdate e =
+  RefLogUpdate
+  { _refLogId           :: PubKey 'Sign e
+  , _refLogUpdNonce     :: Nonce (RefLogUpdate e)
+  , _refLogUpdData      :: ByteString
+  , _refLogUpdSign      :: Signature e
+  }
+  deriving stock (Generic)
+
+makeLenses 'RefLogUpdate
+
+data RefLogUpdateI e m =
+  RefLogUpdateI
+  { refLogUpdate     :: (PubKey 'Sign e, RefLogUpdate e) -> m ()
+  , refLogBroadcast  :: RefLogUpdate e -> m ()
+  }
+
+data RefLogUpdateEv e
+data RefLogRequestAnswer e
+
+data instance EventKey e (RefLogUpdateEv e) =
+  RefLogUpdateEvKey
+  deriving (Generic,Typeable,Eq)
+
+instance Typeable (RefLogUpdateEv e) => Hashable (EventKey e (RefLogUpdateEv e)) where
+  hashWithSalt salt _ = hashWithSalt salt (someTypeRep p)
+    where
+      p = Proxy @RefLogUpdateEv
+
+newtype instance Event e (RefLogUpdateEv e) =
+  RefLogUpdateEvData (PubKey 'Sign e, RefLogUpdate e)
+  deriving (Typeable)
+
+instance EventType ( Event e (RefLogUpdateEv e) ) where
+  isPersistent = True
+
+instance Expires (EventKey e (RefLogUpdateEv e)) where
+  expiresIn = const Nothing
+
+data instance EventKey e (RefLogRequestAnswer e) =
+  RefLogReqAnswerKey
+  deriving stock (Generic,Typeable,Eq)
+
+instance Typeable (RefLogRequestAnswer e) => Hashable (EventKey e (RefLogRequestAnswer e)) where
+  hashWithSalt salt _ = hashWithSalt salt (someTypeRep p)
+    where
+      p = Proxy @(RefLogRequestAnswer e)
+
+data instance Event e (RefLogRequestAnswer e) =
+  RefLogReqAnswerData (PubKey 'Sign e) (Hash HbSync)
+  deriving (Typeable)
+
+instance EventType ( Event e (RefLogRequestAnswer e) ) where
+  isPersistent = True
+
+instance Expires (EventKey e (RefLogRequestAnswer e)) where
+  expiresIn = const Nothing
+
+makeRefLogUpdate :: forall e m . ( MonadIO m
+                                 , HasNonces (RefLogUpdate e) m
+                                 , Nonce (RefLogUpdate e) ~ ByteString
+                                 , Signatures e
+                                 )
+                 => PubKey 'Sign e
+                 -> PrivKey 'Sign e
+                 -> ByteString
+                 -> m (RefLogUpdate e)
+
+makeRefLogUpdate pubk privk bs = do
+  nonce <- newNonce @(RefLogUpdate e)
+  let noncebs = nonce <> bs
+  let sign = makeSign @e privk noncebs
+  pure $ RefLogUpdate pubk nonce bs sign
+
+verifyRefLogUpdate :: forall e m . ( MonadIO m
+                                   -- , HasNonces (RefLogUpdate e) m
+                                   , Nonce (RefLogUpdate e) ~ ByteString
+                                   , Signatures e
+                                  )
+                 => RefLogUpdate e -> m Bool
+verifyRefLogUpdate msg = do
+  let pubk = view refLogId msg
+  let noncebs = view refLogUpdNonce msg <> view refLogUpdData msg
+  let sign = view refLogUpdSign msg
+  pure $ verifySign @e pubk sign noncebs
+
+data RefLogRequestI e m =
+  RefLogRequestI
+  { onRefLogRequest :: (Peer e, PubKey 'Sign e) -> m (Maybe (Hash HbSync))
+  , onRefLogResponse :: (Peer e, PubKey 'Sign e, Hash HbSync) -> m ()
+  }
+
+refLogRequestProto :: forall e m . ( MonadIO m
+                                   , Request e (RefLogRequest e) m
+                                   , Response e (RefLogRequest e) m
+                                   , HasDeferred e (RefLogRequest e) m
+                                   , Sessions e (KnownPeer e) m
+                                   , IsPeerAddr e m
+                                   , Pretty (AsBase58 (PubKey 'Sign e))
+                                   , EventEmitter e (RefLogRequestAnswer e) m
+                                   , Pretty (Peer e)
+                                   )
+                  => RefLogRequestI e m -> RefLogRequest e -> m ()
+
+refLogRequestProto adapter cmd = do
+
+  p <- thatPeer proto
+  auth <- find (KnownPeerKey p) id <&> isJust
+
+  when auth do
+
+    -- FIXME: asap-only-accept-response-if-we-have-asked
+
+    case cmd of
+      (RefLogRequest pk) -> do
+         trace $ "got RefLogUpdateRequest for" <+> pretty (AsBase58 pk)
+         pip <- thatPeer proto
+         answ' <- onRefLogRequest adapter (pip,pk)
+         maybe1 answ' none $ \answ -> do
+          response (RefLogResponse @e pk answ)
+
+      (RefLogResponse pk h) -> do
+         trace $ "got RefLogResponse for" <+> pretty (AsBase58 pk) <+> pretty h
+         pip <- thatPeer proto
+         emit RefLogReqAnswerKey (RefLogReqAnswerData @e pk h)
+         onRefLogResponse adapter (pip,pk,h)
+
+  where
+    proto = Proxy @(RefLogRequest e)
+
+refLogUpdateProto :: forall e m . ( MonadIO m
+                                  , Request e (RefLogUpdate e) m
+                                  , Response e (RefLogUpdate e) m
+                                  , HasDeferred e (RefLogUpdate e) m
+                                  , IsPeerAddr e m
+                                  , Pretty (Peer e)
+                                  , Signatures e
+                                  , Nonce (RefLogUpdate e) ~ ByteString
+                                  , Sessions e (KnownPeer e) m
+                                  , Pretty (AsBase58 (PubKey 'Sign e))
+                                  , EventEmitter e (RefLogUpdateEv e) m
+                                  )
+                  => RefLogUpdateI e m -> RefLogUpdate e -> m ()
+
+refLogUpdateProto adapter =
+  \case
+    e@RefLogUpdate{} -> do
+      p <- thatPeer proto
+      auth <- find (KnownPeerKey p) id <&> isJust
+
+      when auth do
+
+        let pubk = view refLogId e
+        trace $ "got RefLogUpdate for" <+> pretty (AsBase58 pubk)
+        signed <- verifyRefLogUpdate @e e
+
+        when signed do
+          trace "RefLogUpdate is signed properly"
+
+          -- FIXME: refactor:use-type-application-for-deferred
+          deferred proto do
+            emit @e RefLogUpdateEvKey (RefLogUpdateEvData (pubk, e))
+            refLogUpdate adapter (pubk, e)
+            refLogBroadcast adapter e
+            pure ()
+
+    where
+      proto = Proxy @(RefLogUpdate e)
+
+instance  ( Serialise (PubKey 'Sign e)
+          , Serialise (Nonce (RefLogUpdate e))
+          , Serialise (Signature e)
+          ) => Serialise (RefLogUpdate e)
+
+
+instance  ( Serialise (PubKey 'Sign e)
+          ) => Serialise (RefLogRequest e)
+

hbs2-core/lib/HBS2/Net/Proto/Types.hs

@@ -2,7 +2,6 @@
 {-# Language FunctionalDependencies #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language UndecidableInstances #-}
-{-# Language TemplateHaskell #-}
 module HBS2.Net.Proto.Types
   ( module HBS2.Net.Proto.Types
   ) where

hbs2-core/lib/HBS2/OrDie.hs

@@ -8,10 +8,10 @@ class OrDie m a where
   type family OrDieResult a :: Type
   orDie :: m a -> String -> m (OrDieResult a)
 
-instance OrDie IO (Maybe a) where
+instance MonadIO m => OrDie m (Maybe a) where
   type instance OrDieResult (Maybe a) = a
   orDie mv err = mv >>= \case
-      Nothing -> die err
+      Nothing -> liftIO $ die err
       Just x  -> pure x
 
 instance MonadIO m => OrDie m ExitCode where

hbs2-core/lib/HBS2/Storage.hs

@@ -45,9 +45,9 @@ class ( Monad m
 
   hasBlock :: a -> Key h -> m (Maybe Integer)
 
-  -- listBlocks :: a -> ( Key block -> m () ) -> m ()
+  updateRef :: Hashed h k => a -> k -> Key h -> m ()
-
 
+  getRef :: Hashed h k => a -> k -> m (Maybe (Key h))
 
 calcChunks :: forall a b . (Integral a, Integral b)
            => Integer  -- | block size

hbs2-core/lib/HBS2/System/Logger/Simple.hs

@@ -15,6 +15,8 @@ module HBS2.System.Logger.Simple
   , setLogging, setLoggingOff
   , defLog
   , loggerTr
+  , toStderr
+  , toStdout
   , SetLoggerEntry
   , module HBS2.System.Logger.Simple.Class
   ) where
@@ -33,10 +35,15 @@ import Data.IntMap (IntMap)
 import Data.IntMap qualified as IntMap
 import Lens.Micro.Platform
 
+data LoggerType = LoggerStdout
+                | LoggerStderr
+                | LoggerNull
+
 data LoggerEntry =
   LoggerEntry
   { _loggerSet  :: !LoggerSet
   , _loggerTr   :: LogStr -> LogStr
+  , _loggerType :: !LoggerType
   }
 
 makeLenses 'LoggerEntry
@@ -63,17 +70,39 @@ delLogger e =
     Nothing -> pure ()
     Just s  -> liftIO $ rmLoggerSet s
 
+toStderr :: SetLoggerEntry
+toStderr = set loggerType LoggerStderr
+
+toStdout :: SetLoggerEntry
+toStdout = set loggerType LoggerStdout
+
 setLogging :: forall a m . (MonadIO m, HasLogLevel a)
            => (LoggerEntry -> LoggerEntry)
            -> m ()
 
 setLogging f = do
   se <- liftIO $ newStdoutLoggerSet 10000 -- FIXME: ??
-  let def = f (LoggerEntry se id)
+  def <- updateLogger $ f (LoggerEntry se id LoggerNull)
   let key = logKey @a
   e <- liftIO $ atomicModifyIORef' loggers (\x -> (IntMap.insert key def x, IntMap.lookup key x))
   delLogger e
 
+  where
+    updateLogger e = case view loggerType e of
+
+      LoggerNull -> pure e
+
+      LoggerStderr -> do
+        delLogger (Just e)
+        se <- liftIO $ newStderrLoggerSet 10000 -- FIXME: ??
+        pure $ set loggerSet se e
+
+      LoggerStdout -> do
+        delLogger (Just e)
+        se <- liftIO $ newStdoutLoggerSet 10000 -- FIXME: ??
+        pure $ set loggerSet se e
+
+
 setLoggingOff :: forall a m . (MonadIO m, HasLogLevel a) => m ()
 setLoggingOff = do
   let key = logKey @a

hbs2-git/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for hbs2-git
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

hbs2-git/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2023, Dmitry Zuikov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Dmitry Zuikov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hbs2-git/git-hbs2/GitRemoteMain.hs

@@ -0,0 +1,265 @@
+module Main where
+
+import HBS2.Prelude
+import HBS2.Data.Types.Refs
+import HBS2.Base58
+import HBS2.OrDie
+import HBS2.Git.Types
+import HBS2.Git.Local.CLI
+
+import HBS2.System.Logger.Simple
+
+import HBS2Git.Types()
+import HBS2Git.Types qualified as G
+import HBS2Git.App
+import HBS2Git.State
+import HBS2Git.Update
+import HBS2Git.Export
+import HBS2Git.Config as Config
+
+import GitRemoteTypes
+import GitRemotePush
+
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Monad.Reader
+import Data.Attoparsec.Text
+import Data.Attoparsec.Text qualified as Atto
+import Data.ByteString.Char8 qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Foldable
+import Data.Functor
+import Data.HashSet qualified as HashSet
+import Data.Maybe
+import Data.Text qualified as Text
+import System.Environment
+import System.Exit qualified as Exit
+import System.Posix.Signals
+import System.ProgressBar
+import Text.InterpolatedString.Perl6 (qc)
+import UnliftIO.IO as UIO
+import Control.Monad.Trans.Maybe
+
+
+send :: MonadIO m => BS.ByteString -> m ()
+send = liftIO . BS.hPutStr stdout
+
+sendLn :: MonadIO m => BS.ByteString -> m ()
+sendLn s = do
+  trace $ "sendLn" <+> pretty (show s)
+  liftIO $ BS.hPutStrLn stdout s
+
+sendEol :: MonadIO m => m ()
+sendEol = liftIO $ BS.hPutStrLn stdout "" >> hFlush stdout
+
+receive :: MonadIO m => m BS.ByteString
+receive = liftIO $ BS.hGetLine stdin
+
+done :: MonadIO m => m Bool
+done = UIO.hIsEOF stdin
+
+parseRepoURL :: String -> Maybe HashRef
+parseRepoURL url' = either (const Nothing) Just (parseOnly p url)
+  where
+    url = Text.pack url'
+    p = do
+      _ <- string "hbs2://"
+      topic'  <- Atto.manyTill' anyChar endOfInput
+      let topic = BS.unpack <$> fromBase58 (BS.pack topic')
+      maybe (fail "invalid url") (pure . fromString) topic
+
+
+capabilities :: BS.ByteString
+capabilities = BS.unlines ["push","fetch"]
+
+
+readHeadDef :: HasCatAPI m => DBEnv -> m LBS.ByteString
+readHeadDef db  =
+  withDB db stateGetHead >>=
+   \r' -> maybe1 r' (pure "\n") \r -> do
+          readObject r <&> fromMaybe "\n"
+
+loop :: forall m . ( MonadIO m
+                   , HasProgress (RunWithConfig (GitRemoteApp m))
+                   ) => [String] -> GitRemoteApp m ()
+loop args = do
+
+
+  -- setLogging @TRACE tracePrefix
+
+  trace $ "args:" <+> pretty args
+
+  let ref' = case args of
+              [_, s] -> Text.stripPrefix "hbs2://" (Text.pack s) <&> fromString @RepoRef . Text.unpack
+              _      -> Nothing
+
+  ref <- pure ref' `orDie` ("invalid reference: "  <> show args)
+
+  trace $ "ref:" <+> pretty ref
+
+  dbPath <- makeDbPath ref
+
+  trace $ "dbPath:" <+> pretty dbPath
+
+  db <- dbEnv dbPath
+
+  --FIXME: git-fetch-second-time
+  -- Разобраться, почему git fetch срабатывает со второго раза
+
+  -- FIXME: git-push-always-up-to-date
+  --  Разобраться, почему git push всегда говорит
+  --  , что всё up-to-date
+
+  checkRef <- readRef ref <&> isJust
+
+  unless checkRef do
+    warn $ "reference" <+> pretty ref <+> "missing"
+    warn "trying to init reference --- may be it's ours"
+    liftIO $ runApp NoLog (runExport Nothing ref)
+
+  hdRefOld <- readHeadDef db
+
+  updateLocalState ref
+
+  hd <- readHeadDef db
+
+  hashes <- withDB db stateGetAllObjects
+
+  -- FIXME: asap-get-all-existing-objects-or-all-if-clone
+  --   если clone - доставать всё
+  --   если fetch - брать список объектов и импортировать
+  --   только те, которых нет в репо
+
+  existed <- gitListAllObjects <&> HashSet.fromList
+
+  jobz <- liftIO newTQueueIO
+
+  -- TODO: check-if-fetch-really-works
+  -- TODO: check-if-fetch-actually-works
+
+  jobNumT <- liftIO $ newTVarIO 0
+  liftIO $ atomically $ for_ hashes $ \o@(_,gh,_) -> do
+    unless (HashSet.member gh existed) do
+      modifyTVar' jobNumT succ
+      writeTQueue jobz o
+
+  env <- ask
+
+  batch <- liftIO $ newTVarIO False
+
+  fix \next -> do
+
+    eof <- done
+
+    when eof do
+      exitFailure
+
+    s <- receive
+
+    let str = BS.unwords (BS.words s)
+    let cmd = BS.words str
+
+    -- trace $ pretty (fmap BS.unpack cmd)
+    -- hPrint stderr $ show $ pretty (fmap BS.unpack cmd)
+    --
+
+    isBatch <- liftIO $ readTVarIO batch
+
+    case cmd of
+      [] -> do
+        liftIO $ atomically $ writeTVar batch False
+        -- -- FIXME: wtf
+        -- when isBatch next
+        if isBatch then do
+            sendEol
+            next
+          else do
+            updateLocalState ref
+
+      ["capabilities"] -> do
+          trace $ "send capabilities" <+> pretty (BS.unpack capabilities)
+          send capabilities >> sendEol
+          next
+
+      ["list"] -> do
+
+
+        hl <- liftIO $ readTVarIO jobNumT
+        pb <- newProgressMonitor "storing git objects" hl
+
+        -- FIXME: thread-num-hardcoded
+        liftIO $ replicateConcurrently_ 4 $ fix \nl -> do
+          atomically (tryReadTQueue jobz) >>= \case
+            Nothing -> pure ()
+            Just (h,_,t) -> do
+              runRemoteM env do
+                -- FIXME: proper-error-handling
+                o <- readObject h `orDie` [qc|unable to fetch object {pretty t} {pretty h}|]
+                r <- gitStoreObject (GitObject t o)
+
+                when (isNothing r) do
+                  err $ "can't write object to git" <+> pretty h
+
+              G.updateProgress pb 1
+              nl
+
+        for_ (LBS.lines hd) (sendLn . LBS.toStrict)
+        sendEol
+        next
+
+      ["list","for-push"] -> do
+        -- FIXME: send-head-before-update
+        for_ (LBS.lines hdRefOld) (sendLn . LBS.toStrict)
+        sendEol
+        next
+
+      -- TODO: check-if-git-push-works
+      ["fetch", sha1, x] -> do
+        trace $ "fetch" <+> pretty (BS.unpack sha1) <+> pretty (BS.unpack x)
+        liftIO $ atomically $ writeTVar batch True
+        next
+
+      ["push", rr] -> do
+        let bra = BS.split ':' rr
+        let pu = fmap (fromString' . BS.unpack) bra
+        liftIO $ atomically $ writeTVar batch True
+        push ref pu
+        next
+
+      other -> die $ show other
+
+  where
+    fromString' "" = Nothing
+    fromString' x  = Just $ fromString x
+
+main :: IO ()
+main = do
+
+  hSetBuffering stdin  NoBuffering
+  hSetBuffering stdout LineBuffering
+
+  doTrace <- lookupEnv "HBS2TRACE" <&> isJust
+
+  when doTrace do
+    setLogging @DEBUG  debugPrefix
+    setLogging @TRACE  tracePrefix
+
+  setLogging @NOTICE noticePrefix
+  setLogging @ERROR  errorPrefix
+  setLogging @WARN   warnPrefix
+  setLogging @INFO   infoPrefix
+
+  args <- getArgs
+
+  void $ installHandler sigPIPE Ignore Nothing
+
+  env <- RemoteEnv <$> detectHBS2PeerCatAPI
+                   <*> detectHBS2PeerSizeAPI
+                   <*> liftIO (newTVarIO mempty)
+
+  runRemoteM env do
+    loop args
+
+  shutUp
+
+

hbs2-git/git-hbs2/GitRemotePush.hs

@@ -0,0 +1,101 @@
+{-# Language AllowAmbiguousTypes #-}
+module GitRemotePush where
+
+import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs
+import HBS2.OrDie
+import HBS2.System.Logger.Simple
+import HBS2.Net.Auth.Credentials hiding (getCredentials)
+-- import HBS2.Merkle
+-- import HBS2.Hash
+
+import HBS2.Git.Local
+import HBS2.Git.Local.CLI
+
+import HBS2Git.Config as Config
+import HBS2Git.Types
+import HBS2Git.State
+import HBS2Git.App
+import HBS2Git.Export (export)
+
+import GitRemoteTypes
+
+import Data.Maybe
+import Control.Monad.Reader
+import Data.Functor
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Lens.Micro.Platform
+import Data.HashMap.Strict qualified as HashMap
+import Text.InterpolatedString.Perl6 (qc)
+import Data.ByteString qualified as BS
+import Control.Concurrent.STM.TVar
+import Control.Concurrent.STM
+
+newtype RunWithConfig m a =
+  WithConfig { fromWithConf :: ReaderT [Syntax C] m a }
+  deriving newtype ( Applicative
+                   , Functor
+                   , Monad
+                   , MonadIO
+                   , MonadReader [Syntax C]
+                   , MonadTrans
+                   )
+
+
+runWithConfig :: MonadIO m => [Syntax C] -> RunWithConfig m a -> m a
+runWithConfig conf m = runReaderT (fromWithConf m) conf
+
+instance MonadIO m => HasConf (RunWithConfig (GitRemoteApp m)) where
+  getConf = ask
+
+instance MonadIO m => HasCatAPI (RunWithConfig (GitRemoteApp m)) where
+  getHttpCatAPI = lift getHttpCatAPI
+  getHttpSizeAPI = lift getHttpSizeAPI
+
+instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where
+  getCredentials = lift . getCredentials
+  setCredentials r c = lift $ setCredentials r c
+
+push :: forall  m . ( MonadIO m
+                    , HasProgress (RunWithConfig (GitRemoteApp m))
+                    )
+
+     => RepoRef -> [Maybe GitRef] -> GitRemoteApp m ()
+
+push remote [bFrom , Just br] = do
+
+  (_, syn) <- Config.configInit
+
+  dbPath <- makeDbPath remote
+  db <- dbEnv dbPath
+
+  runWithConfig syn do
+
+    brCfg <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
+
+    loadCredentials mempty
+
+    oldHead <- readHead db <&> fromMaybe mempty
+
+    newHead <- case bFrom of
+                Just newBr -> do
+                   gh <- gitGetHash (normalizeRef newBr) `orDie` [qc|can't read hash for ref {pretty newBr}|]
+                   pure $ over repoHeads (HashMap.insert br gh) oldHead
+
+                Nothing -> do
+                  warn $ "about to delete branch" <+> pretty br <+> pretty "in" <+> pretty remote
+
+                  when ( br `Set.member` brCfg ) do
+                    err $ "remove" <+> pretty br <+> "from config first"
+                    exitFailure
+
+                  pure $ over repoHeads (HashMap.delete br) oldHead
+
+    (root, hh) <- export remote newHead
+
+    info  $ "head:" <+> pretty hh
+    info  $ "merkle:" <+> pretty root
+
+push r w = warn $ "ignoring weird push" <+> pretty w <+> pretty r
+

hbs2-git/git-hbs2/GitRemoteTypes.hs

@@ -0,0 +1,54 @@
+{-# Language TemplateHaskell #-}
+{-# Language UndecidableInstances #-}
+module GitRemoteTypes where
+
+import HBS2.Prelude
+import HBS2.OrDie
+import HBS2.Net.Auth.Credentials (PeerCredentials)
+import HBS2.Net.Proto.Definition()
+
+import HBS2Git.Types
+import Control.Monad.Reader
+import Lens.Micro.Platform
+import Data.HashMap.Strict qualified as HashMap
+import Data.HashMap.Strict (HashMap)
+import Control.Concurrent.STM
+
+data RemoteEnv =
+  RemoteEnv
+  { _reHttpCat :: API
+  , _reHttpSize :: API
+  , _reCreds :: TVar (HashMap RepoRef (PeerCredentials Schema))
+  }
+
+makeLenses 'RemoteEnv
+
+newtype GitRemoteApp m a =
+  GitRemoteApp { fromRemoteApp :: ReaderT RemoteEnv m a }
+  deriving newtype ( Applicative
+                   , Functor
+                   , Monad
+                   , MonadIO
+                   , MonadReader RemoteEnv
+                   )
+
+runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a
+runRemoteM env m = runReaderT (fromRemoteApp m) env
+
+instance MonadIO m => HasCatAPI (GitRemoteApp m) where
+  getHttpCatAPI = view (asks reHttpCat)
+  getHttpSizeAPI = view (asks reHttpSize)
+
+instance MonadIO m => HasRefCredentials (GitRemoteApp m) where
+
+  setCredentials ref cred = do
+    asks (view reCreds) >>= \t -> liftIO $ atomically $
+      modifyTVar' t (HashMap.insert ref cred)
+
+  getCredentials ref = do
+    hm <- asks (view reCreds) >>= liftIO . readTVarIO
+    pure (HashMap.lookup ref hm) `orDie` "keyring not set"
+
+
+
+

hbs2-git/git-hbs2/Main.hs

@@ -0,0 +1,40 @@
+module Main where
+
+import HBS2.Prelude
+import HBS2.System.Logger.Simple hiding (info)
+
+import HBS2Git.App
+import HBS2Git.Export
+import HBS2Git.ListRefs
+
+import RunShow
+
+import Options.Applicative as O
+import Control.Monad
+
+main :: IO ()
+main = join . customExecParser (prefs showHelpOnError) $
+  info (helper <*> parser)
+  (  fullDesc
+  <> header "hbsync block fetch"
+  <> progDesc "fetches blocks from hbsync peers"
+  )
+  where
+    parser ::  Parser (IO ())
+    parser = hsubparser (  command "export"    (info pExport (progDesc "export repo"))
+                        <> command "list-refs" (info pListRefs (progDesc "list refs"))
+                        <> command "show"      (info pShow  (progDesc "show current state"))
+                        )
+
+    pExport = do
+      ref  <- strArgument (metavar "HASH-REF")
+      kr   <- optional $ strOption (short 'k' <> long "keyring" <> metavar "KEYRING-FILE")
+      pure $ runApp WithLog (runExport kr ref)
+
+    pListRefs = do
+      pure $ runApp NoLog runListRefs
+
+    pShow = do
+      ref <- strArgument (metavar "HASH-REF")
+      pure $ runApp NoLog (runShow ref)
+

hbs2-git/git-hbs2/RunShow.hs

@@ -0,0 +1,31 @@
+module RunShow where
+
+import HBS2.Prelude
+import HBS2.Base58
+
+import HBS2.System.Logger.Simple
+import HBS2.Git.Types
+import HBS2Git.App
+import HBS2Git.State
+
+import Data.Foldable
+
+runShow :: MonadIO m => RepoRef -> App m ()
+runShow h = do
+  shutUp
+  setLogging @INFO infoPrefix
+
+  db <- makeDbPath h >>= dbEnv
+
+  withDB db do
+
+    hd <- stateGetHead
+    imported <- stateGetLastImported 10
+
+    info $ "current state for" <+> pretty (AsBase58 h)
+    info $ "head:" <+> pretty hd
+    info $ "last operations:" <> line
+
+    for_ imported $ \(t,h1,h2) -> do
+      info $ pretty t <+> pretty h1 <+> pretty h2
+

hbs2-git/hbs2-git.cabal

@@ -0,0 +1,156 @@
+cabal-version:      3.0
+name:               hbs2-git
+version:            0.1.0.0
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+maintainer:         dzuikov@gmail.com
+-- copyright:
+category:           Development
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common shared-properties
+  ghc-options:
+        -Wall
+        -Wno-type-defaults
+        -- -fno-warn-unused-matches
+        -- -fno-warn-unused-do-bind
+        -- -Werror=missing-methods
+        -- -Werror=incomplete-patterns
+        -- -fno-warn-unused-binds
+
+
+  default-language:    Haskell2010
+
+  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
+               , aeson
+               , async
+               , base16-bytestring
+               , bytestring
+               , cache
+               , containers
+               , cryptonite
+               , directory
+               , filepath
+               , interpolatedstring-perl6
+               , memory
+               , microlens-platform
+               , mtl
+               , prettyprinter
+               , safe
+               , serialise
+               , suckless-conf
+               , text
+               , transformers
+               , typed-process
+               , uniplate
+               , hashable
+               , sqlite-simple
+               , stm
+               , unordered-containers
+               , filelock
+               , http-conduit
+
+library
+    import:           shared-properties
+
+    exposed-modules:
+      HBS2.Git.Types
+      HBS2.Git.Local
+      HBS2.Git.Local.CLI
+      HBS2Git.Types
+      HBS2Git.Export
+      HBS2Git.Import
+      HBS2Git.ListRefs
+      HBS2Git.Config
+      HBS2Git.App
+      HBS2Git.State
+      HBS2Git.Update
+
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    base
+                   ,  terminal-progress-bar
+
+    hs-source-dirs:   lib
+    default-language: Haskell2010
+
+executable git-hbs2
+    import:           shared-properties
+    main-is:          Main.hs
+
+    ghc-options:
+        -threaded
+        -rtsopts
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+    other-modules:
+      RunShow
+
+    -- other-extensions:
+    build-depends:
+        base, hbs2-git
+      , optparse-applicative
+
+    hs-source-dirs:   git-hbs2
+    default-language: Haskell2010
+
+
+executable git-remote-hbs2
+    import:           shared-properties
+    main-is:          GitRemoteMain.hs
+
+    ghc-options:
+        -threaded
+        -rtsopts
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
+
+    other-modules:
+      GitRemoteTypes
+      GitRemotePush
+
+    -- other-extensions:
+    build-depends:
+        base, hbs2-git
+      , async
+      , attoparsec
+      , optparse-applicative
+      , unix
+      , unliftio
+      , terminal-progress-bar
+
+    hs-source-dirs:   git-hbs2
+    default-language: Haskell2010
+

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

@@ -0,0 +1,31 @@
+module HBS2.Git.Local
+  ( module HBS2.Git.Types
+  , module HBS2.Git.Local
+  )where
+
+import HBS2.Git.Types
+
+import Data.Functor
+import Data.String
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Set (Set)
+import Data.Set qualified as Set
+import System.Directory
+import System.FilePath
+
+gitReadRefs :: MonadIO m => FilePath -> Set String -> m [(GitRef, GitHash)]
+gitReadRefs p m = do
+
+  xs <- forM (Set.toList m) $ \br -> do
+          let fn = p </> "refs/heads" </> br
+          here <- liftIO $ doesFileExist fn
+          if here then do
+            s <- liftIO $ readFile fn <&> (fromString br,) . fromString
+            pure [s]
+          else do
+            pure mempty
+
+  pure $ mconcat xs
+
+

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

@@ -0,0 +1,258 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Git.Local.CLI where
+
+import HBS2.Git.Types
+
+import HBS2.System.Logger.Simple
+
+import Control.Concurrent.Async
+import Control.Monad.IO.Class
+import Control.Monad.Writer
+import Data.ByteString.Char8 qualified as BS8
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Function
+import Data.Maybe
+import Data.Set qualified as Set
+import Data.Set (Set)
+import Data.String
+import Data.Text.Encoding qualified as Text
+import Data.Text.Encoding (decodeLatin1)
+import Data.Text qualified as Text
+import Data.Text (Text)
+import Prettyprinter
+import Safe
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+
+-- FIXME: specify-git-dir
+
+parseHash :: BS8.ByteString -> GitHash
+parseHash = fromString . BS8.unpack
+
+parseHashLazy :: LBS.ByteString -> GitHash
+parseHashLazy = fromString . BS8.unpack . LBS.toStrict
+
+gitGetDepsPure :: GitObject -> Set GitHash
+
+gitGetDepsPure (GitObject Tree bs) = Set.fromList $ execWriter (go bs)
+  where
+    go :: ByteString -> Writer [GitHash] ()
+    go s = case LBS.uncons s of
+      Nothing -> pure ()
+      Just ('\x00', rest) -> do
+        let (hash, rest') = LBS.splitAt 20 rest
+        tell [GitHash (LBS.toStrict hash)]
+        go rest'
+
+      Just (_, rest) -> go rest
+
+gitGetDepsPure (GitObject Commit bs) = Set.fromList (recurse ls)
+  where
+    ls = LBS.lines bs
+    recurse :: [LBS.ByteString] -> [GitHash]
+    recurse [] = []
+    recurse ("":_)  = []
+    recurse (x:xs) =
+      case LBS.words x of
+        ["tree", s]   -> fromString (LBS.unpack s) : recurse xs
+        ["parent", s] -> fromString (LBS.unpack s) : recurse xs
+        _             -> recurse xs
+
+
+gitGetDepsPure _ = mempty
+
+
+
+
+gitGetObjectType :: MonadIO m => GitHash -> m (Maybe GitObjectType)
+gitGetObjectType hash = do
+  (_, out, _) <- readProcess (shell [qc|git cat-file -t {pretty hash}|])
+  case headMay (LBS.words out) of
+    Just "commit" -> pure (Just Commit)
+    Just "tree"   -> pure (Just Tree)
+    Just "blob"   -> pure (Just Blob)
+    _        -> pure Nothing
+
+
+
+gitGetCommitDeps :: MonadIO m => GitHash -> m [GitHash]
+gitGetCommitDeps hash  = do
+  (_, out, _) <- readProcess (shell [qc|git cat-file commit {pretty hash}|])
+  pure $ Set.toList (gitGetDepsPure (GitObject Commit out))
+
+gitGetTreeDeps :: MonadIO m => GitHash -> m [GitHash]
+gitGetTreeDeps hash = do
+  (_, out, _) <- readProcess (shell [qc|git ls-tree {pretty hash}|])
+  let ls =  fmap parseHash . getHash <$> BS8.lines (LBS.toStrict out)
+  pure (catMaybes ls)
+  where
+    getHash = flip atMay 2 . BS8.words
+
+
+gitGetDependencies :: MonadIO m => GitHash -> m [GitHash]
+gitGetDependencies hash = do
+  ot <- gitGetObjectType hash
+  case ot of
+    Just Commit -> gitGetCommitDeps hash
+    Just Tree   -> gitGetTreeDeps hash
+    _           -> pure mempty
+
+
+gitGetTransitiveClosure :: forall cache . (HasCache cache GitHash (Set GitHash) IO)
+                        => cache
+                        -> Set GitHash
+                        -> GitHash
+                        -> IO (Set GitHash)
+
+gitGetTransitiveClosure cache exclude hash = do
+    -- trace $ "gitGetTransitiveClosure" <+> pretty hash
+    r <- cacheLookup cache hash :: IO (Maybe (Set GitHash))
+    case r of
+      Just xs -> pure xs
+      Nothing -> do
+        deps <- gitGetDependencies hash
+        clos <- mapConcurrently (gitGetTransitiveClosure cache exclude) deps
+        let res = (Set.fromList (hash:deps) <> Set.unions clos) `Set.difference` exclude
+        cacheInsert cache hash res
+        pure res
+
+
+-- FIXME: inject-git-working-dir-via-typeclass
+
+gitConfigGet :: MonadIO m => Text -> m (Maybe Text)
+gitConfigGet k = do
+  let cmd = [qc|git config {k}|]
+  (code, out, _) <- liftIO $ readProcess (shell cmd)
+
+  case code of
+    ExitSuccess -> pure (Just $ Text.strip [qc|{LBS.unpack out}|])
+    _           -> pure Nothing
+
+
+gitConfigSet :: MonadIO m => Text -> Text -> m ()
+gitConfigSet k v = do
+  let cmd = [qc|git config --add {k} {v}|]
+  liftIO $ putStrLn cmd
+  runProcess_ (shell cmd)
+
+gitGetRemotes :: MonadIO m => m [(Text,Text)]
+gitGetRemotes = do
+  let cmd = [qc|git config --get-regexp '^remote\..*\.url$'|]
+  (code, out, _) <- liftIO $ readProcess (shell cmd)
+
+  let txt = Text.decodeUtf8 (LBS.toStrict out)
+
+  let ls = Text.lines txt -- & foldMap (drop 1 . Text.words)
+
+  remotes <- forM ls $ \l ->
+                case Text.words l of
+                  [r,val] | Text.isPrefixOf "remote." r -> pure $ (,val) <$> stripRemote r
+                  _       -> pure Nothing
+
+  pure $ catMaybes remotes
+
+  where
+    stripRemote x = headMay $ take 1 $ drop 1 $ Text.splitOn "." x
+
+-- FIXME: respect-git-workdir
+gitHeadFullName :: MonadIO m => GitRef -> m GitRef
+gitHeadFullName (GitRef r) = do
+  let r' = Text.stripPrefix "refs/heads" r & fromMaybe r
+  pure $ GitRef $ "refs/heads/" <> r'
+
+-- FIXME: error handling!
+gitReadObject :: MonadIO m => Maybe GitObjectType -> GitHash -> m LBS.ByteString
+gitReadObject mbType' hash = do
+
+  mbType'' <- case mbType' of
+    Nothing -> gitGetObjectType hash
+    Just tp -> pure (Just tp)
+
+  oType <- maybe (error [qc|unknown type of {pretty hash}|]) pure mbType''
+
+  -- liftIO $ hPutStrLn stderr [qc|git cat-file {pretty oType} {pretty hash}|]
+
+  (_, out, _) <- readProcess (shell [qc|git cat-file {pretty oType} {pretty hash}|])
+
+  pure out
+
+
+gitRemotes :: MonadIO m => m (Set GitRef)
+gitRemotes = do
+  let cmd = setStdin closed $ setStdout closed
+                            $ setStderr closed
+                            $ shell [qc|git remote|]
+
+  (_, out, _) <- readProcess cmd
+  let txt = decodeLatin1 (LBS.toStrict out)
+  pure $ Set.fromList (GitRef . Text.strip <$> Text.lines txt)
+
+
+gitNormalizeRemoteBranchName :: MonadIO  m => GitRef -> m GitRef
+gitNormalizeRemoteBranchName orig@(GitRef ref) = do
+  remotes <- gitRemotes
+  stripped <- forM (Set.toList remotes) $ \(GitRef remote) -> do
+     pure $ GitRef <$> (("refs/heads" <>) <$> Text.stripPrefix remote ref)
+
+
+  let GitRef r = headDef orig (catMaybes stripped)
+
+  if Text.isPrefixOf "refs/heads" r
+      then pure (GitRef r)
+      else pure (GitRef $ "refs/heads/" <> r)
+
+
+gitStoreObject :: MonadIO m => GitObject -> m (Maybe GitHash)
+gitStoreObject (GitObject t s) = do
+  let cmd = [qc|git hash-object -t {pretty t} -w --stdin|]
+  let procCfg = setStdin (byteStringInput s) $ setStderr closed
+                                             (shell cmd)
+  (code, out, _) <- readProcess procCfg
+  case code of
+    ExitSuccess -> pure $ Just (parseHashLazy out)
+    ExitFailure{} -> pure Nothing
+
+
+gitListAllObjects :: MonadIO m => m [GitHash]
+gitListAllObjects = do
+  let cmd = [qc|git cat-file --batch-check --batch-all-objects|]
+  let procCfg = setStdin closed $ setStderr closed (shell cmd)
+  (_, out, _) <- readProcess procCfg
+
+  pure $ LBS.lines out & foldMap (fromLine . LBS.words)
+
+  where
+    fromLine = \case
+      [ha, _, _] -> [fromString (LBS.unpack ha)]
+      _          -> []
+
+-- FIXME: better error handling
+gitGetHash :: MonadIO m => GitRef -> m (Maybe GitHash)
+gitGetHash ref = do
+
+  trace $ "gitGetHash" <+> [qc|git rev-parse {pretty ref}|]
+
+  (code, out, _) <- readProcess (shell [qc|git rev-parse {pretty ref}|])
+
+  if code == ExitSuccess then do
+    let hash = fromString . LBS.unpack <$> headMay (LBS.lines out)
+    pure hash
+  else
+    pure Nothing
+
+
+gitListLocalBranches :: MonadIO m => m [(GitRef, GitHash)]
+gitListLocalBranches  = do
+  let cmd = [qc|git branch --format='%(objectname) %(refname)'|]
+  let procCfg = setStdin closed $ setStderr closed (shell cmd)
+  (_, out, _) <- readProcess procCfg
+
+  pure $ LBS.lines out & foldMap (fromLine . LBS.words)
+
+  where
+    fromLine = \case
+      [h, n] -> [(fromString (LBS.unpack n), fromString (LBS.unpack h))]
+      _      -> []
+
+

hbs2-git/lib/HBS2/Git/Types.hs

@@ -0,0 +1,115 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2.Git.Types where
+
+import HBS2.Prelude
+import HBS2.System.Logger.Simple
+
+import Crypto.Hash hiding (SHA1)
+import Crypto.Hash qualified as Crypto
+import Data.Aeson
+import Data.ByteArray qualified as BA
+import Data.ByteString.Base16 qualified as B16
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Data
+import Data.Generics.Uniplate.Data()
+import Data.String (IsString(..))
+import Data.Text.Encoding (decodeLatin1)
+import Data.Text qualified as Text
+import Data.Text (Text)
+import GHC.Generics
+import Prettyprinter
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Hashable
+import Codec.Serialise
+import Data.Maybe
+
+class Monad m => HasCache t k v m where
+  cacheLookup  :: t -> k -> m (Maybe v)
+  cacheInsert  :: t -> k -> v -> m ()
+
+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 Pretty GitHash where
+  pretty (GitHash s) = pretty @String [qc|{B16.encode s}|]
+
+
+data GitObjectType = Commit | Tree | Blob
+                     deriving stock (Eq,Ord,Show,Generic)
+
+instance ToJSON GitObjectType
+instance FromJSON GitObjectType
+
+instance IsString GitObjectType where
+  fromString = \case
+    "commit" -> Commit
+    "tree"   -> Tree
+    "blob"   -> Blob
+    x        -> error [qc|invalid git object type {x}|]
+
+instance Pretty GitObjectType where
+  pretty = \case
+    Commit -> pretty @String "commit"
+    Tree   -> pretty @String "tree"
+    Blob   -> pretty @String "blob"
+
+
+data GitObject = GitObject GitObjectType LBS.ByteString
+
+newtype GitRef = GitRef { unGitRef :: Text }
+                 deriving stock (Eq,Ord,Data,Generic,Show)
+                 deriving newtype (IsString,FromJSON,ToJSON,Monoid,Semigroup,Hashable)
+
+instance Serialise GitRef
+
+mkGitRef :: ByteString -> GitRef
+mkGitRef x = GitRef (decodeLatin1 x)
+
+instance Pretty GitRef where
+  pretty (GitRef x) = pretty @String [qc|{x}|]
+
+
+instance FromJSONKey GitRef where
+  fromJSONKey = FromJSONKeyText GitRef
+
+class Monad m => HasDependecies m a where
+  getDependencies :: a -> m [GitHash]
+
+class GitHashed a where
+  gitHashObject :: a -> GitHash
+
+instance GitHashed LBS.ByteString where
+  gitHashObject s = GitHash $ BA.convert digest
+    where
+      digest = hashlazy s :: Digest Crypto.SHA1
+
+instance GitHashed GitObject where
+  gitHashObject (GitObject t c) = gitHashObject  (hd <> c)
+    where
+      hd = LBS.pack $ show (pretty t) <> " " <> show (LBS.length c) <> "\x0"
+
+normalizeRef :: GitRef -> GitRef
+normalizeRef (GitRef x) = GitRef "refs/heads/" <> GitRef (fromMaybe x (Text.stripPrefix "refs/heads/" (strip x)))
+  where
+    strip = Text.dropWhile (=='+')
+
+
+shutUp :: MonadIO m => m ()
+shutUp = do
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @NOTICE
+  setLoggingOff @TRACE
+
+

hbs2-git/lib/HBS2Git/App.hs

@@ -0,0 +1,331 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module HBS2Git.App
+  ( module HBS2Git.App
+  , module HBS2Git.Types
+  )
+  where
+
+import HBS2.Prelude
+import HBS2.Data.Types.Refs
+import HBS2.Base58
+import HBS2.OrDie
+import HBS2.Hash
+import HBS2.System.Logger.Simple
+import HBS2.Merkle
+import HBS2.Git.Types
+import HBS2.Net.Proto.Definition()
+import HBS2.Net.Auth.Credentials hiding (getCredentials)
+import HBS2.Net.Proto.RefLog
+
+import HBS2Git.Types
+import HBS2Git.Config as Config
+import HBS2Git.State
+
+import Data.Maybe
+import Control.Monad.Trans.Maybe
+import Data.Foldable
+import Data.Either
+import Control.Monad.Reader
+import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.ByteString.Char8 qualified as B8
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Lens.Micro.Platform
+import System.Directory
+-- import System.FilePath
+import System.FilePath
+import System.Process.Typed
+import Text.InterpolatedString.Perl6 (qc)
+import Network.HTTP.Simple
+import Control.Concurrent.STM
+import Codec.Serialise
+import Data.HashMap.Strict qualified as HashMap
+import Data.List qualified as List
+import Data.Text qualified as Text
+
+instance MonadIO m => HasCfgKey ConfBranch (Set String) m where
+  key = "branch"
+
+instance MonadIO m => HasCfgKey ConfBranch (Set GitRef) m where
+  key = "branch"
+
+instance MonadIO m => HasCfgKey HeadBranch (Maybe GitRef) m where
+  key = "head-branch"
+
+instance MonadIO m => HasCfgKey KeyRingFile (Maybe FilePath) m where
+  key = "keyring"
+
+instance MonadIO m => HasCfgKey KeyRingFiles (Set FilePath) m where
+  key = "keyring"
+
+instance MonadIO m => HasCfgKey StoragePref (Maybe FilePath) m where
+  key = "storage"
+
+logPrefix s = set loggerTr (s <>)
+
+tracePrefix :: SetLoggerEntry
+tracePrefix  = toStderr . logPrefix "[trace] "
+
+debugPrefix :: SetLoggerEntry
+debugPrefix  = toStderr . logPrefix "[debug] "
+
+errorPrefix :: SetLoggerEntry
+errorPrefix  = toStderr . logPrefix "[error] "
+
+warnPrefix :: SetLoggerEntry
+warnPrefix   = toStderr . logPrefix "[warn] "
+
+noticePrefix :: SetLoggerEntry
+noticePrefix = toStderr
+
+infoPrefix :: SetLoggerEntry
+infoPrefix = toStderr
+
+data WithLog = NoLog | WithLog
+
+instance MonadIO m => HasCatAPI (App m) where
+  getHttpCatAPI = asks (view appPeerHttpCat)
+  getHttpSizeAPI = asks (view appPeerHttpSize)
+
+instance MonadIO m => HasRefCredentials (App m) where
+  setCredentials ref cred = do
+    asks (view appRefCred) >>= \t -> liftIO $ atomically $
+      modifyTVar' t (HashMap.insert ref cred)
+
+  getCredentials ref = do
+    hm <- asks (view appRefCred) >>= liftIO . readTVarIO
+    pure (HashMap.lookup ref hm) `orDie` "keyring not set"
+
+
+withApp :: MonadIO m => AppEnv -> App m a -> m a
+withApp env m = runReaderT (fromApp m) env
+
+detectHBS2PeerCatAPI :: MonadIO m => m String
+detectHBS2PeerCatAPI = do
+  -- FIXME: hardcoded-hbs2-peer
+  (_, o, _) <- readProcess (shell [qc|hbs2-peer poke|])
+
+  trace $ pretty (LBS.unpack o)
+
+  let dieMsg = "hbs2-peer is down or it's http is inactive"
+
+  let answ = parseTop (LBS.unpack o) & fromRight mempty
+
+  let po = headMay [ n | ListVal (Key "http-port:" [LitIntVal n]) <- answ  ]
+  -- shutUp
+
+  pnum <- pure po `orDie`  dieMsg
+
+  debug $ pretty "using http port" <+> pretty po
+
+  pure [qc|http://localhost:{pnum}/cat|]
+
+
+detectHBS2PeerSizeAPI :: MonadIO m => m String
+detectHBS2PeerSizeAPI = do
+  api <- detectHBS2PeerCatAPI
+  let new = Text.replace "/cat" "/size" $ Text.pack api
+  pure $ Text.unpack new
+
+getAppStateDir :: forall m . MonadIO m => m FilePath
+getAppStateDir = liftIO $ getXdgDirectory XdgData Config.appName
+
+runApp :: MonadIO m => WithLog -> App m () -> m ()
+runApp l m = do
+
+  case l of
+    NoLog   -> pure ()
+    WithLog -> do
+      setLogging @DEBUG  debugPrefix
+      setLogging @ERROR  errorPrefix
+      setLogging @NOTICE noticePrefix
+      setLogging @TRACE  tracePrefix
+      setLogging @INFO   infoPrefix
+
+  (pwd, syn) <- Config.configInit
+
+  xdgstate <- getAppStateDir
+  -- let statePath = xdgstate </> makeRelative home pwd
+  -- let dbPath = statePath </> "state.db"
+  -- db <- dbEnv dbPath
+  -- trace $ "state" <+> pretty statePath
+  -- here <- liftIO $ doesDirectoryExist statePath
+  -- unless here do
+  --   liftIO $ createDirectoryIfMissing True statePath
+  -- withDB db stateInit
+
+  reQ <- detectHBS2PeerCatAPI
+  szQ <- detectHBS2PeerSizeAPI
+
+  mtCred <- liftIO $ newTVarIO mempty
+
+  let env = AppEnv pwd (pwd </> ".git") syn xdgstate reQ szQ mtCred
+
+  runReaderT (fromApp m) env
+
+  debug $ vcat (fmap pretty syn)
+
+  setLoggingOff @DEBUG
+  setLoggingOff @ERROR
+  setLoggingOff @NOTICE
+  setLoggingOff @TRACE
+  setLoggingOff @INFO
+
+readBlock :: forall m . (HasCatAPI m, MonadIO m) => HashRef -> m (Maybe ByteString)
+readBlock h = do
+  -- trace $ "readBlock" <+> pretty h
+  req1 <-  getHttpCatAPI -- asks (view appPeerHttpCat)
+  let reqs = req1 <> "/" <> show (pretty h)
+  req  <- liftIO $ parseRequest reqs
+  httpLBS req <&> getResponseBody <&> Just
+
+getBlockSize :: forall m . (HasCatAPI m, MonadIO m) => HashRef -> m (Maybe Integer)
+getBlockSize h = do
+  req1 <-  getHttpSizeAPI
+  let reqs = req1 <> "/" <> show (pretty h)
+  req  <- liftIO $ parseRequest reqs
+  httpJSONEither req <&> getResponseBody  <&> either (const Nothing) Just
+
+readRef :: MonadIO m => RepoRef -> m (Maybe HashRef)
+readRef r = do
+  let k = pretty (AsBase58 r)
+  trace  [qc|hbs2-peer reflog get {k}|]
+  let cmd = setStdin closed $ setStderr closed
+                            $ shell [qc|hbs2-peer reflog get {k}|]
+  (code, out, _)  <- liftIO $ readProcess cmd
+
+  trace $ viaShow out
+
+  case code of
+    ExitFailure{} -> pure Nothing
+    _  -> do
+      let s = LBS.unpack <$> headMay (LBS.lines out)
+      pure $ s >>= fromStringMay
+
+type ObjType = MTreeAnn [HashRef]
+
+readObject :: forall m . (MonadIO m, HasCatAPI m) => HashRef -> m (Maybe ByteString)
+readObject h = runMaybeT do
+
+  q <- liftIO newTQueueIO
+
+  -- trace $ "readObject" <+> pretty h
+
+  blk <- MaybeT $ readBlock h
+
+  ann <- MaybeT $ pure $ deserialiseOrFail @(MTreeAnn [HashRef]) blk & either (const Nothing) Just
+
+  walkMerkleTree (_mtaTree ann) (lift . readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
+    case hr of
+      Left{} -> mzero
+      Right (hrr :: [HashRef]) -> do
+        for_ hrr $ \(HashRef hx) -> do
+
+            block <- MaybeT $ readBlock (HashRef hx)
+            liftIO $ atomically $ writeTQueue q block
+
+  mconcat <$> liftIO (atomically $ flushTQueue q)
+
+
+postRefUpdate :: (MonadIO m, HasRefCredentials m) => RepoRef -> Integer -> HashRef -> m ()
+postRefUpdate ref seqno hash = do
+  trace $ "refPostUpdate"  <+> pretty seqno <+> pretty hash
+
+  cred <- getCredentials ref
+  let pubk = view peerSignPk cred
+  let privk = view peerSignSk cred
+  let tran = SequentialRef seqno (AnnotatedHashRef Nothing hash)
+  let bs = serialise tran & LBS.toStrict
+  msg <- makeRefLogUpdate @Schema pubk privk bs <&> serialise
+
+  let input = byteStringInput msg
+  let cmd = setStdin input $ shell [qc|hbs2-peer reflog send-raw|]
+
+  (code, _, _)  <- liftIO $ readProcess cmd
+
+  trace $ "hbs2-peer exited with code" <+> viaShow code
+
+storeObject :: (MonadIO m, HasConf m) => ByteString -> ByteString -> m (Maybe HashRef)
+storeObject = storeObjectHBS2Store
+
+-- FIXME: ASAP-store-calls-hbs2
+--   Это может приводить к тому, что если пир и hbs2-peer
+--   смотрят на разные каталоги --- ошибки могут быть очень загадочны.
+--   Нужно починить.
+--
+-- FIXME: support-another-apis-for-storage
+storeObjectHBS2Store :: (MonadIO m, HasConf m) => ByteString -> ByteString -> m (Maybe HashRef)
+storeObjectHBS2Store meta bs = do
+
+  stor <- cfgValue @StoragePref @(Maybe FilePath)
+
+  -- FIXME: fix-temporary-workaround-while-hbs2-is-used
+  --  Пока не избавились от hbs2 store для сохранения объектов
+  --  можно использовать ключ storage в конфиге hbs2-git
+  let pref =  maybe "" (mappend "-p ") stor
+
+  let meta58 = show $ pretty $ B8.unpack $ toBase58 (LBS.toStrict meta)
+
+  -- trace $ "meta58" <+> pretty meta58
+
+  let input = byteStringInput bs
+  let cmd = setStdin input $ setStderr closed
+                           $ shell [qc|hbs2 store --short-meta-base58={meta58} {pref}|]
+
+  (_, out, _) <- liftIO $ readProcess cmd
+
+  case LBS.words out of
+    ["merkle-root:", h] -> pure $ Just $ fromString (LBS.unpack h)
+    _                   -> pure Nothing
+
+
+makeDbPath :: MonadIO m => RepoRef -> m FilePath
+makeDbPath h = do
+  state <- getAppStateDir
+  liftIO $ createDirectoryIfMissing True state
+  pure $ state </> show (pretty (AsBase58 h))
+
+
+readHead :: (MonadIO m, HasCatAPI m) => DBEnv -> m (Maybe RepoHead)
+readHead db = runMaybeT do
+  href <- MaybeT $ withDB db stateGetHead
+  trace $ "repoHead" <+> pretty href
+  bs   <- MaybeT $ readObject href
+
+  let toParse = fmap LBS.words ( LBS.lines bs )
+
+  let fromSymb = Just . fromString . LBS.unpack . LBS.dropWhile (=='@')
+  let fromBS :: forall a . IsString a => LBS.ByteString -> a
+      fromBS = fromString . LBS.unpack
+
+  let parsed = flip foldMap toParse $ \case
+                [a,"HEAD"] -> [RepoHead (fromSymb a) mempty]
+                [h,r]      -> [RepoHead Nothing (HashMap.singleton (fromBS r) (fromBS h))]
+                _          -> mempty
+
+  pure $ mconcat parsed
+
+loadCredentials :: ( MonadIO m
+                   , HasConf m
+                   , HasRefCredentials m
+                   ) => [FilePath] -> m ()
+loadCredentials fp = do
+  krOpt' <- cfgValue @KeyRingFiles @(Set FilePath) <&> Set.toList
+
+  let krOpt = List.nub $ fp <> krOpt'
+
+  when (null krOpt) do
+    die "keyring not set"
+
+  for_ krOpt $ \fn -> do
+    krData <- liftIO $ B8.readFile fn
+    cred <- pure (parseCredentials @Schema (AsCredFile krData)) `orDie` "bad keyring file"
+    let puk = view peerSignPk cred
+    trace $ "got creds for" <+> pretty (AsBase58 puk)
+    setCredentials (RefLogKey puk) cred
+    pure ()
+
+

hbs2-git/lib/HBS2Git/Config.hs

@@ -0,0 +1,78 @@
+module HBS2Git.Config
+  ( module HBS2Git.Config
+  , module Data.Config.Suckless
+  ) where
+
+import HBS2.Prelude
+import HBS2.System.Logger.Simple
+import HBS2.OrDie
+
+import Data.Config.Suckless
+
+import HBS2Git.Types
+
+import Data.Functor
+import System.FilePath
+import System.Directory
+
+-- type C = MegaParsec
+
+appName :: FilePath
+appName = "hbs2-git"
+
+findGitDir :: MonadIO m => FilePath -> m (Maybe FilePath)
+findGitDir dir = liftIO do
+  let gitDir = dir </> ".git"
+  exists <- doesDirectoryExist gitDir
+  if exists
+    then return $ Just gitDir
+    else let parentDir = takeDirectory dir
+         in if parentDir == dir -- we've reached the root directory
+               then return Nothing
+               else findGitDir parentDir
+
+
+configPath :: MonadIO m => FilePath -> m FilePath
+configPath pwd = liftIO do
+  xdg <- liftIO $ getXdgDirectory XdgConfig appName
+  home <- liftIO getHomeDirectory
+  gitDir <- findGitDir pwd `orDie` ".git directory not found"
+  pure $ xdg </> makeRelative home pwd
+
+-- returns current directory, where found .git directory
+configInit :: MonadIO m => m (FilePath, [Syntax C])
+configInit = liftIO do
+  trace "configInit"
+
+  trace "locating .git directory"
+
+  this <- getCurrentDirectory
+
+  gitDir <- findGitDir this `orDie` ".git directory not found"
+
+  let pwd = takeDirectory gitDir
+
+  confP <- configPath pwd
+
+  trace $ "git dir" <+> pretty gitDir
+  trace $ "confPath:" <+> pretty confP
+
+  here <- doesDirectoryExist confP
+
+  unless here do
+    debug $ "create directory" <+> pretty confP
+    createDirectoryIfMissing True confP
+
+  let confFile = confP </> "config"
+
+  confHere <- doesFileExist confFile
+
+  unless confHere do
+    appendFile confFile ""
+
+  cfg <- readFile confFile <&> parseTop <&> either mempty id
+
+  pure (pwd, cfg)
+
+
+

hbs2-git/lib/HBS2Git/Export.hs

@@ -0,0 +1,217 @@
+{-# Language AllowAmbiguousTypes #-}
+module HBS2Git.Export where
+
+import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs
+import HBS2.OrDie
+import HBS2.System.Logger.Simple
+import HBS2.Merkle
+import HBS2.Hash
+import HBS2.Net.Proto.Definition()
+import HBS2.Net.Auth.Credentials hiding (getCredentials)
+import HBS2.Base58
+-- FIXME: UDP-name-is-irrelevant
+import HBS2.Net.Messaging.UDP (UDP)
+
+
+import HBS2.Git.Local
+import HBS2.Git.Local.CLI
+
+import HBS2Git.App
+import HBS2Git.State
+import HBS2Git.Update
+
+import Data.Functor
+import Data.List (sortBy)
+import Control.Applicative
+import Control.Monad.Reader
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.ByteString qualified as BS
+import Data.Cache as Cache
+import Data.Foldable (for_)
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
+import Data.Maybe
+import Data.Set qualified as Set
+import Data.Set (Set)
+import Lens.Micro.Platform
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TVar
+
+data HashCache =
+  HashCache
+  { hCache :: Cache GitHash (Set GitHash)
+  , hDb    :: DBEnv
+  }
+
+instance Hashable GitHash => HasCache HashCache GitHash (Set GitHash) IO where
+  cacheInsert (HashCache cache _) = Cache.insert cache
+
+  cacheLookup (HashCache cache db) k = do
+    refs <- withDB db (stateGetDeps k)
+    case refs of
+      [] -> Cache.lookup' cache k
+      xs -> pure $ Just $ Set.fromList xs
+
+newHashCache :: MonadIO m => DBEnv -> m HashCache
+newHashCache db = do
+  ca <- liftIO $ Cache.newCache Nothing
+  pure $ HashCache ca db
+
+
+export :: forall  m . ( MonadIO m
+                      , HasCatAPI m
+                      , HasConf m
+                      , HasRefCredentials m
+                      , HasProgress m
+                      ) => RepoRef -> RepoHead -> m (HashRef, HashRef)
+export h repoHead = do
+
+  let refs = HashMap.toList (view repoHeads repoHead)
+
+  let repoHeadStr =  (LBS.pack . show . pretty . AsGitRefsFile) repoHead
+
+  dbPath <- makeDbPath h
+
+  trace $ "dbPath" <+> pretty dbPath
+
+  db <- dbEnv dbPath
+
+  cache <- newHashCache db
+
+  notice "calculate dependencies"
+
+  for_ refs $ \(_, h) -> do
+    liftIO $ gitGetTransitiveClosure cache mempty h <&> Set.toList
+
+  -- notice "store dependencies to state"
+
+  sz   <- liftIO $ Cache.size (hCache cache)
+  mon1 <- newProgressMonitor "storing dependencies" sz
+
+  withDB db $ transactional do
+    els <- liftIO $ Cache.toList (hCache cache)
+    for_ els $ \(k,vs,_) -> do
+      updateProgress mon1 1
+      for_ (Set.toList vs) $ \h -> do
+        stateAddDep k h
+
+  deps <- withDB db $ do
+            x <- forM refs $ stateGetDeps . snd
+            pure $ mconcat x
+
+  withDB db $ transactional do -- to speedup inserts
+
+    let metaApp = "application:" <+> "hbs2-git" <> line
+
+    let metaHead = fromString $ show
+                              $ metaApp <> "type:" <+> "head" <> line
+
+    -- let gha = gitHashObject (GitObject Blob repoHead)
+    hh  <- lift $ storeObject metaHead repoHeadStr `orDie` "cant save repo head"
+
+
+    mon3 <- newProgressMonitor "store all objects from repo" (length deps)
+
+    for_ deps $ \d -> do
+      here <- stateGetHash d <&> isJust
+      -- FIXME: asap-check-if-objects-is-in-hbs2
+      unless here do
+        lbs <- gitReadObject Nothing d
+        -- TODO: why-not-default-blob
+        --   anything is blob
+        tp <- gitGetObjectType d <&> fromMaybe Blob --
+
+        let metaO = fromString $ show
+                               $ metaApp
+                               <> "type:" <+> pretty tp <+> pretty d
+                               <> line
+
+
+        hr' <- lift $ storeObject metaO lbs
+
+        maybe1 hr' (pure ()) $ \hr -> do
+          statePutHash tp d hr
+
+        updateProgress mon3 1
+
+    hashes <- (hh : ) <$> stateGetAllHashes
+
+    let pt = toPTree (MaxSize 512) (MaxNum 512) hashes -- FIXME: settings
+
+    tobj <- liftIO newTQueueIO
+    -- FIXME: progress-indicator
+    root <- makeMerkle 0 pt $ \(ha,_,bss) -> do
+      liftIO $ atomically $ writeTQueue tobj (ha,bss)
+
+    objs <- liftIO $ atomically $ flushTQueue tobj
+
+    mon2 <- newProgressMonitor "store objects" (length objs)
+
+    for_ objs $ \(ha,bss) -> do
+      updateProgress mon2 1
+      here <- lift $ getBlockSize (HashRef ha) <&> isJust
+      unless here do
+        void $ lift $ storeObject (fromString (show metaApp)) bss
+
+    trace "generate update transaction"
+
+    trace $ "objects:" <+> pretty (length hashes)
+
+    seqno <- stateGetSequence <&> succ
+    -- FIXME: same-transaction-different-seqno
+    postRefUpdate h seqno (HashRef root)
+
+    pure (HashRef root, hh)
+
+
+runExport :: forall m . (MonadIO m, HasProgress (App m)) => Maybe FilePath -> RepoRef -> App m ()
+runExport fp h = do
+
+  trace $ "Export" <+> pretty (AsBase58 h)
+
+  git <- asks (view appGitDir)
+
+  trace $ "git directory is" <+> pretty git
+
+  loadCredentials (maybeToList fp)
+
+  branches   <- cfgValue @ConfBranch
+
+  -- FIXME: wtf-runExport
+  branchesGr <- cfgValue @ConfBranch <&> Set.map normalizeRef
+  headBranch' <- cfgValue @HeadBranch
+
+  trace $ "BRANCHES" <+> pretty (Set.toList branches)
+
+  let defSort a b = case (a,b) of
+        ("master",_) -> LT
+        ("main", _)  -> LT
+        _            -> GT
+
+  let sortedBr = sortBy defSort $ Set.toList branches
+
+  let headBranch = fromMaybe "master"
+                     $ headBranch' <|> (fromString <$> headMay sortedBr)
+
+  refs <- gitListLocalBranches
+             <&> filter (\x -> Set.member (fst x) branchesGr)
+
+  trace $ "REFS" <+> pretty refs
+
+  fullHead <- gitHeadFullName headBranch
+
+  debug $ "HEAD" <+> pretty fullHead
+
+  let repoHead = RepoHead (Just fullHead)
+                          (HashMap.fromList refs)
+
+  trace $ "NEW REPO HEAD" <+> pretty (AsGitRefsFile repoHead)
+
+  (root, hhh) <- export h repoHead
+
+  updateLocalState h
+
+  info  $ "head:" <+> pretty hhh
+  info  $ "merkle:" <+> pretty root
+

hbs2-git/lib/HBS2Git/Import.hs

@@ -0,0 +1,163 @@
+{-# Language TemplateHaskell #-}
+module HBS2Git.Import where
+
+import HBS2.Prelude.Plated
+import HBS2.Data.Types.Refs
+import HBS2.OrDie
+import HBS2.System.Logger.Simple
+import HBS2.Merkle
+import HBS2.Hash
+import HBS2.Net.Proto.RefLog
+import Text.InterpolatedString.Perl6 (qc)
+import HBS2.Data.Detect hiding (Blob)
+
+import Data.Config.Suckless
+
+import HBS2.Git.Local
+
+import HBS2Git.App
+import HBS2Git.State
+
+import Control.Monad.Trans.Maybe
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TQueue qualified as Q
+import Control.Monad.Reader
+import Data.Foldable (for_)
+import Data.Maybe
+import Data.Text qualified as Text
+import Data.ByteString.Lazy qualified as LBS
+import Lens.Micro.Platform
+-- import System.Exit
+import Codec.Serialise
+
+data RunImportOpts =
+  RunImportOpts
+  { _runImportDry    :: Maybe Bool
+  , _runImportRefVal :: Maybe HashRef
+  }
+
+makeLenses 'RunImportOpts
+
+isRunImportDry :: RunImportOpts -> Bool
+isRunImportDry o = view runImportDry o == Just True
+
+
+walkHashes q h = walkMerkle h (readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
+  case hr of
+    Left hx -> die $ show $ pretty "missed block:" <+> pretty hx
+    Right (hrr :: [HashRef]) -> do
+       forM_ hrr $ liftIO . atomically . Q.writeTQueue q
+
+importRefLog :: (MonadIO m, HasCatAPI m) => DBEnv -> RepoRef -> m ()
+importRefLog db ref = do
+
+  logRoot <- readRef ref `orDie` [qc|can't read ref {pretty ref}|]
+
+  trace $ pretty logRoot
+
+  logQ <- liftIO newTQueueIO
+  walkHashes logQ (fromHashRef logRoot)
+
+  entries <- liftIO $ atomically $ flushTQueue logQ
+
+  forM_ entries $ \e -> do
+
+    missed <- readBlock e <&> isNothing
+
+    when missed do
+      debug $ "MISSED BLOCK" <+> pretty e
+
+    runMaybeT $ do
+      bs <- MaybeT $ readBlock e
+      refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate Schema) bs & either (const Nothing) Just
+      e <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just
+      let (SequentialRef n (AnnotatedHashRef _ h)) = e
+      withDB db $ stateUpdateRefLog n h
+
+  new <- withDB db stateGetHead <&> isNothing
+
+  when new do
+    pure ()
+
+importObjects :: (MonadIO m, HasCatAPI m) => DBEnv -> HashRef -> m ()
+importObjects db root = do
+
+  q <- liftIO newTQueueIO
+
+  walkHashes q (fromHashRef root)
+
+  entries <- liftIO $ atomically $ Q.flushTQueue q
+
+  hd <- pure (headMay entries) `orDie` "no head block found"
+
+  -- TODO: what-if-metadata-is-really-big?
+  hdData <- readBlock hd `orDie` "empty head block"
+
+  let hdBlk = tryDetect (fromHashRef hd) hdData
+
+  let meta = headDef "" [ Text.unpack s | ShortMetadata s <- universeBi hdBlk ]
+
+  syn <- liftIO $ parseTop meta & either (const $ die "invalid head block meta") pure
+
+  let app sy = headDef False
+               [ True
+               | ListVal @C (Key "application:" [SymbolVal "hbs2-git"]) <- sy
+               ]
+
+  let hdd = headDef False
+            [ True
+            | ListVal @C (Key "type:" [SymbolVal "head"]) <- syn
+            ]
+
+  unless ( app syn  && hdd ) do
+    liftIO $ die "invalid head block meta"
+
+  let rest = drop 1 entries
+
+
+  withDB db $ transactional $ do
+
+    trace "ABOUT TO UPDATE HEAD"
+
+    statePutHead hd
+    statePutImported root hd
+
+    mon <- newProgressMonitor "importing objects" (length rest)
+
+    for_ rest $ \r -> do
+
+      updateProgress mon 1
+
+      gh <- stateGetGitHash r <&> isJust
+
+      unless gh do
+
+        blk <- lift $ readBlock r `orDie` "empty data block"
+
+        let what = tryDetect (fromHashRef r) blk
+
+        let short = headDef "" [ s | ShortMetadata s <- universeBi what ]
+
+        let fields = Text.lines short & fmap Text.words
+
+        let fromTxt =  fromString . Text.unpack
+        let fromRec t = Just . (t,) . fromTxt
+
+        hm <- forM fields $ \case
+                ["type:", "blob", x]   -> pure $ fromRec Blob x
+                ["type:", "commit", x] -> pure $ fromRec Commit x
+                ["type:", "tree", x]   -> pure $ fromRec Tree x
+                _                      -> pure Nothing
+
+        case catMaybes hm of
+          [(t,sha1)] -> do
+            trace $ "statePutHash" <+> pretty t <+> pretty sha1
+
+            -- FIXME: return-dry?
+            statePutHash t sha1 r
+
+          _          -> err $ "skipping bad object" <+> pretty r
+
+  pure ()
+
+

hbs2-git/lib/HBS2Git/ListRefs.hs

@@ -0,0 +1,30 @@
+module HBS2Git.ListRefs where
+
+import HBS2Git.Types
+import HBS2Git.App
+
+import HBS2.Git.Local.CLI
+
+import Data.Functor
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Prettyprinter
+
+newtype AsRemoteEntry = AsRemoteEntry (Text,Text)
+
+instance Pretty AsRemoteEntry where
+  pretty (AsRemoteEntry (x,y)) = fill 16 (pretty x) <+> pretty y
+
+-- TODO: backlog-list-refs-all-option
+--  сделать опцию --all которая выведет
+--  все известные ref-ы из стейта.
+--  Сейчас выводятся только локальные
+
+runListRefs :: MonadIO m => App m ()
+runListRefs = do
+  refs <- gitGetRemotes <&> filter isHbs2
+  liftIO $ print $ vcat (fmap (pretty.AsRemoteEntry) refs)
+
+  where
+    isHbs2 (_,b) = Text.isPrefixOf "hbs2://" b
+

hbs2-git/lib/HBS2Git/State.hs

@@ -0,0 +1,243 @@
+module HBS2Git.State where
+
+import HBS2Git.Types
+import HBS2.Data.Types.Refs
+import HBS2.Git.Types
+
+import Data.Functor
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.ToField
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Text.InterpolatedString.Perl6 (qc)
+import Data.String
+import System.Directory
+import System.FilePath
+import Data.Maybe
+import Data.Text (Text)
+import Prettyprinter
+
+instance ToField GitHash where
+  toField h = toField (show $ pretty h)
+
+instance FromField GitHash where
+  fromField = fmap fromString . fromField @String
+
+instance FromField GitObjectType where
+  fromField = fmap fromString . fromField @String
+
+instance ToField HashRef where
+  toField h = toField (show $ pretty h)
+
+
+instance ToField GitObjectType where
+  toField h = toField (show $ pretty h)
+
+instance FromField HashRef where
+  fromField = fmap fromString . fromField @String
+
+
+newtype DB m a =
+  DB { fromDB :: ReaderT DBEnv m a }
+  deriving newtype ( Applicative
+                   , Functor
+                   , Monad
+                   , MonadIO
+                   , MonadReader Connection
+                   , MonadTrans
+                   )
+
+instance (HasRefCredentials m) => HasRefCredentials (DB m) where
+  getCredentials = lift . getCredentials
+
+dbEnv :: MonadIO m => FilePath -> m DBEnv
+dbEnv fp = do
+  let dir = takeDirectory fp
+  liftIO $ createDirectoryIfMissing True dir
+  co <- liftIO $ open fp
+  withDB co stateInit
+  pure co
+
+withDB :: DBEnv -> DB m a -> m a
+withDB env action = runReaderT (fromDB action) env
+
+stateInit :: MonadIO m => DB m ()
+stateInit = do
+  conn <- ask
+  liftIO $ execute_ conn [qc|
+  create table if not exists dep
+  ( object text not null
+  , parent text not null
+  , primary key (object, parent)
+  )
+  |]
+
+  liftIO $ execute_ conn [qc|
+  create table if not exists object
+  ( githash text not null
+  , hash text not null unique
+  , type text not null
+  , primary key (githash,hash)
+  )
+  |]
+
+  liftIO $ execute_ conn [qc|
+  create table if not exists head
+  ( key text not null primary key
+  , hash text not null unique
+  )
+  |]
+
+  liftIO $ execute_ conn [qc|
+  create table if not exists imported
+  ( seq integer primary key autoincrement
+  , ts DATE DEFAULT (datetime('now','localtime'))
+  , merkle text not null
+  , head text not null
+  , unique (merkle,head)
+  )
+  |]
+
+  liftIO $ execute_ conn [qc|
+  create table if not exists reflog
+  ( seq integer primary key
+  , ts DATE DEFAULT (datetime('now','localtime'))
+  , merkle text not null
+  , unique (merkle)
+  )
+  |]
+
+
+transactional :: forall a m . MonadIO m => DB m a -> DB m a
+transactional action = do
+  conn <- ask
+  liftIO $ execute_ conn "begin"
+  x <- action
+  liftIO $ execute_ conn "commit"
+  pure x
+
+-- TODO: backlog-head-history
+--   можно сделать таблицу history, в которую
+--   писать журнал всех изменений голов.
+--   тогда можно будет откатиться на любое предыдущее
+--   состояние репозитория
+
+statePutImported :: MonadIO m => HashRef -> HashRef -> DB m ()
+statePutImported merkle hd = do
+  conn <- ask
+  liftIO $ execute conn [qc|
+  insert into imported (merkle,head) values(?,?)
+  on conflict (merkle,head) do nothing
+  |] (merkle,hd)
+
+stateUpdateRefLog :: MonadIO m => Integer -> HashRef -> DB m ()
+stateUpdateRefLog seqno merkle = do
+  conn <- ask
+  liftIO $ execute conn [qc|
+  insert into reflog (seq,merkle) values(?,?)
+  on conflict (merkle) do nothing
+  on conflict (seq) do nothing
+  |] (seqno,merkle)
+
+stateGetRefLogLast :: MonadIO m => DB m (Maybe (Integer, HashRef))
+stateGetRefLogLast = do
+  conn <- ask
+  liftIO $ query_ conn [qc|
+  select seq, merkle from reflog
+  order by seq desc
+  limit 1
+  |] <&> listToMaybe
+
+statePutHead :: MonadIO m => HashRef -> DB m ()
+statePutHead h = do
+  conn <- ask
+  liftIO $ execute conn [qc|
+  insert into head (key,hash) values('head',?)
+  on conflict (key) do update set hash = ?
+  |] (h,h)
+
+stateGetHead :: MonadIO m => DB m (Maybe HashRef)
+stateGetHead = do
+  conn <- ask
+  liftIO $ query_ conn [qc|
+  select hash from head where key = 'head'
+  limit 1
+  |] <&> listToMaybe . fmap fromOnly
+
+stateAddDep :: MonadIO m => GitHash -> GitHash -> DB m ()
+stateAddDep h1 h2 = do
+  conn <- ask
+  void $ liftIO $ execute conn [qc|
+    insert into dep (object,parent) values(?,?)
+    on conflict (object,parent) do nothing
+    |] (h1,h2)
+
+stateGetDeps :: MonadIO m => GitHash -> DB m [GitHash]
+stateGetDeps h = do
+  conn <- ask
+  liftIO $ query conn [qc|
+  select parent from dep where object = ?
+  |] (Only h) <&> fmap fromOnly
+
+
+statePutHash :: MonadIO m => GitObjectType -> GitHash -> HashRef -> DB m ()
+statePutHash t g h = do
+  conn <- ask
+  liftIO $ execute conn [qc|
+  insert into object (githash,hash,type) values(?,?,?)
+  on conflict (githash,hash) do nothing
+  |] (g,h,t)
+
+stateGetHash :: MonadIO m => GitHash -> DB m (Maybe HashRef)
+stateGetHash h = do
+  conn <- ask
+  liftIO $ query conn [qc|
+  select hash from object where githash = ?
+  limit 1
+  |] (Only h) <&> fmap fromOnly <&> listToMaybe
+
+
+stateGetGitHash :: MonadIO m => HashRef -> DB m (Maybe GitHash)
+stateGetGitHash h = do
+  conn <- ask
+  liftIO $ query conn [qc|
+  select githash from object where hash = ?
+  limit 1
+  |] (Only h) <&> fmap fromOnly <&> listToMaybe
+
+stateGetAllHashes :: MonadIO m => DB m [HashRef]
+stateGetAllHashes = do
+  conn <- ask
+  liftIO $ query_ conn [qc|
+  select distinct(hash) from object
+  |] <&> fmap fromOnly
+
+stateGetAllObjects:: MonadIO m => DB m [(HashRef,GitHash,GitObjectType)]
+stateGetAllObjects = do
+  conn <- ask
+  liftIO $ query_ conn [qc|
+  select hash, githash, type from object
+  |]
+
+stateGetLastImported :: MonadIO m => Int -> DB m [(Text,HashRef,HashRef)]
+stateGetLastImported n = do
+  conn <- ask
+  liftIO $ query conn [qc|
+  select ts, merkle, head from imported
+  order by seq desc
+  limit  ?
+  |] (Only n)
+
+stateGetSequence :: MonadIO m => DB m Integer
+stateGetSequence = do
+  conn <- ask
+  liftIO $ query_ conn [qc|
+    select coalesce(max(seq),0) from reflog;
+  |] <&> fmap fromOnly
+     <&> listToMaybe
+     <&> fromMaybe 0
+
+
+
+

hbs2-git/lib/HBS2Git/Types.hs

@@ -0,0 +1,176 @@
+{-# Language PatternSynonyms #-}
+{-# Language UndecidableInstances #-}
+{-# Language TemplateHaskell #-}
+{-# Language AllowAmbiguousTypes #-}
+module HBS2Git.Types
+  ( module HBS2Git.Types
+  , module Control.Monad.IO.Class
+  )
+  where
+
+import HBS2.Prelude.Plated
+import HBS2.Git.Types
+import HBS2.Net.Messaging.UDP (UDP)
+import HBS2.Data.Types.Refs
+import HBS2.Net.Auth.Credentials
+
+import Data.Config.Suckless
+
+import System.ProgressBar
+import System.Exit as Exit
+import Control.Monad.Trans.Maybe
+import Control.Applicative
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Database.SQLite.Simple (Connection)
+import Data.Set qualified as Set
+import Data.Set (Set)
+import Lens.Micro.Platform
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HashMap
+import Codec.Serialise
+import Control.Concurrent.STM
+import System.IO qualified as IO
+import System.IO (Handle)
+import Data.Kind
+
+type Schema = UDP
+
+type API = String
+
+type DBEnv = Connection
+
+type RepoRef = RefLogKey Schema
+
+type C = MegaParsec
+
+data ConfBranch
+data HeadBranch
+data KeyRingFile
+data KeyRingFiles
+data StoragePref
+
+data AppEnv =
+  AppEnv
+  { _appCurDir       :: FilePath
+  , _appGitDir       :: FilePath
+  , _appConf         :: [Syntax C]
+  , _appStateDir     :: FilePath
+  , _appPeerHttpCat  :: String
+  , _appPeerHttpSize :: API
+  , _appRefCred      :: TVar (HashMap RepoRef (PeerCredentials Schema))
+  }
+
+makeLenses 'AppEnv
+
+newtype AsGitRefsFile a = AsGitRefsFile a
+
+data RepoHead =
+  RepoHead
+  { _repoHEAD  :: Maybe GitRef
+  , _repoHeads :: HashMap GitRef GitHash
+  }
+  deriving stock (Generic)
+
+makeLenses 'RepoHead
+
+
+instance Monoid RepoHead where
+  mempty = RepoHead Nothing mempty
+
+instance Semigroup RepoHead where
+  (<>) a b = mempty & set repoHEAD  ( view repoHEAD b <|> view repoHEAD a )
+                    & set repoHeads ( view repoHeads a <> view repoHeads b )
+
+instance Pretty (AsGitRefsFile RepoHead) where
+  pretty (AsGitRefsFile h) = vcat (hhead : fmap fmt els)
+    where
+      hhead = case view repoHEAD h of
+               Nothing -> mempty
+               Just r -> "@" <> pretty r <+> "HEAD"
+
+      els = HashMap.toList (view repoHeads h)
+      fmt (r,hx) = pretty hx <+> pretty (normalizeRef r)
+
+instance Serialise RepoHead
+
+
+pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
+pattern Key n ns <- SymbolVal  n : ns
+
+class HasProgress m where
+  type family ProgressMonitor m :: Type
+  newProgressMonitor :: String -> Int -> m (ProgressMonitor  m)
+  updateProgress :: ProgressMonitor m -> Int -> m ()
+
+
+instance {-# OVERLAPPABLE #-} MonadIO m => HasProgress m where
+  type instance ProgressMonitor m = ProgressBar ()
+  updateProgress bar n = liftIO (incProgress bar n)
+  newProgressMonitor s total = liftIO $ liftIO $ newProgressBar st 10 (Progress 0 total ())
+    where
+      st = defStyle { stylePrefix = msg (fromString s) }
+
+class MonadIO m => HasCatAPI m where
+  getHttpCatAPI  :: m API
+  getHttpSizeAPI :: m API
+
+class MonadIO m => HasRefCredentials m where
+  getCredentials :: RepoRef -> m (PeerCredentials Schema)
+  setCredentials :: RepoRef -> PeerCredentials Schema -> m ()
+
+instance (HasCatAPI m, MonadIO m) => HasCatAPI (MaybeT m) where
+  getHttpCatAPI = lift getHttpCatAPI
+  getHttpSizeAPI = lift getHttpSizeAPI
+
+class Monad m => HasCfgKey a b m where
+  -- type family CfgValue a :: Type
+  key :: Id
+
+class (Monad m, HasCfgKey a b m) => HasCfgValue a b m where
+  cfgValue :: m b
+
+class Monad m => HasConf m where
+  getConf :: m [Syntax C]
+
+newtype App m a =
+  App { fromApp :: ReaderT AppEnv m a }
+  deriving newtype ( Applicative, Functor, Monad, MonadIO, MonadReader AppEnv )
+
+instance MonadIO m => HasConf (App m) where
+  getConf = asks (view appConf)
+
+instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Maybe b) m) => HasCfgValue a (Maybe b) m where
+  cfgValue = lastMay . val <$> getConf
+    where
+      val syn = [ fromString (show $ pretty e)
+                | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b) @m
+                ]
+
+instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b) m) => HasCfgValue a (Set b) m where
+  cfgValue  = Set.fromList . val <$> getConf
+    where
+      val syn = [ fromString (show $ pretty e)
+                | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Set b) @m
+                ]
+
+hPrint :: (Show a, MonadIO m) => Handle -> a -> m ()
+hPrint h s = liftIO $ IO.hPrint h s
+
+hPutStrLn :: (Show a, MonadIO m) => Handle -> String -> m ()
+hPutStrLn h s = liftIO $ IO.hPutStrLn h s
+
+exitSuccess :: MonadIO m => m ()
+exitSuccess = do
+  shutUp
+  liftIO Exit.exitSuccess
+
+exitFailure :: MonadIO m => m ()
+exitFailure = do
+  shutUp
+  liftIO Exit.exitFailure
+
+die :: MonadIO m => String -> m a
+die s = do
+  liftIO $ Exit.die s
+

hbs2-git/lib/HBS2Git/Update.hs

@@ -0,0 +1,37 @@
+module HBS2Git.Update where
+
+import HBS2.Prelude.Plated
+import HBS2.OrDie
+
+import HBS2.System.Logger.Simple
+
+import HBS2.Git.Types
+import HBS2Git.Types
+import HBS2Git.App
+import HBS2Git.State
+import HBS2Git.Import
+
+
+updateLocalState :: (MonadIO m, HasCatAPI m) => RepoRef -> m ()
+updateLocalState ref = do
+
+  dbPath <- makeDbPath ref
+
+  trace $ "dbPath:" <+> pretty dbPath
+
+  db <- dbEnv dbPath
+
+  trace $ "updateLocalState" <+> pretty ref
+
+  -- TODO: read-reflog
+  -- TODO: update-reflog
+  importRefLog db ref
+
+  (n,hash) <- withDB db $ stateGetRefLogLast `orDie` "empty reflog"
+
+  trace $ "got reflog" <+> pretty (n,hash)
+
+  importObjects db hash
+
+  pure ()
+

hbs2-peer/app/BlockDownload.hs

@@ -4,6 +4,7 @@
 module BlockDownload where
 
 import HBS2.Actors.Peer
+import HBS2.Base58
 import HBS2.Clock
 import HBS2.Data.Detect
 import HBS2.Data.Types.Refs
@@ -15,6 +16,7 @@ import HBS2.Net.PeerLocator
 import HBS2.Net.Proto
 import HBS2.Net.Proto.Definition
 import HBS2.Net.Proto.Peer
+import HBS2.Net.Proto.RefLog
 import HBS2.Net.Proto.Sessions
 import HBS2.Prelude.Plated
 import HBS2.Storage
@@ -28,6 +30,7 @@ import Control.Concurrent.STM
 import Control.Monad.Reader
 import Control.Monad.Trans.Maybe
 import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy qualified as LBS
 import Data.Cache qualified as Cache
 import Data.Foldable hiding (find)
 import Data.HashMap.Strict qualified as HashMap
@@ -57,14 +60,23 @@ withBlockForDownload :: (MonadIO m, MyPeer e, HasStorage m, HasPeerLocator e m)
 
 withBlockForDownload p action = do
   -- FIXME: busyloop-e46ad5e0
+  --
+  sto <- lift getStorage
+
   h <- getBlockForDownload
-  banned <- isBanned p h
+
-  trace $ "withBlockForDownload" <+> pretty p <+> pretty h
+  here <- liftIO $ hasBlock sto h <&> isJust
-  if banned then do
+
-    trace $ "skip banned block" <+> pretty p <+> pretty h
+  if here then do
-    addDownload h
+    processBlock h
   else do
-    action h
+    banned <- isBanned p h
+    trace $ "withBlockForDownload" <+> pretty p <+> pretty h
+    if banned then do
+      -- trace $ "skip banned block" <+> pretty p <+> pretty h
+      addDownload h
+    else do
+      action h
 
 addBlockInfo :: (MonadIO m, MyPeer e)
              => Peer e
@@ -133,7 +145,14 @@ processBlock h = do
    case bt of
      Nothing -> addDownload h
 
-     Just (AnnRef{}) -> pure ()
+     Just (SeqRef (SequentialRef n (AnnotatedHashRef a' b))) -> do
+      maybe1 a' none $ \a -> do
+        addDownload (fromHashRef a)
+
+      addDownload (fromHashRef b)
+
+     Just (AnnRef h) -> do
+       addDownload h
 
      Just (MerkleAnn ann) -> do
        case (_mtaMeta ann) of
@@ -354,6 +373,8 @@ blockDownloadLoop :: forall e  m . ( m ~ PeerM e IO
                                    , EventListener e (BlockChunks e) m
                                    , EventListener e (BlockAnnounce e) m
                                    , EventListener e (PeerHandshake e) m
+                                   , EventListener e (RefLogUpdateEv e) m
+                                   , EventListener e (RefLogRequestAnswer e) m
                                    , EventEmitter e (BlockChunks e) m
                                    , EventEmitter e (DownloadReq e) m
                                    , Sessions e (BlockChunks e) m
@@ -369,7 +390,6 @@ blockDownloadLoop :: forall e  m . ( m ~ PeerM e IO
 blockDownloadLoop env0 = do
 
   e    <- ask
-  stor <- getStorage
 
   let blks = mempty
 

hbs2-peer/app/HttpWorker.hs

@@ -0,0 +1,60 @@
+module HttpWorker where
+
+import HBS2.Prelude
+import HBS2.Actors.Peer
+import HBS2.Storage
+
+import HBS2.System.Logger.Simple
+
+import PeerTypes
+import PeerConfig
+
+import Data.Maybe
+import Data.Function
+import Data.Functor
+import Data.Text.Lazy qualified as Text
+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
+
+
+
+-- TODO: introduce-http-of-off-feature
+
+httpWorker :: forall e m . ( MyPeer e
+                           , MonadIO m
+                           , HasStorage m
+                           ) => PeerConfig -> DownloadEnv e -> m ()
+
+httpWorker conf e = do
+
+  sto <- getStorage
+  let port' = cfgValue @PeerHttpPortKey conf  <&>  fromIntegral
+
+  maybe1 port' none $ \port -> liftIO do
+
+    scotty port $ do
+      middleware logStdoutDev
+
+      get "/size/:hash" do
+        what <- param @String "hash" <&> fromString
+        size <- liftIO $ hasBlock sto what
+        case size of
+          Nothing -> status status404
+          Just n -> do
+            json n
+
+      get "/cat/:hash" do
+        what <- param @String "hash" <&> fromString
+        blob <- liftIO $ getBlock sto what
+        case blob of
+          Nothing -> status status404
+          Just lbs -> do
+            addHeader "content-type" "application/octet-stream"
+            addHeader "content-length" [qc|{LBS.length lbs}|]
+            raw lbs
+
+  pure ()
+

hbs2-peer/app/PeerConfig.hs

@@ -42,6 +42,10 @@ pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
 pattern Key n ns <- SymbolVal  n : ns
 
 data PeerDownloadLogKey
+data PeerHttpPortKey
+
+instance HasCfgKey PeerHttpPortKey (Maybe Integer) where
+  key = "http-port"
 
 instance HasCfgKey PeerDownloadLogKey (Maybe String) where
   key = "download-log"
@@ -167,6 +171,15 @@ instance {-# OVERLAPPABLE #-} (IsString b, HasCfgKey a (Maybe b)) => HasCfgValue
                 | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b)
                 ]
 
+
+instance {-# OVERLAPPABLE #-} (HasCfgKey a (Maybe Integer)) => HasCfgValue a (Maybe Integer) where
+  cfgValue (PeerConfig syn) = val
+    where
+      val =
+        lastMay [ e
+                | ListVal @C (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer)
+                ]
+
 instance (HasCfgKey a FeatureSwitch) => HasCfgValue a FeatureSwitch where
   cfgValue (PeerConfig syn) = val
     where

hbs2-peer/app/PeerMain.hs

@@ -11,6 +11,7 @@ import HBS2.Clock
 import HBS2.Defaults
 import HBS2.Events
 import HBS2.Hash
+import HBS2.Data.Types.Refs (RefLogKey(..))
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.IP.Addr
 import HBS2.Net.Messaging.UDP
@@ -20,6 +21,7 @@ import HBS2.Net.Proto.Definition
 import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.PeerAnnounce
 import HBS2.Net.Proto.PeerExchange
+import HBS2.Net.Proto.RefLog
 import HBS2.Net.Proto.Sessions
 import HBS2.OrDie
 import HBS2.Prelude.Plated
@@ -36,22 +38,32 @@ import PeerInfo
 import PeerConfig
 import Bootstrap
 import CheckMetrics
+import RefLog qualified
+import RefLog (reflogWorker)
+import HttpWorker
 
-import Data.Text qualified as Text
+import Codec.Serialise
-import Data.Foldable (for_)
-import Data.Maybe
-import Crypto.Saltine (sodiumInit)
-import Data.Function
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception as Exception
 import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
+import Crypto.Saltine (sodiumInit)
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString qualified as BS
+import Data.Either
+import Data.Foldable (for_)
+import Data.Function
 import Data.List qualified  as L
-import Data.Set qualified as Set
 import Data.Map qualified as Map
+import Data.Maybe
+import Data.Set qualified as Set
+import Data.Set (Set)
+import Data.Text qualified as Text
 import Data.Text (Text)
+import GHC.Stats
+import GHC.TypeLits
 import Lens.Micro.Platform
 import Network.Socket
 import Options.Applicative
@@ -59,11 +71,9 @@ import Prettyprinter
 import System.Directory
 import System.Exit
 import System.IO
-import Data.Set (Set)
-import GHC.TypeLits
-import GHC.Stats
 import System.Metrics
 
+
 defStorageThreads :: Integral a => a
 defStorageThreads = 4
 
@@ -144,6 +154,9 @@ data RPCCommand =
   | FETCH (Hash HbSync)
   | PEERS
   | SETLOG SetLogging
+  | REFLOGUPDATE ByteString
+  | REFLOGFETCH (PubKey 'Sign UDP)
+  | REFLOGGET (PubKey 'Sign UDP)
 
 data PeerOpts =
   PeerOpts
@@ -204,6 +217,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
                         <> command "announce"  (info pAnnounce (progDesc "announce block"))
                         <> command "ping"      (info pPing (progDesc "ping another peer"))
                         <> command "fetch"     (info pFetch (progDesc "fetch block"))
+                        <> command "reflog"    (info pRefLog (progDesc "reflog commands"))
                         <> command "peers"     (info pPeers (progDesc "show known peers"))
                         <> command "log"       (info pLog   (progDesc "set logging level"))
                         )
@@ -276,6 +290,52 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
       pref <- optional $ strArgument ( metavar "DIR" )
       pure $ peerConfigInit pref
 
+    pRefLog = hsubparser (  command "send" (info pRefLogSend (progDesc "send reflog transaction" ))
+                         <> command "send-raw" (info pRefLogSendRaw (progDesc "send reflog raw transaction" ))
+                         <> command "fetch" (info pRefLogFetch (progDesc "fetch reflog from all" ))
+                         <> command "get"   (info pRefLogGet (progDesc "get own reflog from all" ))
+                         )
+
+    pRefLogSend = do
+      rpc <- pRpcCommon
+      kr <- strOption (long  "keyring" <> short 'k' <> help "reflog keyring" <> metavar "FILE")
+      pure $ do
+        setLogging @TRACE tracePrefix
+        trace "pRefLogSend"
+        s <- BS.readFile kr
+        -- FIXME: UDP is weird here
+        creds <- pure (parseCredentials @UDP (AsCredFile s)) `orDie` "bad keyring file"
+        bs <- BS.take defChunkSize  <$> BS.hGetContents stdin
+        let pubk = view peerSignPk creds
+        let privk = view peerSignSk creds
+        msg <- makeRefLogUpdate @UDP pubk privk bs <&> serialise
+        runRpcCommand rpc (REFLOGUPDATE msg)
+
+    pRefLogSendRaw = do
+      rpc <- pRpcCommon
+      pure $ do
+        setLogging @TRACE tracePrefix
+        trace "pRefLogSendRaw"
+        bs <- LBS.take defChunkSize  <$> LBS.hGetContents stdin
+        runRpcCommand rpc (REFLOGUPDATE bs)
+
+    pRefLogFetch = do
+      rpc <- pRpcCommon
+      ref <- strArgument ( metavar "REFLOG-KEY" )
+      pure $ do
+        href <- pure (fromStringMay ref) `orDie` "invalid REFLOG-KEY"
+        setLogging @TRACE tracePrefix
+        trace "pRefLogFetch"
+        runRpcCommand rpc (REFLOGFETCH href)
+
+    pRefLogGet = do
+      rpc <- pRpcCommon
+      ref <- strArgument ( metavar "REFLOG-KEY" )
+      pure $ do
+        href <- pure (fromStringMay ref) `orDie` "invalid REFLOG-KEY"
+        setLogging @TRACE tracePrefix
+        runRpcCommand rpc (REFLOGGET href)
+
 
 myException :: SomeException -> IO ()
 myException e = die ( show e ) >> exitFailure
@@ -335,20 +395,10 @@ instance ( Monad m
 
   response = lift . response
 
-forKnownPeers :: forall e  m . ( MonadIO m
-                               , HasPeerLocator e m
-                               , Sessions e (KnownPeer e) m
-                               , HasPeer e
-                               )
-               =>  ( Peer e -> PeerData e -> m () ) -> m ()
-forKnownPeers m = do
-  pl <- getPeerLocator @e
-  pips <- knownPeers @e pl
-  for_ pips $ \p -> do
-    pd' <- find (KnownPeerKey p) id
-    maybe1 pd' (pure ()) (m p)
 
-runPeer :: forall e . e ~ UDP => PeerOpts -> IO ()
+-- runPeer :: forall e . (e ~ UDP, Nonce (RefLogUpdate e) ~ BS.ByteString) => PeerOpts -> IO ()
+runPeer :: forall e . (e ~ UDP) => PeerOpts -> IO ()
+
 runPeer opts = Exception.handle myException $ do
 
   metrics <- newStore
@@ -453,6 +503,24 @@ runPeer opts = Exception.handle myException $ do
 
             runPeerM penv $ do
               adapter <- mkAdapter
+
+
+              reflogAdapter <- RefLog.mkAdapter
+              reflogReqAdapter <- RefLog.mkRefLogRequestAdapter @e
+
+              let doDownload h = do
+                    withPeerM penv $ withDownload denv (addDownload h)
+
+              let doFetchRef puk = do
+                   withPeerM penv $ do
+                     forKnownPeers @e $ \p _ -> do
+                       request p (RefLogRequest @e puk)
+
+              let rwa = RefLog.RefLogWorkerAdapter
+                   { RefLog.reflogDownload = doDownload
+                   , RefLog.reflogFetch = doFetchRef
+                   }
+
               env <- ask
 
               pnonce <- peerNonce @e
@@ -537,6 +605,8 @@ runPeer opts = Exception.handle myException $ do
                   debug "sending local peer announce"
                   request localMulticast (PeerAnnounce @e pnonce)
 
+                peerThread (httpWorker conf denv)
+
                 peerThread (checkMetrics metrics)
 
                 peerThread (peerPingLoop @e)
@@ -553,6 +623,8 @@ runPeer opts = Exception.handle myException $ do
 
                 peerThread (downloadQueue conf denv)
 
+                peerThread (reflogWorker @e conf rwa)
+
                 peerThread $ forever $ do
                           cmd <- liftIO $ atomically $ readTQueue rpcQ
                           case cmd of
@@ -626,6 +698,20 @@ runPeer opts = Exception.handle myException $ do
                                           withDownload denv $ do
                                             processBlock h
 
+                            REFLOGUPDATE bs -> do
+
+                              trace "REFLOGUPDATE"
+
+                              let msg' = deserialiseOrFail @(RefLogUpdate UDP) bs
+                                          & either (const Nothing) Just
+
+                              when (isNothing msg') do
+                                warn "unable to parse RefLogUpdate message"
+
+                              maybe1 msg' none $ \msg -> do
+                                RefLog.doRefLogUpdate (view refLogId msg, msg)
+                                RefLog.doRefLogBroadCast msg
+
                             _ -> pure ()
 
 
@@ -636,16 +722,32 @@ runPeer opts = Exception.handle myException $ do
                     , makeResponse blockAnnounceProto
                     , makeResponse (withCredentials pc . peerHandShakeProto)
                     , makeResponse peerExchangeProto
+                    , makeResponse (refLogUpdateProto reflogAdapter)
+                    , makeResponse (refLogRequestProto reflogReqAdapter)
                     ]
 
               void $ liftIO $ waitAnyCatchCancel workers
 
+
   let pokeAction _ = do
         who <- thatPeer (Proxy @(RPC e))
         let k = view peerSignPk pc
+        let rpc  = "rpc:" <+> dquotes (pretty (listenAddr udp1))
+        let udp  = "udp:" <+> dquotes (pretty (listenAddr mess))
+
+        let http = case cfgValue @PeerHttpPortKey conf :: Maybe Integer of
+                     Nothing -> mempty
+                     Just p  -> "http-port:" <+> pretty p
+
+        let answ = show $ vcat [ "peer-key:" <+> dquotes (pretty (AsBase58 k))
+                               , rpc
+                               , udp
+                               , http
+                               ]
+
         -- FIXME: to-delete-POKE
         liftIO $ atomically $ writeTQueue rpcQ POKE
-        request who (RPCPokeAnswer @e k)
+        request who (RPCPokeAnswerFull @e (Text.pack answ))
 
   let annAction h = do
         liftIO $ atomically $ writeTQueue rpcQ (ANNOUNCE h)
@@ -685,7 +787,26 @@ runPeer opts = Exception.handle myException $ do
           trace "TraceOff"
           setLoggingOff @TRACE
 
+  let reflogUpdateAction bs = void $ runMaybeT do
+        liftIO $ atomically $ writeTQueue rpcQ (REFLOGUPDATE bs)
+        -- trace $ "reflogUpdateAction"
+        --
+  let reflogFetchAction puk = do
+        trace "reflogFetchAction"
+        void $ liftIO $ async $ withPeerM penv $ do
+          forKnownPeers @e $ \p _ -> do
+            request p (RefLogRequest @e puk)
+
+  let reflogGetAction puk = do
+        trace $ "reflogGetAction" <+> pretty (AsBase58 puk)
+        who <- thatPeer (Proxy @(RPC e))
+        void $ liftIO $ async $ withPeerM penv $ do
+          sto <- getStorage
+          h <- liftIO $ getRef sto (RefLogKey puk)
+          request who (RPCRefLogGetAnswer @e  h)
+
   let arpc = RpcAdapter pokeAction
+                        dontHandle
                         dontHandle
                         annAction
                         pingAction
@@ -694,6 +815,10 @@ runPeer opts = Exception.handle myException $ do
                         peersAction
                         dontHandle
                         logLevelAction
+                        reflogUpdateAction
+                        reflogFetchAction
+                        reflogGetAction
+                        dontHandle
 
   rpc <- async $ runRPC udp1 do
                    runProto @e
@@ -736,10 +861,14 @@ emitToPeer :: ( MonadIO m
 
 emitToPeer env k e = liftIO $ withPeerM env (emit k e)
 
-withRPC :: RPCOpt -> RPC UDP -> IO ()
+rpcClientMain :: RPCOpt -> IO () -> IO ()
-withRPC o cmd = do
+rpcClientMain opt action = do
-
   setLoggingOff @DEBUG
+  action
+
+withRPC :: RPCOpt -> RPC UDP -> IO ()
+withRPC o cmd = rpcClientMain o $ do
+
 
   conf <- peerConfigRead (view rpcOptConf o)
 
@@ -760,11 +889,35 @@ withRPC o cmd = do
 
   pokeQ <- newTQueueIO
 
+  pokeFQ <- newTQueueIO
+
+  refQ <- newTQueueIO
+
+  let  adapter =
+        RpcAdapter dontHandle
+                   (liftIO . atomically . writeTQueue pokeQ)
+                   (liftIO . atomically . writeTQueue pokeFQ)
+                   (const $ liftIO exitSuccess)
+                   (const $ notice "ping?")
+                   (liftIO . atomically . writeTQueue pingQ)
+                   dontHandle
+                   dontHandle
+
+                   (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa
+                   )
+
+                   dontHandle
+                   dontHandle
+                   dontHandle
+                   dontHandle
+
+                   ( liftIO . atomically . writeTQueue refQ )
+
   prpc <- async $ runRPC udp1 do
                     env <- ask
                     proto <- liftIO $ async $ continueWithRPC env $ do
                       runProto @UDP
-                        [ makeResponse (rpcHandler (adapter pingQ pokeQ))
+                        [ makeResponse (rpcHandler adapter)
                         ]
 
                     request rpc cmd
@@ -782,13 +935,13 @@ withRPC o cmd = do
 
 
                       RPCPoke{} -> do
-                        let onTimeout = do pause @'Seconds 0.5
+                        let onTimeout = do pause @'Seconds 1.5
                                            Log.info "no-one-is-here"
                                            exitFailure
 
                         void $ liftIO $ race onTimeout do
-                                 k <- liftIO $ atomically $ readTQueue pokeQ
+                                 k <- liftIO $ atomically $ readTQueue pokeFQ
-                                 Log.info $ "alive-and-kicking" <+> pretty (AsBase58 k)
+                                 Log.info $ pretty k
                                  exitSuccess
 
                       RPCPeers{} -> liftIO do
@@ -797,26 +950,29 @@ withRPC o cmd = do
 
                       RPCLogLevel{} -> liftIO exitSuccess
 
+                      RPCRefLogUpdate{} -> liftIO do
+                        pause @'Seconds 0.1
+                        exitSuccess
+
+                      RPCRefLogFetch {} -> liftIO do
+                        pause @'Seconds 0.5
+                        exitSuccess
+
+                      RPCRefLogGet{} -> liftIO do
+                        void $ liftIO $ race (pause @'Seconds 0.1 >> exitFailure) do
+                                 k <- liftIO $ atomically $ readTQueue refQ
+                                 case k of
+                                  Nothing -> exitFailure
+                                  Just re -> do
+                                   print $ pretty re
+                                   exitSuccess
+
                       _ -> pure ()
 
                     void $ liftIO $ waitAnyCatchCancel [proto]
 
   void $ waitAnyCatchCancel [mrpc, prpc]
 
-  where
-    adapter q pq = RpcAdapter dontHandle
-                          (liftIO . atomically . writeTQueue pq)
-                          (const $ liftIO exitSuccess)
-                          (const $ notice "ping?")
-                          (liftIO . atomically . writeTQueue q)
-                          dontHandle
-                          dontHandle
-
-                          (\(pa, k) -> Log.info $ pretty (AsBase58 k) <+> pretty pa
-                          )
-
-                          dontHandle
-
 runRpcCommand :: RPCOpt -> RPCCommand -> IO ()
 runRpcCommand opt = \case
   POKE -> withRPC opt RPCPoke
@@ -825,6 +981,9 @@ runRpcCommand opt = \case
   FETCH h  -> withRPC opt (RPCFetch h)
   PEERS -> withRPC opt RPCPeers
   SETLOG s -> withRPC opt (RPCLogLevel s)
+  REFLOGUPDATE bs -> withRPC opt (RPCRefLogUpdate bs)
+  REFLOGFETCH k -> withRPC opt (RPCRefLogFetch k)
+  REFLOGGET k -> withRPC opt (RPCRefLogGet k)
 
   _ -> pure ()
 

hbs2-peer/app/PeerTypes.hs

@@ -11,6 +11,7 @@ import HBS2.Events
 import HBS2.Hash
 import HBS2.Net.Messaging.UDP (UDP)
 import HBS2.Net.Proto
+import HBS2.Net.Proto.Peer
 import HBS2.Net.Proto.BlockInfo
 import HBS2.Net.Proto.Definition
 import HBS2.Net.Proto.Sessions
@@ -21,6 +22,7 @@ import HBS2.System.Logger.Simple
 
 import PeerInfo
 
+import Data.Foldable (for_)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad.Reader
@@ -45,6 +47,8 @@ type MyPeer e = ( Eq (Peer e)
 
 data DownloadReq e
 
+data DownloadAsap e
+
 data instance EventKey e (DownloadReq e) =
   DownloadReqKey
   deriving (Generic,Typeable,Eq)
@@ -64,6 +68,8 @@ instance EventType ( Event e (DownloadReq e) ) where
 instance Expires (EventKey e (DownloadReq e)) where
   expiresIn = const Nothing
 
+
+
 type DownloadFromPeerStuff e m = ( MyPeer e
                                  , MonadIO m
                                  , Request e (BlockInfo e) m
@@ -254,6 +260,16 @@ isBlockHereCached h = do
      when blk $ Cache.insert szcache h ()
      pure blk
 
+checkForDownload :: forall e m . ( MyPeer e
+                                 , MonadIO m
+                                 , HasPeerLocator e (BlockDownloadM e m)
+                                 , HasStorage m -- (BlockDownloadM e m)
+                                 )
+                 => ByteString -> BlockDownloadM e m ()
+
+checkForDownload lbs = do
+  pure ()
+
 addDownload :: forall e m . ( MyPeer e
                             , MonadIO m
                             , HasPeerLocator e (BlockDownloadM e m)
@@ -395,3 +411,18 @@ updateBlockPeerSize h p s = do
 
   liftIO $ atomically $ modifyTVar tv (HashMap.alter alt h)
 
+
+forKnownPeers :: forall e  m . ( MonadIO m
+                               , HasPeerLocator e m
+                               , Sessions e (KnownPeer e) m
+                               , HasPeer e
+                               )
+               =>  ( Peer e -> PeerData e -> m () ) -> m ()
+forKnownPeers m = do
+  pl <- getPeerLocator @e
+  pips <- knownPeers @e pl
+  for_ pips $ \p -> do
+    pd' <- find (KnownPeerKey p) id
+    maybe1 pd' (pure ()) (m p)
+
+

hbs2-peer/app/RPC.hs

@@ -10,6 +10,9 @@ import HBS2.Actors.Peer
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Proto.Definition()
 
+import PeerConfig
+
+import Data.Text (Text)
 import Control.Monad.Reader
 import Data.ByteString.Lazy (ByteString)
 import Codec.Serialise (serialise,deserialiseOrFail)
@@ -27,11 +30,16 @@ data RPC e =
   | RPCPing (PeerAddr e)
   | RPCPong (PeerAddr e)
   | RPCPokeAnswer (PubKey 'Sign e)
+  | RPCPokeAnswerFull Text
   | RPCAnnounce (Hash HbSync)
   | RPCFetch (Hash HbSync)
   | RPCPeers
   | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign e)
   | RPCLogLevel SetLogging
+  | RPCRefLogUpdate ByteString
+  | RPCRefLogFetch (PubKey 'Sign e)
+  | RPCRefLogGet (PubKey 'Sign e)
+  | RPCRefLogGetAnswer (Maybe (Hash HbSync))
   deriving stock (Generic)
 
 
@@ -54,15 +62,20 @@ makeLenses 'RPCEnv
 
 data RpcAdapter e m =
   RpcAdapter
-  { rpcOnPoke        :: RPC e -> m ()
+  { rpcOnPoke          :: RPC e -> m ()
-  , rpcOnPokeAnswer  :: PubKey 'Sign e -> m ()
+  , rpcOnPokeAnswer    :: PubKey 'Sign e -> m ()
-  , rpcOnAnnounce    :: Hash HbSync -> m ()
+  , rpcOnPokeAnswerFull :: Text -> m ()
-  , rpcOnPing        :: PeerAddr e -> m ()
+  , rpcOnAnnounce      :: Hash HbSync -> m ()
-  , rpcOnPong        :: PeerAddr e -> m ()
+  , rpcOnPing          :: PeerAddr e -> m ()
-  , rpcOnFetch       :: Hash HbSync -> m ()
+  , rpcOnPong          :: PeerAddr e -> m ()
-  , rpcOnPeers       :: RPC e -> m ()
+  , rpcOnFetch         :: Hash HbSync -> m ()
-  , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign e) -> m ()
+  , rpcOnPeers         :: RPC e -> m ()
-  , rpcOnLogLevel    :: SetLogging -> m ()
+  , rpcOnPeersAnswer   :: (PeerAddr e, PubKey 'Sign e) -> m ()
+  , rpcOnLogLevel      :: SetLogging -> m ()
+  , rpcOnRefLogUpdate  :: ByteString -> m ()
+  , rpcOnRefLogFetch   :: PubKey 'Sign e -> m ()
+  , rpcOnRefLogGet     :: PubKey 'Sign e -> m ()
+  , rpcOnRefLogGetAnsw :: Maybe (Hash HbSync) -> m ()
   }
 
 newtype RpcM m a = RpcM { fromRpcM :: ReaderT RPCEnv m a }
@@ -105,6 +118,7 @@ rpcHandler :: forall e m  . ( MonadIO m
 rpcHandler adapter = \case
     p@RPCPoke{}        -> rpcOnPoke adapter p
     (RPCPokeAnswer k)  -> rpcOnPokeAnswer adapter k
+    (RPCPokeAnswerFull k)  -> rpcOnPokeAnswerFull adapter k
     (RPCAnnounce h)    -> rpcOnAnnounce adapter h
     (RPCPing pa)       -> rpcOnPing adapter pa
     (RPCPong pa)       -> rpcOnPong adapter pa
@@ -112,4 +126,8 @@ rpcHandler adapter = \case
     p@RPCPeers{}       -> rpcOnPeers adapter p
     (RPCPeersAnswer pa k) -> rpcOnPeersAnswer adapter (pa,k)
     (RPCLogLevel l)    -> rpcOnLogLevel adapter l
+    (RPCRefLogUpdate bs)  -> rpcOnRefLogUpdate adapter bs
+    (RPCRefLogFetch e) -> rpcOnRefLogFetch adapter e
+    (RPCRefLogGet e)   -> rpcOnRefLogGet adapter e
+    (RPCRefLogGetAnswer s)   -> rpcOnRefLogGetAnsw adapter s
 

hbs2-peer/app/RefLog.hs

@@ -0,0 +1,283 @@
+{-# Language AllowAmbiguousTypes #-}
+{-# Language UndecidableInstances #-}
+module RefLog where
+
+import HBS2.Prelude.Plated
+import HBS2.Clock
+import HBS2.Actors.Peer
+import HBS2.Events
+import HBS2.Data.Types.Refs
+import HBS2.Data.Detect
+import HBS2.Net.PeerLocator
+import HBS2.Net.Proto
+import HBS2.Base58
+import HBS2.Storage
+import HBS2.Hash
+import HBS2.Net.Proto.Peer
+import HBS2.Net.Proto.RefLog
+import HBS2.Net.Proto.Sessions
+import HBS2.Net.Auth.Credentials
+import HBS2.Merkle
+
+import HBS2.System.Logger.Simple
+
+import PeerConfig
+import PeerTypes
+
+import Data.Functor
+import Data.Function(fix)
+import Data.Maybe
+import Data.Foldable(for_)
+import Data.List qualified as List
+import Data.Text qualified as Text
+import Control.Concurrent.STM
+import Control.Monad
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString qualified as BS
+import Data.HashMap.Strict qualified as HashMap
+import Codec.Serialise
+import Data.HashSet qualified as HashSet
+import Control.Concurrent.Async
+import Control.Monad.Trans.Maybe
+import Lens.Micro.Platform
+
+doRefLogUpdate :: forall e m . ( MonadIO m
+                               , Pretty (AsBase58 (PubKey 'Sign e))
+                               )
+               => (PubKey 'Sign e, RefLogUpdate e) -> m ()
+
+doRefLogUpdate (reflog, _) = do
+  trace $ "doRefLogUpdate" <+> pretty (AsBase58 reflog)
+  pure ()
+
+doRefLogBroadCast :: forall e m . ( MonadIO m
+                                  , MyPeer e
+                                  , HasPeerLocator e m
+                                  , Request e (RefLogUpdate e) m
+                                  , Sessions e (KnownPeer e) m
+                                  )
+                   => RefLogUpdate e -> m ()
+
+doRefLogBroadCast msg = do
+  -- TODO: broadcast-reflog-update
+  trace "doRefLogBroadCast"
+  forKnownPeers $ \pip _ -> do
+    trace $ "send msg to peer" <+> pretty pip
+    request @e pip msg
+
+
+mkRefLogRequestAdapter :: forall e m . ( MonadIO m
+                                       , HasPeerLocator e m
+                                       , MyPeer e
+                                       , HasStorage m
+                                       , Pretty (AsBase58 (PubKey 'Sign e))
+                                       )
+          => m (RefLogRequestI e (ResponseM e m ))
+mkRefLogRequestAdapter = do
+  sto <- getStorage
+  pure $ RefLogRequestI (doOnRefLogRequest sto) dontHandle
+
+
+doOnRefLogRequest :: forall e m . ( MonadIO m
+                                  , MyPeer e
+                                  )
+                   =>  AnyStorage -> (Peer e, PubKey 'Sign e) -> m (Maybe (Hash HbSync))
+
+doOnRefLogRequest sto (_,pk) = do
+  r <- liftIO $ getRef sto (RefLogKey pk)
+  trace $ "doOnRefLogRequest" <+> pretty (AsBase58 pk) <+> pretty r
+  pure r
+
+
+mkAdapter :: forall e m . ( MonadIO m
+                          , HasPeerLocator e m
+                          , Sessions e (KnownPeer e) m
+                          , Request e (RefLogUpdate e) m
+                          , MyPeer e
+                          , Pretty (AsBase58 (PubKey 'Sign e))
+                          )
+          => m (RefLogUpdateI e (ResponseM e m ))
+
+mkAdapter = do
+  let bcast = lift . doRefLogBroadCast @e
+  let upd   = lift . doRefLogUpdate @e
+  pure $ RefLogUpdateI upd bcast
+
+
+data RefLogWorkerAdapter e =
+ RefLogWorkerAdapter
+ { reflogDownload :: Hash HbSync -> IO ()
+ , reflogFetch    :: PubKey 'Sign e -> IO ()
+ }
+
+reflogWorker :: forall e m . ( MonadIO m, MyPeer e
+                             , EventListener e (RefLogUpdateEv e) m
+                             , EventListener e (RefLogRequestAnswer e) m
+                             -- , Request e (RefLogRequest e) (Peerm
+                             , HasStorage m
+                             , Nonce (RefLogUpdate e) ~ BS.ByteString
+                             , Signatures e
+                             , Serialise (RefLogUpdate e)
+                             , EventEmitter e (RefLogUpdateEv e) m -- (PeerM e m)
+                             )
+             => PeerConfig
+             -> RefLogWorkerAdapter e
+             -> m ()
+
+reflogWorker conf adapter = do
+
+  sto <- getStorage
+
+  q <- liftIO newTQueueIO
+
+  let reflogUpdate reflog ha tran = do
+        signed <- verifyRefLogUpdate tran
+        when signed do
+          -- trace $ "GOT PRETTY VALID REFLOG UPDATE TRANSACTION" <+> pretty ha
+
+          liftIO $ atomically $ writeTQueue q (reflog, [tran])
+
+          -- FIXME: fix-this-copypaste
+          let bss = view refLogUpdData tran
+          let what = tryDetect (hashObject bss) (LBS.fromStrict bss)
+          case what of
+            SeqRef (SequentialRef _ (AnnotatedHashRef _ ref)) -> do
+              liftIO $ reflogDownload adapter (fromHashRef ref)
+
+            AnnRef ref -> do
+              liftIO $ reflogDownload adapter ref
+
+            _ -> pure ()
+
+  subscribe @e RefLogUpdateEvKey $ \(RefLogUpdateEvData (reflog,v)) -> do
+    trace $ "reflog worker.got refupdate" <+> pretty (AsBase58 reflog)
+    liftIO $ reflogUpdate reflog Nothing v
+    liftIO $ atomically $ writeTQueue q (reflog, [v])
+
+  subscribe @e RefLogReqAnswerKey $ \(RefLogReqAnswerData reflog h) -> do
+    trace $ "reflog worker. GOT REFLOG ANSWER" <+> pretty (AsBase58 reflog) <+> pretty h
+    -- TODO: ASAP-only-process-link-if-we-subscribed
+    -- TODO: ASAP-start-only-one-instance-for-link-monitor
+    -- TODO: periodically-check-if-reflog-is-done
+    -- TODO: ASAP-when-done-delete-monitor
+    -- TODO: ASAP-dont-do-if-already-done
+    void $ liftIO $ race (pause @'Seconds 3600) do
+    -- FIXME: log-this-situation
+    -- FIXME: fix-time-hardcode-again
+      reflogDownload adapter h
+      fix \next -> do
+        missed <- missedEntries sto h
+        if missed /= 0 then do
+          pause @'Seconds 1
+          trace $ "reflogWorker: missed refs for" <+> pretty h <+> pretty missed
+          next
+        else do
+          trace $ "block" <+> pretty h <+> "is downloaded"
+          hashes <- readHashesFromBlock sto (Just h)
+          for_ hashes $ \ha -> runMaybeT do
+            bss <- liftIO $ getBlock sto (fromHashRef ha)
+
+            when (isNothing bss) do
+              liftIO $ reflogDownload adapter (fromHashRef ha)
+
+            bs <- MaybeT $ pure bss
+
+            tran <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate e) bs & either (const Nothing) Just
+            liftIO $ reflogUpdate reflog (Just ha) tran
+
+  let (PeerConfig syn) = conf
+
+  let mkRef = fromStringMay . Text.unpack :: (Text -> Maybe (PubKey 'Sign e))
+
+  let defPoll = lastDef 10 [ x
+                           | ListVal @C (Key "poll-default" [SymbolVal "reflog", LitIntVal x]) <- syn
+                           ]
+
+  let polls = HashMap.fromListWith min $ catMaybes (
+       [ (,x) <$> mkRef ref
+       | ListVal @C (Key "poll" [SymbolVal "reflog", LitIntVal x, LitStrVal ref]) <- syn
+       ]
+       <>
+       [ (,defPoll) <$> mkRef ref
+       | ListVal @C (Key "subscribe" [SymbolVal "reflog", LitStrVal ref]) <- syn
+       ] )
+
+  let pollIntervals = HashMap.fromListWith (<>) [ (i, [r]) | (r,i) <- HashMap.toList polls ]
+                            & HashMap.toList
+
+
+  pollers' <- liftIO $ async $ do
+                pause @'Seconds 10
+                forM pollIntervals  $ \(i,refs) -> liftIO do
+                  async $ forever $ do
+                    for_ refs $ \r -> do
+                      trace $ "POLL REFERENCE" <+> pretty (AsBase58 r) <+> pretty i <> "m"
+                      reflogFetch adapter r
+
+                    pause (fromIntegral i :: Timeout 'Minutes)
+
+  w1 <- liftIO $ async $ forever $ do
+          el0 <- liftIO $ atomically $ readTQueue q
+          els <- liftIO $ atomically $ flushTQueue q
+
+          let byRef = HashMap.fromListWith (<>) (el0 : els)
+
+          for_ (HashMap.toList byRef) $ \(r,x) -> do
+            let reflogkey = RefLogKey r
+            -- trace $ "UPDATE REFLOG" <+> pretty (hashObject @HbSync reflogkey) <+> pretty (fmap AsBase58 x)
+            h' <- liftIO $! getRef sto (RefLogKey r)
+            -- trace $ "UPDATE REGLOG OKAY" <+> pretty (isJust h')
+
+            hashes <- liftIO $ readHashesFromBlock sto h'
+
+            -- save new transaction, must be idempotent
+            newHashes <- liftIO $ mapM (putBlock sto . serialise) x <&> catMaybes <&> fmap HashRef
+
+            -- TODO: needs-very-fast-sort-and-dedupe
+            let hashesNew = HashSet.fromList (hashes <> newHashes) & HashSet.toList
+
+            -- FIXME: remove-chunk-num-hardcode
+            let pt = toPTree (MaxSize 256) (MaxNum 256) hashesNew
+
+            newRoot <- liftIO do
+              nref <- makeMerkle 0 pt $ \(_,_,bss) -> do
+                void $ putBlock sto bss
+
+              updateRef sto reflogkey nref
+              pure nref
+
+            -- TODO: old-root-to-delete
+
+            trace $ "new reflog value" <+> pretty (AsBase58 r) <+> pretty newRoot
+
+          -- TODO: read-reflog-value
+          -- TODO: read-reflog-hashes
+          -- TODO: store-all-values
+          -- TODO: get all hashes
+
+          trace  "I'm a reflog update worker"
+
+  pollers <- liftIO $ wait pollers'
+  void $ liftIO $ waitAnyCatchCancel $ w1 : pollers
+
+  where
+
+    readHashesFromBlock _ Nothing = pure mempty
+    readHashesFromBlock sto (Just h) = do
+      treeQ <- liftIO newTQueueIO
+      walkMerkle h (getBlock sto) $ \hr -> do
+        case hr of
+          Left{} -> pure ()
+          Right (hrr :: [HashRef]) -> atomically $ writeTQueue treeQ hrr
+      re <- liftIO $ atomically $ flushTQueue treeQ
+      pure $ mconcat re
+
+    missedEntries sto h = do
+      missed <- liftIO $ newTVarIO 0
+      walkMerkle h (getBlock sto) $ \hr -> do
+        case hr of
+          Left{} -> atomically $ modifyTVar missed succ
+          Right (_ :: [HashRef]) -> pure ()
+      liftIO $ readTVarIO missed
+
+

hbs2-peer/hbs2-peer.cabal

@@ -55,6 +55,10 @@ common common-deps
         , interpolatedstring-perl6
         , filelock
         , ekg-core
+        , scotty
+        , warp
+        , http-types
+        , wai-extra
 
 common shared-properties
   ghc-options:
@@ -113,7 +117,9 @@ executable hbs2-peer
                     , RPC
                     , PeerTypes
                     , PeerConfig
+                    , RefLog
                     , CheckMetrics
+                    , HttpWorker
 
     -- other-extensions:
     build-depends:    base

hbs2-storage-simple/lib/HBS2/Storage/Simple.hs

@@ -20,6 +20,7 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Trans.Maybe
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.ByteString qualified as BS
 import Data.ByteString (ByteString)
 import Data.Foldable
@@ -54,9 +55,13 @@ import Control.Concurrent.STM.TVar qualified as TV
 --        operations and wait in getBlock 'till it's completion
 --        in order to make the disk access in this fashion safe
 
-class (Eq (Key h), Hashable (Key h), IsKey h, Key h ~ Hash h) => IsSimpleStorageKey h
+type IsSimpleStorageKey h  = ( Eq (Key h)
-instance (Eq (Key h), Hashable (Key h), IsKey h, Key h ~ Hash h) => IsSimpleStorageKey h
+                             , Hashable (Key h)
-
+                             , IsKey h
+                             , Key h ~ Hash h
+                             , ToByteString (AsBase58 (Hash h))
+                             , FromByteString (AsBase58 (Hash h))
+                             )
 
 type instance Block LBS.ByteString = LBS.ByteString
 
@@ -323,6 +328,20 @@ simpleWriteLinkRaw ss h lbs = do
       BS.writeFile fnr (toByteString (AsBase58 r))
       pure h
 
+simpleWriteLinkRawRef :: forall h . ( IsSimpleStorageKey h
+                                 , Hashed h LBS.ByteString
+                                 , ToByteString (AsBase58 (Hash h))
+                                 )
+                      => SimpleStorage h
+                      -> Hash h
+                      -> Hash h
+                      -> IO ()
+
+simpleWriteLinkRawRef ss h ref = do
+  let fnr = simpleRefFileName ss h
+  void $ spawnAndWait ss $ do
+    BS.writeFile fnr (toByteString (AsBase58 ref))
+
 simpleReadLinkRaw :: IsKey h
                   => SimpleStorage h
                   -> Hash h
@@ -331,10 +350,8 @@ simpleReadLinkRaw :: IsKey h
 simpleReadLinkRaw ss hash = do
   let fn = simpleRefFileName ss hash
   rs <- spawnAndWait ss $ do
-    r <- tryJust (guard . isDoesNotExistError) (LBS.readFile fn)
+          -- FIXME: log-this-situation
-    case r of
+          (Just <$> LBS.readFile fn) `catchAny` const (pure Nothing)
-      Right bs -> pure (Just bs)
-      Left  _  -> pure Nothing
 
   pure $ fromMaybe Nothing rs
 
@@ -351,16 +368,12 @@ simpleReadLinkVal :: ( IsKey h
 simpleReadLinkVal ss hash = do
   let fn = simpleRefFileName ss hash
   rs <- spawnAndWait ss $ do
-    r <- tryJust (guard . isDoesNotExistError) (BS.readFile fn)
+        -- FIXME: log-this-situation
-    case r of
+        (Just <$> BS.readFile fn) `catchAny` \_ -> pure Nothing
-      Right bh -> pure (Just bh)
+
-      Left  _  -> pure Nothing
   runMaybeT do
       MaybeT . getBlock ss . unAsBase58 =<< MaybeT (pure (fromByteString =<< join rs))
 
--- instance Hashed hash LBS.ByteString => Hashed hash LBS.ByteString where
---   hashObject s = hashObject s
-
 instance ( MonadIO m, IsKey hash
          , Hashed hash LBS.ByteString
          , Key hash ~ Hash hash
@@ -379,6 +392,16 @@ instance ( MonadIO m, IsKey hash
 
   hasBlock s k = liftIO $ simpleBlockExists s k
 
+  updateRef ss ref v = do
+    let refHash = hashObject @hash ref
+    -- liftIO $ print $ "updateRef:" <+> pretty refHash
+    void $ liftIO $ simpleWriteLinkRawRef ss refHash v
 
-
+  getRef ss ref = do
+    let refHash = hashObject @hash ref
+    runMaybeT do
+      bs <- MaybeT $ liftIO $ simpleReadLinkRaw ss refHash
+      let bss = LBS.toStrict bs
+      parsed <- MaybeT $ pure $ fromByteString bss
+      pure $ unAsBase58 parsed
 

hbs2-storage-simple/test/Main.hs

@@ -14,6 +14,7 @@ main =
       [
         testCase "testSimpleStorageRandomReadWrite" testSimpleStorageRandomReadWrite
       , testCase "testSimpleStorageNoKeys" testSimpleStorageNoKeys
+      , testCase "testSimpleStorageRefs" testSimpleStorageRefs
       ]
 
 

hbs2-storage-simple/test/TestSimpleStorage.hs

@@ -1,5 +1,12 @@
 module TestSimpleStorage where
 
+import HBS2.OrDie
+import HBS2.Hash
+import HBS2.Clock
+import HBS2.Prelude.Plated
+import HBS2.Storage
+import HBS2.Storage.Simple
+
 import Control.Monad.Except
 import Control.Monad
 import Data.Traversable
@@ -19,11 +26,6 @@ import System.TimeIt
 
 import Test.Tasty.HUnit
 
-import HBS2.Hash
-import HBS2.Clock
-import HBS2.Prelude.Plated
-import HBS2.Storage
-import HBS2.Storage.Simple
 
 
 -- CASE:
@@ -177,4 +179,35 @@ testSimpleStorageRandomReadWrite = do
     mapM_ cancel workers
 
 
+testSimpleStorageRefs :: IO ()
+testSimpleStorageRefs  = do
+  withSystemTempDirectory "simpleStorageTest" $ \dir -> do
+
+    let opts = [ StoragePrefix (dir </> ".storage")
+               ]
+
+    storage <- simpleStorageInit opts :: IO (SimpleStorage HbSync)
+
+    worker <- async  (simpleStorageWorker storage)
+
+    link worker
+
+    let k  = "JOPAKITA" :: LBS.ByteString
+    let v  = "PECHENTRESKI" :: LBS.ByteString
+
+    vh <- putBlock storage v `orDie` "cant write"
+
+    updateRef storage k vh
+
+    qqq <- simpleReadLinkRaw storage (hashObject k)
+
+    pechen <- getRef storage k
+
+    assertEqual "kv1" (Just vh) pechen
+
+    non <- getRef storage ("QQQQQ" :: LBS.ByteString)
+
+    assertEqual "kv2" Nothing non
+
+    pure ()
 

hbs2-tests/hbs2-tests.cabal

@@ -305,3 +305,52 @@ test-suite test-acb
         -- , fast-logger
 
 
+executable test-walk-tree-meta
+    import:           shared-properties
+    import:           common-deps
+    default-language: Haskell2010
+
+    ghc-options:
+      -- -prof
+      -- -fprof-auto
+
+    other-modules:
+
+    -- other-extensions:
+
+    -- type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          TestWalkTreeMeta.hs
+
+    build-depends:
+          base, hbs2-core
+        -- , async
+        -- , attoparsec
+        , bytestring
+        -- , cache
+        -- , clock
+        , containers
+        , interpolatedstring-perl6
+        -- , data-default
+        -- , data-textual
+        -- , directory
+        -- , hashable
+        -- , microlens-platform
+        -- , mtl
+        -- , mwc-random
+        -- , network
+        -- , network-ip
+        , prettyprinter
+        -- , random
+        , safe
+        , serialise
+        -- , stm
+        -- , streaming
+        -- , saltine
+        , text
+        , typed-process
+        -- , transformers
+        , uniplate
+        -- , vector
+        -- , fast-logger
+

hbs2-tests/test/TestWalkTreeMeta.hs

@@ -0,0 +1,52 @@
+module Main where
+
+import HBS2.Prelude.Plated
+import HBS2.Merkle
+import HBS2.System.Logger.Simple
+import HBS2.OrDie
+import HBS2.Data.Types.Refs
+import HBS2.Hash
+
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Functor
+import Data.Function
+import Data.Foldable
+import Data.ByteString.Lazy.Char8 qualified as LBS
+import Data.ByteString.Lazy.Char8 (ByteString)
+import System.Process.Typed
+import Data.Functor
+import System.Environment
+import System.Exit
+import System.IO
+import Codec.Serialise
+
+
+readBlock :: MonadIO m => HashRef -> m (Maybe ByteString)
+readBlock hr = do
+  (co, out, _) <- readProcess (shell [qc|hbs2 cat --raw {pretty hr}|])
+  case co of
+    ExitFailure{} -> pure Nothing
+    ExitSuccess   -> pure $ Just out
+
+main :: IO ()
+main = do
+
+  h <- fromString <$> ( getArgs <&> headMay ) `orDie` "tree hash not set"
+
+  print $ pretty h
+
+  blk <- readBlock h `orDie` "can't read block"
+
+  let ann = deserialiseOrFail @(MTreeAnn [HashRef]) blk & either (error "oopsie") id
+
+  walkMerkleTree (_mtaTree ann) (readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
+    case hr of
+      Left hx -> void $ hPrint stderr $ "missed block:" <+> pretty hx
+      Right (hrr :: [HashRef]) -> do
+        for_ hrr $ \(HashRef hx) -> do
+            block <- readBlock (HashRef hx) `orDie` show ("missed block: " <+> pretty hx)
+            LBS.putStr block
+
+  exitSuccess
+  pure ()
+

hbs2/Main.hs

@@ -26,6 +26,7 @@ import Control.Monad.Trans.State.Strict
 import Crypto.Saltine.Core.Box qualified as Encrypt
 import Data.ByteString.Lazy qualified as LBS
 import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy (ByteString)
 import Data.Either
 import Data.Function
@@ -33,6 +34,7 @@ import Data.Functor
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Monoid qualified as Monoid
+import Data.Text (Text)
 import Data.Set qualified as Set
 import Data.UUID qualified as UUID
 import Data.UUID.V4 qualified as UUID
@@ -83,6 +85,7 @@ data StoreOpts =
   {  storeInit      :: Maybe OptInit
   ,  storeInputFile :: Maybe OptInputFile
   ,  storeGroupkeyFile :: Maybe OptGroupkeyFile
+  ,  storeBase58Meta :: Maybe String
   }
   deriving stock (Data)
 
@@ -91,6 +94,7 @@ data CatOpts =
   { catMerkleHash :: Maybe MerkleHash
   , catHashesOnly :: Maybe CatHashesOnly
   , catPathToKeyring :: Maybe OptKeyringFile
+  , catRaw        :: Maybe Bool
   }
   deriving stock (Data)
 
@@ -112,8 +116,17 @@ runHash opts ss = do
   withBinaryFile (hashFp opts) ReadMode $ \h -> do
     LBS.hGetContents h >>= print . pretty . hashObject @HbSync
 
+runCat :: CatOpts -> SimpleStorage HbSync -> IO ()
+
+runCat opts ss | catRaw opts == Just True = do
+
+  let mhash' = uniLastMay @MerkleHash opts <&> fromMerkleHash
+
+  maybe1 mhash' exitFailure $ \h -> do
+    obj <- getBlock ss h
+    maybe exitFailure LBS.putStr obj
+    exitSuccess
 
-runCat :: Data opts => opts -> SimpleStorage HbSync -> IO ()
 runCat opts ss = do
 
   let honly = or [ x | CatHashesOnly x <- universeBi opts  ]
@@ -141,6 +154,7 @@ runCat opts ss = do
                        Nothing  -> die $ show $ "missed block: " <+> pretty hx
                        Just blk -> LBS.putStr blk
 
+      -- TODO: to-the-library
       let walkAnn :: MTreeAnn [HashRef] -> IO ()
           walkAnn ann = do
             bprocess :: Hash HbSync -> ByteString -> IO ByteString <- case (_mtaCrypt ann) of
@@ -189,6 +203,11 @@ runCat opts ss = do
         Blob h -> getBlock ss h >>= maybe (die "blob not found") LBS.putStr
         Merkle h -> walk h
         MerkleAnn ann -> walkAnn ann
+
+        -- FIXME: what-if-multiple-seq-ref-?
+        SeqRef (SequentialRef n (AnnotatedHashRef _ h)) -> do
+          walk (fromHashRef h)
+
         AnnRef h -> do
           let lnk = deserialise @AnnotatedHashRef obj
           let mbHead =  headMay [ h
@@ -197,7 +216,7 @@ runCat opts ss = do
           maybe (error "empty ref") walk mbHead
 
 
-runStore ::(Data opts) => opts -> SimpleStorage HbSync -> IO ()
+runStore :: StoreOpts -> SimpleStorage HbSync -> IO ()
 
 runStore opts ss | justInit = do
   putStrLn "initialized"
@@ -208,13 +227,27 @@ runStore opts ss | justInit = do
 runStore opts ss = do
 
   let fname = uniLastMay @OptInputFile opts
+  let meta58  = storeBase58Meta opts
 
   handle <- maybe (pure stdin) (flip openFile ReadMode . unOptFile) fname
 
-  case (uniLastMay @OptGroupkeyFile opts) of
+  case uniLastMay @OptGroupkeyFile opts of
     Nothing -> do
-        root <- putAsMerkle ss handle
+        root' <- putAsMerkle ss handle
+
+        root <- case meta58 of
+                  Nothing -> pure root'
+                  Just s -> do
+                    let metad = fromBase58 (BS8.pack s) & fromMaybe "" & BS8.unpack & fromString
+                    mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash root'))
+                        `orDie` "merkle tree was not stored properly with `putAsMerkle`"
+                    mannh <- maybe (die "can not store MerkleAnn") pure
+                                  =<< (putBlock ss . serialise @(MTreeAnn [HashRef])) do
+                                            MTreeAnn (ShortMetadata metad) NullEncryption  mtree
+                    pure (MerkleHash mannh)
+
         print $ "merkle-root: " <+> pretty root
+
     Just gkfile -> do
         gk :: GroupKey MerkleEncryptionType 'NaClAsymm
             <- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile))
@@ -231,7 +264,7 @@ runStore opts ss = do
                 & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict)
 
         mhash <- putAsMerkle ss encryptedChunks
-        mtree <- (mdeserialiseMay <$> getBlock ss (fromMerkleHash mhash))
+        mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash mhash))
             `orDie` "merkle tree was not stored properly with `putAsMerkle`"
 
         mannh <- maybe (die "can not store MerkleAnn") pure
@@ -249,15 +282,6 @@ runNewGroupkey pubkeysFile = do
       List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk
   print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey
 
-runNewRef :: Data opts => opts -> MerkleHash -> SimpleStorage HbSync -> IO ()
-runNewRef opts mhash ss = do
-  uuid <- UUID.nextRandom <&> (hashObject @HbSync . UUID.toASCIIBytes)
-  let href = HashRef (fromMerkleHash mhash)
-  let mref = HashRefMerkle (HashRefObject href Nothing)
-  let ref = AnnotatedHashRef Nothing mref
-  res <- simpleWriteLinkRaw ss uuid (serialise ref)
-  print (pretty res)
-
 runNewKey :: IO ()
 runNewKey = do
   cred <- newCredentials @UDP
@@ -444,6 +468,17 @@ mdeserialiseMay :: Serialise a => Maybe ByteString -> Maybe a
 mdeserialiseMay = (deserialiseMay =<<)
 
 ---
+runEnc58 :: IO ()
+runEnc58 = do
+   s <- LBS.hGetContents stdin  <&> LBS.toStrict
+   print $ pretty (AsBase58 s)
+
+runRefLogGet :: RefLogKey e -> SimpleStorage HbSync -> IO ()
+runRefLogGet s ss = do
+  ref' <- getRef ss s
+  maybe1 ref' exitFailure $ \ref -> do
+    print $ pretty ref
+    exitSuccess
 
 withStore :: Data opts => opts -> ( SimpleStorage HbSync -> IO () ) -> IO ()
 withStore opts f = do
@@ -472,7 +507,6 @@ main = join . customExecParser (prefs showHelpOnError) $
   where
     parser ::  Parser (IO ())
     parser = hsubparser (  command "store"           (info pStore (progDesc "store block"))
-                        <> command "new-ref"         (info pNewRef (progDesc "creates reference"))
                         <> command "cat"             (info pCat (progDesc "cat block"))
                         <> command "hash"            (info pHash (progDesc "calculates hash"))
                         <> command "keyring-new"     (info pNewKey (progDesc "generates a new keyring"))
@@ -487,6 +521,7 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "lref-list"       (info pListLRef (progDesc "list node linear refs"))
                         <> command "lref-get"        (info pGetLRef (progDesc "get a linear ref"))
                         <> command "lref-update"     (info pUpdateLRef (progDesc "updates a linear ref"))
+                        <> command "reflog"          (info pReflog (progDesc "reflog commands"))
                         -- <> command "lref-del"        (info pDelLRef (progDesc "removes a linear ref from node linear ref list"))
                         )
 
@@ -494,26 +529,22 @@ main = join . customExecParser (prefs showHelpOnError) $
       pref <- optional $ strOption ( short 'p' <> long "prefix" <> help "storage prefix" )
       pure $ CommonOpts pref
 
-    pNewRef = do
-      o <- common
-      merkle <- flag' True ( long "merkle-tree" <> help "it's a merkle-tree reference" )
-      hash <- strArgument ( metavar "HASH" )
-      pure $ withStore o (runNewRef (NewRefOpts merkle) hash)
-
     pStore = do
       o <- common
       file <- optional $ strArgument ( metavar "FILE" )
       init <- optional $ flag' True ( long "init" <> help "just init storage") <&> OptInit
       groupkeyFile <- optional $ strOption ( long "groupkey" <> help "path to groupkey file" )
-      pure $ withStore o (runStore ( StoreOpts init file (OptGroupkeyFile <$> groupkeyFile) ))
+      b58meta <- optional $ strOption ( long "short-meta-base58" <> help "pass escaped metadata string")
+      pure $ withStore o (runStore ( StoreOpts init file (OptGroupkeyFile <$> groupkeyFile) b58meta))
 
     pCat = do
       o <- common
       hash  <- optional $ strArgument ( metavar "HASH" )
       onlyh <- optional $ flag' True ( short 'H' <> long "hashes-only" <> help "list only block hashes" )
       keyringFile <- optional $ strOption ( long "keyring" <> help "path to keyring file" )
+      raw <- optional $ flag' True ( short 'r' <> long "raw" <> help "dump raw block" )
       pure $ withStore o $ runCat
-          $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile)
+          $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile) raw
 
     pNewGroupkey = do
       pubkeysFile <- strArgument ( metavar "FILE" <> help "path to a file with a list of recipient public keys" )
@@ -577,3 +608,14 @@ main = join . customExecParser (prefs showHelpOnError) $
       valh <- strArgument ( metavar "HASH" )
       o <- common
       pure $ withStore o (runUpdateLRef ownerCredFile refh valh)
+
+    pReflog = hsubparser ( command "get" (info pRefLogGet (progDesc "get reflog root") )  )
+
+    pRefLogGet = do
+      o <- common
+      reflogs <- strArgument ( metavar "REFLOG" )
+      pure $ withStore o (runRefLogGet reflogs)
+
+      -- o <- common
+      -- reflog <- strArgument ( metavar "REFLOG-HASH" )
+

nix/peer/flake.lock

@@ -6,11 +6,11 @@
         "nixpkgs": "nixpkgs"
       },
       "locked": {
-        "lastModified": 1673201375,
+        "lastModified": 1678566036,
-        "narHash": "sha256-qlDIl1j6m3hrwbp993/1ncxyKfFRjt32zc3IHq6CeIk=",
+        "narHash": "sha256-dq+gCYplCTkbHOH1ERCzuTnwY/RvwMyw/kijPy7C3vE=",
         "owner": "erikarvstedt",
         "repo": "extra-container",
-        "rev": "8448f0d65bb436550c2a6eece0dd1b43c8b33462",
+        "rev": "a4fe3227bf63bf8479938e1457ebe1c04fe51ef5",
         "type": "github"
       },
       "original": {
@@ -29,11 +29,11 @@
         "suckless-conf": "suckless-conf"
       },
       "locked": {
-        "lastModified": 1676442489,
+        "lastModified": 1677558983,
-        "narHash": "sha256-uYkq5T+SwflDjL0gMVGIte6zKMLMrSwjskcEQo6jMRs=",
+        "narHash": "sha256-1KlLTPdRv2cwQkg9FKSEYHqFJ/6WT3mSliyxc22hVzI=",
         "owner": "voidlizard",
         "repo": "fixme",
-        "rev": "e13eda2bf1b58064a56bf38a46b1643c2927b334",
+        "rev": "80caffb07aaa18e1fd2bcbbc2b4acfea628aaa5f",
         "type": "github"
       },
       "original": {
@@ -236,16 +236,16 @@
         "suckless-conf": "suckless-conf_2"
       },
       "locked": {
-        "lastModified": 1676462595,
+        "lastModified": 1679562884,
-        "narHash": "sha256-BjV83Y+XE8BQEruzHv16rvJ7oi8yME+QYVMGS8b6pS0=",
+        "narHash": "sha256-NXnEgzSBEXE+XaVM9Io4rsA7Y6jvQ3WoCE8CqvDi6no=",
         "owner": "voidlizard",
         "repo": "hbs2",
-        "rev": "b93f519931b5d50e4d978ce854de2caf0e41f8e2",
+        "rev": "0ca64bf1929994b3e8f5fe6ad834440f018368ff",
         "type": "github"
       },
       "original": {
         "owner": "voidlizard",
-        "ref": "announce-group",
+        "ref": "hbs2-git",
         "repo": "hbs2",
         "type": "github"
       }
@@ -258,11 +258,11 @@
         "utils": "utils"
       },
       "locked": {
-        "lastModified": 1675935446,
+        "lastModified": 1679394816,
-        "narHash": "sha256-WajulTn7QdwC7QuXRBavrANuIXE5z+08EdxdRw1qsNs=",
+        "narHash": "sha256-1V1esJt2YAxsKmRuGuB62RF5vhDAVFDvJXVNhtEO22A=",
         "owner": "nix-community",
         "repo": "home-manager",
-        "rev": "2dce7f1a55e785a22d61668516df62899278c9e4",
+        "rev": "e386ec640e16dc91120977285cb8c72c77078164",
         "type": "github"
       },
       "original": {
@@ -326,11 +326,11 @@
     },
     "nixpkgs_3": {
       "locked": {
-        "lastModified": 1676209454,
+        "lastModified": 1679319606,
-        "narHash": "sha256-alj9mBkV9U6tTPDK026671D2pesLSYZZc9j5dBZJ9f0=",
+        "narHash": "sha256-wyEMIZB6BnsmJWInEgDZu66hXVMGJEZFl5uDsn27f9M=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "8c619a1f3cedd16ea172146e30645e703d21bfc1",
+        "rev": "8bc6945b1224a1cfa679d6801580b1054dba1a5c",
         "type": "github"
       },
       "original": {
@@ -371,11 +371,11 @@
         "nixpkgs": "nixpkgs_2"
       },
       "locked": {
-        "lastModified": 1675946914,
+        "lastModified": 1676656630,
-        "narHash": "sha256-OE0R9dnB+ZXpf30g1xVSMur68iKUDB53pnyA3K2e788=",
+        "narHash": "sha256-FFEgtajUGdYd/Ux5lkjXXpAKosve+NAfxp/eG7m7JQY=",
         "owner": "voidlizard",
         "repo": "suckless-conf",
-        "rev": "995e1cd52cfe2e9aa4e00ea5cd016548f7932e5a",
+        "rev": "b017bc1e9d6a11d89da294089d312203c39c0b1f",
         "type": "github"
       },
       "original": {
@@ -408,11 +408,11 @@
     },
     "utils": {
       "locked": {
-        "lastModified": 1667395993,
+        "lastModified": 1676283394,
-        "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
+        "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
+        "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
         "type": "github"
       },
       "original": {

nix/peer/flake.nix

@@ -5,7 +5,7 @@
   inputs = {
     extra-container.url = "github:erikarvstedt/extra-container";
     nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
-    hbs2.url = "github:voidlizard/hbs2/announce-group";
+    hbs2.url = "github:voidlizard/hbs2/hbs2-git";
     hbs2.inputs.nixpkgs.follows = "nixpkgs";
 
     home-manager.url = "github:nix-community/home-manager";
@@ -66,8 +66,14 @@
                 inputs.hbs2.packages.${pkgs.system}.default
                 screen
                 tshark
+                tmux
+                gitFull
               ];
 
+              environment.etc = {
+                "tmux.conf".source = ./tmux.conf;
+              };
+
               # environment.xdg.data."hbs2/wtf" = {
               #   text = "pwned";
               # };
@@ -87,9 +93,17 @@ j1u3RJEr8kosBH2DR8XMY6Mj8s
                 text = ''
 listen "0.0.0.0:7351"
 rpc    "127.0.0.1:13331"
+http-port 5001
 key    "./key"
-storage  "/root/hbs2"
+storage  "/root/.local/share/hbs2"
 accept-block-announce *
+download-log "/tmp/download-log"
+bootstrap-dns "bootstrap.hbs2.net"
+known-peer "10.250.0.1:7354"
+known-peer "10.250.0.1:7351"
+
+poll reflog 1 "2YNGdnDBnciF1Kgmx1EZTjKUp1h5pvYAjrHoApbArpeX"
+
 '';
 
               };

nix/peer/tmux.conf

@@ -0,0 +1,68 @@
+# 0 is too far from ` ;)
+set -g base-index 1
+
+# Automatically set window title
+set-window-option -g automatic-rename on
+set-option -g set-titles on
+
+#set -g default-terminal screen-256color
+set -g status-keys vi
+set -g history-limit 10000
+
+setw -g mode-keys vi
+# setw -g mode-mouse on
+setw -g monitor-activity on
+
+bind-key v split-window -h
+bind-key s split-window -v
+
+bind-key J resize-pane -D 5
+bind-key K resize-pane -U 5
+bind-key H resize-pane -L 5
+bind-key L resize-pane -R 5
+
+bind-key M-j resize-pane -D
+bind-key M-k resize-pane -U
+bind-key M-h resize-pane -L
+bind-key M-l resize-pane -R
+
+# Vim style pane selection
+bind h select-pane -L
+bind j select-pane -D
+bind k select-pane -U
+bind l select-pane -R
+
+# Use Alt-vim keys without prefix key to switch panes
+bind -n M-h select-pane -L
+bind -n M-j select-pane -D
+bind -n M-k select-pane -U
+bind -n M-l select-pane -R
+
+# Use Alt-arrow keys without prefix key to switch panes
+bind -n M-Left select-pane -L
+bind -n M-Right select-pane -R
+bind -n M-Up select-pane -U
+bind -n M-Down select-pane -D
+
+bind -n M-enter swap-pane -U
+
+# Shift arrow to switch windows
+bind -n S-Left  previous-window
+bind -n S-Right next-window
+
+# No delay for escape key press
+set -sg escape-time 0
+
+# Reload tmux config
+bind r source-file ~/.tmux.conf
+
+# THEME
+set -g status-bg black
+set -g status-fg white
+# set -g window-status-current-bg white
+# set -g window-status-current-fg black
+# set -g window-status-current-attr bold
+set -g status-interval 60
+set -g status-left-length 30
+set -g status-left '#[fg=green](#S) #(whoami)'
+set -g status-right '#[fg=yellow]#(cut -d " " -f 1-3 /proc/loadavg)#[default] #[fg=white]%H:%M#[default]'