wip

bf6/hbs23

@@ -4,6 +4,18 @@
 
 ; # (println (grep (sym "-g") *args))
 
+(define (--help)
+  (begin
+    (println [concat
+
+"hbs2-cli wrapper"           chr:lf
+"supported commands list:"   chr:lf
+"  "
+
+             ])
+  )
+)
+
 (match *args
 
   ( (list? [sym? store] ...)
@@ -30,10 +42,102 @@
     )
   )
 
+  ( (list? [sym? has] hash)
+    (begin
+      (local s (hbs2:peer:storage:block:size hash))
+      (cond
+        ( (eq? :no-block s) (die))
+        ( _ (print s))
+      ))
+  )
 
   ( (list? [sym? cat] ...)
-    (begin
+
-      (println "FUCKING CAT" space ...))
+      (begin
+
+        (local optdef `( [-H           0 HASHES]
+                         [--raw        0 RAW]
+                         [--metadata   0 META]
+                         [--m          0 META]
+                       ))
+
+        (local parsed (cli:split optdef ...))
+        (local opts (nth 0 parsed))
+        (local hash (head (nth 1 parsed)))
+
+        (if (@? HASHES opts)
+          (begin
+            (iterate [fn x . println x] [tail [hbs2:tree:scan:deep hash]])
+            (quit)
+        ))
+
+
+        (if (@? RAW    opts)
+          (begin
+            (bytes:put (hbs2:peer:storage:block:get hash))
+            (quit)
+          )
+        )
+
+        (if (@? META opts)
+          (begin
+            (display (hbs2:tree:metadata:get hash))
+            (quit)
+          )
+        )
+
+        (hbs2:tree:read:stdout hash)
+
+      )
+  )
+
+  ( (list? [sym? del] ...)
+
+      (begin
+
+        (local optdef `( [-y       0 YES]
+                         [-r       0 REC]
+                       ))
+
+        (local parsed (cli:split optdef ...))
+        (local opts (nth 0 parsed))
+        (local hash (head (nth 1 parsed)))
+
+        (local hashes
+          (cond
+            ( (@? REC opts)  (hbs2:tree:scan:deep hash) )
+            ( _              (hbs2:tree:scan hash)  )
+          )
+        )
+
+        (define (ask ha)
+            (if (@? YES opts) true
+            (begin
+              (print "deleting " ha " ")
+              (print "sure [y/n]? ") (flush:stdout)
+              (local answ (str:getchar:stdin))
+              (newline)
+              (eq? (upper answ) "Y")
+            ))
+        )
+
+        (cond
+          ( (and (@? YES opts) (@? REC opts)) (hbs2:tree:delete hash))
+          ( _
+            (for (reverse hashes)
+              [fn ha .
+                  [begin
+                    (local y (or (@? YES opts) (ask ha)))
+                    (if y
+                      (begin
+                        (hbs2:peer:storage:block:del ha)
+                     ))
+                  ]])
+          )
+        )
+
+
+      )
 
   )
 
@@ -50,8 +154,23 @@
       )
   )
 
+  ( (list? [sym? reflog] [sym? get] hash)
+    (display (hbs2:reflog:get hash))
+  )
+
+  ( (list? [sym? reflog] [sym? fetch] hash)
+    (hbs2:reflog:fetch hash)
+  )
+
+  ( (list? [sym? metadata] [sym? dump] hash)
+    (display (hbs2:tree:metadata:get hash))
+  )
+
+  ( (list? [sym? deps] hash)
+    (iterate println (hbs2:tree:scan:deep hash) )
+  )
+
   ( _  (--help) )
 )
 
-; vim: filetype=lisp
+; vim: filetype=scheme syntax=scheme
-

hbs2-cli/lib/HBS2/CLI/Run/Peer.hs

@@ -66,7 +66,16 @@ peerEntries = do
         lbs <- getBlock sto (fromHashRef ha)
                 `orDie` show ("missed-block" <+> pretty ha)
 
-        pure $ mkForm "blob" [mkStr (LBS8.unpack lbs)]
+        mkOpaque lbs
+
+    _ -> throwIO $ BadFormException @c nil
+
+  entry $ bindMatch "hbs2:peer:storage:block:del" $ \case
+    [HashLike ha] -> do
+      flip runContT pure do
+        sto <- getStorage
+        delBlock sto (fromHashRef ha)
+        pure nil
 
     _ -> throwIO $ BadFormException @c nil
 

hbs2-cli/lib/HBS2/CLI/Run/Tree.hs

@@ -157,6 +157,20 @@ It's just an easy way to create a such thing, you may browse it by hbs2 cat -H
 
       _ -> throwIO (BadFormException @c nil)
 
+  brief "delete tree" $
+    entry $ bindMatch "hbs2:tree:delete" $ nil_ \case
+      [HashLike href] -> do
+        sto <- getStorage
+
+        what <- S.toList_ $ deepScan ScanDeep (const none) (coerce href) (getBlock sto) $ \ha -> do
+          S.yield ha
+
+        for_ (reverse what) $ \ha -> do
+          display_ $ "deleting" <+> pretty ha
+          delBlock sto ha
+
+      _ -> throwIO (BadFormException @c nil)
+
 
   brief "shallow scan of a block/tree" $
     entry $ bindMatch "hbs2:tree:scan:deep" $ \case

miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs

@@ -1168,6 +1168,12 @@ internalEntries = do
       _ -> do
         throwIO (BadFormException @C nil)
 
+    entry $ bindMatch "for" $ nil_ $ \case
+      [ ListVal es, what ] -> do
+        mapM_ (apply_ what . List.singleton) es
+
+      _ -> do
+        throwIO (BadFormException @C nil)
 
     entry $ bindMatch "replicate" $ \case
       [LitIntVal n, e] -> pure $ mkList (replicate (fromIntegral n) e)
@@ -1615,6 +1621,19 @@ internalEntries = do
       [ sy ] -> display sy >> liftIO (putStrLn "")
       ss     -> mapM_ display ss >> liftIO (putStrLn "")
 
+    entry $ bindMatch "flush:stdout" $ nil_ $ \case
+      [] -> liftIO do
+        hFlush stdout
+
+      _ -> throwIO (BadFormException @c nil)
+
+    entry $ bindMatch "str:getchar:stdin" $ \case
+      [] -> liftIO do
+        hSetBuffering stdin NoBuffering
+        mkStr . List.singleton <$> getChar
+
+      _ -> throwIO (BadFormException @c nil)
+
     entry $ bindMatch "str:stdin" $ \case
       [] -> liftIO getContents <&> mkStr @c
 
@@ -2099,8 +2118,13 @@ internalEntries = do
 
       _ -> throwIO $ BadFormException @c nil
 
+    entry $ bindMatch "quit" $ nil_ $ \case
+      [] -> liftIO $ Exit.exitSuccess
+      _ -> throwIO $ BadFormException @c nil
+
     entry $ bindMatch "die" $ nil_ $ \case
-      e -> liftIO $ Exit.die (show $ foldMap asSym e)
+      [] -> liftIO $ Exit.exitFailure
+      e  -> liftIO $ Exit.die (show $ foldMap asSym e)
 
     entry $ bindMatch "cp" $ nil_ $ \case
       (StringLikeList p) -> liftIO do