From 6d7e587a2422d6a4f0bf482dfdd939a27a93bcae Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 23 Mar 2023 20:45:25 +0300 Subject: [PATCH] hbs-git alpha --- .fixme/log | 3 + docs/devlog.md | 126 +++++++ docs/drafts/pep-04-01.txt | 117 +++++++ flake.nix | 3 +- hbs2-core/hbs2-core.cabal | 1 + hbs2-core/lib/HBS2/Actors/Peer.hs | 6 +- hbs2-core/lib/HBS2/Data/Detect.hs | 6 +- hbs2-core/lib/HBS2/Data/Types/Refs.hs | 38 +- hbs2-core/lib/HBS2/Merkle.hs | 1 + hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 27 +- hbs2-core/lib/HBS2/Net/Proto/RefLog.hs | 206 +++++++++++ hbs2-core/lib/HBS2/Net/Proto/Types.hs | 1 - hbs2-core/lib/HBS2/OrDie.hs | 4 +- hbs2-core/lib/HBS2/Storage.hs | 4 +- hbs2-core/lib/HBS2/System/Logger/Simple.hs | 31 +- hbs2-git/CHANGELOG.md | 5 + hbs2-git/LICENSE | 30 ++ hbs2-git/git-hbs2/GitRemoteMain.hs | 265 ++++++++++++++ hbs2-git/git-hbs2/GitRemotePush.hs | 101 ++++++ hbs2-git/git-hbs2/GitRemoteTypes.hs | 54 +++ hbs2-git/git-hbs2/Main.hs | 40 +++ hbs2-git/git-hbs2/RunShow.hs | 31 ++ hbs2-git/hbs2-git.cabal | 156 +++++++++ hbs2-git/lib/HBS2/Git/Local.hs | 31 ++ hbs2-git/lib/HBS2/Git/Local/CLI.hs | 258 ++++++++++++++ hbs2-git/lib/HBS2/Git/Types.hs | 115 ++++++ hbs2-git/lib/HBS2Git/App.hs | 331 ++++++++++++++++++ hbs2-git/lib/HBS2Git/Config.hs | 78 +++++ hbs2-git/lib/HBS2Git/Export.hs | 217 ++++++++++++ hbs2-git/lib/HBS2Git/Import.hs | 163 +++++++++ hbs2-git/lib/HBS2Git/ListRefs.hs | 30 ++ hbs2-git/lib/HBS2Git/State.hs | 243 +++++++++++++ hbs2-git/lib/HBS2Git/Types.hs | 176 ++++++++++ hbs2-git/lib/HBS2Git/Update.hs | 37 ++ hbs2-peer/app/BlockDownload.hs | 36 +- hbs2-peer/app/HttpWorker.hs | 60 ++++ hbs2-peer/app/PeerConfig.hs | 13 + hbs2-peer/app/PeerMain.hs | 247 ++++++++++--- hbs2-peer/app/PeerTypes.hs | 31 ++ hbs2-peer/app/RPC.hs | 36 +- hbs2-peer/app/RefLog.hs | 283 +++++++++++++++ hbs2-peer/hbs2-peer.cabal | 6 + .../lib/HBS2/Storage/Simple.hs | 53 ++- hbs2-storage-simple/test/Main.hs | 1 + hbs2-storage-simple/test/TestSimpleStorage.hs | 43 ++- hbs2-tests/hbs2-tests.cabal | 49 +++ hbs2-tests/test/TestWalkTreeMeta.hs | 52 +++ hbs2/Main.hs | 88 +++-- nix/peer/flake.lock | 44 +-- nix/peer/flake.nix | 18 +- nix/peer/tmux.conf | 68 ++++ 51 files changed, 3920 insertions(+), 143 deletions(-) create mode 100644 docs/drafts/pep-04-01.txt create mode 100644 hbs2-core/lib/HBS2/Net/Proto/RefLog.hs create mode 100644 hbs2-git/CHANGELOG.md create mode 100644 hbs2-git/LICENSE create mode 100644 hbs2-git/git-hbs2/GitRemoteMain.hs create mode 100644 hbs2-git/git-hbs2/GitRemotePush.hs create mode 100644 hbs2-git/git-hbs2/GitRemoteTypes.hs create mode 100644 hbs2-git/git-hbs2/Main.hs create mode 100644 hbs2-git/git-hbs2/RunShow.hs create mode 100644 hbs2-git/hbs2-git.cabal create mode 100644 hbs2-git/lib/HBS2/Git/Local.hs create mode 100644 hbs2-git/lib/HBS2/Git/Local/CLI.hs create mode 100644 hbs2-git/lib/HBS2/Git/Types.hs create mode 100644 hbs2-git/lib/HBS2Git/App.hs create mode 100644 hbs2-git/lib/HBS2Git/Config.hs create mode 100644 hbs2-git/lib/HBS2Git/Export.hs create mode 100644 hbs2-git/lib/HBS2Git/Import.hs create mode 100644 hbs2-git/lib/HBS2Git/ListRefs.hs create mode 100644 hbs2-git/lib/HBS2Git/State.hs create mode 100644 hbs2-git/lib/HBS2Git/Types.hs create mode 100644 hbs2-git/lib/HBS2Git/Update.hs create mode 100644 hbs2-peer/app/HttpWorker.hs create mode 100644 hbs2-peer/app/RefLog.hs create mode 100644 hbs2-tests/test/TestWalkTreeMeta.hs create mode 100644 nix/peer/tmux.conf diff --git a/.fixme/log b/.fixme/log index a80deef2..14be50b5 100644 --- a/.fixme/log +++ b/.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") diff --git a/docs/devlog.md b/docs/devlog.md index 0271b98f..2c40b9bc 100644 --- a/docs/devlog.md +++ b/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 diff --git a/docs/drafts/pep-04-01.txt b/docs/drafts/pep-04-01.txt new file mode 100644 index 00000000..0ee2e1c0 --- /dev/null +++ b/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, где каждый лист - это пара +(ссылка/значение). + + + + diff --git a/flake.nix b/flake.nix index 4061dc34..7cbf2a19 100644 --- a/flake.nix +++ b/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 diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index c812f07e..5d4b7605 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Actors/Peer.hs b/hbs2-core/lib/HBS2/Actors/Peer.hs index 12924058..08a364be 100644 --- a/hbs2-core/lib/HBS2/Actors/Peer.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Data/Detect.hs b/hbs2-core/lib/HBS2/Data/Detect.hs index ce0c8f95..01276884 100644 --- a/hbs2-core/lib/HBS2/Data/Detect.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index f39e6e2a..7753fdd2 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/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) + + diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index f8e3f36c..fa7c472b 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/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 + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 676552cd..280b0346 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs new file mode 100644 index 00000000..d517f222 --- /dev/null +++ b/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) + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 593a545d..3ac65fef 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/OrDie.hs b/hbs2-core/lib/HBS2/OrDie.hs index 5a01a3e7..0833c496 100644 --- a/hbs2-core/lib/HBS2/OrDie.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Storage.hs b/hbs2-core/lib/HBS2/Storage.hs index 60c4b830..c14fc4f9 100644 --- a/hbs2-core/lib/HBS2/Storage.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/System/Logger/Simple.hs b/hbs2-core/lib/HBS2/System/Logger/Simple.hs index 219130f8..63d1562c 100644 --- a/hbs2-core/lib/HBS2/System/Logger/Simple.hs +++ b/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 diff --git a/hbs2-git/CHANGELOG.md b/hbs2-git/CHANGELOG.md new file mode 100644 index 00000000..30f0d555 --- /dev/null +++ b/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. diff --git a/hbs2-git/LICENSE b/hbs2-git/LICENSE new file mode 100644 index 00000000..3086ee5d --- /dev/null +++ b/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. diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs new file mode 100644 index 00000000..680f489e --- /dev/null +++ b/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 + + diff --git a/hbs2-git/git-hbs2/GitRemotePush.hs b/hbs2-git/git-hbs2/GitRemotePush.hs new file mode 100644 index 00000000..6a4d38a7 --- /dev/null +++ b/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 + diff --git a/hbs2-git/git-hbs2/GitRemoteTypes.hs b/hbs2-git/git-hbs2/GitRemoteTypes.hs new file mode 100644 index 00000000..f034f7bc --- /dev/null +++ b/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" + + + + diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs new file mode 100644 index 00000000..c44a9ab1 --- /dev/null +++ b/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) + diff --git a/hbs2-git/git-hbs2/RunShow.hs b/hbs2-git/git-hbs2/RunShow.hs new file mode 100644 index 00000000..66143291 --- /dev/null +++ b/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 + diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal new file mode 100644 index 00000000..33d58123 --- /dev/null +++ b/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 + diff --git a/hbs2-git/lib/HBS2/Git/Local.hs b/hbs2-git/lib/HBS2/Git/Local.hs new file mode 100644 index 00000000..a8e3a9b6 --- /dev/null +++ b/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 + + diff --git a/hbs2-git/lib/HBS2/Git/Local/CLI.hs b/hbs2-git/lib/HBS2/Git/Local/CLI.hs new file mode 100644 index 00000000..ce51272c --- /dev/null +++ b/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))] + _ -> [] + + diff --git a/hbs2-git/lib/HBS2/Git/Types.hs b/hbs2-git/lib/HBS2/Git/Types.hs new file mode 100644 index 00000000..35bd05a8 --- /dev/null +++ b/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 + + diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs new file mode 100644 index 00000000..8f535657 --- /dev/null +++ b/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 () + + diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs new file mode 100644 index 00000000..b5544b3d --- /dev/null +++ b/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) + + + diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs new file mode 100644 index 00000000..35ddc9f8 --- /dev/null +++ b/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 + diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs new file mode 100644 index 00000000..6cc68b4e --- /dev/null +++ b/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 () + + diff --git a/hbs2-git/lib/HBS2Git/ListRefs.hs b/hbs2-git/lib/HBS2Git/ListRefs.hs new file mode 100644 index 00000000..f57381fb --- /dev/null +++ b/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 + diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs new file mode 100644 index 00000000..4267b2e1 --- /dev/null +++ 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 + + + + diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs new file mode 100644 index 00000000..1a577e6c --- /dev/null +++ b/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 + diff --git a/hbs2-git/lib/HBS2Git/Update.hs b/hbs2-git/lib/HBS2Git/Update.hs new file mode 100644 index 00000000..b1986926 --- /dev/null +++ b/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 () + diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index f46d4839..dff6ab27 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/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 - if banned then do - trace $ "skip banned block" <+> pretty p <+> pretty h - addDownload h + + here <- liftIO $ hasBlock sto h <&> isJust + + if here then do + 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 diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs new file mode 100644 index 00000000..cb072e94 --- /dev/null +++ b/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 () + diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 9d1dd7a7..bcf4af5f 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 9233996c..17392efd 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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 Data.Foldable (for_) -import Data.Maybe -import Crypto.Saltine (sodiumInit) -import Data.Function +import Codec.Serialise 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 () -withRPC o cmd = do - +rpcClientMain :: RPCOpt -> IO () -> IO () +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 - Log.info $ "alive-and-kicking" <+> pretty (AsBase58 k) + k <- liftIO $ atomically $ readTQueue pokeFQ + 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 () diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index adcc8d59..3bdba032 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/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) + + diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index c99bad38..deec1b61 100644 --- a/hbs2-peer/app/RPC.hs +++ b/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 () - , rpcOnPokeAnswer :: PubKey 'Sign e -> m () - , rpcOnAnnounce :: Hash HbSync -> m () - , rpcOnPing :: PeerAddr e -> m () - , rpcOnPong :: PeerAddr e -> m () - , rpcOnFetch :: Hash HbSync -> m () - , rpcOnPeers :: RPC e -> m () - , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign e) -> m () - , rpcOnLogLevel :: SetLogging -> m () + { rpcOnPoke :: RPC e -> m () + , rpcOnPokeAnswer :: PubKey 'Sign e -> m () + , rpcOnPokeAnswerFull :: Text -> m () + , rpcOnAnnounce :: Hash HbSync -> m () + , rpcOnPing :: PeerAddr e -> m () + , rpcOnPong :: PeerAddr e -> m () + , rpcOnFetch :: Hash HbSync -> m () + , rpcOnPeers :: RPC e -> 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 diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs new file mode 100644 index 00000000..797b554d --- /dev/null +++ b/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 + + diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index a02f6dcc..ca68c6d7 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/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 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 2568336f..2ef08106 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/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 -instance (Eq (Key h), Hashable (Key h), IsKey h, Key h ~ Hash h) => IsSimpleStorageKey h - +type IsSimpleStorageKey h = ( Eq (Key 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) - case r of - Right bs -> pure (Just bs) - Left _ -> pure Nothing + -- FIXME: log-this-situation + (Just <$> LBS.readFile fn) `catchAny` const (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) - case r of - Right bh -> pure (Just bh) - Left _ -> pure Nothing + -- FIXME: log-this-situation + (Just <$> BS.readFile fn) `catchAny` \_ -> 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 diff --git a/hbs2-storage-simple/test/Main.hs b/hbs2-storage-simple/test/Main.hs index 1855aa0e..c98199d2 100644 --- a/hbs2-storage-simple/test/Main.hs +++ b/hbs2-storage-simple/test/Main.hs @@ -14,6 +14,7 @@ main = [ testCase "testSimpleStorageRandomReadWrite" testSimpleStorageRandomReadWrite , testCase "testSimpleStorageNoKeys" testSimpleStorageNoKeys + , testCase "testSimpleStorageRefs" testSimpleStorageRefs ] diff --git a/hbs2-storage-simple/test/TestSimpleStorage.hs b/hbs2-storage-simple/test/TestSimpleStorage.hs index 125bfc76..fadda6e4 100644 --- a/hbs2-storage-simple/test/TestSimpleStorage.hs +++ b/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 () diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index d79d9b71..09b49919 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/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 + diff --git a/hbs2-tests/test/TestWalkTreeMeta.hs b/hbs2-tests/test/TestWalkTreeMeta.hs new file mode 100644 index 00000000..20aad220 --- /dev/null +++ b/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 () + diff --git a/hbs2/Main.hs b/hbs2/Main.hs index cdede0f5..e9faa5b5 100644 --- a/hbs2/Main.hs +++ b/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" ) + diff --git a/nix/peer/flake.lock b/nix/peer/flake.lock index 8e7fa50d..9c26101e 100644 --- a/nix/peer/flake.lock +++ b/nix/peer/flake.lock @@ -6,11 +6,11 @@ "nixpkgs": "nixpkgs" }, "locked": { - "lastModified": 1673201375, - "narHash": "sha256-qlDIl1j6m3hrwbp993/1ncxyKfFRjt32zc3IHq6CeIk=", + "lastModified": 1678566036, + "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, - "narHash": "sha256-uYkq5T+SwflDjL0gMVGIte6zKMLMrSwjskcEQo6jMRs=", + "lastModified": 1677558983, + "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, - "narHash": "sha256-BjV83Y+XE8BQEruzHv16rvJ7oi8yME+QYVMGS8b6pS0=", + "lastModified": 1679562884, + "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, - "narHash": "sha256-WajulTn7QdwC7QuXRBavrANuIXE5z+08EdxdRw1qsNs=", + "lastModified": 1679394816, + "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, - "narHash": "sha256-alj9mBkV9U6tTPDK026671D2pesLSYZZc9j5dBZJ9f0=", + "lastModified": 1679319606, + "narHash": "sha256-wyEMIZB6BnsmJWInEgDZu66hXVMGJEZFl5uDsn27f9M=", "owner": "nixos", "repo": "nixpkgs", - "rev": "8c619a1f3cedd16ea172146e30645e703d21bfc1", + "rev": "8bc6945b1224a1cfa679d6801580b1054dba1a5c", "type": "github" }, "original": { @@ -371,11 +371,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1675946914, - "narHash": "sha256-OE0R9dnB+ZXpf30g1xVSMur68iKUDB53pnyA3K2e788=", + "lastModified": 1676656630, + "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, - "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", + "lastModified": 1676283394, + "narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=", "owner": "numtide", "repo": "flake-utils", - "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", + "rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073", "type": "github" }, "original": { diff --git a/nix/peer/flake.nix b/nix/peer/flake.nix index 7ca5a8ce..0c95b9e9 100644 --- a/nix/peer/flake.nix +++ b/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" + ''; }; diff --git a/nix/peer/tmux.conf b/nix/peer/tmux.conf new file mode 100644 index 00000000..ec2b6a03 --- /dev/null +++ b/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]'