mirror of https://github.com/voidlizard/hbs2
wip, interwire hbs2-peer and fixme-new
This commit is contained in:
Dmitry Zuikov
parent
25a49a96bf
commit
c90adb1fe1
|
|
@ -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,11 +121,13 @@ runFixmeCLI m = do
|
|||
<*> newTVarIO defaultTemplate
|
||||
<*> newTVarIO mempty
|
||||
<*> newTVarIO (1,3)
|
||||
<*> newTVarIO mzero
|
||||
|
||||
-- FIXME: defer-evolve
|
||||
-- не все действия требуют БД,
|
||||
-- хорошо бы, что бы она не создавалась,
|
||||
-- если не требуется
|
||||
recover env do
|
||||
runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env
|
||||
`finally` flushLoggers
|
||||
where
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue