mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
5d8531be64
commit
95b30baf9c
1
Makefile
1
Makefile
|
|
@ -17,6 +17,7 @@ BINS := \
|
||||||
git-remote-hbs2 \
|
git-remote-hbs2 \
|
||||||
git-hbs2 \
|
git-hbs2 \
|
||||||
hbs2-cli \
|
hbs2-cli \
|
||||||
|
hbs2-sync \
|
||||||
fixme-new \
|
fixme-new \
|
||||||
hbs2-storage-simple-benchmarks \
|
hbs2-storage-simple-benchmarks \
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -47,6 +47,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
||||||
"hbs2-share"
|
"hbs2-share"
|
||||||
"hbs2-fixer"
|
"hbs2-fixer"
|
||||||
"hbs2-cli"
|
"hbs2-cli"
|
||||||
|
"hbs2-sync"
|
||||||
"fixme-new"
|
"fixme-new"
|
||||||
];
|
];
|
||||||
in
|
in
|
||||||
|
|
@ -73,6 +74,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
||||||
"hbs2-git" = "./hbs2-git";
|
"hbs2-git" = "./hbs2-git";
|
||||||
"hbs2-fixer" = "./hbs2-fixer";
|
"hbs2-fixer" = "./hbs2-fixer";
|
||||||
"hbs2-cli" = "./hbs2-cli";
|
"hbs2-cli" = "./hbs2-cli";
|
||||||
|
"hbs2-sync" = "./hbs2-sync";
|
||||||
"fixme-new" = "./fixme-new";
|
"fixme-new" = "./fixme-new";
|
||||||
};
|
};
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -7,4 +7,42 @@ module Data.Config.Suckless.Script
|
||||||
import Data.Config.Suckless as Exported
|
import Data.Config.Suckless as Exported
|
||||||
import Data.Config.Suckless.Script.Internal 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 : _ )]
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -665,8 +665,8 @@ fmt = \case
|
||||||
internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
|
internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
|
||||||
internalEntries = do
|
internalEntries = do
|
||||||
|
|
||||||
entry $ bindValue "false" (Literal noContext (LitBool False))
|
entry $ bindValue "false" (mkBool False)
|
||||||
entry $ bindValue "true" (Literal noContext (LitBool True))
|
entry $ bindValue "true" (mkBool True)
|
||||||
entry $ bindValue "chr:semi" (mkStr ";")
|
entry $ bindValue "chr:semi" (mkStr ";")
|
||||||
entry $ bindValue "chr:tilda" (mkStr "~")
|
entry $ bindValue "chr:tilda" (mkStr "~")
|
||||||
entry $ bindValue "chr:colon" (mkStr ":")
|
entry $ bindValue "chr:colon" (mkStr ":")
|
||||||
|
|
|
||||||
|
|
@ -7,36 +7,6 @@ import Data.HashMap.Strict qualified as HM
|
||||||
import Data.List qualified as List
|
import Data.List qualified as List
|
||||||
import Data.Text qualified as Text
|
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 :: (MonadUnliftIO m, IsContext c) => MakeDictM c m ()
|
||||||
helpEntries = do
|
helpEntries = do
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
# Revision history for hbs2-share
|
||||||
|
|
||||||
|
## 0.1.0.0 -- YYYY-mm-dd
|
||||||
|
|
||||||
|
* First version. Released on an unsuspecting world.
|
||||||
|
|
@ -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.
|
||||||
|
|
@ -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
|
||||||
|
|
||||||
|
|
@ -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
|
||||||
|
|
||||||
|
|
@ -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 ()
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in New Issue