wip, init lwwref

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

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
+

hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs

@@ -50,3 +50,4 @@ keymanEntries = do
       pure $ mkStr fpath
 
     _ -> throwIO (BadFormException @C nil)
+

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)
 

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
 

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
 

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

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

hbs2-git3/lib/HBS2/Git3/State/LWWBlock.hs

@@ -0,0 +1,7 @@
+module HBS2.Git3.State.LWWBlock where
+
+import HBS2.Git3.Prelude
+
+
+
+

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

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
+

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

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

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

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