hbs2-peer timeout fix

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

@@ -110,8 +110,7 @@ peerEntries = do
     $ returns "dict" "dictionary of peer attributes"
     $ examples [qc|
 (hbs2:peer:poke)
-
-(dict
+(
  (peer-key: "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3")
  (udp: "0.0.0.0:7354")
  (tcp: "tcp://0.0.0.0:3001")
@@ -125,7 +124,6 @@ peerEntries = do
         callRpcWaitMay @RpcPoke (TimeoutSec 1) api ()
           <&> fromMaybe ""
           <&> parseTop
-          <&> either (const nil) (mkForm "dict" . fmap fixContext)
-
+          <&> either (const nil) (mkList . fmap fixContext)
 
 

hbs2-peer/app/BlockDownloadNew.hs

@@ -231,13 +231,13 @@ instance MonadUnliftIO m => IsBurstMachine BurstMachine m where
 
     _rates <- newTVarIO (mempty :: Map Double Double)
 
-    pause @'Seconds (min 1 $ realToFrac _buTimeout)
+    pause @'Seconds (max 1 $ realToFrac _buTimeout)
 
     flip runContT pure do
 
       void $ ContT $ withAsync do
         forever do
-          pause @'Seconds (min 2 $ realToFrac _buTimeout * 10)
+          pause @'Seconds (max 1 $ realToFrac _buTimeout * 10)
 
           atomically do
             e <- headDef bu0 . Map.elems <$> readTVar _rates
@@ -253,7 +253,7 @@ instance MonadUnliftIO m => IsBurstMachine BurstMachine m where
 
       void $ ContT $ withAsync do
         forever do
-          pause @'Seconds (realToFrac _buTimeout * 2.0)
+          pause @'Seconds (max 1 $ realToFrac _buTimeout * 2.0)
           ddt <- readTVarIO _dEdT
 
           when (ddt <= 0) do
@@ -293,7 +293,7 @@ instance MonadUnliftIO m => IsBurstMachine BurstMachine m where
 
           pure e2
 
-        pause @'Seconds (min 1 dt)
+        pause @'Seconds (max 1 dt)
         next eNew
 
 instance MonadIO m => IsBurstMachine ConstBurstMachine m where

miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs

@@ -38,7 +38,7 @@ callProc name params syn = do
                 & byteStringInput
 
   -- let what = proc name params & setStderr closed & setStdin input
-  let what = proc name params & setStderr closed & setStdin input
+  let what = proc name params & setStdin input
   (code, i, o) <- readProcess what
 
   unless (code == ExitSuccess) do
@@ -62,7 +62,7 @@ callProcRaw name params  = do
   --               & byteStringInput
 
   -- let what = proc name params & setStderr closed & setStdin input
-  let what = proc name params & setStderr closed & setStdin closed
+  let what = proc name params & setStdin closed
   (code, i, o) <- readProcess what
 
   unless (code == ExitSuccess) do

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

@@ -54,6 +54,7 @@ import Data.Text.Encoding (decodeUtf8With,encodeUtf8)
 import Data.Text.Encoding.Error (ignore)
 import Data.Time.Clock.POSIX
 import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.UUID.V4 qualified as UUID
 
 import HTMLEntities.Text as Html
 import GHC.Generics hiding (C)
@@ -64,7 +65,10 @@ import Streaming.Prelude qualified as S
 import System.Environment
 import System.Directory qualified as Dir
 import System.FilePath.Posix as P
+import System.IO.Temp qualified as Temp
+import System.Exit qualified as Exit
 import Text.InterpolatedString.Perl6 (qc)
+import Lens.Micro.Platform
 import UnliftIO
 import Control.Monad.Trans.Cont
 
@@ -1061,6 +1065,12 @@ internalEntries = do
       _ -> do
           throwIO (BadFormException @C nil)
 
+    entry $ bindMatch "for" $ \case
+      [ ListVal es, what ] -> do
+        mkList <$> mapM (apply_ what . List.singleton) es
+
+      e -> throwIO (BadFormException @c (mkList e))
+
     entry $ bindMatch "quot" $ \case
       [ syn ] -> pure $ mkList [syn]
       _ -> do
@@ -1713,6 +1723,18 @@ internalEntries = do
 
       _ -> throwIO $ BadFormException @c nil
 
+    entry $ bindMatch "die" $ nil_ $ \case
+      e -> liftIO $ Exit.die (show $ foldMap asSym e)
+
+    entry $ bindMatch "cp" $ nil_ $ \case
+      (StringLikeList p) -> liftIO do
+        case List.uncons (reverse p) of
+          Nothing -> pure ()
+          Just (dest, rest) -> do
+            forM_ (reverse rest) $ \f -> Dir.copyFileWithMetadata f dest
+
+      e ->  throwIO $ BadFormException @c (mkList e)
+
     entry $ bindMatch "rm" $ nil_ $ \case
       (StringLikeList p) -> forM_ p rm
       [ ListVal (StringLikeList p) ] -> forM_ p rm
@@ -1726,6 +1748,31 @@ internalEntries = do
       [ StringLike p ] -> touch p
       _ -> throwIO $ BadFormException @c nil
 
+    entry $ bindMatch "sys:temp:dir:get" $ const do
+      mkStr @c <$> sysTempDir
+
+    entry $ bindMatch "sys:temp:file" $ \case
+      [] -> mkSym @c <$> liftIO (Temp.emptySystemTempFile "bf6")
+      [ StringLike d ] -> mkSym @c <$> liftIO (Temp.emptyTempFile d "bf6")
+      [ StringLike d, StringLike p ] -> mkSym @c <$> liftIO (Temp.emptyTempFile d p)
+      e -> throwIO $ BadFormException @c (mkList e)
+
+    entry $ bindMatch "sys:temp:dir" $ \case
+      [ ] -> do
+        s <- sysTempDir
+        mkSym @c <$> liftIO (Temp.createTempDirectory s "bf6")
+
+      [ StringLike d ] -> do
+        mkSym @c <$> liftIO (Temp.createTempDirectory d "bf6")
+
+      [ StringLike d, StringLike p ] -> do
+        mkSym @c <$> liftIO (Temp.createTempDirectory d p)
+
+      e -> throwIO $ BadFormException @c (mkList e)
+
+    entry $ bindMatch "uuid" $ const do
+      mkSym @c . show <$> liftIO UUID.nextRandom
+
     entry $ bindMatch "path:exists?" $ \case
       [ StringLike p ] -> lift do
         liftIO (Dir.doesPathExist p) <&> mkBool

miscellaneous/suckless-conf/lib/Data/Config/Suckless/System.hs

@@ -4,6 +4,7 @@ module Data.Config.Suckless.System where
 import Data.Function
 import System.FilePath
 import System.Directory qualified as D
+import System.IO.Temp qualified as Temp
 import Data.ByteString.Lazy qualified as LBS
 import UnliftIO
 import Control.Exception qualified as E
@@ -117,4 +118,10 @@ dirEntries dir what  = do
       r <- a
       when r b
 
+sysTempDir :: MonadIO m => m FilePath
+sysTempDir = do
+  tmp1 <- liftIO D.getTemporaryDirectory
+  tmp2 <- liftIO $ Temp.getCanonicalTemporaryDirectory
+  pure $ if null tmp1 then tmp2 else tmp1
+
 

miscellaneous/suckless-conf/suckless-conf.cabal

@@ -101,8 +101,10 @@ library
                     , transformers
                     , toml-parser
                     , typed-process
+                    , temporary
                     , unliftio
                     , unordered-containers
+                    , uuid
                     , vector
                     , yaml