From c90adb1fe12b137bb254e7f9d4bf4ce25a8c5247 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Mon, 2 Sep 2024 07:32:41 +0300 Subject: [PATCH] wip, interwire hbs2-peer and fixme-new --- fixme-new/lib/Fixme/Run.hs | 93 +++++++++++++++++++++++++-- fixme-new/lib/Fixme/Scan/Git/Local.hs | 4 +- fixme-new/lib/Fixme/Types.hs | 50 +++++++++++++- 3 files changed, 139 insertions(+), 8 deletions(-) diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 379752a5..964ffaff 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -11,7 +11,10 @@ import Fixme.Scan as Scan import Fixme.Log import HBS2.Git.Local.CLI +import HBS2.Peer.Proto.RefChan.Types +import HBS2.OrDie +import HBS2.Peer.CLI.Detect import HBS2.Base58 import HBS2.Merkle import HBS2.Data.Types.Refs @@ -50,9 +53,50 @@ import System.IO qualified as IO {- HLINT ignore "Functor law" -} -withFixmeCLI :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a + +recover :: (FixmePerks m) => FixmeEnv -> m a -> m a +recover env m = flip fix 0 $ \next attempt + -> do m + `catch` (\PeerNotConnected -> do + if attempt < 1 then do + runWithRPC env $ next (succ attempt) + else do + throwIO PeerNotConnected + ) + +withFixmeCLI :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeEnv -> FixmeM m a -> m a withFixmeCLI env m = do - runReaderT (fromFixmeM m) env + recover env do + withFixmeEnv env m + +runWithRPC :: (FixmePerks m) => FixmeEnv -> m a -> m a +runWithRPC FixmeEnv{..} m = do + + soname <- detectRPC + `orDie` "can't locate hbs2-peer rpc" + + flip runContT pure do + + client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + void $ ContT $ withAsync $ runMessagingUnix client + + peerAPI <- makeServiceCaller @PeerAPI (fromString soname) + refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refChanAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + + let newEnv = Just (MyPeerClientEndpoints soname peerAPI refChanAPI storageAPI) + liftIO $ atomically $ writeTVar fixmeEnvMyEndpoints newEnv + lift m runFixmeCLI :: forall a m . FixmePerks m => FixmeM m a -> m a runFixmeCLI m = do @@ -77,13 +121,15 @@ runFixmeCLI m = do <*> newTVarIO defaultTemplate <*> newTVarIO mempty <*> newTVarIO (1,3) + <*> newTVarIO mzero -- FIXME: defer-evolve -- не все действия требуют БД, -- хорошо бы, что бы она не создавалась, -- если не требуется - runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env - `finally` flushLoggers + recover env do + runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env + `finally` flushLoggers where setupLogger = do setLogging @ERROR $ toStderr . logPrefix "[error] " @@ -351,6 +397,38 @@ runTop forms = do entry $ bindMatch "init" $ nil_ $ const $ do lift init + brief "initializes a new refchan" $ + desc ( vcat [ + "Refchan is an ACL-controlled CRDT channel useful for syncronizing" + , "fixme-new state amongst the different remote setups/peers/directories" + , "use it if you want to use fixme-new in a distributed fashion" + ] + ) $ + args [] $ + returns "string" "refchan-key" $ do + entry $ bindMatch "refchan:init" $ nil_ $ const $ do + + let rch0 = refChanHeadDefault @L4Proto + + rch <- flip runContT pure do + + notice $ yellow "1. find group key" + + -- TODO: use-hbs2-git-api? + (e, gkh, _) <- readProcess (shell [qc|git hbs2 key|]) + <&> over _2 (fromStringMay @HashRef . headDef "" . lines . LBS8.unpack) + + notice $ "gkh:" <+> pretty gkh + + notice $ yellow "2. generate refchan head" + notice $ yellow "3. subscribe peer to this refchan" + notice $ yellow "4. post refcha head" + notice $ yellow "5. add def-refchan ins to the config" + notice $ green "6. we're done" + + pure () + + entry $ bindMatch "set-template" $ nil_ \case [SymbolVal who, SymbolVal w] -> do templates <- lift $ asks fixmeEnvTemplates @@ -373,6 +451,13 @@ runTop forms = do entry $ bindMatch "log:trace:off" $ nil_ $ const do lift $ setLoggingOff @TRACE + + entry $ bindMatch "debug:peer:check" $ nil_ $ const do + peer <- lift $ getClientAPI @PeerAPI @UNIX + poked <- callRpcWaitMay @RpcPoke (TimeoutSec 1) peer () + <&> fromMaybe "hbs2-peer not connected" + liftIO $ putStrLn poked + conf <- readConfig argz <- liftIO getArgs diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs index 05f6496b..ce635c70 100644 --- a/fixme-new/lib/Fixme/Scan/Git/Local.hs +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -465,7 +465,7 @@ scanGitLocal args p = do debug $ "actually-import-fixmies" <+> pretty h - liftIO $ withFixmeEnv env $ withState $ transactional do + lift $ withFixmeEnv env $ withState $ transactional do insertBlob h for_ fixmies insertFixme @@ -474,7 +474,7 @@ scanGitLocal args p = do unless ( ScanRunDry `elem` args ) do lift runLogActions - liftIO $ withFixmeEnv env $ withState $ transactional do + lift $ withFixmeEnv env $ withState $ transactional do for_ co $ \w -> do insertCommit (view _1 w) diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs index 4d5ff28c..e5fb6b7c 100644 --- a/fixme-new/lib/Fixme/Types.hs +++ b/fixme-new/lib/Fixme/Types.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Fixme.Types ( module Fixme.Types + , module Exported ) where import Fixme.Prelude hiding (align) @@ -10,6 +11,17 @@ import HBS2.Base58 import DBPipe.SQLite hiding (field) import HBS2.Git.Local +import HBS2.OrDie +import HBS2.Storage as Exported +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client as Exported hiding (encode,decode) +import HBS2.Peer.RPC.Client.Unix as Exported hiding (encode,decode) +import HBS2.Peer.RPC.API.Peer as Exported +import HBS2.Peer.RPC.API.RefChan as Exported +import HBS2.Peer.RPC.API.Storage as Exported +import HBS2.Peer.RPC.Client.StorageClient as Exported + + import Data.Config.Suckless import Prettyprinter.Render.Terminal @@ -33,6 +45,17 @@ import Text.InterpolatedString.Perl6 (qc) import Data.Generics.Product.Fields (field) import Lens.Micro.Platform + +data MyPeerClientEndpoints = + MyPeerClientEndpoints + { _peerSocket :: FilePath + , _peerPeerAPI :: ServiceCaller PeerAPI UNIX + , _peerRefChanAPI :: ServiceCaller RefChanAPI UNIX + , _peerStorageAPI :: ServiceCaller StorageAPI UNIX + } + +makeLenses 'MyPeerClientEndpoints + -- FIXME: move-to-suckless-conf deriving stock instance Ord (Syntax C) @@ -143,7 +166,6 @@ newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal) - type FixmePerks m = ( MonadUnliftIO m , MonadIO m ) @@ -245,6 +267,11 @@ instance Monoid FixmeOpts where instance Semigroup FixmeOpts where (<>) _ b = FixmeOpts (fixmeOptNoEvolve b) +data PeerNotConnected = PeerNotConnected + deriving (Show,Typeable) + +instance Exception PeerNotConnected + data FixmeEnv = FixmeEnv { fixmeLock :: MVar () @@ -265,6 +292,7 @@ data FixmeEnv = , fixmeEnvTemplates :: TVar (HashMap Id FixmeTemplate) , fixmeEnvMacro :: TVar (HashMap Id (Syntax C)) , fixmeEnvCatContext :: TVar (Int,Int) + , fixmeEnvMyEndpoints :: TVar (Maybe MyPeerClientEndpoints) } @@ -323,6 +351,7 @@ fixmeEnvBare = <*> newTVarIO mempty <*> newTVarIO mempty <*> newTVarIO (1,3) + <*> newTVarIO mzero withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a withFixmeEnv env what = runReaderT ( fromFixmeM what) env @@ -338,6 +367,23 @@ instance Serialise FixmeKey instance Serialise Fixme +instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI PeerAPI UNIX m where + getClientAPI = getApiOrThrow peerPeerAPI + +instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI RefChanAPI UNIX m where + getClientAPI = getApiOrThrow peerRefChanAPI + +instance (FixmePerks m, MonadReader FixmeEnv m) => HasClientAPI StorageAPI UNIX m where + getClientAPI = getApiOrThrow peerStorageAPI + +getApiOrThrow :: (MonadReader FixmeEnv m, MonadIO m) + => Getting b MyPeerClientEndpoints b -> m b +getApiOrThrow getter = + asks fixmeEnvMyEndpoints + >>= readTVarIO + >>= orThrow PeerNotConnected + <&> view getter + instance ToField GitHash where toField h = toField (show $ pretty h)