diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs index ec2a5bc2..3d481fa9 100644 --- a/hbs2-cli/app/Main.hs +++ b/hbs2-cli/app/Main.hs @@ -6,6 +6,7 @@ import HBS2.CLI.Prelude import HBS2.CLI.Run import HBS2.CLI.Run.KeyMan import HBS2.CLI.Run.Keyring +import HBS2.CLI.Run.GroupKey import HBS2.CLI.Run.MetaData import HBS2.OrDie @@ -128,6 +129,8 @@ main = do internalEntries keymanEntries + keyringEntries + groupKeyEntries metaDataEntries entry $ bindMatch "help" $ nil_ $ \syn -> do diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal index a91d85a6..aed816db 100644 --- a/hbs2-cli/hbs2-cli.cabal +++ b/hbs2-cli/hbs2-cli.cabal @@ -103,6 +103,7 @@ library HBS2.CLI.Bind HBS2.CLI.Run HBS2.CLI.Run.Internal + HBS2.CLI.Run.GroupKey HBS2.CLI.Run.KeyMan HBS2.CLI.Run.Keyring HBS2.CLI.Run.MetaData diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs new file mode 100644 index 00000000..77678d9c --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -0,0 +1,38 @@ +module HBS2.CLI.Run.GroupKey where + + +import HBS2.CLI.Prelude hiding (mapMaybe) +import Data.List qualified as L +import Data.Maybe +import HBS2.CLI.Run.Internal +import HBS2.Net.Auth.GroupKeySymm as Symm + +import HBS2.Net.Auth.Credentials + +{- HLINT ignore "Functor law" -} + +groupKeyFromKeyList :: MonadUnliftIO m => [String] -> m (GroupKey 'Symm HBS2Basic) +groupKeyFromKeyList ks = do + let members = mapMaybe (fromStringMay @(PubKey 'Encrypt 'HBS2Basic)) ks + Symm.generateGroupKey @'HBS2Basic Nothing members + +groupKeyEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () +groupKeyEntries = do + entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do + case syn of + [ListVal (StringLikeList keys)] -> do + s <- groupKeyFromKeyList keys + <&> AsGroupKeyFile + <&> show . pretty + + pure $ mkStr s + + StringLikeList keys -> do + s <- groupKeyFromKeyList keys + <&> AsGroupKeyFile + <&> show . pretty + + pure $ mkStr s + + _ -> throwIO $ BadFormException @C nil + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index df7ffb83..3a2b1c94 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -95,6 +95,14 @@ 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 @@ -273,13 +281,13 @@ bind name expr = do writeTVar tv w pure nil -internalEntries :: MonadUnliftIO m => MakeDictM C m () +internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () internalEntries = do entry $ bindMatch "concat" $ \syn -> do case syn of [ListVal (StringLikeList xs)] -> do - pure $ mkStr @C ( mconcat xs ) + pure $ mkStr ( mconcat xs ) StringLikeList xs -> do pure $ mkStr ( mconcat xs ) @@ -288,26 +296,29 @@ internalEntries = do entry $ bindMatch "list" $ \case es -> do - pure $ mkList @C es + pure $ mkList es entry $ bindMatch "dict" $ \case + (pairList -> es@(_:_)) -> do + pure $ mkForm "dict" es [a, b] -> do pure $ mkForm "dict" [ mkList [a, b] ] - PairList es -> do - pure $ mkForm "dict" es - _ -> do - throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "kw" $ \syn -> do + let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] + pure $ mkForm "dict" wat entry $ bindMatch "lambda" $ \case [a, b] -> do - pure $ mkForm @C "lamba" [ mkSym "_", mkSym "..." ] + pure $ mkForm "lamba" [ mkSym "_", mkSym "..." ] _ -> error "SHIT" entry $ bindMatch "map" $ \syn -> do case syn of [ListVal (SymbolVal "lambda" : SymbolVal fn : _), ListVal rs] -> do - mapM (apply fn . List.singleton) rs + mapM (apply @c fn . List.singleton) rs <&> mkList w -> do @@ -320,8 +331,8 @@ internalEntries = do entry $ bindMatch "tail" $ \case [] -> pure nil [ListVal []] -> pure nil - [ListVal es] -> pure $ mkList @C (tail es) - _ -> throwIO (BadFormException @C nil) + [ListVal es] -> pure $ mkList (tail es) + _ -> throwIO (BadFormException @c nil) entry $ bindMatch "lookup" $ \case [s, ListVal (SymbolVal "dict" : es) ] -> do @@ -331,7 +342,7 @@ internalEntries = do [StringLike s, ListVal [] ] -> do pure nil - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @c nil) entry $ bindMatch "display" $ nil_ \case [ sy ] -> display sy @@ -339,27 +350,27 @@ internalEntries = do entry $ bindMatch "newline" $ nil_ $ \case [] -> liftIO (putStrLn "") - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @c nil) entry $ bindMatch "print" $ nil_ $ \case [ sy ] -> display sy >> liftIO (putStrLn "") ss -> mapM_ display ss >> liftIO (putStrLn "") entry $ bindMatch "str:read-stdin" $ \case - [] -> liftIO getContents <&> mkStr @C + [] -> liftIO getContents <&> mkStr @c - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @c nil) entry $ bindMatch "str:read-file" $ \case - [StringLike fn] -> liftIO (readFile fn) <&> mkStr @C + [StringLike fn] -> liftIO (readFile fn) <&> mkStr - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @c nil) entry $ bindMatch "str:save" $ nil_ \case [StringLike fn, StringLike what] -> liftIO (writeFile fn what) - _ -> throwIO (BadFormException @C nil) + _ -> throwIO (BadFormException @c nil) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs index d5946449..72977d67 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -112,25 +112,16 @@ metaDataEntries = do case syn of args -> do + for_ args $ \case + SymbolVal "stdin" -> notice "STDIN" + SymbolVal "auto" -> notice "AUTO" + ListVal (SymbolVal "dict" : [ListVal [SymbolVal "encrypted", key]]) -> notice ("ENCRYPTED" <+> pretty key) + ListVal (SymbolVal "dict" : [ListVal [SymbolVal x, y]]) -> notice ("METADATA" <+> pretty x <+> pretty y) + StringLike rest -> notice $ "FILE" <+> pretty rest + _ -> pure () + error $ show $ pretty args - (LitStrVal s : meta) -> do - let lbs = fromString (Text.unpack s) :: LBS.ByteString - h <- createTreeWithMetadata (metaFromSyntax meta) lbs - pure $ mkStr (show $ pretty h) - - (ListVal [SymbolVal "from-file", StringLike fn ] : meta) -> do - lbs <- liftIO $ LBS.readFile fn - h <- createTreeWithMetadata (metaFromSyntax meta) lbs - pure $ mkStr (show $ pretty h) - - (ListVal [SymbolVal "from-stdin"] : meta) -> do - lbs <- liftIO $ LBS.getContents - h <- createTreeWithMetadata (metaFromSyntax meta) lbs - pure $ mkStr (show $ pretty h) - - _ -> throwIO (BadFormException @c nil) - entry $ bindMatch "cbor:base58" $ \case [ LitStrVal x ] -> do pure $ mkForm "cbor:base58" [mkStr x]