mirror of https://github.com/voidlizard/hbs2
hbs-git alpha
This commit is contained in:
Dmitry Zuikov
parent
6acf766ab3
commit
6d7e587a24
|
|
@ -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")
|
||||
|
|
|
|||
126
docs/devlog.md
126
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
|
||||
|
|
|
|||
|
|
@ -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, где каждый лист - это пара
|
||||
(ссылка/значение).
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
@ -2,7 +2,6 @@
|
|||
{-# Language FunctionalDependencies #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
module HBS2.Net.Proto.Types
|
||||
( module HBS2.Net.Proto.Types
|
||||
) where
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
# Revision history for hbs2-git
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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"
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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))]
|
||||
_ -> []
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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 ()
|
||||
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 ()
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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 ()
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ main =
|
|||
[
|
||||
testCase "testSimpleStorageRandomReadWrite" testSimpleStorageRandomReadWrite
|
||||
, testCase "testSimpleStorageNoKeys" testSimpleStorageNoKeys
|
||||
, testCase "testSimpleStorageRefs" testSimpleStorageRefs
|
||||
]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
88
hbs2/Main.hs
88
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" )
|
||||
|
||||
|
|
|
|||
|
|
@ -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": {
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
'';
|
||||
|
||||
};
|
||||
|
|
|
|||
|
|
@ -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]'
|
||||
Loading…
Reference in New Issue