indexed keys, hbs2-keyman and hbs2-sync updated

cabal.project

@@ -1,9 +1,10 @@
 packages: **/*.cabal
   examples/*/*.cabal
+  **/*/*.cabal
 
 allow-newer: all
 
-constraints: pandoc >=3.1.11, suckless-conf >= 0.1.2.6
+constraints: pandoc >=3.1.11, suckless-conf >= 0.1.2.7
 
 
 -- executable-static: True

fixme-new/fixme.cabal

@@ -55,10 +55,10 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , hbs2-git
       , db-pipe
-      , suckless-conf >= 0.1.2.6
+      , suckless-conf
       , fuzzy-parse
 
       , aeson

fixme-new/lib/Fixme/Types.hs

@@ -36,12 +36,6 @@ import Lens.Micro.Platform
 -- FIXME: move-to-suckless-conf
 deriving stock instance Ord (Syntax C)
 
-pattern StringLike :: forall {c} . String -> Syntax c
-pattern StringLike e <- (stringLike -> Just e)
-
-pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
-pattern StringLikeList e <- (stringLikeList -> e)
-
 pattern FixmeHashLike :: forall {c} . Text -> Syntax c
 pattern FixmeHashLike  e <- (fixmeHashFromSyn -> Just e)
 

flake.lock

@@ -519,18 +519,17 @@
         ]
       },
       "locked": {
-        "lastModified": 1715919707,
+        "lastModified": 1724324873,
-        "narHash": "sha256-lbvrCqJHC//NJgfvsy15+Evup5CS+CE50NolDwPIh94=",
+        "narHash": "sha256-FfhaOF/22/QRwGe2lHr8a2kl5nGSJiHIFA1J5KLqIAI=",
-        "ref": "refs/heads/master",
+        "rev": "6802f96076ffc984c9b9f44adbf3e9648bb369a0",
-        "rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01",
+        "revCount": 36,
-        "revCount": 35,
         "type": "git",
-        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6"
+        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
       },
       "original": {
-        "rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01",
+        "rev": "6802f96076ffc984c9b9f44adbf3e9648bb369a0",
         "type": "git",
-        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6"
+        "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
       }
     }
   },

flake.nix

@@ -14,7 +14,7 @@ inputs = {
     fixme.inputs.nixpkgs.follows = "nixpkgs";
 
     suckless-conf.url =
-      "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?rev=41830ea2f2e9bb589976f0433207a8f1b73b0b01&tag=0.1.2.6";
+      "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?rev=6802f96076ffc984c9b9f44adbf3e9648bb369a0";
 
     suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
 
@@ -44,6 +44,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-git"
      "hbs2-qblf"
      "hbs2-keyman"
+     "hbs2-keyman-direct-lib"
      "hbs2-fixer"
      "hbs2-cli"
      "hbs2-sync"
@@ -68,7 +69,8 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-core"   = "./hbs2-core";
      "hbs2-storage-simple" = "./hbs2-storage-simple";
      "hbs2-peer"   = "./hbs2-peer";
-     "hbs2-keyman" = "./hbs2-keyman";
+     "hbs2-keyman" = "./hbs2-keyman/hbs2-keyman";
+     "hbs2-keyman-direct-lib" = "./hbs2-keyman/hbs2-keyman-direct-lib";
      "hbs2-git"    = "./hbs2-git";
      "hbs2-fixer"  = "./hbs2-fixer";
      "hbs2-cli"    = "./hbs2-cli";

hbs2-cli/hbs2-cli.cabal

@@ -57,7 +57,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , db-pipe
       , suckless-conf
 
@@ -120,10 +120,6 @@ library
 
       HBS2.CLI.Run.Help
 
-      Data.Config.Suckless.Script
-      Data.Config.Suckless.Script.Internal
-      Data.Config.Suckless.Script.File
-
     build-depends:    base
                     , magic
 

hbs2-cli/lib/Data/Config/Suckless/Script.hs

@@ -1,48 +0,0 @@
-{-# Language UndecidableInstances #-}
-module Data.Config.Suckless.Script
-  ( module Exported
-  , module Data.Config.Suckless.Script
-  ) where
-
-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/File.hs

@@ -1,85 +0,0 @@
-{-# Language MultiWayIf #-}
-module Data.Config.Suckless.Script.File where
-
-import Data.Config.Suckless
-import Data.Config.Suckless.Script.Internal
-
-import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Cont
-import Data.Maybe
-import Data.Either
-import Data.Foldable
-import System.Directory
-import System.FilePath
-import System.FilePattern
-import Data.HashSet qualified as HS
-
-import Lens.Micro.Platform
-import UnliftIO
-import Control.Concurrent.STM qualified as STM
-import Streaming.Prelude qualified as S
-
--- FIXME: skip-symlink
-glob :: forall m . MonadIO m
-     => [FilePattern]           -- ^ search patterns
-     -> [FilePattern]           -- ^ ignore patterns
-     -> FilePath                -- ^ directory
-     -> (FilePath -> m Bool)    -- ^ file action
-     -> m ()
-
-glob pat ignore dir action = do
-  q <- newTQueueIO
-  void $ liftIO (async $ go q dir >> atomically (writeTQueue q Nothing))
-  fix $ \next -> do
-    atomically (readTQueue q) >>= \case
-      Nothing -> pure ()
-      Just x -> do
-        r <- action x
-        when r next
-
-  where
-
-    matches p f = or [ i ?== f | i <- p ]
-    skip p = or [ i ?== p | i <- ignore ]
-
-    go q f = do
-
-      isD <- doesDirectoryExist f
-
-      if not isD then do
-        isF <- doesFileExist f
-        when (isF && matches pat f && not (skip f)) do
-          atomically $ writeTQueue q (Just f)
-      else do
-        co' <- (try @_ @IOError $ listDirectory f)
-                 <&> fromRight mempty
-
-        forConcurrently_ co' $ \x -> do
-          let p = normalise (f </> x)
-          unless (skip p) (go q p)
-
-entries :: forall c m . ( IsContext c
-                        , Exception (BadFormException c)
-                        , MonadUnliftIO m)
-         => MakeDictM c m ()
-entries = do
-  entry $ bindMatch "glob" $ \syn -> do
-
-    (p,i,d) <- case syn of
-                 [] -> pure (["*"], [], ".")
-
-                 [StringLike d, StringLike i, StringLike e] -> do
-                    pure ([i], [e], d)
-
-                 [StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do
-                    pure (i, e, d)
-
-                 _ -> throwIO (BadFormException @c nil)
-
-    r <- S.toList_ $ glob p i d $ \fn -> do
-          S.yield (mkStr @c fn) -- do
-          pure True
-
-    pure (mkList r)
-

hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs

@@ -1,975 +0,0 @@
-{-# Language AllowAmbiguousTypes #-}
-{-# Language UndecidableInstances #-}
-module Data.Config.Suckless.Script.Internal
-  ( module Data.Config.Suckless.Script.Internal
-  , module Export
-  ) where
-
-import Data.Config.Suckless
-
-import Control.Applicative
-import Control.Monad.Identity
-import Control.Monad.Reader
-import Control.Monad.Writer
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8 qualified as BS8
-import Data.Data
-import Data.Function as Export
-import Data.Functor as Export
-import Data.Hashable
-import Data.HashMap.Strict (HashMap)
-import Data.HashMap.Strict qualified as HM
-import Data.Kind
-import Data.List (isPrefixOf)
-import Data.List qualified as List
-import Data.Maybe
-import Data.String
-import Data.Text.IO qualified as TIO
-import Data.Text qualified as Text
-import Data.Text (Text)
-import Data.Time.Clock.POSIX
-import GHC.Generics hiding (C)
-import Prettyprinter
-import Prettyprinter.Render.Terminal
-import Safe
-import Streaming.Prelude qualified as S
-import System.Environment
-import Text.InterpolatedString.Perl6 (qc)
-import UnliftIO
-
--- TODO: move-to-suckless-conf
-
-data ManApplyArg = ManApplyArg Text Text
-                   deriving stock (Eq,Show,Data,Generic)
-
-newtype ManApply = ManApply [ ManApplyArg ]
-                   deriving stock (Eq,Show,Data,Generic)
-                   deriving newtype (Semigroup,Monoid)
-
-data ManSynopsis =
-  ManSynopsis ManApply
-  deriving stock (Eq,Show,Data,Generic)
-
-data ManDesc     = ManDescRaw Text
-  deriving stock (Eq,Show,Data,Generic)
-
-data ManRetVal   = ManRetVal
-  deriving stock (Eq,Show,Data,Generic)
-
-newtype ManName a = ManName Id
-  deriving stock (Eq,Show,Data,Generic)
-  deriving newtype (IsString,Pretty)
-
-newtype ManBrief = ManBrief Text
-  deriving stock (Eq,Show,Data,Generic)
-  deriving newtype (Pretty,IsString)
-
-data ManReturns = ManReturns Text Text
-  deriving stock (Eq,Show,Data,Generic)
-
-newtype ManExamples =
-  ManExamples Text
-  deriving stock (Eq,Show,Data,Generic)
-  deriving newtype (Pretty,IsString,Monoid,Semigroup)
-
-class ManNameOf a ann where
-  manNameOf :: a -> ManName ann
-
-data Man a =
-  Man
-  { manName     :: Maybe (ManName a)
-  , manHidden   :: Bool
-  , manBrief    :: Maybe ManBrief
-  , manSynopsis :: [ManSynopsis]
-  , manDesc     :: Maybe ManDesc
-  , manReturns  :: Maybe ManReturns
-  , manExamples :: [ManExamples]
-  }
-  deriving stock (Eq,Show,Generic)
-
-instance Monoid (Man a) where
-  mempty = Man Nothing False Nothing mempty Nothing Nothing mempty
-
-instance Semigroup (Man a) where
-  (<>) a b = Man (manName b <|> manName a)
-                 (manHidden b || manHidden a)
-                 (manBrief b <|> manBrief a)
-                 (manSynopsis a <> manSynopsis b)
-                 (manDesc b <|> manDesc a)
-                 (manReturns b <|> manReturns a)
-                 (manExamples a <> manExamples b)
-
-instance ManNameOf Id a where
-  manNameOf = ManName
-
-
-instance Pretty ManDesc where
-  pretty = \case
-    ManDescRaw t -> pretty t
-
-instance IsString ManDesc where
-  fromString s = ManDescRaw (Text.pack s)
-
-instance Pretty (Man a) where
-  pretty e =   "NAME"
-             <> line
-             <> indent 8 (pretty (manName e) <> fmtBrief e)
-             <> line
-             <> fmtSynopsis
-             <> fmtDescription
-             <> retval
-             <> fmtExamples
-   where
-    fmtBrief a = case manBrief a of
-      Nothing -> mempty
-      Just x  -> " - " <> pretty x
-
-    retval = case manReturns e of
-      Nothing -> mempty
-      Just (ManReturns t s) ->
-        line <> "RETURN VALUE" <> line
-        <> indent 8 (
-            if not (Text.null s) then
-              (pretty t <> hsep ["","-",""] <> pretty s) <> line
-            else pretty t )
-
-    fmtDescription = line
-      <> "DESCRIPTION" <> line
-      <> indent 8 ( case manDesc e of
-           Nothing -> pretty (manBrief e)
-           Just x  -> pretty x)
-      <> line
-
-    fmtSynopsis = case manSynopsis e of
-      [] -> mempty
-      _  ->
-           line
-        <> "SYNOPSIS"
-        <> line
-        <> vcat (fmap synEntry (manSynopsis e))
-        <> line
-
-    fmtExamples = case manExamples e of
-      [] -> mempty
-      es -> line
-        <> "EXAMPLES"
-        <> line
-        <> indent 8 ( vcat (fmap pretty es) )
-
-    synEntry (ManSynopsis (ManApply [])) =
-      indent 8 ( parens (pretty (manName e)) ) <> line
-
-    synEntry (ManSynopsis (ManApply xs)) = do
-      indent 8 do
-        parens (pretty (manName e) <+>
-         hsep [ pretty n | ManApplyArg t n <- xs ]  )
-         <> line
-         <> line
-         <> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ]
-
-pattern StringLike :: forall {c} . String -> Syntax c
-pattern StringLike e <- (stringLike -> Just e)
-
-pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
-pattern StringLikeList e <- (stringLikeList -> e)
-
-pattern BlobLike :: forall {c} . ByteString -> Syntax c
-pattern BlobLike s <- (blobLike -> Just s)
-
-pattern Nil :: forall {c} . Syntax c
-pattern Nil <- ListVal []
-
-
-
-class Display a where
-  display :: MonadIO m => a -> m ()
-
-instance  {-# OVERLAPPABLE #-} Pretty w => Display w  where
-  display = liftIO . print . pretty
-
-instance IsContext c => Display (Syntax c) where
-  display = \case
-    LitStrVal s -> liftIO $ TIO.putStr s
-    -- ListVal [SymbolVal "small-encrypted-block", LitStrVal txt] -> do
-    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
-    --   liftIO $ print $ parens $ "small-encrypted-block" <+> parens ("blob" <+> dquotes s)
-    -- ListVal [SymbolVal "blob", LitStrVal txt] -> do
-    --   let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty
-    --   liftIO $ print $ parens $ "blob:base58" <+> dquotes s
-    x           -> liftIO $ putStr (show $ pretty x)
-
-instance Display Text where
-  display = liftIO . TIO.putStr
-
-instance Display String where
-  display = liftIO . putStr
-
-display_ :: (MonadIO m, Show a) => a -> m ()
-display_ = liftIO . print
-
-{- HLINT ignore "Functor law" -}
-
-class IsContext c => MkSym c a where
-  mkSym :: a -> Syntax c
-
-instance IsContext c => MkSym c String where
-  mkSym s = Symbol noContext (Id $ Text.pack s)
-
-instance IsContext c => MkSym c Text where
-  mkSym s = Symbol noContext (Id s)
-
-instance IsContext c => MkSym c Id where
-  mkSym = Symbol noContext
-
-class IsContext c => MkStr c s where
-  mkStr :: s -> Syntax c
-
-instance IsContext c => MkStr c String where
-  mkStr s = Literal noContext $ LitStr (Text.pack s)
-
-instance IsContext c => MkStr c Text where
-  mkStr s = Literal noContext $ LitStr s
-
-mkBool :: forall c . IsContext c => Bool -> Syntax c
-mkBool v = Literal noContext (LitBool v)
-
-
-class IsContext c => MkForm c a where
- mkForm :: a-> [Syntax c] -> Syntax c
-
-instance (IsContext c, MkSym c s) => MkForm c s where
- mkForm s sy = List noContext ( mkSym @c s :  sy )
-
-mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
-mkList = List noContext
-
-isFalse :: forall c . IsContext c => Syntax c -> Bool
-isFalse = \case
-    Literal _ (LitBool False) -> True
-    ListVal [] -> True
-    _ -> False
-
-eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m ()
-eatNil f = \case
-  Nil -> pure ()
-  x   -> void $ f x
-
-class IsContext c => MkInt c s where
-  mkInt :: s -> Syntax c
-
-instance (Integral i, IsContext c) => MkInt c i where
-  mkInt n = Literal noContext $ LitInt (fromIntegral n)
-
-class OptionalVal c b where
-  optional :: b -> Syntax c -> b
-
-instance IsContext c => OptionalVal c Int where
-  optional d = \case
-    LitIntVal x -> fromIntegral x
-    _           -> d
-
-hasKey :: IsContext c => Id -> [Syntax c] -> Maybe (Syntax c)
-hasKey k ss = headMay [ e | ListVal [SymbolVal z, e] <- ss, z == k]
-
-stringLike :: Syntax c -> Maybe String
-stringLike = \case
-  LitStrVal s -> Just $ Text.unpack s
-  SymbolVal (Id s) -> Just $ Text.unpack s
-  _ -> Nothing
-
-stringLikeList :: [Syntax c] -> [String]
-stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
-
-pattern Lambda :: forall {c}. [Id] -> Syntax c -> Syntax c
-pattern Lambda a e <- ListVal [SymbolVal "lambda", LambdaArgs a, e]
-
-pattern LambdaArgs :: [Id] -> Syntax c
-pattern LambdaArgs a <- (lambdaArgList -> Just a)
-
-
-lambdaArgList :: Syntax c -> Maybe [Id]
-
-lambdaArgList (ListVal a) = sequence argz
-  where
-    argz = flip fmap a \case
-      (SymbolVal x) -> Just x
-      _             -> Nothing
-
-lambdaArgList _ = Nothing
-
-blobLike :: Syntax c -> Maybe ByteString
-blobLike = \case
-  LitStrVal s -> Just $ BS8.pack (Text.unpack s)
-  ListVal [SymbolVal "blob", LitStrVal s] -> Just $ BS8.pack (Text.unpack s)
-  _ -> Nothing
-
-pattern PairList :: [Syntax c] -> [Syntax c]
-pattern PairList es <- (pairList -> es)
-
-pairList :: [Syntax c ] -> [Syntax c]
-pairList syn = [ isPair s | s <- syn ] & takeWhile isJust & catMaybes
-
-optlist :: IsContext c => [Syntax c] -> [(Id, Syntax c)]
-optlist = reverse . go []
-  where
-    go acc ( SymbolVal i : b : rest ) = go ((i, b) : acc) rest
-    go acc [ SymbolVal i ] = (i, nil) : acc
-    go acc _ = acc
-
-
-isPair :: Syntax c -> Maybe (Syntax c)
-isPair = \case
-  e@(ListVal [_,_]) -> Just e
-  _ -> Nothing
-
-data BindAction c ( m :: Type -> Type)  =
-    BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) }
-  | BindValue  (Syntax c)
-
-data Bind c ( m :: Type -> Type)  = Bind
-  { bindMan         :: Maybe (Man AnsiStyle)
-  , bindAction      :: BindAction c m
-  } deriving (Generic)
-
-deriving newtype instance Hashable Id
-
-newtype NameNotBoundException =
-  NameNotBound Id
-  deriving stock Show
-  deriving newtype (Generic,Typeable)
-
-newtype NotLambda = NotLambda Id
-                    deriving stock Show
-                    deriving newtype (Generic,Typeable)
-
-instance Exception NotLambda
-
-data BadFormException c = BadFormException (Syntax c)
-                        | ArityMismatch (Syntax c)
-
-newtype TypeCheckError c = TypeCheckError (Syntax c)
-
-instance Exception (TypeCheckError C)
-
-newtype BadValueException = BadValueException String
-                            deriving stock Show
-                            deriving newtype (Generic,Typeable)
-
-instance Exception NameNotBoundException
-
-instance IsContext c => Show (BadFormException c) where
-  show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
-  show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy
-
-instance IsContext c => Show (TypeCheckError c) where
-  show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
-
-instance Exception (BadFormException C)
-
-instance Exception BadValueException
-
-type Dict c m = HashMap Id (Bind c m)
-
-newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a }
-                     deriving newtype ( Applicative
-                                      , Functor
-                                      , Monad
-                                      , MonadIO
-                                      , MonadUnliftIO
-                                      , MonadReader (TVar (Dict c m))
-                                      )
-
-instance MonadTrans (RunM c) where
-  lift = RunM . lift
-
-newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a }
-                          deriving newtype ( Applicative
-                                           , Functor
-                                           , Monad
-                                           , MonadWriter (Dict c m)
-                                           )
-
-makeDict :: (IsContext c, Monad m) =>  MakeDictM c m () -> Dict c m
-makeDict w = execWriter ( fromMakeDict w )
-
-entry :: Dict c m  -> MakeDictM c m ()
-entry = tell
-
-hide :: MakeDictM c m ()
-hide = pure ()
-
-desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m ()
-desc txt = censor (HM.map setDesc)
-  where
-    w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) }
-    setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
-
-brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m ()
-brief txt = censor (HM.map setBrief)
-  where
-    w0 = mempty { manBrief = Just txt }
-    setBrief (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x
-
-returns :: Text -> Text -> MakeDictM c m () -> MakeDictM c m ()
-returns tp txt = censor (HM.map setReturns)
-  where
-    w0 = mempty { manReturns = Just (ManReturns tp txt) }
-    setReturns (Bind w x) = Bind (Just (maybe w0 (<>w0) w)) x
-
-
-addSynopsis :: ManSynopsis -> Bind c m -> Bind c m
-addSynopsis synopsis (Bind w x) = Bind (Just updatedMan) x
-  where
-    updatedMan = case w of
-      Nothing -> mempty { manSynopsis = [synopsis] }
-      Just man -> man { manSynopsis = manSynopsis man <> [synopsis] }
-
-noArgs :: MakeDictM c m () -> MakeDictM c m ()
-noArgs = censor (HM.map (addSynopsis (ManSynopsis (ManApply []))))
-
-arg :: Text -> Text -> ManApplyArg
-arg = ManApplyArg
-
-
-args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m ()
-args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList))))
-
-opt :: Doc a -> Doc a -> Doc a
-opt n d = n <+> "-" <+> d
-
-examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m ()
-examples (ManExamples s) = censor (HM.map setExamples )
-  where
-    ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s))
-    ex0 = mempty { manExamples = [ex] }
-    setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x
-
-splitForms :: [String] -> [[String]]
-splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
-  where
-    go acc ( "then" : rest ) = emit acc >> go mempty rest
-    go acc ( "and" : rest ) = emit acc >> go mempty rest
-    go acc ( x : rest ) | isPrefixOf "-"  x =  go ( x : acc ) rest
-    go acc ( x : rest ) | isPrefixOf "--" x =  go ( x : acc ) rest
-    go acc ( x : rest ) = go ( x : acc ) rest
-    go acc [] = emit acc
-
-    emit = S.yield . reverse
-
-applyLambda :: forall c m . ( IsContext c
-                            , MonadUnliftIO m
-                            , Exception (BadFormException c)
-                            )
-            => [Id]
-            -> Syntax c
-            -> [Syntax c]
-            -> RunM c m (Syntax c)
-applyLambda decl body args = do
-
-  when (length decl /= length args) do
-    throwIO (ArityMismatch @c nil)
-
-  ev <- mapM eval args
-  tv <- ask
-  d0 <- readTVarIO tv
-
-  forM_ (zip decl ev) $ \(n,v) -> do
-    bind n v
-
-  e <- eval body
-
-  atomically $ writeTVar tv d0
-  pure e
-
-apply_ :: forall c m . ( IsContext c
-                      , MonadUnliftIO m
-                      , Exception (BadFormException c)
-                      )
-      => Syntax c
-      -> [Syntax c]
-      -> RunM c m (Syntax c)
-
-apply_ s args = case s of
-  ListVal [SymbolVal "builtin:lambda", SymbolVal n]  -> apply n args
-  SymbolVal   what  -> apply what args
-  Lambda d body     -> applyLambda d body args
-  e -> throwIO $ BadFormException @c s
-
-apply :: forall c m . ( IsContext c
-                      , MonadUnliftIO m
-                      , Exception (BadFormException c)
-                      )
-      => Id
-      -> [Syntax c]
-      -> RunM c m (Syntax c)
-apply name args' = do
-  -- notice $ red "APPLY" <+> pretty name
-  what <- ask >>=  readTVarIO <&> HM.lookup name
-
-  case bindAction <$> what of
-    Just (BindLambda e) -> mapM eval args' >>= e
-
-    Just (BindValue (Lambda argz body) )  -> do
-      applyLambda argz body args'
-
-    Just (BindValue _) -> do
-      throwIO (NotLambda name)
-
-    Nothing -> throwIO (NameNotBound name)
-
-bind :: forall c m . ( IsContext c
-                     , MonadUnliftIO m
-                     , Exception (BadFormException c)
-                     )
-     => Id
-     -> Syntax c
-     -> RunM c m ()
-bind name expr = do
-  t <- ask
-
-  what <- case expr of
-           ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do
-             m <- readTVarIO t
-             HM.lookup n m & maybe (throwIO (NameNotBound n)) pure
-
-           e -> pure $ Bind mzero (BindValue e)
-
-  atomically do
-    modifyTVar t (HM.insert name what)
-
-bindBuiltins ::  forall c m . ( IsContext c
-                              , MonadUnliftIO m
-                              , Exception (BadFormException c)
-                              )
-            => Dict c m
-            -> RunM c m ()
-
-bindBuiltins  dict = do
-  t <- ask
-  atomically do
-    modifyTVar t (<> dict)
-
-eval :: forall c m . ( IsContext c
-                     , MonadUnliftIO m
-                     , Exception (BadFormException c)
-                     ) => Syntax c -> RunM c m (Syntax c)
-eval syn = handle (handleForm syn) $ do
-
-    dict <- ask >>= readTVarIO
-
-    case syn of
-
-      ListVal [ w, SymbolVal ".", b] -> do
-        pure  $ mkList  [w, b]
-
-      ListVal [ SymbolVal "quot", ListVal b] -> do
-        pure  $ mkList  b
-
-      ListVal [SymbolVal "define", SymbolVal what, e] -> do
-        ev <- eval e
-        bind what ev>> pure nil
-
-      ListVal [SymbolVal "lambda", arglist, body] -> do
-        pure $ mkForm @c "lambda" [ arglist, body ]
-
-      ListVal [SymbolVal "define", LambdaArgs (name : args), e] -> do
-        bind name ( mkForm @c  "lambda" [ mkList [ mkSym s | s <- args], e ] )
-        pure nil
-
-      ListVal [SymbolVal "false?", e'] -> do
-        e <- eval e'
-        pure $ if isFalse e then mkBool True else mkBool False
-
-      ListVal [SymbolVal "if", w, e1, e2] -> do
-        what <- eval w
-        if isFalse what then eval e2 else eval e1
-
-      ListVal (SymbolVal "begin" : what) -> do
-        evalTop what
-
-      e@(ListVal (SymbolVal "blob" : what)) -> do
-        pure e
-        -- evalTop what
-
-      lc@(ListVal (Lambda decl body : args))  -> do
-        applyLambda decl body args
-
-      ListVal (SymbolVal name : args') -> do
-        apply name args'
-
-      SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
-        pure (mkSym @c (Text.drop 1 s))
-
-      SymbolVal name | HM.member name dict -> do
-        let what = HM.lookup name dict
-                     & maybe (BindValue (mkSym name)) bindAction
-
-        case what of
-          BindValue e  -> pure e
-          BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name]
-
-      e@(SymbolVal name) | not (HM.member name dict) -> do
-        pure e
-
-      e@Literal{} -> pure e
-
-      e -> throwIO $ BadFormException @c e
-
-  where
-    handleForm syn = \case
-      (BadFormException _  :: BadFormException c) -> do
-        throwIO (BadFormException syn)
-      (ArityMismatch s  :: BadFormException c) -> do
-        throwIO (ArityMismatch syn)
-
-runM :: forall c m a. ( IsContext c
-                      , MonadUnliftIO m
-                      , Exception (BadFormException c)
-                      ) => Dict c m -> RunM c m a ->  m a
-runM  d  m = do
-  tvd <- newTVarIO d
-  runReaderT (fromRunM m) tvd
-
-run :: forall c m . ( IsContext c
-                    , MonadUnliftIO m
-                    , Exception (BadFormException c)
-                    ) => Dict c m -> [Syntax c] -> m (Syntax c)
-run d sy = do
-  tvd <- newTVarIO d
-  lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd
-
-evalTop :: forall c m . ( IsContext c
-                        , MonadUnliftIO m
-                        , Exception (BadFormException c))
-     => [Syntax c]
-     -> RunM c m (Syntax c)
-evalTop syn = lastDef nil <$> mapM eval syn
-
-bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
-bindMatch n fn = HM.singleton n (Bind man (BindLambda fn))
-  where
-    man = Just $ mempty { manName = Just (manNameOf n) }
-
-bindValue :: Id -> Syntax c -> Dict c m
-bindValue n e = HM.singleton n (Bind mzero (BindValue e))
-
-nil :: forall c . IsContext c => Syntax c
-nil = List noContext []
-
-nil_ :: (IsContext c, MonadIO m) =>  (a -> RunM c m b) -> a -> RunM c m (Syntax c)
-nil_ m w = m w >> pure (List noContext [])
-
-fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2
-fixContext = go
-  where
-    go = \case
-      List    _ xs -> List noContext (fmap go xs)
-      Symbol  _ w  -> Symbol noContext w
-      Literal _ l  -> Literal noContext l
-
-
-fmt :: Syntax c -> Doc ann
-fmt = \case
-  LitStrVal x -> pretty $ Text.unpack x
-  x -> pretty x
-
-internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m ()
-internalEntries = do
-
-    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 ":")
-    entry $ bindValue "chr:comma"  (mkStr ",")
-    entry $ bindValue "chr:q"      (mkStr "'")
-    entry $ bindValue "chr:minus"  (mkStr "-")
-    entry $ bindValue "chr:dq"     (mkStr "\"")
-    entry $ bindValue "chr:lf"     (mkStr "\n")
-    entry $ bindValue "chr:cr"     (mkStr "\r")
-    entry $ bindValue "chr:tab"    (mkStr "\t")
-    entry $ bindValue "chr:space"  (mkStr " ")
-
-    brief "concatenates list of string-like elements into a string"
-      $ args [arg "list" "(list ...)"]
-      $ args [arg "..." "..."]
-      $ returns "string" ""
-      $ examples [qc|
-        (concat a b c d)
-        abcd|]
-      $ examples [qc|
-        (concat 1 2 3 4 5)
-        12345|]
-
-      $ entry $ bindMatch "concat" $ \syn -> do
-
-        case syn of
-          [ListVal xs] -> do
-            pure $ mkStr ( show $ hcat (fmap fmt xs) )
-
-          xs -> do
-            pure $ mkStr ( show $ hcat (fmap fmt xs) )
-
-    brief "creates a list of elements"
-      $ args [arg "..." "..."]
-      $ returns "list" ""
-      $ examples [qc|
-(list 1 2 3 fuu bar "baz")
-(1 2 3 fuu bar "baz")
-      |]
-      $ entry $ bindMatch "list" $ \case
-        es -> do
-          pure $ mkList es
-
-    entry $ bindMatch "dict" $ \case
-      (pairList -> es@(_:_)) -> do
-        pure $ mkForm "dict" es
-      [a, b] -> do
-        pure $ mkForm "dict" [ mkList [a, b] ]
-      _ -> throwIO (BadFormException @C nil)
-
-    brief "creates a dict from a linear list of string-like items"
-      $ args [arg "list-of-terms" "..."]
-      $ desc (    "macro; syntax sugar" <> line
-               <> "useful for creating function args" <> line
-               <> "leftover records are skipped"
-             )
-      $ returns "dict" ""
-      $ examples [qc|
-[kw a 1 b 2 c 3]
-(dict (a 1) (b 2) (c 3))
-
-[kw a]
-(dict (a ()))
-
-[kw a b]
-(dict (a b))
-
-[kw 1 2 3]
-(dict)
-
-[kw a b c]
-(dict (a b) (c ()))
-      |]
-      $ entry $ bindMatch "kw" $ \syn -> do
-         let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ]
-         pure $ mkForm "dict" wat
-
-    entry $ bindMatch "iterate" $ nil_ $ \syn -> do
-      case syn of
-        [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
-          mapM_ (apply @c fn . List.singleton) rs
-
-        [Lambda decl body,  ListVal args]  -> do
-          mapM_ (applyLambda decl body . List.singleton) args
-
-        _ -> do
-          throwIO (BadFormException @C nil)
-
-    entry $ bindMatch "repeat" $ nil_ $ \case
-      [LitIntVal n, Lambda [] b] -> do
-        replicateM_ (fromIntegral n) (applyLambda [] b [])
-
-      [LitIntVal n, e@(ListVal _)] -> do
-        replicateM_ (fromIntegral n) (eval e)
-
-      z ->
-        throwIO (BadFormException @C nil)
-
-    entry $ bindMatch "map" $ \syn -> do
-      case syn of
-        [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do
-          mapM (apply @c fn . List.singleton) rs
-            <&> mkList
-
-        [Lambda decl body,  ListVal args]  -> do
-          mapM (applyLambda decl body . List.singleton) args
-            <&> mkList
-
-        _ -> do
-          throwIO (BadFormException @C nil)
-
-    entry $ bindMatch "head" $ \case
-      [ ListVal es ] -> pure (head es)
-      _ -> throwIO (TypeCheckError @C nil)
-
-    brief "get tail of list"
-      $ args [arg "list" "list"]
-      $ desc "nil if the list is empty; error if not list"
-      $ examples [qc|
-      (tail [list 1 2 3])
-      (2 3)
-      (tail [list])
-      |]
-      $ entry $ bindMatch "tail" $ \case
-        [] -> pure nil
-        [ListVal []] -> pure nil
-        [ListVal es] -> pure $ mkList  (tail es)
-        _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "lookup" $ \case
-      [s, ListVal (SymbolVal "dict" : es) ] -> do
-        let val = headDef nil [ v | ListVal [k, v] <- es, k == s ]
-        pure val
-
-      [StringLike s, ListVal [] ] -> do
-        pure nil
-
-      _ -> throwIO (BadFormException @c nil)
-
-    brief "returns current unix time"
-      $ returns "int" "current unix time in seconds"
-      $ noArgs
-      $ entry $ bindMatch "now" $ \case
-        [] -> mkInt . round <$> liftIO getPOSIXTime
-        _  -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "display" $ nil_ \case
-      [ sy ] -> display sy
-      ss     -> display (mkList ss)
-
-    brief "prints new line character to stdout"
-      $ entry $ bindMatch "newline" $ nil_ $ \case
-          [] -> liftIO (putStrLn "")
-          _  -> throwIO (BadFormException @c nil)
-
-    brief "prints a list of terms to stdout"
-      $ entry $ bindMatch "print" $ nil_ $ \case
-          [ sy ] -> display sy
-          ss     -> mapM_ display ss
-
-    entry $ bindMatch "println" $ nil_ $ \case
-      [ sy ] -> display sy >> liftIO (putStrLn "")
-      ss     -> mapM_ display ss >> liftIO (putStrLn "")
-
-    entry $ bindMatch "str:read-stdin" $ \case
-      [] -> liftIO getContents <&> mkStr @c
-
-      _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "str:put" $ nil_ $ \case
-      [LitStrVal s] -> liftIO $ TIO.putStr s
-      _ -> throwIO (BadFormException @c nil)
-
-    brief "reads file as a string" do
-      entry $ bindMatch "str:read-file" $ \case
-        [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr
-
-        _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "str:save" $ nil_ \case
-      [StringLike fn, StringLike what] ->
-        liftIO (writeFile fn what)
-
-      _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindValue "space" $ mkStr " "
-
-    entry $ bindMatch "parse-top" $ \case
-
-      [SymbolVal w, LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkForm w . fmap fixContext)
-
-      [LitStrVal s] -> do
-        pure $  parseTop s & either (const nil) (mkList . fmap fixContext)
-
-      _ -> throwIO (BadFormException @c nil)
-
-    let atomFrom = \case
-          [StringLike s] -> pure (mkSym s)
-          [e]            -> pure (mkSym $ show $ pretty e)
-          _ -> throwIO (BadFormException @c nil)
-
-    brief "type of argument"
-      $ args [arg "term" "term"]
-      $ returns "symbol" "type"
-      $ entry $ bindMatch "type" \case
-        [ListVal _]    -> pure $ mkSym "list"
-        [SymbolVal _]  -> pure $ mkSym "symbol"
-        [LitStrVal _]  -> pure $ mkSym "string"
-        [LitIntVal _]  -> pure $ mkSym "int"
-        [LitScientificVal _] -> pure $ mkSym "float"
-        [LitBoolVal _] -> pure $ mkSym "bool"
-        _ -> throwIO (BadFormException @c nil)
-
-    brief "creates a symbol from argument"
-      $ args [arg "any-term" "term"]
-      $ returns "symbol" ""
-      do
-        entry $ bindMatch "sym"  atomFrom
-        entry $ bindMatch "atom" atomFrom
-
-    brief "compares two terms" $
-      args [arg "term" "a", arg "term" "b"] $
-      returns "boolean" "#t if terms are equal, otherwise #f" $
-        entry $ bindMatch "eq?" $ \case
-          [a, b] -> do
-            pure $ if a == b then mkBool True else mkBool False
-          _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "length" $ \case
-      [ListVal es] -> pure $ mkInt (length es)
-      [StringLike es] -> pure $ mkInt (length es)
-      _ -> pure $ mkInt 0
-
-    entry $ bindMatch "nil?" $ \case
-      [ListVal []] -> pure $ mkBool True
-      _ -> pure $ mkBool False
-
-    entry $ bindMatch "not" $ \case
-      [w] -> do
-        pure $ if isFalse w then mkBool True else mkBool False
-      _ -> throwIO (BadFormException @c nil)
-
-    brief "get system environment"
-     $ args []
-     $ args [ arg "string" "string" ]
-     $ returns "env" "single var or dict of all vars"
-     $ examples [qc|
-      (env HOME)
-      /home/user
-
-      (env)
-      (dict
-         (HOME "/home/user") ... (CC "gcc") ...)
-     |]
-     $ entry $ bindMatch "env" $ \case
-         [] -> do
-           s <- liftIO getEnvironment
-           pure $ mkForm "dict" [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ]
-
-         [StringLike s] -> do
-           liftIO (lookupEnv s)
-              <&> maybe nil mkStr
-         _ -> throwIO (BadFormException @c nil)
-
-    -- FIXME: we-need-opaque-type
-    entry $ bindMatch "blob:read-stdin" $ \case
-      [] -> do
-        blob <- liftIO BS8.getContents <&> BS8.unpack
-        pure (mkForm "blob" [mkStr @c blob])
-
-      _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "blob:read-file" $ \case
-      [StringLike fn] -> do
-        blob <- liftIO (BS8.readFile fn) <&> BS8.unpack
-        pure (mkForm "blob" [mkStr @c blob])
-
-      _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "blob:save" $ nil_ $ \case
-      [StringLike fn, ListVal [SymbolVal "blob", LitStrVal t]] -> do
-        let s = Text.unpack t & BS8.pack
-        liftIO $ BS8.writeFile fn s
-
-      _ -> throwIO (BadFormException @c nil)
-
-    entry $ bindMatch "blob:put" $ nil_ $ \case
-      [ListVal [SymbolVal "blob", LitStrVal t]] -> do
-        let s = Text.unpack t & BS8.pack
-        liftIO $ BS8.putStr s
-
-      _ -> throwIO (BadFormException @c nil)
-
-

hbs2-cli/lib/HBS2/CLI/Prelude.hs

@@ -9,12 +9,14 @@ module HBS2.CLI.Prelude
   , module HBS2.Misc.PrettyStuff
   , qc,qq,q
   , Generic
+  , pattern SignPubKeyLike
   ) where
 
 import HBS2.Prelude.Plated
 import HBS2.OrDie
 import HBS2.System.Logger.Simple.ANSI
 import HBS2.Misc.PrettyStuff
+import HBS2.Net.Auth.Credentials
 
 import Data.HashMap.Strict
 import Data.Config.Suckless

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

@@ -14,6 +14,7 @@ import HBS2.CLI.Run.Internal.GroupKey as G
 import HBS2.Net.Auth.GroupKeySymm as Symm
 import HBS2.Storage
 
+import HBS2.KeyMan.Keys.Direct
 
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client
@@ -32,6 +33,7 @@ import Codec.Serialise
 
 groupKeyEntries :: forall c m . ( MonadUnliftIO m
                                 , IsContext c
+                                , Exception (BadFormException c)
                                 , HasClientAPI StorageAPI UNIX m
                                 , HasStorage m
                                 ) => MakeDictM c m ()
@@ -48,17 +50,40 @@ groupKeyEntries = do
 
       _ -> throwIO $ BadFormException @C nil
 
-  entry $ bindMatch "hbs2:groupkey:store" $ \case
-      [LitStrVal s] -> do
-        let lbs = LBS8.pack (Text.unpack s)
-        gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
-                `orDie` "invalid group key"
 
-        sto <- getStorage
+  brief "stores groupkey to the peer's storage" $
-        ha <- writeAsMerkle sto (serialise gk)
+   args [arg "string" "groupkey"] $
-        pure $ mkStr (show $ pretty ha)
+   returns "string" "hash" $
+    entry $ bindMatch "hbs2:groupkey:store" $ \case
+        [LitStrVal s] -> do
+          let lbs = LBS8.pack (Text.unpack s)
+          gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs)
+                  `orDie` "invalid group key"
 
-      _ -> throwIO $ BadFormException @C nil
+          sto <- getStorage
+          ha <- writeAsMerkle sto (serialise gk)
+          pure $ mkStr (show $ pretty ha)
+
+        _ -> throwIO $ BadFormException @c nil
+
+
+  brief "publish groupkey to the given refchan" $
+    args [arg "string" "refchan", arg "string" "groupkey-blob|groupkey-hash"] $
+    desc "groupkey may be also hash of te stored groupkey" $
+      entry $ bindMatch "hbs2:groupkey:publish" $ nil_ $ \case
+
+      [SignPubKeyLike rchan, LitStrVal gk] -> do
+        -- get
+        -- check
+        -- store
+        -- find refchan
+        -- post tx as metadata
+        notice $ red "not implemented yet"
+
+      [SignPubKeyLike rchan, HashLike gkh] -> do
+        notice $ red "not implemented yet"
+
+      _ -> throwIO $ BadFormException @c nil
 
 
 -- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \
@@ -99,6 +124,17 @@ groupKeyEntries = do
       _ -> throwIO $ BadFormException @C nil
 
 
+  entry $ bindMatch "hbs2:groupkey:dump" $ nil_ $ \syn -> do
+    case syn of
+      -- TODO: from-file
+      -- TODO: from-stdin
+      -- TODO: base58 file
+      [HashLike gkh] -> do
+        gk <- loadGroupKey gkh
+        liftIO $ print $ pretty gk
+
+      _ -> throwIO $ BadFormException @C nil
+
   entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do
     case syn of
       [LitStrVal s] -> do
@@ -113,6 +149,25 @@ groupKeyEntries = do
 
       _ -> throwIO $ BadFormException @C nil
 
+  brief "find groupkey secret in hbs2-keyman" $
+    args [arg "string" "group-key-hash"] $
+    returns "secret-key-id" "string" $
+    entry $ bindMatch "hbs2:groupkey:find-secret" $ \case
+      [HashLike gkh] -> do
+
+        sto <- getStorage
+
+        gk <- loadGroupKey gkh >>= orThrowUser "can't load groupkey"
+
+        what <- runKeymanClient $ findMatchedGroupKeySecret sto gk
+                   >>= orThrowUser "groupkey secret not found"
+
+        let gid = generateGroupKeyId GroupKeyIdBasic1 what
+
+        pure $ mkStr (show $ pretty gid)
+
+      _ -> throwIO $ BadFormException @c nil
+
 
   entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
     [BlobLike bs] -> do

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

@@ -32,20 +32,6 @@ import Data.ByteString.Char8 qualified as BS8
 import Data.Text qualified as Text
 import Lens.Micro.Platform
 
-pattern HashLike:: forall {c} . HashRef -> Syntax c
-pattern HashLike x <- (
-  \case
-    StringLike s -> fromStringMay @HashRef s
-    _            -> Nothing
-      -> Just x )
-
-pattern SignPubKeyLike :: forall {c} . (PubKey 'Sign 'HBS2Basic) -> Syntax c
-pattern SignPubKeyLike x <- (
-  \case
-    StringLike s -> fromStringMay s
-    _            -> Nothing
-      -> Just x )
-
 
 data HBS2CliEnv =
   HBS2CliEnv

hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs

@@ -54,7 +54,7 @@ decryptBlock :: (MonadUnliftIO m, Serialise t)
              -> SmallEncryptedBlock t
              -> m t
 decryptBlock sto seb = do
-  let find gk = runKeymanClient (extractGroupKeySecret gk)
+  let find gk = runKeymanClientRO (findMatchedGroupKeySecret sto gk)
 
   -- FIXME: improve-error-diagnostics
   runExceptT (Symm.decryptBlock sto find seb)

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

@@ -43,6 +43,10 @@ import Data.HashSet qualified as HS
 import Data.Coerce
 import Control.Monad.Trans.Cont
 import Control.Monad.Except
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.Text qualified as Text
+import Codec.Serialise
 
 import Text.InterpolatedString.Perl6 (qc)
 
@@ -293,5 +297,29 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
 
             <> pretty rch
 
-        _ -> throwIO (BadFormException @C nil)
+        _ -> throwIO (BadFormException @c nil)
+
+
+  brief "creates RefChanUpdate/AnnotatedHashRef transaction for refchan" $
+    args [arg "string" "sign-key", arg "string" "payload-tree-hash"] $
+    entry $ bindMatch "hbs2:refchan:tx:annref:create" $ \case
+      [SignPubKeyLike signpk, HashLike hash] -> do
+         sto <- getStorage
+         void $ hasBlock sto (fromHashRef hash) `orDie` "no block found"
+         let lbs = AnnotatedHashRef Nothing hash & serialise
+         creds  <- runKeymanClient $ loadCredentials signpk >>= orThrowUser "can't find credentials"
+         let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
+         pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)]
+
+      _ -> throwIO (BadFormException @c nil)
+
+  brief "posts Propose transaction to the refchan" $
+    args [arg "string" "refchan", arg "blob" "signed-box"] $
+    entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \case
+      [SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
+        api <- getClientAPI @RefChanAPI @UNIX
+        bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction"
+        void $ callService @RpcRefChanPropose api (rchan, bbox)
+
+      _ -> throwIO (BadFormException @c nil)
 

hbs2-core/lib/HBS2/Data/Types/Refs.hs

@@ -1,8 +1,10 @@
 {-# Language DuplicateRecordFields #-}
 {-# Language UndecidableInstances #-}
+{-# Language PatternSynonyms #-}
 module HBS2.Data.Types.Refs
   ( module HBS2.Data.Types.Refs
   , serialise
+  , pattern HashLike
   ) where
 
 import HBS2.Base58
@@ -10,10 +12,13 @@ import HBS2.Hash
 import HBS2.Net.Proto.Types
 import HBS2.Prelude
 
+import Data.Config.Suckless.Syntax
+
 import Codec.Serialise(serialise)
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Data
+import Data.Text qualified as Text
 
 class RefMetaData a where
   refMetaData :: a -> [(String, String)]
@@ -126,3 +131,15 @@ instance RefMetaData RefAlias2 where
 
 type LoadedRef a = Either HashRef a
 
+
+-- TODO: move-outta-here
+pattern HashLike:: forall {c} . HashRef -> Syntax c
+pattern HashLike x <- (
+  \case
+    LitStrVal s      -> fromStringMay @HashRef (Text.unpack s)
+    SymbolVal (Id s) -> fromStringMay @HashRef (Text.unpack s)
+    _                -> Nothing
+      -> Just x )
+
+
+

hbs2-core/lib/HBS2/Net/Auth/Credentials.hs

@@ -15,6 +15,8 @@ import HBS2.Net.Auth.Schema
 import HBS2.Base58
 import HBS2.Hash
 
+import Data.Config.Suckless
+
 import Control.Applicative
 import Codec.Serialise
 import Crypto.Saltine.Core.Sign (Keypair(..))
@@ -263,4 +265,10 @@ instance Hashed HbSync Sign.PublicKey where
   hashObject pk = hashObject (Crypto.encode pk)
 
 
+pattern SignPubKeyLike :: forall {c} . PubKey 'Sign 'HBS2Basic -> Syntax c
+pattern SignPubKeyLike x <- (
+  \case
+    StringLike s -> fromStringMay s
+    _            -> Nothing
+      -> Just x )
 

hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs

@@ -2,6 +2,7 @@
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language ConstraintKinds #-}
+{-# Language FunctionalDependencies #-}
 module HBS2.Net.Auth.GroupKeySymm
   ( module HBS2.Net.Auth.GroupKeySymm
   , module HBS2.Net.Proto.Types
@@ -26,9 +27,11 @@ import HBS2.Storage(Storage(..))
 import HBS2.Defaults
 
 
+import Control.Applicative
 import Data.ByteArray.Hash qualified as BA
 import Data.ByteArray.Hash (SipHash(..), SipKey(..))
-import Codec.Serialise
+import Codec.Serialise as Serialise
+import Codec.Serialise.Decoding qualified as Serialise
 import Crypto.KDF.HKDF qualified as HKDF
 import Control.Monad
 import Control.Monad.Except
@@ -39,6 +42,7 @@ import Crypto.Saltine.Class qualified as Saltine
 import Crypto.Saltine.Core.Box qualified as AK
 import Crypto.Saltine.Core.SecretBox (Key)
 import Crypto.Saltine.Core.SecretBox qualified as SK
+import Data.ByteString qualified as N
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Char8 qualified as B8
 import Data.ByteString qualified as BS
@@ -53,6 +57,9 @@ import Data.ByteArray()
 import Network.ByteOrder qualified as N
 import Streaming.Prelude qualified as S
 import Lens.Micro.Platform
+import Data.Coerce
+import Data.Typeable (TypeRep, typeRep)
+import Type.Reflection (SomeTypeRep(..), someTypeRep)
 
 import Streaming qualified as S
 import Streaming (Stream(..), Of(..))
@@ -63,18 +70,52 @@ import Data.Bits (xor)
 
 type GroupSecret = Key
 
+-- NOTE: non-breaking-change
+--   Что тут произошло: нам нужно добавить уникальный идентификатор
+--   секрета, что автоматически публиковать и искать секреты
+--   Мы добавляем его в тип ключа, однако хотим оставить совместимость
+--   в обе стороны -- что бы старые версии могли работать с новыми
+--   ключами. Таким образом, этот идентификатор является опциональным.
+--   Для этого мы оставляем конструктор "без всего", который структурно
+--   эквивалентен "старому" типу ключа. При сериализации мы пишем
+--   сначала "старый" конструктор, потом в эту строку дописываем новый (без реципиентов)
+--   Поскольку ключ является моноидом, при десереализации мы складываем "старый" и "новый"
+--   конструктор и получаем "новый", с Id и всеми делами (если они не Nothing).
+--   Таким образом, старые ключи не будут индексироваться (но будут работать в старых версиях),
+--   а "новые" ключи будут иметь возможность индексации и валидации.
+
+type Recipients s = HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecret)
 
 -- NOTE: breaking-change
 
+data GroupKeyIdScheme = GroupKeyIdBasic1 -- encrypt zeroes then hash
+                        deriving stock (Eq,Ord,Generic,Show)
+
+newtype GroupKeyId = GroupKeyId N.ByteString
+                     deriving stock (Eq,Ord,Generic,Show)
+
+instance Pretty GroupKeyId where
+  pretty what = pretty (AsBase58 (coerce @_ @N.ByteString what))
+
+instance Pretty GroupKeyIdScheme where
+  pretty = \case
+    GroupKeyIdBasic1  -> "basic1"
+
 -- NOTE: not-a-monoid
 --  это моноид, но опасный, потому, что секретные ключи у двух разных
 --  групповых ключей могут быть разными, и если
 --  просто объединить два словаря - какой-то секретный
 --  ключ может быть потерян. а что делать-то, с другой стороны?
 data instance GroupKey 'Symm s =
-  GroupKeySymm
+    GroupKeySymmPlain
-  { recipients :: HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecret)
+    { recipients :: Recipients s
-  }
+    }
+  | GroupKeySymmFancy
+    { recipients         :: Recipients s
+    , groupKeyIdScheme   :: Maybe GroupKeyIdScheme
+    , groupKeyId         :: Maybe GroupKeyId
+    , groupKeyTimestamp  :: Maybe Word64
+    }
   deriving stock (Generic)
 
 deriving instance
@@ -83,15 +124,37 @@ deriving instance
     )
     => Eq (GroupKey 'Symm s)
 
+
+getGroupKeyIdScheme :: GroupKey 'Symm s -> Maybe GroupKeyIdScheme
+getGroupKeyIdScheme = \case
+  GroupKeySymmPlain{} -> Nothing
+  GroupKeySymmFancy{..} -> groupKeyIdScheme
+
+getGroupKeyId :: GroupKey 'Symm s -> Maybe GroupKeyId
+getGroupKeyId = \case
+  GroupKeySymmPlain{} -> Nothing
+  GroupKeySymmFancy{..} -> groupKeyId
+
+getGroupKeyTimestamp :: GroupKey 'Symm s -> Maybe Word64
+getGroupKeyTimestamp = \case
+  GroupKeySymmPlain{} -> Nothing
+  GroupKeySymmFancy{..} -> groupKeyTimestamp
+
 instance ForGroupKeySymm s => Monoid (GroupKey 'Symm s) where
-  mempty = GroupKeySymm mempty
+  mempty = GroupKeySymmFancy mempty mzero mzero mzero
 
 instance ForGroupKeySymm s => Semigroup (GroupKey 'Symm s) where
-  (<>) (GroupKeySymm a) (GroupKeySymm b) = GroupKeySymm (a <> b)
+  (<>) (GroupKeySymmPlain a) (GroupKeySymmPlain b) = GroupKeySymmFancy (a <> b) mzero mzero mzero
+  (<>) (GroupKeySymmPlain r0) (GroupKeySymmFancy r s k t) = GroupKeySymmFancy (r0 <> r) s k t
+  (<>) (GroupKeySymmFancy r s k t) (GroupKeySymmPlain r0) = GroupKeySymmFancy (r0 <> r) s k t
+  (<>) (GroupKeySymmFancy r0 s0 k0 t0) (GroupKeySymmFancy r1 s1 k1 t1) = GroupKeySymmFancy (r0 <> r1) (s1 <|> s0) (k1 <|> k0) (max t0 t1)
 
+instance Serialise GroupKeyIdScheme
+instance Serialise GroupKeyId
 instance Serialise Key
 instance Serialise SK.Nonce
 
+
 -- NOTE: hardcoded-hbs2-basic-auth-type
 data instance ToEncrypt 'Symm s LBS.ByteString =
   ToEncryptSymmBS
@@ -116,12 +179,54 @@ type ForGroupKeySymm (s :: CryptoScheme ) =
   , Hashable (PubKey 'Encrypt s)
   )
 
-instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s)
 
-instance Pretty (AsBase58 (PubKey 'Encrypt s)) => Pretty (GroupKey 'Symm s) where
+newtype GroupKeyExtension s = GroupKeyExtension (GroupKey 'Symm s)
-  pretty g = vcat (fmap prettyEntry (HashMap.toList (recipients g)))
+                              deriving stock (Generic)
+
+data GroupKeySymmV1 s = GroupKeySymmV1 { recipientsV1 :: Recipients s }
+                        deriving stock Generic
+
+instance ForGroupKeySymm s => Serialise (GroupKeyExtension s)
+
+instance ForGroupKeySymm s => Serialise (GroupKeySymmV1 s)
+
+instance (ForGroupKeySymm s) => Serialise (GroupKey 'Symm s) where
+
+  encode x = do
+    let compat = GroupKeySymmV1 @s (recipients x)
+    let compatEncoded = Serialise.encode compat
+    let version = 2
+    let ext     = (getGroupKeyIdScheme x, getGroupKeyId x, getGroupKeyTimestamp x)
+    compatEncoded  <> Serialise.encode version <> Serialise.encode ext
+
+  decode = do
+    GroupKeySymmV1{..}  <- Serialise.decode @(GroupKeySymmV1 s)
+
+    avail <- Serialise.peekAvailable
+
+    if avail == 0 then
+      pure $ GroupKeySymmPlain recipientsV1
+    else do
+      version <- Serialise.decode @Int
+
+      case version of
+        2 -> do
+          (s,kid, t) <- Serialise.decode @(Maybe GroupKeyIdScheme, Maybe GroupKeyId, Maybe Word64)
+          pure $ GroupKeySymmFancy recipientsV1 s kid t
+
+        _ -> pure $ GroupKeySymmPlain recipientsV1
+
+
+instance (Pretty (AsBase58 (PubKey 'Encrypt s)) ) => Pretty (GroupKey 'Symm s) where
+  pretty g = gkType <> line <> vcat (fmap prettyEntry (HashMap.toList (recipients @s g)))
     where
       prettyEntry (pk, _) = "member" <+> dquotes (pretty (AsBase58 pk))
+      gkType = case g of
+        GroupKeySymmPlain{} -> ";" <+> "plain group key" <> line
+        GroupKeySymmFancy{} -> ";" <+> "fancy group key" <> line
+                               <> "group-key-id" <+> pretty (getGroupKeyId g) <> line
+                               <> "group-key-id-scheme" <+> pretty (getGroupKeyIdScheme g) <> line
+                               <> "group-key-timestamp" <+> pretty (getGroupKeyTimestamp g) <> line
 
 
 instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where
@@ -130,7 +235,7 @@ instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where
     toMPlus $ deserialiseOrFail @(GroupKey 'Symm s) (LBS.fromStrict bs)
 
 instance ForGroupKeySymm s => Pretty (AsGroupKeyFile (GroupKey 'Symm s)) where
-  pretty (AsGroupKeyFile pc) =  "# hbs2 symmetric group key file"
+  pretty (AsGroupKeyFile pc) =  "# hbs2 symmetric group key file v2"
                                 <> line <> co
     where
       co = vcat $ fmap pretty
@@ -158,13 +263,47 @@ generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt
                  -> [PubKey 'Encrypt s]
                  -> m (GroupKey 'Symm s)
 
-generateGroupKey mbk pks = GroupKeySymm <$> create
+generateGroupKey = generateGroupKeyFancy
+
+
+generateGroupKeyPlain :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
+                 => Maybe GroupSecret
+                 -> [PubKey 'Encrypt s]
+                 -> m (GroupKey 'Symm s)
+
+generateGroupKeyPlain mbk rcpt = do
+  what <- generateGroupKeyFancy @s mbk rcpt
+  pure $ GroupKeySymmPlain (recipients what)
+
+groupKeyCheckSeed :: N.ByteString
+groupKeyCheckSeed = BS.replicate 32 0
+
+generateGroupKeyId :: GroupKeyIdScheme -> GroupSecret -> GroupKeyId
+generateGroupKeyId _ sk = do
+    let enc = SK.secretbox sk (nonceFrom (mempty :: ByteString)) groupKeyCheckSeed
+    let ha = hashObject @HbSync enc
+    GroupKeyId (coerce ha)
+
+generateGroupKeyFancy :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
+                 => Maybe GroupSecret
+                 -> [PubKey 'Encrypt s]
+                 -> m (GroupKey 'Symm s)
+
+generateGroupKeyFancy mbk pks = create
   where
-    create = HashMap.fromList <$> do
+    scheme = GroupKeyIdBasic1
+    create = do
+      now <- liftIO getPOSIXTime <&> Just . round
       sk <- maybe1 mbk (liftIO SK.newKey) pure
-      forM pks $ \pk -> do
+      rcpt <- forM pks $ \pk -> do
-        box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
+                box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
-        pure (pk, box)
+                pure (pk, box)
+      let theId = generateGroupKeyId scheme sk
+      pure $ GroupKeySymmFancy
+                (HashMap.fromList rcpt)
+                (Just scheme)
+                (Just theId)
+                now
 
 lookupGroupKey :: forall s .  ( ForGroupKeySymm s
                               , PubKey 'Encrypt s ~ AK.PublicKey
@@ -176,7 +315,7 @@ lookupGroupKey :: forall s .  ( ForGroupKeySymm s
                -> Maybe GroupSecret
 
 lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
-  (EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk)
+  (EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients @s gk)
   gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs
   MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just
 
@@ -286,6 +425,17 @@ instance ( MonadIO m
 
 data EncMethod = Method1 | Method2
 
+-- findSecretDefault :: MonadIO m =>
+
+
+findSecretDefault :: forall s m . (s ~ 'HBS2Basic, Monad  m)
+                  => [KeyringEntry s]
+                  -> GroupKey 'Symm s
+                  -> m (Maybe GroupSecret)
+
+findSecretDefault keys gk = do
+  pure $ [ lookupGroupKey sk pk gk | KeyringEntry pk sk  _ <- keys ] & catMaybes & headMay
+
 instance ( MonadIO m
          , MonadError OperationError m
          , h ~ HbSync
@@ -295,17 +445,20 @@ instance ( MonadIO m
          ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
 
   data instance TreeKey (ToDecrypt 'Symm sch ByteString) =
-      ToDecryptBS   [KeyringEntry sch] (Hash HbSync)
+      -- ToDecryptBS   [KeyringEntry sch] (Hash HbSync)
-    | ToDecryptBS2  (GroupKey 'Symm sch) B8.ByteString [KeyringEntry sch] (MTreeAnn [HashRef])
+    ToDecryptBS { treeHash   :: Hash HbSync
+                , findSecret :: forall m1 . MonadIO m1 => GroupKey 'Symm sch -> m1 (Maybe GroupSecret)
+                }
 
   type instance ToBlockR  (ToDecrypt 'Symm sch ByteString) = ByteString
   type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString
 
-  readFromMerkle sto decrypt  = do
+  readFromMerkle sto decrypt@ToDecryptBS{..}  = do
 
-    (keys, gk, nonceS, tree) <- decryptDataFrom decrypt
+    (gk, nonceS, tree) <- decryptDataFrom decrypt
 
-    let gksec' = [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay
+    gksec' <- findSecret gk
+     -- [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay
 
     gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure
 
@@ -344,12 +497,8 @@ instance ( MonadIO m
     where
 
       decryptDataFrom = \case
-        ToDecryptBS2 gk nonce ke tree  -> do
-          let keys = [ (view krPk x, view krSk x) | x <- ke ]
-          pure (keys, gk, nonce, tree)
 
-        ToDecryptBS ke h  -> do
+        ToDecryptBS h _  -> do
-          let keys = [ (view krPk x, view krSk x) | x <- ke ]
 
           bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure
           let what = tryDetect h bs
@@ -364,8 +513,7 @@ instance ( MonadIO m
 
           gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs)
 
-          pure (keys, gk, nonceS, tree)
+          pure (gk, nonceS, tree)
-
 
 
 encryptBlock :: ( MonadIO m

hbs2-core/lib/HBS2/Net/Auth/Schema.hs

@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# Language UndecidableInstances #-}
+{-# Language PatternSynonyms #-}
 module HBS2.Net.Auth.Schema
   ( module HBS2.Net.Auth.Schema
   , module HBS2.Net.Proto.Types
@@ -11,6 +12,8 @@ import HBS2.Net.Proto.Types
 import HBS2.Hash
 import HBS2.Net.Messaging.Unix
 
+import Data.Config.Suckless
+
 import Data.Word
 import Crypto.Error
 import Crypto.PubKey.Ed25519 qualified as Ed
@@ -69,3 +72,6 @@ instance (MonadIO m, ForDerivedKey s, s ~ 'HBS2Basic) => HasDerivedKey s 'Sign W
        prk = HKDF.extract @(HashType HbSync) salt ikm
        k0  = HKDF.expand @_ @_ @ByteString prk salt Ed.secretKeySize
 
+
+
+

hbs2-core/lib/HBS2/Net/Messaging/Unix.hs

@@ -225,10 +225,10 @@ runMessagingUnix env = do
     clientLoop m = fix \next -> do
       m
       if not (MUDontRetry `elem` msgUnixOpts env) then do
-        debug "LOOP!"
+        trace "LOOP!"
         next
       else do
-        debug "LOOP EXIT"
+        trace "LOOP EXIT"
 
     handleClient | MUDontRetry `elem` msgUnixOpts env  = \_ w -> handleAny throwStopped w
                  | otherwise =  handleAny
@@ -237,8 +237,6 @@ runMessagingUnix env = do
 
     runClient = liftIO $ clientLoop $ handleClient logAndRetry $ flip runContT pure $ do
 
-      debug "HERE WE GO AGAIN!"
-
       let sa   = SockAddrUnix (msgUnixSockPath env)
       let p  = msgUnixSockPath env
       let who = PeerUNIX p

hbs2-core/lib/HBS2/Prelude.hs

@@ -1,4 +1,6 @@
 {-# Language FunctionalDependencies #-}
+{-# Language PatternSynonyms #-}
+{-# Language ViewPatterns #-}
 module HBS2.Prelude
   ( module Data.String
   , module Safe
@@ -171,3 +173,8 @@ instance Hashable a => Hashable (ByFirst a b) where
 
 -- asyncLinked :: forall m . MonadUnliftIO m =>
 
+
+
+
+
+

hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs

@@ -244,6 +244,8 @@ readBundle sto rh ref = do
 
   let q = tryDetect (fromHashRef ref) obj
 
+  let findSec = runKeymanClientRO . findMatchedGroupKeySecret sto
+
   case q of
     Merkle t -> do
       let meta = BundleMeta ref False
@@ -251,9 +253,8 @@ readBundle sto rh ref = do
         readFromMerkle sto (SimpleKey key)
 
     MerkleAnn (MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
-      ke <- loadKeyrings (HashRef gkh)
       let meta = BundleMeta ref True
-      BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS ke key)
+      BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS key (liftIO . findSec))
 
     _ -> throwError UnsupportedFormat
 

hbs2-git/hbs2-git.cabal

@@ -55,7 +55,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , db-pipe
       , suckless-conf
 

hbs2-keyman/app/Main.hs

@@ -1,133 +0,0 @@
-module Main where
-
-import HBS2.KeyMan.Prelude
-import HBS2.KeyMan.App.Types
-import HBS2.KeyMan.Config
-import HBS2.KeyMan.State
-
-import HBS2.Net.Auth.Credentials
-
-import HBS2.Data.KeyRing qualified as KeyRing
-
-import HBS2.System.Dir
-import HBS2.System.Logger.Simple
-
-import Data.Config.Suckless.KeyValue
-
-import Options.Applicative qualified as O
-import Data.Text qualified as Text
-import Options.Applicative hiding (info)
-import Data.Set qualified as Set
-import Data.ByteString qualified as BS
-import Control.Monad.Trans.Maybe
-import Control.Monad.Reader
-
-
-data GlobalOptions = GlobalOptions
-  {
-  }
-
-type Command m = m ()
-
--- Парсер для глобальных опций
-globalOptions :: Parser GlobalOptions
-globalOptions = pure GlobalOptions
-
-type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials 'HBS2Basic)
-
--- TODO: key-mamagement-command-about-to-move-here
-
-commands :: (AppPerks m) => Parser (Command m)
-commands = hsubparser
-  (  command "update"     (O.info (updateKeys <**> helper) (progDesc "update keys" ))
-  <> command "list"       (O.info (listKeysCmd <**> helper) (progDesc "list keys" ))
-  <> command "disclose"   (O.info (discloseKeyCmd <**> helper) (progDesc "disclose credentials" ))
-  <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key"))
-  <> command "add-mask"   (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'"))
-  <> command "config"     (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config"))
-  )
-
-opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
-opts = O.info (liftA2 (,) globalOptions commands <**> helper)
-  ( fullDesc
- <> header "hbs2-keyman" )
-
-
-showConfig :: (AppPerks m) => Parser (Command m)
-showConfig = do
-  pure do
-    readConfig >>=  liftIO . print . vcat . fmap pretty
-
-addPath :: (AppPerks m) => Parser (Command m)
-addPath = do
-  masks <- many $ strArgument (metavar "KEYFILE-MASK")
-  pure do
-    cfg <- getConfigPath <&> takeDirectory
-    mkdir cfg
-    for_ masks $ \m -> do
-      liftIO $ appendFile (cfg </> "config") (show $ "key-files" <+> dquotes (pretty m) <> line)
-
-listKeysCmd :: (AppPerks m) => Parser (Command m)
-listKeysCmd = pure do
-  kw <- withState listKeys
-  liftIO $ print $ vcat (fmap pretty kw)
-
-updateKeys :: (AppPerks m) => Parser (Command m)
-updateKeys = do
-  prune <- flag False True ( long "prune" <> short 'p' <> help "prune keys for missed files")
-  pure do
-
-    masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
-    files <- KeyRing.findFilesBy masks
-
-    when prune do
-      -- here <- doesPathExist fn
-      --
-      keys <- withState listKeys
-      for_ keys $ \k -> void $ runMaybeT do
-        fn <- keyFile k & toMPlus <&> Text.unpack
-        here <- doesPathExist fn
-        unless here do
-          info $ "prune" <+> pretty fn
-          lift $ withState $ deleteKey (keyId k)
-
-    for_ files $ \fn -> runMaybeT do
-
-      bs <- liftIO $ BS.readFile fn
-
-      krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
-
-      let skp = view peerSignPk krf
-
-      withState do
-        -- info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn
-        updateKeyFile (SomePubKey @'Sign skp) fn
-        updateKeyType (SomePubKey @'Sign skp)
-
-        for_ (view peerKeyring  krf) $ \(KeyringEntry pk _ _) -> do
-          -- info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn
-          updateKeyFile (SomePubKey @'Encrypt pk) fn
-          updateKeyType (SomePubKey @'Encrypt pk)
-
-        commitAll
-
-setWeightCmd :: (AppPerks m) => Parser (Command m)
-setWeightCmd = do
-  k <- argument str (metavar "KEY" <> help "Key identifier")
-  v <- argument auto (metavar "WEIGHT" <> help "Weight value")
-  pure do
-    withState $ updateKeyWeight k v
-
-discloseKeyCmd :: (AppPerks m) => Parser (Command m)
-discloseKeyCmd  = do
-  -- k <- argument str (metavar "KEY" <> help "Key identifier")
-  -- v <- argument auto (metavar "WEIGHT" <> help "Weight value")
-  pure do
-    notice "WIP"
-
-main :: IO ()
-main = do
-  (_, action) <- execParser opts
-  runApp action
-
-

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/App/Types.hs

@@ -17,8 +17,7 @@ import HBS2.Base58
 import HBS2.Net.Auth.Credentials()
 import HBS2.Net.Proto.Types
 
-
+import HBS2.System.Logger.Simple.ANSI
-import HBS2.System.Logger.Simple
 import Data.Config.Suckless
 import DBPipe.SQLite
 

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Keys/Direct.hs

@@ -5,28 +5,31 @@ import HBS2.KeyMan.Prelude
 import HBS2.KeyMan.State
 import HBS2.KeyMan.Config
 
-import HBS2.Prelude.Plated
+import HBS2.Storage
+import HBS2.Data.Types.Refs
 import HBS2.Net.Auth.Credentials
 import HBS2.Net.Auth.GroupKeySymm as Symm
-import HBS2.Net.Proto.Types
 
 
 import HBS2.System.Dir
 
 import Control.Monad.Cont
-import UnliftIO
 import DBPipe.SQLite
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Maybe
 import Data.HashMap.Strict qualified as HM
+import Data.HashSet qualified as HS
 import Control.Monad.Trans.Maybe
 import Data.List qualified as List
 import Data.ByteString qualified as BS
 import Data.Ord
+import Data.Coerce
 import Streaming.Prelude qualified as S
 
 data KeyManClientError = KeyManClientSomeError
 
+newtype KeyManClientEnv = KeyManClientEnv AppEnv
+
 newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a }
                            deriving newtype ( Applicative
                                             , Functor
@@ -35,22 +38,38 @@ newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a }
                                             , MonadUnliftIO
                                             )
 
+newKeymanClientEnv :: MonadUnliftIO m => m KeyManClientEnv
+newKeymanClientEnv = KeyManClientEnv <$> liftIO newAppEnv
+
+withKeymanClientRO :: MonadUnliftIO m => KeyManClientEnv -> KeyManClient m a -> m a
+withKeymanClientRO env action = do
+  let db = appDb (coerce env)
+  withDB db (fromKeyManClient action)
+
+runKeymanClientRO :: MonadUnliftIO m => KeyManClient m a -> m a
+runKeymanClientRO action = do
+  env <- newKeymanClientEnv
+  withKeymanClientRO env action
+
 runKeymanClient :: MonadUnliftIO m => KeyManClient m a -> m a
 runKeymanClient action = do
+  KeyManClientEnv env <- newKeymanClientEnv
+  -- FIXME: dbpath-to-appstatenv
+  --  сейчас dbPath берётся из конфига, а db из стейта
+  --  и хотя они должны быть одинаковы, это не гарантируется
   dbPath <- getStatePath
-  env <- liftIO newAppEnv
+
   let db = appDb env
+
+  here <- doesPathExist dbPath
+
+  unless here do
+    withDB db $ populateState
+
   flip runContT pure $ do
     void $ ContT $ bracket (async (runPipe db)) cancel
-
-    here <- doesPathExist dbPath
-
-    unless here do
-      withDB db $ populateState
-
     lift $ withDB db (fromKeyManClient action)
 
-
 loadCredentials :: forall a m .
                      ( MonadIO m
                      , SomePubKeyPerks a
@@ -122,3 +141,70 @@ extractGroupKeySecret gk = do
 
     pure $ headMay r
 
+
+type TrackGroupKeyView = ( SomeHash GroupKeyId
+                         , SomeHash HashRef
+                         , String
+                         , FilePath
+                         , Int)
+
+findMatchedGroupKeySecret :: forall s m . ( MonadIO m
+                                          , SerialisedCredentials 'HBS2Basic
+                                          , s ~ 'HBS2Basic
+                                          )
+                        => AnyStorage
+                        -> GroupKey 'Symm s
+                        -> KeyManClient m (Maybe GroupSecret)
+
+findMatchedGroupKeySecret sto gk = do
+
+  let sql = [qc|
+      select t.secret
+           , t.gkhash
+           , f.key
+           , f.file
+           , coalesce(kw.weight, 0) as weight
+      from  gkaccess gka
+            join gktrack t on gka.gkhash = t.gkhash
+            join keyfile f on f.key = gka.key
+            left join keyweight kw on kw.key = f.key
+      where t.secret = ?
+      order by kw.weight desc nulls last
+          |]
+
+  let pks = recipients gk & HM.keysSet
+
+  flip runContT pure $ callCC $ \exit -> do
+
+    kre0 <- lift $ loadKeyRingEntries (HS.toList pks) <&> fmap snd
+
+    sec0 <- findSecretDefault kre0 gk
+
+    -- возвращаем первый, который нашли
+    maybe1 sec0 none (exit . Just)
+
+    -- если старый формат ключа -- то ничего не найдём
+    secId <- ContT $ maybe1 (getGroupKeyId gk) (pure Nothing)
+
+    rows <- lift $ KeyManClient $ select @TrackGroupKeyView sql (Only (SomeHash secId))
+
+    let gkss = HS.fromList (fmap (coerce @_ @HashRef . view _2) rows) & HS.toList
+
+    -- TODO: memoize
+
+    -- ищем такой же
+    --   если нашли -- хорошо бы проверить пруф, но как?
+    --   для исходного ключа -- мы оказались здесь потому,
+    --   что не смогли достать секрет из него и ищем такой же,
+    --   но доступный нам. соответственно, мы не можем убедиться,
+    --   что исходный ключ с правильным Id / правильным секретом.
+    --   можем только обломаться при расшифровке и записать этот факт
+    for_ gkss $ \gkh -> void $ runMaybeT do
+      gkx <- loadGroupKeyMaybe @s sto gkh >>= toMPlus
+      sec' <- lift $ lift $ extractGroupKeySecret gkx
+      maybe1 sec' none $ (lift . exit . Just)
+
+    pure Nothing
+
+
+

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/Prelude.hs

@@ -0,0 +1,10 @@
+module HBS2.KeyMan.Prelude
+  ( module HBS2.Prelude.Plated
+  , module Exported
+  ) where
+
+
+import HBS2.Prelude.Plated
+import HBS2.Misc.PrettyStuff as Exported
+import HBS2.System.Logger.Simple.ANSI as Exported
+

hbs2-keyman/hbs2-keyman-direct-lib/HBS2/KeyMan/State.hs

@@ -4,12 +4,16 @@
 module HBS2.KeyMan.State
   ( module HBS2.KeyMan.State
   , commitAll
+  , transactional
+  , module Exported
   ) where
 
 import HBS2.Prelude.Plated
 import HBS2.Base58
+import HBS2.Hash
 import HBS2.Net.Auth.Credentials
-import HBS2.Net.Proto.Types
+import HBS2.Data.Types.Refs
+import HBS2.Net.Auth.GroupKeySymm as Exported
 
 import HBS2.KeyMan.Config
 
@@ -19,17 +23,39 @@ import DBPipe.SQLite
 -- import Crypto.Saltine.Core.Box qualified as Encrypt
 import System.Directory
 import System.FilePath
-import Control.Monad.Trans.Maybe
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Maybe
+import Data.HashSet (HashSet)
+import Data.HashSet qualified as HS
+import Data.HashMap.Strict qualified as HM
+import Data.Coerce
 
 import UnliftIO
 
+
+newtype SomeHash a = SomeHash a
+                     deriving stock Generic
+
+instance ToField (SomeHash HashRef) where
+  toField (SomeHash x) = toField $ show $ pretty x
+
+instance FromField (SomeHash HashRef) where
+  fromField = fmap (SomeHash . fromString @HashRef) . fromField @String
+
+instance ToField (SomeHash GroupKeyId) where
+  toField (SomeHash x) = toField $ show $ pretty x
+
+instance FromField (SomeHash GroupKeyId) where
+  fromField = do
+    fmap (SomeHash . convert . fromString @HashRef) . fromField @String
+    where
+      convert ha = GroupKeyId (coerce ha)
+
 -- newtype ToDB a = ToDB a
 class SomePubKeyType a where
   somePubKeyType :: a -> String
 
-type SomePubKeyPerks a = (Pretty (AsBase58 a))
+type SomePubKeyPerks a = (Pretty (AsBase58 a), FromStringMaybe a)
 
 data SomePubKey (c :: CryptoAction) = forall a . SomePubKeyPerks a => SomePubKey a
 
@@ -84,12 +110,36 @@ populateState = do
     )
     |]
 
+
+  ddl [qc|
+    create table if not exists gkseentx
+    ( hash  text not null
+    , primary key (hash)
+    )
+    |]
+
+  ddl [qc|
+    create table if not exists gktrack
+    ( secret  text not null
+    , gkhash  text not null
+    , primary key (secret,gkhash)
+    )
+    |]
+
+  ddl [qc|
+    create table if not exists gkaccess
+    ( gkhash  text not null
+    , key     text not null
+    , primary key (gkhash,key)
+    )
+    |]
+
+
   commitAll
 
 instance ToField (SomePubKey a) where
   toField (SomePubKey s) = toField $ show $ pretty (AsBase58 s)
 
-
 updateKeyFile :: forall a m . (SomePubKeyType (SomePubKey a), MonadIO m)
               => SomePubKey a
               -> FilePath
@@ -204,3 +254,42 @@ selectKeyWeight key = do
     limit 1
     |] (Only (SomePubKey key)) <&> maybe 0 fromOnly . listToMaybe
 
+
+deleteAllSeenGKTx :: MonadIO m => DBPipeM m ()
+deleteAllSeenGKTx = do
+  insert_ [qc|delete from gkseentx|]
+
+insertSeenGKTx :: (MonadIO m) => HashRef  -> DBPipeM m ()
+insertSeenGKTx hash = do
+  insert [qc|
+    insert into gkseentx (hash) values(?)
+       on conflict (hash) do nothing
+           |] (Only (SomeHash hash))
+
+selectAllSeenGKTx :: (MonadIO m) => DBPipeM m (HashSet HashRef)
+selectAllSeenGKTx = do
+  select_ [qc|select hash from gkseentx|] <&> HS.fromList . fmap (coerce . fromOnly @(SomeHash HashRef))
+
+
+insertGKTrack :: MonadIO m => GroupKeyId -> HashRef -> DBPipeM m ()
+insertGKTrack s g = do
+  insert [qc|
+    insert into gktrack (secret,gkhash)
+    values(?,?)
+    on conflict (secret,gkhash) do nothing
+    |] (SomeHash s, SomeHash g)
+
+insertGKAccess:: MonadIO m => HashRef -> GroupKey 'Symm 'HBS2Basic -> DBPipeM m ()
+insertGKAccess gkh gk = do
+  let rcpt = recipients gk & HM.keys
+  for_ rcpt $ \k -> do
+    insert [qc|
+      insert into gkaccess (gkhash,key)
+      values(?,?)
+      on conflict (gkhash,key) do nothing
+              |] (SomeHash gkh, SomePubKey k)
+
+
+
+
+

hbs2-keyman/hbs2-keyman-direct-lib/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-keyman/hbs2-keyman-direct-lib/hbs2-keyman-direct-lib.cabal

@@ -0,0 +1,109 @@
+cabal-version:      3.0
+name:               hbs2-keyman-direct-lib
+version:            0.24.1.2
+-- synopsis:
+-- description:
+license:            BSD-3-Clause
+license-file:       LICENSE
+author:             Dmitry Zuikov
+maintainer:         dzuikov@gmail.com
+-- copyright:
+category:           Data
+build-type:         Simple
+-- extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall -fno-warn-type-defaults
+
+common common-deps
+    build-depends:
+          base, hbs2-core, hbs2-storage-simple, suckless-conf, db-pipe
+        , async
+        , bytestring
+        , cache
+        , containers
+        , data-default
+        , deepseq
+        , directory
+        , filepath
+        , filepattern
+        , generic-lens
+        , hashable
+        , heaps
+        , microlens-platform
+        , mtl
+        , mwc-random
+        , prettyprinter
+        , QuickCheck
+        , random
+        , random-shuffle
+        , resourcet
+        , safe
+        , serialise
+        , split
+        , stm
+        , streaming
+        , tasty
+        , tasty-hunit
+        , temporary
+        , text
+        , timeit
+        , transformers
+        , uniplate
+        , unordered-containers
+        , vector
+        , prettyprinter-ansi-terminal
+        , interpolatedstring-perl6
+        , unliftio
+
+  default-extensions:
+                       ApplicativeDo
+                     , BangPatterns
+                     , BlockArguments
+                     , ConstraintKinds
+                     , DataKinds
+                     , DeriveDataTypeable
+                     , DeriveGeneric
+                     , DerivingStrategies
+                     , DerivingVia
+                     , ExtendedDefaultRules
+                     , FlexibleContexts
+                     , FlexibleInstances
+                     , GADTs
+                     , GeneralizedNewtypeDeriving
+                     , ImportQualifiedPost
+                     , LambdaCase
+                     , MultiParamTypeClasses
+                     , OverloadedStrings
+                     , OverloadedLabels
+                     , QuasiQuotes
+                     , RankNTypes
+                     , RecordWildCards
+                     , RecursiveDo
+                     , ScopedTypeVariables
+                     , StandaloneDeriving
+                     , TupleSections
+                     , TypeApplications
+                     , TypeFamilies
+                     , TypeOperators
+
+
+
+library
+    import:           warnings
+    import:           common-deps
+
+    exposed-modules:
+      HBS2.KeyMan.App.Types
+      HBS2.KeyMan.Prelude
+      HBS2.KeyMan.Config
+      HBS2.KeyMan.State
+      HBS2.KeyMan.Keys.Direct
+
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    base
+    hs-source-dirs:   .
+    default-language: GHC2021
+

hbs2-keyman/hbs2-keyman/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-keyman/hbs2-keyman/Main.hs

@@ -0,0 +1,255 @@
+module Main where
+
+import HBS2.KeyMan.Prelude
+import HBS2.KeyMan.App.Types
+import HBS2.KeyMan.Config
+import HBS2.KeyMan.State
+
+import HBS2.Net.Auth.Credentials
+
+import HBS2.Data.KeyRing qualified as KeyRing
+
+import HBS2.System.Dir
+
+import HBS2.Storage
+import HBS2.Storage.Operations.ByteString
+import HBS2.Data.Types.SignedBox
+import HBS2.Peer.Proto.RefChan
+import HBS2.Peer.CLI.Detect
+import HBS2.Peer.RPC.Client
+import HBS2.Peer.RPC.Client.Unix
+import HBS2.Peer.RPC.Client.RefChan
+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.List qualified as List
+import Options.Applicative qualified as O
+import Data.Text qualified as Text
+import Options.Applicative hiding (info,action)
+import Data.Set qualified as Set
+import Data.HashSet qualified as HS
+import Data.ByteString qualified as BS
+import Data.ByteString qualified as LBS
+import Data.Maybe
+import Data.Either
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
+import Control.Monad.Reader
+import Control.Monad.Except
+import Codec.Serialise
+import Data.Coerce
+
+import Streaming.Prelude qualified as S
+
+data GlobalOptions = GlobalOptions
+  {
+  }
+
+type Command m = m ()
+
+-- Парсер для глобальных опций
+globalOptions :: Parser GlobalOptions
+globalOptions = pure GlobalOptions
+
+type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials 'HBS2Basic)
+
+-- TODO: key-mamagement-command-about-to-move-here
+
+commands :: (AppPerks m) => Parser (Command m)
+commands = hsubparser
+  (  command "update"     (O.info (updateKeys <**> helper) (progDesc "update keys" ))
+  <> command "list"       (O.info (listKeysCmd <**> helper) (progDesc "list keys" ))
+  <> command "disclose"   (O.info (discloseKeyCmd <**> helper) (progDesc "disclose credentials" ))
+  <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key"))
+  <> command "add-mask"   (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'"))
+  <> command "config"     (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config"))
+  )
+
+opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
+opts = O.info (liftA2 (,) globalOptions commands <**> helper)
+  ( fullDesc
+ <> header "hbs2-keyman" )
+
+
+showConfig :: (AppPerks m) => Parser (Command m)
+showConfig = do
+  pure do
+    readConfig >>=  liftIO . print . vcat . fmap pretty
+
+addPath :: (AppPerks m) => Parser (Command m)
+addPath = do
+  masks <- many $ strArgument (metavar "KEYFILE-MASK")
+  pure do
+    cfg <- getConfigPath <&> takeDirectory
+    mkdir cfg
+    for_ masks $ \m -> do
+      liftIO $ appendFile (cfg </> "config") (show $ "key-files" <+> dquotes (pretty m) <> line)
+
+listKeysCmd :: (AppPerks m) => Parser (Command m)
+listKeysCmd = pure do
+  kw <- withState listKeys
+  liftIO $ print $ vcat (fmap pretty kw)
+
+
+data RChanScanEnv =
+  RChanScanEnv
+  { storage     :: AnyStorage
+  , refchanAPI  ::  ServiceCaller RefChanAPI UNIX
+  }
+
+newtype ScanRefChansM m a = ScanRefChansM { fromScanRefChansM :: ReaderT RChanScanEnv m a }
+                            deriving newtype ( Applicative
+                                             , Functor
+                                             , Monad
+                                             , MonadIO
+                                             , MonadUnliftIO
+                                             , MonadReader RChanScanEnv
+                                             , MonadTrans
+                                             )
+
+runScan :: Monad m => RChanScanEnv -> ScanRefChansM m a -> m a
+runScan env action = runReaderT ( fromScanRefChansM action ) env
+
+
+instance Monad m => HasClientAPI RefChanAPI UNIX (ScanRefChansM m) where
+  getClientAPI = asks refchanAPI
+
+instance Monad m => HasStorage (ScanRefChansM m) where
+  getStorage = asks storage
+
+
+updateKeys :: forall proto m . (AppPerks m, proto ~ UNIX) => Parser (Command m)
+updateKeys = do
+  prune <- flag False True ( long "prune" <> short 'p' <> help "prune keys for missed files")
+  pure do
+    updateLocalKeys prune
+    updateGroupKeys
+
+  where
+
+    updateGroupKeys = do
+      -- scanning refchans for group keys
+      conf <- getConf
+      let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ]
+
+      seen <- withState selectAllSeenGKTx
+
+      flip runContT pure $ callCC \exit -> do
+        when (List.null rchans) $ exit ()
+        so' <- detectRPC
+        so <- ContT $ maybe1 so' (warn $ yellow "peer is down")
+
+        rpc <- ContT $ withRPC2 @RefChanAPI so
+        sto <- ContT (withRPC2 @StorageAPI so) <&> AnyStorage . StorageClient
+
+
+        txs <- S.toList_ do
+          runScan (RChanScanEnv sto rpc) do
+
+            for_ rchans $ \r -> do
+
+              walkRefChanTx @proto (pure . not . flip HS.member seen) r $ \tx0 -> \case
+                P _  (ProposeTran _ box) -> do
+
+                  trace $ "got the fucking tx" <+> pretty tx0
+
+                  void $ runMaybeT do
+                    (_,bs) <- unboxSignedBox0 box & toMPlus
+
+                    AnnotatedHashRef _ gkh <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                                & toMPlus . either (const Nothing) Just
+
+                    -- FIXME: request-download-for-missed-groupkeys
+                    -- FIXME: implement-download-with-timeout
+                    gkbs <- runExceptT (readFromMerkle sto (SimpleKey (coerce gkh)))
+                              >>= toMPlus
+
+                    -- FIXME: do-it-right
+                    --   если смогли скачать -- то уже потом не будем обрабатывать
+                    --   потенциальная проблема -- мусорная транзакция, которая так и
+                    --   будет болтаться, если она не AnnotatedHashRef
+                    lift $ lift $ S.yield (Left tx0)
+
+                    gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gkbs & toMPlus
+
+                    gkId <- getGroupKeyId gk & toMPlus
+
+                    --TODO: verify-group-key-id-if-possible
+
+                    notice $ green "found new gk0" <+> pretty gkId <+> pretty gkh
+
+                    lift $ lift $ S.yield (Right (gkId, gkh, gk) )
+
+                _ -> do
+                  lift $ S.yield (Left tx0)
+
+        lift $ withState $ transactional do
+          for_ (lefts txs) insertSeenGKTx
+          for_ (rights txs)  $ \(gkId, h, gh) -> do
+            insertGKTrack gkId h
+            insertGKAccess h gh
+
+        pure ()
+
+    updateLocalKeys prune = do
+
+      masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
+      files <- KeyRing.findFilesBy masks
+
+      when prune do
+        -- here <- doesPathExist fn
+        --
+        keys <- withState listKeys
+        for_ keys $ \k -> void $ runMaybeT do
+          fn <- keyFile k & toMPlus <&> Text.unpack
+          here <- doesPathExist fn
+          unless here do
+            info $ "prune" <+> pretty fn
+            lift $ withState $ deleteKey (keyId k)
+
+      for_ files $ \fn -> runMaybeT do
+
+        bs <- liftIO $ BS.readFile fn
+
+        krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
+
+        let skp = view peerSignPk krf
+
+        withState do
+          -- info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn
+          updateKeyFile (SomePubKey @'Sign skp) fn
+          updateKeyType (SomePubKey @'Sign skp)
+
+          for_ (view peerKeyring  krf) $ \(KeyringEntry pk _ _) -> do
+            -- info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn
+            updateKeyFile (SomePubKey @'Encrypt pk) fn
+            updateKeyType (SomePubKey @'Encrypt pk)
+
+          commitAll
+
+
+
+setWeightCmd :: (AppPerks m) => Parser (Command m)
+setWeightCmd = do
+  k <- argument str (metavar "KEY" <> help "Key identifier")
+  v <- argument auto (metavar "WEIGHT" <> help "Weight value")
+  pure do
+    withState $ updateKeyWeight k v
+
+discloseKeyCmd :: (AppPerks m) => Parser (Command m)
+discloseKeyCmd  = do
+  -- k <- argument str (metavar "KEY" <> help "Key identifier")
+  -- v <- argument auto (metavar "WEIGHT" <> help "Weight value")
+  pure do
+    notice "WIP"
+
+main :: IO ()
+main = do
+  (_, action) <- execParser opts
+  runApp action
+
+

hbs2-keyman/hbs2-keyman/hbs2-keyman.cabal

@@ -90,23 +90,6 @@ common common-deps
 
 
 
-library
-    import:           warnings
-    import:           common-deps
-
-    exposed-modules:
-      HBS2.KeyMan.App.Types
-      HBS2.KeyMan.Prelude
-      HBS2.KeyMan.Config
-      HBS2.KeyMan.State
-      HBS2.KeyMan.Keys.Direct
-
-    -- other-modules:
-    -- other-extensions:
-    build-depends:    base
-    hs-source-dirs:   src
-    default-language: GHC2021
-
 executable hbs2-keyman
     import:           warnings
     import:           common-deps
@@ -116,9 +99,10 @@ executable hbs2-keyman
     -- other-extensions:
     build-depends:
           base
-        , hbs2-keyman
+        , hbs2-keyman-direct-lib
+        , hbs2-peer
         , optparse-applicative
 
-    hs-source-dirs:   app
+    hs-source-dirs:   .
     default-language: GHC2021
 

hbs2-keyman/src/HBS2/KeyMan/Prelude.hs

@@ -1,8 +0,0 @@
-module HBS2.KeyMan.Prelude
-  ( module HBS2.Prelude.Plated
-  ) where
-
-
-import HBS2.Prelude.Plated
-
-

hbs2-peer/hbs2-peer.cabal

@@ -284,7 +284,7 @@ executable hbs2-peer
                     , Paths_hbs2_peer
 
     -- other-extensions:
-    build-depends:    base, hbs2-peer, hbs2-keyman, vty
+    build-depends:    base, hbs2-peer, hbs2-keyman-direct-lib, vty
 
     hs-source-dirs:   app
 

hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs

@@ -190,3 +190,5 @@ walkRefChanTx filt puk action = do
             tx   <- ContT $ maybe1 (unpackRefChanUpdate h lbs) none
             lift $ action h tx
 
+
+

hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs

@@ -18,6 +18,7 @@ import HBS2.System.Logger.Simple
 import Data.Kind
 import Control.Monad.Reader
 import UnliftIO
+import Control.Monad.Trans.Cont
 
 withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
                              , HasProtocol e (ServiceProto api e)
@@ -29,23 +30,24 @@ withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
 
 withRPC2 soname action = do
 
-  debug $ "withRPC2" <+> pretty soname
+  flip runContT pure do
 
-  client1 <- newMessagingUnix False 1.0 soname
+    trace $ "withRPC2" <+> pretty soname
 
-  m1 <- async $ runMessagingUnix client1
+    client1 <- newMessagingUnix False 1.0 soname
-  -- link m1
 
-  caller <- makeServiceCaller @api @UNIX (fromString soname)
+    m1 <- ContT $ withAsync (runMessagingUnix client1)
-  p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1
+    -- link m1
 
-  r <- action caller
+    caller <- makeServiceCaller @api @UNIX (fromString soname)
+    p2 <- ContT $ withAsync (liftIO $ runReaderT (runServiceClient @api @e caller) client1)
 
-  pause @'Seconds 0.05
+    r <- lift $ action caller
-  cancel p2
 
-  void $ waitAnyCatchCancel [m1, p2]
+    pause @'Seconds 0.05
+    cancel p2
 
-  pure r
+    void $ waitAnyCatchCancel [m1, p2]
 
+    pure r
 

hbs2-sync/hbs2-sync.cabal

@@ -56,7 +56,7 @@ common shared-properties
         hbs2-core
       , hbs2-peer
       , hbs2-storage-simple
-      , hbs2-keyman
+      , hbs2-keyman-direct-lib
       , db-pipe
       , suckless-conf
 

hbs2-sync/src/HBS2/Sync/Internal.hs

@@ -35,6 +35,7 @@ syncEntries :: forall c m . ( MonadUnliftIO m
                             , HasRunDir m
                             , HasTombs m
                             , HasCache m
+                            , HasKeyManClient m
                             , MonadReader (Maybe SyncEnv) m
                             )
             => MakeDictM c m ()

hbs2-sync/src/HBS2/Sync/Prelude.hs

@@ -37,8 +37,11 @@ import HBS2.KeyMan.Keys.Direct as Exported ( runKeymanClient
                                            , loadCredentials
                                            , loadKeyRingEntries
                                            , extractGroupKeySecret
+                                           , KeyManClientEnv
                                            )
 
+import HBS2.KeyMan.Keys.Direct qualified as KE
+
 import Data.Config.Suckless as Exported
 import Data.Config.Suckless.Script as Exported
 
@@ -112,13 +115,14 @@ instance Pretty DirSyncEnv where
 
 data SyncEnv =
   SyncEnv
-  { refchanAPI  :: ServiceCaller RefChanAPI UNIX
+  { refchanAPI      :: ServiceCaller RefChanAPI UNIX
-  , storageAPI  :: ServiceCaller StorageAPI UNIX
+  , storageAPI      :: ServiceCaller StorageAPI UNIX
-  , peerAPI     :: ServiceCaller PeerAPI UNIX
+  , peerAPI         :: ServiceCaller PeerAPI UNIX
-  , dirSyncEnv  :: TVar (Map FilePath DirSyncEnv)
+  , dirSyncEnv      :: TVar (Map FilePath DirSyncEnv)
-  , dirThis     :: TVar (Maybe FilePath)
+  , dirThis         :: TVar (Maybe FilePath)
-  , dirTombs    :: TVar (Map FilePath (CompactStorage HbSync))
+  , dirTombs        :: TVar (Map FilePath (CompactStorage HbSync))
-  , dirCache    :: TVar (Map FilePath (CompactStorage HbSync))
+  , dirCache        :: TVar (Map FilePath (CompactStorage HbSync))
+  , keymanClientEnv :: TVar (Maybe KeyManClientEnv)
   }
 
 newtype SyncApp m a =
@@ -142,6 +146,9 @@ class Monad m => HasCache m where
   getCache :: m (CompactStorage HbSync)
   closeCache :: m ()
 
+class Monad m => HasKeyManClient m where
+  getKeyManClientEnv :: m KeyManClientEnv
+
 instance MonadUnliftIO m => HasTombs (SyncApp m) where
   getTombs = do
     SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
@@ -205,6 +212,23 @@ instance MonadUnliftIO m => HasCache (SyncApp m) where
       compactStorageClose cache
 
 
+instance MonadUnliftIO m => HasKeyManClient (SyncApp m) where
+  getKeyManClientEnv = do
+    SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
+    e <- readTVarIO keymanClientEnv
+
+    case e of
+      Just env -> pure env
+      -- NOTE: race-but-harmless
+      --   если у нас в двух потоках позовут этот метод,
+      --   то будет открыто два соединения, и сохранено
+      --   последнее. Поскольку соединение readonly это
+      --   безобидно. В целом, надо навести с этим порядок
+      Nothing -> do
+        env <- KE.newKeymanClientEnv
+        atomically  $ writeTVar keymanClientEnv (Just env)
+        pure env
+
 instance MonadIO m => HasClientAPI StorageAPI UNIX (SyncApp m) where
   getClientAPI = ask >>= orThrow PeerNotConnectedException
                      <&> storageAPI
@@ -262,8 +286,9 @@ recover what = do
         this  <- newTVarIO Nothing
         tombs <- newTVarIO mempty
         cache <- newTVarIO mempty
+        dummyKeyman <- newTVarIO Nothing
 
-        let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache)
+        let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache dummyKeyman)
 
         liftIO $ withSyncApp env what
 
@@ -391,7 +416,8 @@ instance (Monad m, HasCache m) => HasCache (RunM c m) where
   getCache = lift getCache
   closeCache = lift closeCache
 
-
+instance (MonadUnliftIO m, HasKeyManClient m) => HasKeyManClient (RunM c m) where
+  getKeyManClientEnv = lift getKeyManClientEnv
 
 -- debugPrefix :: LoggerEntry -> LoggerEntry
 debugPrefix = toStderr . logPrefix "[debug] "

hbs2-sync/src/HBS2/Sync/State.hs

@@ -22,6 +22,8 @@ import HBS2.Peer.RPC.Client.Unix (UNIX)
 import HBS2.Peer.RPC.Client
 import HBS2.Peer.RPC.Client.RefChan as Client
 
+import HBS2.KeyMan.Keys.Direct
+
 import HBS2.CLI.Run.MetaData (createTreeWithMetadata)
 
 import DBPipe.SQLite
@@ -180,6 +182,7 @@ getStateFromDir0 :: ( MonadUnliftIO m
                    , HasStorage m
                    , HasRunDir m
                    , HasCache m
+                   , HasKeyManClient m
                    )
                 => Bool
                 -> m [(FilePath, Entry)]
@@ -200,6 +203,7 @@ getStateFromDir :: ( MonadUnliftIO m
                    , HasStorage m
                    , HasRunDir m
                    , HasCache m
+                   , HasKeyManClient m
                    )
                 => Bool           -- ^ use remote state as seed
                 -> FilePath       -- ^ dir
@@ -243,6 +247,7 @@ getStateFromRefChan :: forall m . ( MonadUnliftIO  m
                                   , HasStorage m
                                   , HasRunDir m
                                   , HasCache m
+                                  , HasKeyManClient m
                                   )
                     => MyRefChan
                     -> m [(FilePath, Entry)]
@@ -259,6 +264,12 @@ getStateFromRefChan rchan = do
 
   db <- newDBPipeEnv dbPipeOptsDef (statePath </> "state.db")
 
+  here <- doesDirectoryExist statePath
+
+  unless here $ mkdir statePath
+
+  keEnv <- getKeyManClientEnv
+
   flip runContT pure do
 
     void $ ContT $ bracket (async (runPipe db)) cancel
@@ -276,19 +287,15 @@ getStateFromRefChan rchan = do
 
     let members = view refChanHeadReaders rch & HS.toList
 
-    krl <- liftIO $ runKeymanClient $ loadKeyRingEntries members
+    krl <- liftIO $ withKeymanClientRO keEnv $ loadKeyRingEntries members
                 <&> L.sortOn (Down . fst)
                 <&> fmap snd
 
     let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ]
 
-    let findKey gk = do
+    -- FIXME: asap-insert-findMatchedGroupKey
-          r <- S.toList_ do
+    let findKey gk = lift $ lift $ withKeymanClientRO keEnv do
-                forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do
+          findMatchedGroupKeySecret sto gk
-                  (KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs
-                  let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk
-                  for_ s $ lift . S.yield
-          pure $ headMay r
 
     -- let check hx = pure True
     hseen <- withDB db (select_ [qc|select txhash from seen|])
@@ -592,8 +599,9 @@ mergeState seed orig = do
         else
           new
 
-getTreeContents :: ( MonadUnliftIO m
+getTreeContents :: forall m . ( MonadUnliftIO m
-                   , MonadError OperationError m
+                              , MonadIO m
+                              , MonadError OperationError m
                    )
                 => AnyStorage
                 -> HashRef
@@ -617,10 +625,10 @@ getTreeContents sto href = do
                   >>= orThrowError (GroupKeyNotFound 11)
                   <&> HM.keys . Symm.recipients
 
-      kre <- runKeymanClient do
+      let findStuff g = do
-                loadKeyRingEntries rcpts <&> fmap snd
+            runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g
 
-      readFromMerkle sto (ToDecryptBS kre (coerce href))
+      readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff))
 
     _ -> throwError UnsupportedFormat
 
@@ -633,6 +641,7 @@ runDirectory :: ( IsContext c
                 , HasRunDir m
                 , HasTombs m
                 , HasCache m
+                , HasKeyManClient m
                 , Exception (BadFormException c)
                 ) =>  RunM c m ()
 runDirectory = do

hbs2/Main.hs

@@ -268,7 +268,8 @@ runCat opts ss = do
                          lift $ runKeymanClient do
                            loadKeyRingEntries rcpts <&> fmap snd
 
-          elbs <- runExceptT $ readFromMerkle ss (ToDecryptBS keyring mhash)
+          let sto = AnyStorage ss
+          elbs <- runExceptT $ readFromMerkle ss (ToDecryptBS mhash (liftIO . runKeymanClientRO . findMatchedGroupKeySecret sto))
           case elbs of
             Right lbs -> LBS.putStr lbs
             Left e    -> die (show e)

hbs2/hbs2.cabal

@@ -64,7 +64,7 @@ executable hbs2
     other-modules:
       Paths_hbs2
     -- other-extensions:
-    build-depends:    base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-keyman
+    build-depends:    base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-keyman-direct-lib
                     , aeson
                     , async
                     , base58-bytestring