wip, interwire hbs2-peer and fixme-new

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
+  recover env do
-                 `finally` flushLoggers
+    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

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)
 

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)