mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
48bc05972b
commit
06f93a9710
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Reference in New Issue