From 95b30baf9c8503eebe601f113b20be365462a337 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 3 Aug 2024 14:13:38 +0300 Subject: [PATCH] wip --- Makefile | 1 + flake.nix | 2 + hbs2-cli/lib/Data/Config/Suckless/Script.hs | 38 ++++++ .../Data/Config/Suckless/Script/Internal.hs | 4 +- hbs2-cli/lib/HBS2/CLI/Run/Help.hs | 30 ----- hbs2-sync/CHANGELOG.md | 5 + hbs2-sync/LICENSE | 30 +++++ hbs2-sync/app/Main.hs | 71 +++++++++++ hbs2-sync/hbs2-sync.cabal | 110 ++++++++++++++++++ hbs2-sync/src/HBS2/Sync/Prelude.hs | 101 ++++++++++++++++ 10 files changed, 360 insertions(+), 32 deletions(-) create mode 100644 hbs2-sync/CHANGELOG.md create mode 100644 hbs2-sync/LICENSE create mode 100644 hbs2-sync/app/Main.hs create mode 100644 hbs2-sync/hbs2-sync.cabal create mode 100644 hbs2-sync/src/HBS2/Sync/Prelude.hs diff --git a/Makefile b/Makefile index 2d6b3bc7..3b1858d8 100644 --- a/Makefile +++ b/Makefile @@ -17,6 +17,7 @@ BINS := \ git-remote-hbs2 \ git-hbs2 \ hbs2-cli \ + hbs2-sync \ fixme-new \ hbs2-storage-simple-benchmarks \ diff --git a/flake.nix b/flake.nix index 25d8410e..c840d080 100644 --- a/flake.nix +++ b/flake.nix @@ -47,6 +47,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: "hbs2-share" "hbs2-fixer" "hbs2-cli" + "hbs2-sync" "fixme-new" ]; in @@ -73,6 +74,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: "hbs2-git" = "./hbs2-git"; "hbs2-fixer" = "./hbs2-fixer"; "hbs2-cli" = "./hbs2-cli"; + "hbs2-sync" = "./hbs2-sync"; "fixme-new" = "./fixme-new"; }; diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script.hs b/hbs2-cli/lib/Data/Config/Suckless/Script.hs index 4fbf3897..735398f9 100644 --- a/hbs2-cli/lib/Data/Config/Suckless/Script.hs +++ b/hbs2-cli/lib/Data/Config/Suckless/Script.hs @@ -7,4 +7,42 @@ module Data.Config.Suckless.Script import Data.Config.Suckless as Exported import Data.Config.Suckless.Script.Internal as Exported +import Control.Monad.Reader +import Data.HashMap.Strict qualified as HM +import Prettyprinter +import Prettyprinter.Render.Terminal +import Data.List qualified as List +import Data.Text qualified as Text +import UnliftIO + + +{- HLINT ignore "Functor law" -} + +helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m () +helpList hasDoc p = do + + let match = maybe (const True) (Text.isPrefixOf . Text.pack) p + + d <- ask >>= readTVarIO + let ks = [k | Id k <- List.sort (HM.keys d) + , match k + , not hasDoc || docDefined (HM.lookup (Id k) d) + ] + + display_ $ vcat (fmap pretty ks) + + where + docDefined (Just (Bind (Just w) _)) = True + docDefined _ = False + +helpEntry :: MonadUnliftIO m => Id -> RunM c m () +helpEntry what = do + man <- ask >>= readTVarIO + <&> HM.lookup what + <&> maybe mzero bindMan + + liftIO $ hPutDoc stdout (pretty man) + +pattern HelpEntryBound :: forall {c}. Id -> [Syntax c] +pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs index 60e6913b..59165f8f 100644 --- a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs +++ b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs @@ -665,8 +665,8 @@ fmt = \case internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () internalEntries = do - entry $ bindValue "false" (Literal noContext (LitBool False)) - entry $ bindValue "true" (Literal noContext (LitBool True)) + entry $ bindValue "false" (mkBool False) + entry $ bindValue "true" (mkBool True) entry $ bindValue "chr:semi" (mkStr ";") entry $ bindValue "chr:tilda" (mkStr "~") entry $ bindValue "chr:colon" (mkStr ":") diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Help.hs b/hbs2-cli/lib/HBS2/CLI/Run/Help.hs index 4fffbcb3..cde30753 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Help.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Help.hs @@ -7,36 +7,6 @@ import Data.HashMap.Strict qualified as HM import Data.List qualified as List import Data.Text qualified as Text -{- HLINT ignore "Functor law" -} - -helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m () -helpList hasDoc p = do - - let match = maybe (const True) (Text.isPrefixOf . Text.pack) p - - d <- ask >>= readTVarIO - let ks = [k | Id k <- List.sort (HM.keys d) - , match k - , not hasDoc || docDefined (HM.lookup (Id k) d) - ] - - display_ $ vcat (fmap pretty ks) - - where - docDefined (Just (Bind (Just w) _)) = True - docDefined _ = False - -helpEntry :: MonadUnliftIO m => Id -> RunM c m () -helpEntry what = do - man <- ask >>= readTVarIO - <&> HM.lookup what - <&> maybe mzero bindMan - - liftIO $ hPutDoc stdout (pretty man) - -pattern HelpEntryBound :: forall {c}. Id -> [Syntax c] -pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] - helpEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m () helpEntries = do diff --git a/hbs2-sync/CHANGELOG.md b/hbs2-sync/CHANGELOG.md new file mode 100644 index 00000000..5afa450c --- /dev/null +++ b/hbs2-sync/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hbs2-share + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/hbs2-sync/LICENSE b/hbs2-sync/LICENSE new file mode 100644 index 00000000..3086ee5d --- /dev/null +++ b/hbs2-sync/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Dmitry Zuikov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dmitry Zuikov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hbs2-sync/app/Main.hs b/hbs2-sync/app/Main.hs new file mode 100644 index 00000000..c4595829 --- /dev/null +++ b/hbs2-sync/app/Main.hs @@ -0,0 +1,71 @@ +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +module Main where + +import HBS2.Sync.Prelude + +import System.Environment +import System.Exit qualified as Exit +import UnliftIO +import Control.Monad.Identity + +quit :: forall m . MonadUnliftIO m => m () +quit = liftIO Exit.exitSuccess + +die :: forall a m . (MonadUnliftIO m, Pretty a) => a -> m () +die what = liftIO do + hPutDoc stderr (pretty what) + Exit.exitFailure + +helpEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () +helpEntries = do + + entry $ bindMatch "help" $ nil_ $ \syn -> do + + display_ $ "hbs2-sync tool" <> line + + case syn of + + (StringLike p : _) -> do + helpList False (Just p) + + HelpEntryBound what -> helpEntry what + + _ -> helpList False Nothing + + quit + + entry $ bindMatch "--help" $ nil_ \case + HelpEntryBound what -> helpBanner >> helpEntry what >> quit + [StringLike s] -> helpBanner >> helpList False (Just s) >> quit + _ -> helpBanner >> helpList False Nothing >> quit + +helpBanner :: MonadUnliftIO m => m () +helpBanner = liftIO do + print $ + "hbs2-sync tool" <> line + +main :: IO () +main = do + + cli <- liftIO getArgs <&> unlines . fmap unwords . splitForms + >>= either (error.show) pure . parseTop + <&> \case + [] -> [mkList [mkSym "run", mkSym "."]] + xs -> xs + + let dict = makeDict do + helpEntries + + entry $ bindMatch "init" $ nil_ $ const do + pure () + + entry $ bindMatch "run" $ nil_ \case + [StringLike what] -> do + runDirectory what + + _ -> do + die "command not specified; run hbs2-sync help for details" + + void $ runSyncApp $ run dict cli + diff --git a/hbs2-sync/hbs2-sync.cabal b/hbs2-sync/hbs2-sync.cabal new file mode 100644 index 00000000..a4c0abc3 --- /dev/null +++ b/hbs2-sync/hbs2-sync.cabal @@ -0,0 +1,110 @@ +cabal-version: 3.0 +name: hbs2-sync +version: 0.24.1.2 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Dmitry Zuikov +maintainer: dzuikov@gmail.com +-- copyright: +category: System +build-type: Simple +-- extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common shared-properties + ghc-options: + -Wall + -fno-warn-type-defaults + -threaded + -rtsopts + -O2 + "-with-rtsopts=-N4 -A64m -AL256m -I0" + + default-language: GHC2021 + + default-extensions: + ApplicativeDo + , BangPatterns + , BlockArguments + , ConstraintKinds + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , ExtendedDefaultRules + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeFamilies + + + build-depends: + hbs2-core + , hbs2-peer + , hbs2-storage-simple + , hbs2-keyman + , db-pipe + , suckless-conf + + , atomic-write + , bytestring + , containers + , directory + , filepath + , filepattern + , interpolatedstring-perl6 + , memory + , microlens-platform + , mtl + , prettyprinter + , serialise + , streaming + , stm + , text + , time + , timeit + , transformers + , typed-process + , unordered-containers + , unliftio + , zlib + + +library + import: shared-properties + + exposed-modules: + HBS2.Sync.Prelude + + other-modules: + + -- other-modules: + -- other-extensions: + build-depends: base, hbs2-peer, hbs2-cli + hs-source-dirs: src + +executable hbs2-sync + import: shared-properties + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: + base, hbs2-sync, hbs2-peer + + hs-source-dirs: app + default-language: GHC2021 + diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs new file mode 100644 index 00000000..0241dfe5 --- /dev/null +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -0,0 +1,101 @@ +module HBS2.Sync.Prelude + ( module HBS2.Sync.Prelude + , module Exported + ) where + + +import HBS2.Prelude.Plated as Exported +import HBS2.OrDie as Exported +import HBS2.Data.Types.Refs as Exported +import HBS2.Clock as Exported +import HBS2.Net.Proto.Service +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.Storage +import HBS2.System.Logger.Simple.ANSI as Exported +import HBS2.Misc.PrettyStuff as Exported + +import Data.Config.Suckless as Exported +import Data.Config.Suckless.Script as Exported + +import Prettyprinter as Exported +import Control.Monad.Reader as Exported +import Control.Monad.Trans.Cont as Exported +import Codec.Serialise as Exported + +import UnliftIO + +data SyncEnv = + SyncEnv + { rechanAPI :: ServiceCaller RefChanAPI UNIX + , storageAPI :: ServiceCaller StorageAPI UNIX + , peerAPI :: ServiceCaller PeerAPI UNIX + } + +newtype SyncApp m a = + SyncApp { fromSyncApp :: ReaderT (Maybe SyncEnv) m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadUnliftIO + , MonadIO + , MonadReader (Maybe SyncEnv)) + + +type SyncAppPerks m = MonadUnliftIO m + +withSyncApp :: SyncAppPerks m => Maybe SyncEnv -> SyncApp m a -> m a +withSyncApp env action = runReaderT (fromSyncApp action) env + +runSyncApp :: SyncAppPerks m => SyncApp m a -> m a +runSyncApp m = do + withSyncApp Nothing m + +recover :: SyncApp IO a -> SyncApp IO a +recover what = do + catch what $ \case + PeerNotConnectedException -> 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 sto = AnyStorage (StorageClient storageAPI) + + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refChanAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + let env = Just (SyncEnv refChanAPI storageAPI peerAPI) + + liftIO $ withSyncApp env what + +data PeerException = + PeerNotConnectedException + deriving stock (Show, Typeable) + +instance Exception PeerException + + +runDirectory :: SyncAppPerks m => FilePath -> m () +runDirectory path = do + pure () + +