diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs index 06d162ef..9b98e5ac 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs +++ b/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) diff --git a/hbs2-peer/app/BlockDownloadNew.hs b/hbs2-peer/app/BlockDownloadNew.hs index 4ab726ef..b62eff5e 100644 --- a/hbs2-peer/app/BlockDownloadNew.hs +++ b/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 diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs index 80517059..b4b81c55 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Almost/RPC.hs +++ b/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 diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index 4649b2c9..54e5d5b3 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/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 diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/System.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/System.hs index 8b35063c..3aeed406 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/System.hs +++ b/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 + diff --git a/miscellaneous/suckless-conf/suckless-conf.cabal b/miscellaneous/suckless-conf/suckless-conf.cabal index 5415eae9..9bf6c115 100644 --- a/miscellaneous/suckless-conf/suckless-conf.cabal +++ b/miscellaneous/suckless-conf/suckless-conf.cabal @@ -101,8 +101,10 @@ library , transformers , toml-parser , typed-process + , temporary , unliftio , unordered-containers + , uuid , vector , yaml