From 06df252ce401f7701f1d830d1867fedda1b36d05 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 21 Jun 2025 13:58:46 +0200
Subject: Multiply-timeout command

Changelog: Added `multiply_timeout` command
---
 src/Test.hs | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

(limited to 'src/Test.hs')

diff --git a/src/Test.hs b/src/Test.hs
index 6c44e94..3e98efa 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -2,13 +2,20 @@ module Test (
     Test(..),
     TestStep(..),
     TestBlock(..),
+
+    MultiplyTimeout(..),
 ) where
 
+import Control.Concurrent.MVar
+import Control.Monad.Except
+import Control.Monad.Reader
+
 import Data.Scientific
 import Data.Text (Text)
 import Data.Typeable
 
 import Network
+import Output
 import Process
 import Run.Monad
 import Script.Expr
@@ -52,3 +59,23 @@ data TestStep a where
 instance Typeable a => ExprType (TestBlock a) where
     textExprType _ = "test block"
     textExprValue _ = "<test block>"
+
+
+data MultiplyTimeout = MultiplyTimeout Scientific
+
+instance ObjectType TestRun MultiplyTimeout where
+    type ConstructorArgs MultiplyTimeout = Scientific
+
+    createObject oid timeout
+        | timeout > 0 = do
+            var <- asks (teTimeout . fst)
+            liftIO $ modifyMVar_ var $ return . (* timeout)
+            return $ Object oid $ MultiplyTimeout timeout
+
+        | otherwise = do
+            outLine OutputError Nothing "timeout must be positive"
+            throwError Failed
+
+    destroyObject Object { objImpl = MultiplyTimeout timeout } = do
+        var <- asks (teTimeout . fst)
+        liftIO $ modifyMVar_ var $ return . (/ timeout)
-- 
cgit v1.2.3