wip

hbs2-cli/app/Main.hs

@@ -5,6 +5,8 @@ module Main where
 import HBS2.Prelude.Plated
 import HBS2.OrDie
 
+import HBS2.Data.Types.Refs
+import HBS2.Merkle
 import HBS2.Misc.PrettyStuff as All
 import HBS2.System.Logger.Simple.ANSI as All
 
@@ -30,8 +32,6 @@ import HBS2.KeyMan.Keys.Direct
 import HBS2.KeyMan.State
 import HBS2.KeyMan.App.Types
 
-import HBS2.Misc.PrettyStuff
-
 import Data.Coerce
 import Data.Config.Suckless
 import Data.HashMap.Strict (HashMap)
@@ -40,16 +40,20 @@ import Data.Kind
 import Data.List (isPrefixOf)
 import Data.List qualified as List
 import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as TE
 import Data.Text.IO qualified as TIO
+import Data.Either
 import Data.Maybe
 import Codec.Serialise
 import Control.Monad.Reader
 import Control.Monad.Writer
 import Control.Monad.Identity
+import Control.Monad.Trans.Maybe
 import UnliftIO
 import System.Environment
 import System.IO (hPrint)
@@ -65,6 +69,14 @@ pattern StringLike e <- (stringLike -> Just e)
 pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
 pattern StringLikeList e <- (stringLikeList -> e)
 
+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
+
 stringLike :: Syntax c -> Maybe String
 stringLike = \case
   LitStrVal s -> Just $ Text.unpack s
@@ -99,6 +111,10 @@ instance Exception NotLambda
 
 data BadFormException c = BadFormException (Syntax c)
 
+newtype TypeCheckError c = TypeCheckError (Syntax c)
+
+instance Exception (TypeCheckError C)
+
 newtype BadValueException = BadValueException String
                             deriving stock Show
                             deriving newtype (Generic,Typeable)
@@ -108,6 +124,9 @@ instance Exception NameNotBoundException
 instance IsContext c => Show (BadFormException c) where
   show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
 
+instance IsContext c => Show (TypeCheckError c) where
+  show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
+
 instance Exception (BadFormException C)
 
 instance Exception BadValueException
@@ -137,28 +156,33 @@ splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
 
     emit = S.yield . reverse
 
-
+apply :: forall c m . ( IsContext c
-run :: forall c m . ( IsContext c
                       , MonadUnliftIO m
                       , Exception (BadFormException c)
-                    ) => Dict c m -> [Syntax c] -> m (Syntax c)
+                      )
-run d sy = do
+      => Id
-  tvd <- newTVarIO d
+      -> [Syntax c]
-  lastDef nil <$> runReaderT (fromRunM (mapM runExpr sy)) tvd
+      -> RunM c m (Syntax c)
-  where
+apply name args' = do
-    runExpr :: Syntax c -> RunM c m (Syntax c)
-    runExpr syn = handle (handleForm syn) $ case syn of
-
-      ListVal [ w, SymbolVal ".", b] -> do
-        pure  $ mkList  [w, b]
-
-      ListVal (SymbolVal name : args') -> do
   what <- ask >>=  readTVarIO <&> HM.lookup name . fromDict
   case bindAction <$> what of
     Just (BindLambda e) -> mapM runExpr args' >>= e
     Just (BindValue v)  -> throwIO (NotLambda name)
     Nothing -> throwIO (NameNotBound name)
 
+
+runExpr :: forall c m . ( IsContext c
+                        , MonadUnliftIO m
+                        , Exception (BadFormException c)
+                        ) => Syntax c -> RunM c m (Syntax c)
+runExpr syn = handle (handleForm syn) $ case syn of
+
+  ListVal [ w, SymbolVal ".", b] -> do
+    pure  $ mkList  [w, b]
+
+  ListVal (SymbolVal name : args') -> do
+    apply name args'
+
   SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
     pure (mkSym @c (Text.drop 1 s))
 
@@ -169,13 +193,23 @@ run d sy = do
 
     case what of
       BindValue e  -> pure e
-          BindLambda e -> pure $ mkForm "lambda" [mkSym "..."]
+      BindLambda e -> pure $ mkForm "lambda" [mkSym name, mkSym "..."]
 
   e -> pure e
 
-    handleForm syn (BadFormException _  :: BadFormException c) = do
+  where
+    handleForm syn = \case
+      (BadFormException _  :: BadFormException c) -> do
         throwIO (BadFormException syn)
 
+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 runExpr sy)) tvd
+
 bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
 bindMatch n fn = Dict (HM.singleton n (Bind (BindLambda fn) n ""))
 
@@ -195,7 +229,7 @@ bind name expr = do
 
 setupLogger :: MonadIO m => m ()
 setupLogger = do
-  setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
+  -- setLogging @DEBUG  $ toStderr . logPrefix "[debug] "
   setLogging @ERROR  $ toStderr . logPrefix "[error] "
   setLogging @WARN   $ toStderr . logPrefix "[warn] "
   setLogging @NOTICE $ toStdout . logPrefix ""
@@ -278,6 +312,53 @@ mkRefLogUpdateFrom mbs  reflog = do
   pure $ mkForm "cbor:base58" [ mkStr s ]
 
 
+metaFromSyntax :: [Syntax c] -> HashMap Text Text
+metaFromSyntax syn =
+  HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ]
+  where
+    t x = Text.pack (show $ pretty x)
+
+createTreeWithMetadata :: (MonadUnliftIO m)
+                       => HashMap Text Text
+                       -> LBS.ByteString
+                       -> m HashRef
+createTreeWithMetadata meta lbs = do
+    debug   "create fucking metadata"
+    -- TODO: set-hbs2-peer
+    so <- detectRPC `orDie` "hbs2-peer not found"
+
+    let mt = vcat [ pretty k <> ":" <+> pretty v | (k,v) <- HM.toList meta ]
+               & show & Text.pack
+
+    withRPC2 @StorageAPI  @UNIX so $ \caller -> do
+      let sto = AnyStorage (StorageClient caller)
+
+      t0 <- writeAsMerkle sto lbs
+              >>= getBlock sto
+              >>= orThrowUser "can't read merkle tree just written"
+              <&> deserialiseOrFail @(MTree [HashRef])
+              >>= orThrowUser "merkle tree corrupted/invalid"
+
+      -- FIXME: support-encryption
+      let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0
+
+      putBlock sto (serialise mann)
+        >>= orThrowUser "can't write tree"
+        <&> HashRef
+
+
+helpList :: MonadUnliftIO m => Maybe String -> RunM c m ()
+helpList p = do
+
+  let match = maybe (const True) (Text.isPrefixOf . Text.pack) p
+
+  d <- ask >>= readTVarIO <&> fromDict
+  let ks = [k | Id k <- List.sort (HM.keys d)
+           , match k
+           ]
+
+  display_ $ vcat (fmap pretty ks)
+
 main :: IO ()
 main = do
 
@@ -288,29 +369,60 @@ main = do
 
   let dict = execWriter do
 
-        tell $ bindMatch "help" $ nil_ \case
+        tell $ bindMatch "help" $ nil_ $ \syn -> do
-           [] -> do
-            d <- ask >>= readTVarIO <&> fromDict
-            let ks = List.sort (HM.keys d)
-            display_ $ vcat (fmap pretty ks)
 
-           _ -> pure ()
+            display_ $ "hbs2-cli tool" <> line
 
-        tell $ bindMatch "concat" $ \case
+            case syn of
-          StringLikeList xs@(_:_) -> do
+              (StringLike p : _) -> do
+                helpList (Just p)
+
+              [ListVal (SymbolVal "lambda" : SymbolVal what : _ )] -> do
+                liftIO $ hPutDoc stdout $
+                  "function" <+> ul (pretty what)
+                  <> line
+
+              _ -> helpList Nothing
+
+
+        tell $ bindMatch "concat" $ \syn -> do
+
+          case syn of
+            [ListVal (StringLikeList xs)] -> do
+              pure $ mkStr @C ( mconcat xs )
+
+            StringLikeList xs -> do
               pure $ mkStr ( mconcat xs )
-          _ -> throwIO (BadFormException @C nil)
 
+            _ -> throwIO (BadFormException @C nil)
 
         tell $ bindMatch "list" $ \case
           es -> do
-            pure $ mkList es
+            pure $ mkList @C es
 
         tell $ bindMatch "dict" $ \case
           es -> do
             pure $ mkForm "dict" es
 
-          -- _ -> pure nil
+
+        tell $ bindMatch "map" $ \syn -> do
+          case syn of
+            [ListVal (SymbolVal "lambda" : SymbolVal fn : _), ListVal rs] -> do
+              mapM (apply fn . List.singleton) rs
+                <&> mkList
+
+            w -> do
+              throwIO (BadFormException @C nil)
+
+        tell $ bindMatch "head" $ \case
+          [ ListVal es ] -> pure (head es)
+          _ -> throwIO (TypeCheckError @C nil)
+
+        tell $ bindMatch "tail" $ \case
+          [] -> pure nil
+          [ListVal []] -> pure nil
+          [ListVal es] -> pure $ mkList @C (tail es)
+          _ -> throwIO (BadFormException @C nil)
 
         tell $ bindMatch "lookup" $ \case
           [s, ListVal (SymbolVal "dict" : es) ] -> do
@@ -326,7 +438,7 @@ main = do
           [ sy ] -> display sy
           ss     -> display (mkList ss)
 
-        tell $ bindMatch "internal:show-cli" $ nil_ \case
+        tell $ bindMatch "debug:show-cli" $ nil_ \case
           _ -> display cli
 
         tell $ bindMatch "hbs2:peer:detect" $ nil_ \case
@@ -349,6 +461,34 @@ main = do
 
             readTVarIO r
 
+        tell $ bindMatch "hbs2:keyring:list-encryption" $ \syn -> do
+          lbs <- case syn of
+
+                [ ListVal [ SymbolVal "file", StringLike fn ] ] -> do
+                  liftIO $ BS.readFile fn
+
+                [ LitStrVal s ] -> do
+                  pure (BS8.pack (Text.unpack s))
+
+                _ -> throwIO (BadFormException @C nil)
+
+          cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs))
+                    `orDie` "bad keyring file"
+
+          let e = [ mkStr @C (show (pretty (AsBase58 p))) | KeyringEntry p _ _ <- view peerKeyring cred ]
+
+          pure $ mkList @C e
+
+        tell $ bindMatch "hbs2:keyring:new" $ \syn -> do
+            n <- case syn of
+                  [LitIntVal k] -> pure k
+                  []            -> pure 1
+                  _ -> throwIO (BadFormException @C nil)
+
+            cred0 <- newCredentials @'HBS2Basic
+            cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
+            pure $ mkStr @C $ show $ pretty $ AsCredFile $ AsBase58 cred
+
         tell $ bindMatch "hbs2:keyman:list" $ nil_ \case
           _ -> do
             void $ runKeymanClient  $ KeyManClient $ do
@@ -369,19 +509,79 @@ main = do
 
           _ -> throwIO (BadFormException @C nil)
 
-        tell $ bindMatch "hbs2:tree:metadata:create" $ \case
+        tell $ bindMatch "str:read-file" $ \case
-          (LitStrVal s : _) -> do
+          [StringLike fn] -> liftIO (readFile fn) <&> mkStr @C
-            debug   "create fucking metadata"
 
-            -- TODO: set-hbs2-peer
+          _ -> throwIO (BadFormException @C nil)
+
+        tell $ bindMatch "str:save" $ nil_ \case
+          [StringLike fn, StringLike what] ->
+            liftIO (writeFile fn what)
+
+          _ -> throwIO (BadFormException @C nil)
+
+
+        tell $ bindMatch "hbs2:tree:metadata:get" $ \case
+          [ SymbolVal how, StringLike hash ] -> do
+
+            -- FIXME: put-to-the-state
             so <- detectRPC `orDie` "hbs2-peer not found"
-            withRPC2 @StorageAPI  @UNIX so $ \caller -> do
-              let sto = AnyStorage (StorageClient caller)
-              let lbs = fromString (Text.unpack s) :: LBS.ByteString
-              root <- liftIO $ writeAsMerkle sto lbs
-              display root
 
-            pure nil
+            r <- withRPC2 @StorageAPI  @UNIX so $ \caller -> do
+              let sto = AnyStorage (StorageClient caller)
+
+              runMaybeT do
+
+                headBlock <- getBlock sto (fromString hash)
+                               >>= toMPlus
+                               <&> deserialiseOrFail @(MTreeAnn [HashRef])
+                               >>= toMPlus
+
+                case headBlock of
+                  MTreeAnn { _mtaMeta = ShortMetadata s } -> do
+                    pure $ mkStr @C s
+
+                  MTreeAnn { _mtaMeta = AnnHashRef h } -> do
+                    getBlock sto h
+                       >>= toMPlus
+                       <&> LBS.toStrict
+                       <&> TE.decodeUtf8
+                       <&> mkStr @C
+
+                  _ -> mzero
+
+
+            case (how, r) of
+              ("parsed", Just (LitStrVal r0)) -> do
+
+
+                let xs = parseTop r0
+                           & fromRight mempty
+
+                pure $ mkForm @C "dict" xs
+
+              _ -> pure $ fromMaybe nil r
+
+          _ -> throwIO (BadFormException @C nil)
+
+        tell $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
+
+          case syn of
+
+            (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)
 
@@ -398,6 +598,9 @@ main = do
                 >>= either (error.show) pure . parseTop
       void $ run dict what
 
+    [] -> do
+      void $ run dict [mkForm  "help" []]
+
     _ -> do
       void $ run dict cli
 

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

@@ -19,13 +19,13 @@ import Data.Kind
 import Control.Monad.Reader
 import UnliftIO
 
-withRPC2 :: forall (api :: [Type]) e m . ( e ~ UNIX
+withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
                              , HasProtocol e (ServiceProto api e)
                              , MonadUnliftIO m
                              )
          => FilePath
-         -> ( ServiceCaller api e -> m () )
+         -> ( ServiceCaller api e -> m r )
-         -> m ()
+         -> m r
 
 withRPC2 soname action = do
 
@@ -39,10 +39,13 @@ withRPC2 soname action = do
   caller <- makeServiceCaller @api @UNIX (fromString soname)
   p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1
 
-  action caller
+  r <- action caller
 
   pause @'Seconds 0.05
   cancel p2
 
   void $ waitAnyCatchCancel [m1, p2]
 
+  pure r
+
+

hbs2/Main.hs

@@ -56,6 +56,7 @@ import Data.Either
 import Data.List qualified as List
 import Data.Maybe
 import Data.Text qualified as Text
+import Data.Text.IO qualified as TIO
 import Lens.Micro.Platform
 import Options.Applicative
 import Streaming.Prelude qualified as S
@@ -578,6 +579,9 @@ main = join . customExecParser (prefs showHelpOnError) $
         void $ runMaybeT do
           bs <- getBlock sto h >>= toMPlus
           case tryDetect h bs of
+            MerkleAnn (MTreeAnn { _mtaMeta = ShortMetadata s } ) -> do
+              liftIO $ TIO.putStr s
+
             MerkleAnn (MTreeAnn { _mtaMeta = AnnHashRef mh } ) -> do
 
               bs <- getBlock sto mh