wip

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

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

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
+

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
+      _ -> throwIO (BadFormException @C nil)
-        pure $ mkForm "dict" es
+
-      _ -> do
+    entry $ bindMatch "kw" $ \syn -> do
-        throwIO (BadFormException @C nil)
+      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)
+      [ListVal es] -> pure $ mkList  (tail es)
-      _ -> throwIO (BadFormException @C nil)
+      _ -> 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)
 
 
 

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]