diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs index 59165f8f..2a682a79 100644 --- a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs +++ b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs @@ -537,11 +537,22 @@ bind name expr = do atomically do modifyTVar t (HM.insert name what) +bindBuiltins :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) + => Dict c m + -> RunM c m () + +bindBuiltins dict = do + t <- ask + atomically do + modifyTVar t (<> dict) eval :: forall c m . ( IsContext c - , MonadUnliftIO m - , Exception (BadFormException c) - ) => Syntax c -> RunM c m (Syntax c) + , MonadUnliftIO m + , Exception (BadFormException c) + ) => Syntax c -> RunM c m (Syntax c) eval syn = handle (handleForm syn) $ do dict <- ask >>= readTVarIO diff --git a/hbs2-sync/app/Main.hs b/hbs2-sync/app/Main.hs index c4595829..33a20fff 100644 --- a/hbs2-sync/app/Main.hs +++ b/hbs2-sync/app/Main.hs @@ -56,6 +56,10 @@ main = do let dict = makeDict do helpEntries + syncEntries + + entry $ bindMatch "debug:cli:show" $ nil_ \case + _ -> display cli entry $ bindMatch "init" $ nil_ $ const do pure () diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs index 0241dfe5..7d95d099 100644 --- a/hbs2-sync/src/HBS2/Sync/Prelude.hs +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -5,6 +5,7 @@ module HBS2.Sync.Prelude import HBS2.Prelude.Plated as Exported +import HBS2.Base58 import HBS2.OrDie as Exported import HBS2.Data.Types.Refs as Exported import HBS2.Clock as Exported @@ -19,16 +20,25 @@ import HBS2.Peer.RPC.API.Storage import HBS2.System.Logger.Simple.ANSI as Exported import HBS2.Misc.PrettyStuff as Exported +import HBS2.CLI.Run hiding (PeerException(..)) + import Data.Config.Suckless as Exported import Data.Config.Suckless.Script as Exported +import Data.Config.Suckless.Script.File -import Prettyprinter as Exported +import Codec.Serialise as Exported +import Control.Concurrent.STM (flushTQueue) import Control.Monad.Reader as Exported import Control.Monad.Trans.Cont as Exported -import Codec.Serialise as Exported +import Data.Either +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import System.FilePath import UnliftIO +{- HLINT ignore "Functor law" -} + data SyncEnv = SyncEnv { rechanAPI :: ServiceCaller RefChanAPI UNIX @@ -53,7 +63,8 @@ withSyncApp env action = runReaderT (fromSyncApp action) env runSyncApp :: SyncAppPerks m => SyncApp m a -> m a runSyncApp m = do - withSyncApp Nothing m + setupLogger + withSyncApp Nothing m `finally` flushLoggers recover :: SyncApp IO a -> SyncApp IO a recover what = do @@ -93,9 +104,113 @@ data PeerException = instance Exception PeerException +data RunDirectoryException = + RefChanNotSetException + deriving stock (Show,Typeable) -runDirectory :: SyncAppPerks m => FilePath -> m () +instance Exception RunDirectoryException + +runDirectory :: ( IsContext c + , SyncAppPerks m + , Exception (BadFormException c) + ) => FilePath -> RunM c m () runDirectory path = do + + t <- ask + d0 <- readTVarIO t + + runDir + `catch` \case + RefChanNotSetException -> do + warn $ "no refchan set for" <+> pretty path + `finally` do + warn "exiting" + atomically (writeTVar t d0) + + where + + runDir = do + + notice $ yellow "run directory" <+> pretty path + + trc <- newTVarIO Nothing + texcl <- newTQueueIO + tincl <- newTQueueIO + + atomically $ writeTQueue tincl "**" + + ins <- liftIO $ readFile (path ".hbs2-sync/config") + <&> parseTop + <&> either mempty (fmap fixContext) + + bindBuiltins $ bindMatch "refchan" $ nil_ $ \case + [SignPubKeyLike puk] -> do + debug $ red "USE FUCKING REFCHAN!" <+> pretty (AsBase58 puk) + atomically $ writeTVar trc (Just puk) + + _ -> pure () + + bindBuiltins $ bindMatch "exclude" $ nil_ $ \case + [StringLike excl] -> do + debug $ red "EXCLUDE!" <+> pretty excl + atomically $ writeTQueue texcl excl + + _ -> pure () + + bindBuiltins $ bindMatch "include" $ nil_ $ \case + [StringLike s] -> do + debug $ red "INCLUDE!" <+> pretty s + atomically $ writeTQueue tincl s + + _ -> pure () + + evalTop ins + + i <- atomically (flushTQueue tincl) <&> HS.fromList <&> HS.toList + e <- atomically (flushTQueue texcl) <&> HS.fromList <&> HS.toList + + rc <- readTVarIO trc + >>= orThrow RefChanNotSetException + + debug $ "step 1" <+> "load state from refchan" + debug $ "step 2" <+> "create local state" + debug $ "step 3" <+> "merge states" + debug $ "step 3.1" <+> "generate merge actions" + debug $ "step 3.2" <+> "apply actions" + + glob i e path $ \fn -> do + pure True + + debug $ pretty ins + +syncEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () +syncEntries = do + + entry $ bindMatch "--debug" $ nil_ $ \case + [SymbolVal "off"] -> do + setLoggingOff @DEBUG + + _ -> do + setLogging @DEBUG debugPrefix + +debugPrefix = toStderr . logPrefix "[debug] " + +setupLogger :: MonadIO m => m () +setupLogger = do + -- setLogging @DEBUG $ toStderr . logPrefix "[debug] " + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" pure () +flushLoggers :: MonadIO m => m () +flushLoggers = do + silence + +silence :: MonadIO m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE