diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index 5d5780b4..ab86d2e6 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -24,6 +24,7 @@ import HBS2.Peer.RPC.Client.Unix import HBS2.Net.Auth.Schema() import System.Environment +import System.IO qualified as IO type RefLogId = PubKey 'Sign 'HBS2Basic @@ -35,7 +36,7 @@ setupLogger = do -- setLogging @DEBUG $ toStderr . logPrefix "[debug] " setLogging @ERROR $ toStderr . logPrefix "[error] " setLogging @WARN $ toStderr . logPrefix "[warn] " - setLogging @NOTICE $ toStdout . logPrefix "" + setLogging @NOTICE $ toStderr . logPrefix "" pure () flushLoggers :: MonadIO m => m () @@ -86,6 +87,7 @@ main = do runHBS2Cli do + case cli of [ListVal [SymbolVal "stdin"]] -> do what <- liftIO getContents @@ -94,7 +96,14 @@ main = do recover $ run dict what >>= eatNil display [] -> do - void $ run dict [mkForm "help" []] + eof <- liftIO IO.isEOF + if eof then + void $ run dict [mkForm "help" []] + else do + what <- liftIO getContents + >>= either (error.show) pure . parseTop + + recover $ run dict what >>= eatNil display _ -> do recover $ run dict cli >>= eatNil display diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs index 6ab6dd36..817d8784 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs @@ -33,7 +33,7 @@ keymanGetConfig = do keymanUpdate :: MonadUnliftIO m => m () keymanUpdate = do - void $ runProcess (shell [qc|hbs2-keyman update|]) + void $ runProcess (shell [qc|hbs2-keyman update|] & setStderr closed & setStdout closed) keymanNewCredentials :: MonadUnliftIO m => Maybe String -> Int -> m (PubKey 'Sign 'HBS2Basic) keymanNewCredentials suff n = do @@ -52,3 +52,4 @@ keymanNewCredentials suff n = do keymanUpdate pure psk + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs index f0f371b4..1f29363c 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs @@ -50,3 +50,4 @@ keymanEntries = do pure $ mkStr fpath _ -> throwIO (BadFormException @C nil) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs index b912ee8a..7498113e 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs @@ -37,10 +37,10 @@ lwwRefEntries = do $ returns "string" "lwwref public key" $ entry $ bindMatch "hbs2:lwwref:create" $ \case [] -> do - reflog <- keymanNewCredentials (Just "lwwref") 0 + key <- keymanNewCredentials (Just "lwwref") 0 api <- getClientAPI @PeerAPI @UNIX - void $ callService @RpcPollAdd api (reflog, "lwwref", 31) - pure $ mkStr (show $ pretty (AsBase58 reflog)) + void $ callService @RpcPollAdd api (key, "lwwref", 31) + pure $ mkForm "pk" [mkStr (show $ pretty (AsBase58 key))] _ -> throwIO (BadFormException @C nil) diff --git a/hbs2-git3/hbs2-git3.cabal b/hbs2-git3/hbs2-git3.cabal index 822455aa..07eaeae0 100644 --- a/hbs2-git3/hbs2-git3.cabal +++ b/hbs2-git3/hbs2-git3.cabal @@ -125,12 +125,14 @@ library HBS2.Git3.Prelude HBS2.Git3.Export HBS2.Git3.Import + HBS2.Git3.Repo HBS2.Git3.Run HBS2.Git3.State.Types HBS2.Git3.State.RefLog HBS2.Git3.State.Index HBS2.Git3.State.Segment HBS2.Git3.Config.Local + HBS2.Git3.State.LWWBlock HBS2.Git3.Git HBS2.Git3.Git.Pack diff --git a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs index 093fd0e7..37a250b4 100644 --- a/hbs2-git3/lib/HBS2/Git3/Config/Local.hs +++ b/hbs2-git3/lib/HBS2/Git3/Config/Local.hs @@ -12,6 +12,8 @@ import Data.Config.Suckless.Script import Data.Text.IO qualified as IO +{- HLINT ignore "Functor law"-} + getConfigPath :: MonadIO m => m FilePath getConfigPath = do @@ -21,6 +23,17 @@ getConfigPath = do >>= orThrowUser ".git not found" <&> ( name) . takeDirectory + +getConfigRootFile :: MonadIO m => m FilePath +getConfigRootFile = do + + let name = ".hbs2-git3" + + findGitDir + >>= orThrowUser ".git not found" + <&> ( name) . takeDirectory + <&> ( "config") + readLocalConf :: MonadIO m => m [Syntax C] readLocalConf = do diff --git a/hbs2-git3/lib/HBS2/Git3/Prelude.hs b/hbs2-git3/lib/HBS2/Git3/Prelude.hs index 2b0d3734..742e5a30 100644 --- a/hbs2-git3/lib/HBS2/Git3/Prelude.hs +++ b/hbs2-git3/lib/HBS2/Git3/Prelude.hs @@ -15,12 +15,14 @@ module HBS2.Git3.Prelude ) where import HBS2.Prelude.Plated as Exported +import HBS2.Defaults as Exported import HBS2.OrDie as Exported import HBS2.Data.Types.Refs as Exported import HBS2.Base58 as Exported import HBS2.Merkle as Exported import HBS2.Misc.PrettyStuff as Exported import HBS2.Net.Auth.Credentials +import HBS2.Peer.Proto.LWWRef as Exported import HBS2.Peer.Proto.RefLog as Exported import HBS2.Peer.RPC.API.RefLog as Exported import HBS2.Peer.RPC.API.Peer as Exported @@ -30,6 +32,7 @@ import HBS2.Peer.RPC.Client hiding (encode,decode) import HBS2.Peer.RPC.Client.Unix hiding (encode,decode) import HBS2.Peer.RPC.Client.StorageClient import HBS2.Peer.CLI.Detect +import HBS2.Data.Types.SignedBox as Exported import HBS2.Storage as Exported import HBS2.Storage.Operations.Class as Exported import HBS2.System.Logger.Simple.ANSI as Exported @@ -117,7 +120,9 @@ data Git3Env = , peerStorage :: AnyStorage , peerAPI :: ServiceCaller PeerAPI UNIX , reflogAPI :: ServiceCaller RefLogAPI UNIX + , lwwAPI :: ServiceCaller LWWRefAPI UNIX , gitRefLog :: TVar (Maybe GitRemoteKey) + , gitRepoKey :: TVar (Maybe GitRepoKey) , gitPackedSegmentSize :: TVar Int , gitCompressionLevel :: TVar Int , gitIndexBlockSize :: TVar Natural @@ -132,6 +137,8 @@ class HasExportOpts m where class HasGitRemoteKey m where getGitRemoteKey :: m (Maybe GitRemoteKey) setGitRemoteKey :: GitRemoteKey -> m () + getGitRepoKey :: m (Maybe GitRepoKey) + setGitRepoKey :: GitRepoKey -> m () instance (MonadIO m, MonadReader Git3Env m) => HasGitRemoteKey m where getGitRemoteKey = do @@ -142,6 +149,14 @@ instance (MonadIO m, MonadReader Git3Env m) => HasGitRemoteKey m where e <- ask liftIO $ atomically $ writeTVar (gitRefLog e) (Just k) + getGitRepoKey = do + e <- ask + liftIO $ readTVarIO (gitRepoKey e) + + setGitRepoKey k = do + e <- ask + liftIO $ atomically $ writeTVar (gitRepoKey e) (Just k) + instance (MonadIO m, MonadReader Git3Env m) => HasExportOpts m where getPackedSegmetSize = asks gitPackedSegmentSize >>= readTVarIO setPackedSegmedSize x = do @@ -198,6 +213,13 @@ instance (MonadUnliftIO m) => HasClientAPI RefLogAPI UNIX (Git3 m) where Git3Disconnected{} -> throwIO Git3PeerNotConnected Git3Connected{..} -> pure reflogAPI + +instance (MonadUnliftIO m) => HasClientAPI LWWRefAPI UNIX (Git3 m) where + getClientAPI = do + ask >>= \case + Git3Disconnected{} -> throwIO Git3PeerNotConnected + Git3Connected{..} -> pure lwwAPI + nullGit3Env :: MonadIO m => m Git3Env nullGit3Env = Git3Disconnected <$> newTVarIO Nothing @@ -266,8 +288,9 @@ recover m = fix \again -> do let sto = AnyStorage (StorageClient storageAPI) - connected <- Git3Connected soname sto peerAPI refLogAPI + connected <- Git3Connected soname sto peerAPI refLogAPI lwwAPI <$> newTVarIO (Just ref) + <*> newTVarIO Nothing <*> newTVarIO defSegmentSize <*> newTVarIO defCompressionLevel <*> newTVarIO defIndexBlockSize diff --git a/hbs2-git3/lib/HBS2/Git3/Run.hs b/hbs2-git3/lib/HBS2/Git3/Run.hs index 35e77658..0d35abdf 100644 --- a/hbs2-git3/lib/HBS2/Git3/Run.hs +++ b/hbs2-git3/lib/HBS2/Git3/Run.hs @@ -24,9 +24,10 @@ import HBS2.Git3.Git import HBS2.Git3.Export import HBS2.Git3.Import import HBS2.Git3.State.RefLog +import HBS2.Git3.Repo qualified as Repo import Data.Config.Suckless.Script -import Data.Config.Suckless.Script.File +import Data.Config.Suckless.Almost.RPC import Codec.Compression.Zstd.Streaming qualified as ZstdS import Codec.Compression.Zstd.Streaming (Result(..)) @@ -48,6 +49,9 @@ import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy ( ByteString ) import Data.ByteString.Builder as Builder import Network.ByteOrder qualified as N +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.Encoding.Error qualified as TE import Text.InterpolatedString.Perl6 (qc) import Data.Set qualified as Set import Data.HashSet qualified as HS @@ -573,5 +577,35 @@ theDict = do entry $ bindMatch "reflog:import" $ nil_ $ \syn -> lift $ connectedDo do importGitRefLog + + entry $ bindMatch "repo:key" $ nil_ $ \case + [ SignPubKeyLike k ] -> lift $ connectedDo do + setGitRepoKey k + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "repo:init" $ nil_ $ \syn -> lift $ connectedDo do + Repo.initRepo syn + -- conf <- getConfigRootFile + -- mbKey <- getGitRepoKey + + -- case mbKey of + -- Nothing -> do + + -- notice "TODO: 1. create new key" + -- notice "TODO: 4. subscribe lwwref" + + -- answ <- callProc "hbs2-cli" [] [mkSym "hbs2:lwwref:create"] + + -- pk <- [ puk | ListVal [SymbolVal "pk", SignPubKeyLike puk] <- answ ] + -- & lastMay + -- & orThrowUser "failed to create new lww ref" + + -- liftIO $ print $ pretty (AsBase58 pk) + + -- notice "TODO: 2. derive reflog key" + -- notice "TODO: 3. init lwwblock" + -- notice "TODO: 5. subscribe reflog" + exportEntries "reflog:" diff --git a/hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs b/hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs new file mode 100644 index 00000000..e0524cbb --- /dev/null +++ b/hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs @@ -0,0 +1,7 @@ +module HBS2.Git3.State.LWWBlock where + +import HBS2.Git3.Prelude + + + + diff --git a/hbs2-git3/lib/HBS2/Git3/Types.hs b/hbs2-git3/lib/HBS2/Git3/Types.hs index e2c28b49..c801395f 100644 --- a/hbs2-git3/lib/HBS2/Git3/Types.hs +++ b/hbs2-git3/lib/HBS2/Git3/Types.hs @@ -13,6 +13,8 @@ import Control.Concurrent.STM qualified as STM type GitRemoteKey = PubKey 'Sign 'HBS2Basic +type GitRepoKey = PubKey 'Sign HBS2Basic + newtype Short x = Short x instance Pretty (Short GitObjectType) where diff --git a/hbs2-keyman/hbs2-keyman/Main.hs b/hbs2-keyman/hbs2-keyman/Main.hs index 2c269a01..e6b9495e 100644 --- a/hbs2-keyman/hbs2-keyman/Main.hs +++ b/hbs2-keyman/hbs2-keyman/Main.hs @@ -23,8 +23,8 @@ import HBS2.Peer.RPC.API.RefChan import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient -import Data.Config.Suckless.KeyValue import Data.Config.Suckless +import Data.Config.Suckless.Script import Data.List qualified as List import Options.Applicative qualified as O @@ -261,3 +261,4 @@ main :: IO () main = do (_, action) <- execParser opts runApp action + diff --git a/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs b/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs index 87d4fe92..e4127a5c 100644 --- a/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs +++ b/miscellaneous/fuzzy-parse/src/Data/Text/Fuzzy/SExp.hs @@ -19,6 +19,7 @@ import Data.Text.Fuzzy.Tokenize import Control.Monad.Reader import Data.Typeable import Control.Monad.Except +import Control.Exception import Control.Monad.RWS import Data.Maybe import Data.Char (isSpace,digitToInt) @@ -69,6 +70,7 @@ data SExpParseError = | SyntaxError C0 deriving stock (Show,Typeable) +instance Exception SExpParseError data NumType = NumInteger Integer diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs new file mode 100644 index 00000000..6725bb2e --- /dev/null +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs @@ -0,0 +1,47 @@ +{-# Language TypeOperators #-} +module Data.Config.Suckless.Almost.RPC where + +import Data.Config.Suckless + +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString.Lazy as LBS +import Data.ByteString.Lazy.Char8 as LBS8 +import Data.Function +import Data.Text.Encoding.Error qualified as TE +import Data.Text.Encoding qualified as TE +import Data.Text qualified as T +import Data.Typeable +import Prettyprinter +import System.Process.Typed + +data CallProcException = + CallProcException ExitCode + deriving (Show,Typeable) + +instance Exception CallProcException + +-- FIXME: to-suckless-script +callProc :: forall m . (MonadIO m) + => FilePath + -> [String] + -> [Syntax C] + -> m [Syntax C] + +callProc name params syn = do + let input = fmap (LBS.fromStrict . TE.encodeUtf8 . T.pack . show . pretty) syn + & LBS8.unlines + & byteStringInput + + let what = proc name params & setStderr closed & setStdin input + (code, i, _) <- readProcess what + + unless (code == ExitSuccess) do + liftIO $ throwIO (CallProcException code) + + let s = TE.decodeUtf8With TE.lenientDecode (LBS.toStrict i) + + parseTop s & either (liftIO . throwIO) pure + + diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index 1bf9c763..e04a1abb 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -82,12 +82,11 @@ pattern LitBoolVal v <- Literal _ (LitBool v) pattern ListVal :: [Syntax c] -> Syntax c pattern ListVal v <- List _ v - stringLike :: Syntax c -> Maybe String stringLike = \case LitStrVal s -> Just $ Text.unpack s SymbolVal (Id s) -> Just $ Text.unpack s - _ -> Nothing + x -> Just $ show $ pretty x stringLikeList :: [Syntax c] -> [String] stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes diff --git a/miscellaneous/suckless-conf/suckless-conf.cabal b/miscellaneous/suckless-conf/suckless-conf.cabal index 8011ace2..b6f89efe 100644 --- a/miscellaneous/suckless-conf/suckless-conf.cabal +++ b/miscellaneous/suckless-conf/suckless-conf.cabal @@ -67,6 +67,7 @@ library , Data.Config.Suckless.KeyValue , Data.Config.Suckless.Script , Data.Config.Suckless.Script.File + , Data.Config.Suckless.Almost.RPC other-modules: Data.Config.Suckless.Types @@ -95,6 +96,7 @@ library , text , time , transformers + , typed-process , unliftio , unordered-containers , vector