wip

Makefile

@@ -17,6 +17,7 @@ BINS := \
   git-remote-hbs2    \
   git-hbs2           \
   hbs2-cli           \
+  hbs2-sync          \
   fixme-new          \
 	hbs2-storage-simple-benchmarks \
 

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";
    };
 

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 : _ )]
 

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 ":")

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
 

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.

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.

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
+

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
+

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 ()
+
+