mirror of https://github.com/voidlizard/hbs2
157 lines
4.4 KiB
Haskell
157 lines
4.4 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
{-# LANGUAGE TemplateHaskell #-}
|
||
{-# LANGUAGE PatternSynonyms #-}
|
||
{-# LANGUAGE ViewPatterns #-}
|
||
{-# LANGUAGE UndecidableInstances #-}
|
||
module Main where
|
||
|
||
import HBS2.Prelude.Plated
|
||
import HBS2.Actors.Peer
|
||
import HBS2.Base58
|
||
import HBS2.OrDie
|
||
import HBS2.Hash
|
||
import HBS2.Data.Types.Refs
|
||
import HBS2.Net.Auth.Credentials
|
||
import HBS2.Polling
|
||
import HBS2.Misc.PrettyStuff
|
||
import HBS2.System.Dir
|
||
import HBS2.System.Logger.Simple.ANSI hiding (info)
|
||
import HBS2.Net.Messaging.Unix
|
||
|
||
import HBS2.Net.Proto.Notify
|
||
import HBS2.Net.Proto.Service
|
||
import HBS2.Peer.Proto.RefChan
|
||
import HBS2.Peer.Notify
|
||
import HBS2.Peer.RPC.API.Peer
|
||
-- import HBS2.Peer.RPC.API.RefLog
|
||
-- import HBS2.Peer.RPC.API.LWWRef
|
||
-- import HBS2.Peer.RPC.API.Storage
|
||
-- import HBS2.Peer.RPC.Client.StorageClient
|
||
|
||
import HBS2.Peer.CLI.Detect
|
||
import HBS2.Peer.Proto.RefLog
|
||
|
||
import Data.Config.Suckless
|
||
import Data.Config.Suckless.Script
|
||
|
||
import HBS2.System.Logger.Simple.ANSI
|
||
|
||
import Data.Maybe
|
||
import System.Environment
|
||
import Control.Monad.Trans.Cont
|
||
import Control.Monad.Reader
|
||
import Lens.Micro.Platform
|
||
|
||
|
||
data MyEnv =
|
||
MyEnv
|
||
{ _myRefChan :: Maybe (RefChanId L4Proto)
|
||
}
|
||
|
||
makeLenses ''MyEnv
|
||
|
||
|
||
main :: IO ()
|
||
main = do
|
||
work
|
||
`finally` do
|
||
setLoggingOff @DEBUG
|
||
setLoggingOff @TRACE
|
||
setLoggingOff @NOTICE
|
||
setLoggingOff @ERROR
|
||
setLoggingOff @WARN
|
||
|
||
|
||
respawned :: MonadUnliftIO m => m a1 -> m a2
|
||
respawned action = do
|
||
fix \next -> do
|
||
try @_ @SomeException action
|
||
warn $ red "respawning..."
|
||
pause @'Seconds 2
|
||
next
|
||
|
||
work :: IO ()
|
||
work = do
|
||
|
||
setLogging @WARN (toStderr . logPrefix "[warn] ")
|
||
setLogging @ERROR (toStderr . logPrefix "[error] ")
|
||
setLogging @DEBUG (toStderr . logPrefix "[debug] ")
|
||
setLogging @TRACE (toStderr . logPrefix "[trace] ")
|
||
setLogging @NOTICE toStdout
|
||
|
||
tv <- newTVarIO (MyEnv mzero)
|
||
|
||
let dict = makeDict @C do
|
||
|
||
entry $ bindMatch "--refchan" $ nil_ \case
|
||
[SignPubKeyLike rchan] -> do
|
||
atomically $ modifyTVar tv (set myRefChan (Just rchan))
|
||
|
||
_ -> throwIO $ BadFormException @C nil
|
||
|
||
|
||
argz <- getArgs
|
||
forms <- parseTop (unlines $ unwords <$> splitForms argz)
|
||
& either (error.show) pure
|
||
|
||
|
||
void $ run dict forms
|
||
|
||
rchan <- readTVarIO tv <&> view myRefChan
|
||
>>= orThrowUser "refchan not set"
|
||
|
||
notice $ yellow "refchan set" <+> pretty (AsBase58 rchan)
|
||
|
||
respawned $ flip runContT pure do
|
||
|
||
-- NOTE: dont-retry
|
||
-- MUDontRetry -- ВАЖНО
|
||
-- что бы UnixClient не пытался перезапустить транспорт
|
||
-- т.к кажется в этом случае некорректно будут работать
|
||
-- нотификации ( не будет создан новый сокет, а будут
|
||
-- идти в старый. возможно это надо пофиксить, но пока
|
||
-- непонятно, как )
|
||
--
|
||
-- Короче, запретить ему повторный коннект, ловить
|
||
-- исключения и выход из клиентов и всё по новой.
|
||
--
|
||
-- так лучше
|
||
--
|
||
let o = [MUWatchdog 10]
|
||
|
||
soname <- detectRPC
|
||
>>= orThrowUser "hbs2-peer not found"
|
||
|
||
client <- liftIO $ race (pause @'Seconds 1) (newMessagingUnixOpts o False 1.0 soname)
|
||
>>= orThrowUser ("can't connect to" <+> pretty soname)
|
||
|
||
notif <- ContT $ withAsync (runMessagingUnix client)
|
||
|
||
sink <- newNotifySink
|
||
|
||
p1 <- ContT $ withAsync $ flip runReaderT client $ do
|
||
runProto @UNIX
|
||
[ makeResponse (makeNotifyClient @(RefChanEvents L4Proto) sink)
|
||
]
|
||
|
||
psink <- ContT $ withAsync $ flip runReaderT client $ do
|
||
debug $ red "notify restarted!"
|
||
runNotifyWorkerClient sink
|
||
|
||
-- NOTE: wrap-to-thread-to-kill
|
||
-- важно обернуть это в поток, что бы
|
||
-- можно было пристрелить, если кто-то еще
|
||
-- отгниёт из других потоков
|
||
-- иначе будет висеть вечно
|
||
psink2 <- ContT $ withAsync do
|
||
runNotifySink sink (RefChanNotifyKey rchan) $ \case
|
||
RefChanUpdated r v -> do
|
||
notice $ red "refchan updated" <+> pretty (AsBase58 r) <+> pretty v
|
||
|
||
_ -> do
|
||
notice $ "some other refchan event happened"
|
||
|
||
void $ waitAnyCatchCancel [notif,p1,psink,psink2]
|
||
|
||
|