diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index 3d481fa9..9dae9eaf 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -7,6 +7,7 @@ import HBS2.CLI.Run import HBS2.CLI.Run.KeyMan import HBS2.CLI.Run.Keyring import HBS2.CLI.Run.GroupKey +import HBS2.CLI.Run.Sigil import HBS2.CLI.Run.MetaData import HBS2.OrDie @@ -131,6 +132,7 @@ main = do keymanEntries keyringEntries groupKeyEntries + sigilEntries metaDataEntries entry $ bindMatch "help" $ nil_ $ \syn -> do diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index aed816db..d27e6769 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -107,6 +107,7 @@ library HBS2.CLI.Run.KeyMan HBS2.CLI.Run.Keyring HBS2.CLI.Run.MetaData + HBS2.CLI.Run.Sigil HBS2.CLI.Run.Help build-depends: base diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs index 77678d9c..8d4f3411 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -2,6 +2,8 @@ module HBS2.CLI.Run.GroupKey where import HBS2.CLI.Prelude hiding (mapMaybe) +import HBS2.System.Logger.Simple.ANSI as All +import HBS2.Base58 import Data.List qualified as L import Data.Maybe import HBS2.CLI.Run.Internal @@ -9,6 +11,11 @@ import HBS2.Net.Auth.GroupKeySymm as Symm import HBS2.Net.Auth.Credentials +import Data.Text qualified as Text +import Data.ByteString.Lazy.Char8 as LBS8 +import Data.HashMap.Strict qualified as HM +import Lens.Micro.Platform + {- HLINT ignore "Functor law" -} groupKeyFromKeyList :: MonadUnliftIO m => [String] -> m (GroupKey 'Symm HBS2Basic) @@ -36,3 +43,20 @@ groupKeyEntries = do _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do + case syn of + [LitStrVal s] -> do + + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" + + let rcpt = recipients gk & HM.keys & fmap (mkStr . show . pretty . AsBase58) + + pure $ mkList @c rcpt + + _ -> throwIO $ BadFormException @C nil + + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs b/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs new file mode 100644 index 00000000..c1e8aeb7 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs @@ -0,0 +1,68 @@ +module HBS2.CLI.Run.Sigil where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Base58 +import HBS2.Data.Types.SignedBox +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Credentials.Sigil + +import Data.List qualified as L +import Data.ByteString.Char8 qualified as BS8 +import Data.Text qualified as Text +import Lens.Micro.Platform + +sigilEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +sigilEntries = do + + entry $ bindMatch "hbs2:sigil:parse" $ \case + [StringLike s] -> do + + let bs = BS8.pack s + sigil <- pure (parseSerialisableFromBase58 @(Sigil 'HBS2Basic) bs) + `orDie` "parse sigil failed" + + (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil)) + `orDie` "signature check failed" + + pure (parseTop $ show $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd]))) + `orDie` "bad sigil" + <&> head + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:sigil:create-from-keyring" $ \syn -> do + + args <- case syn of + [ StringLike s ] -> pure (fmap snd . headMay, s) + [ StringLike p, StringLike s ] -> pure ( findKey p, s) + [ LitIntVal n, StringLike s ] -> pure ( L.lookup n, s) + + _ -> throwIO $ BadFormException @C nil + + let lbs = BS8.pack (snd args) + + cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs)) + `orDie` "bad keyring data" + + let es = zip [0..] + [ p | KeyringEntry p _ _ + <- view peerKeyring cred + ] + + enc <- pure (fst args es) + `orDie` "key not found" + + sigil <- pure (makeSigilFromCredentials @'HBS2Basic cred enc Nothing Nothing) + `orDie` "can't create a sigil" + + pure $ mkStr (show $ pretty $ AsBase58 sigil) + + where + findKey s xs = headMay [ k + | e@(_,k) <- xs + , L.isPrefixOf s (show $ pretty (AsBase58 k)) + ] + +