From c176c653933fdd0d65bf28443a1c19251337450d Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Mon, 1 Mar 2021 08:25:08 +0100 Subject: [PATCH] Improve diagnostics of generating output --- Foundation.hs | 2 +- Handler/ShowChallenge.hs | 10 +++++----- config/routes | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Foundation.hs b/Foundation.hs index 34ec1db..703781c 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -225,7 +225,7 @@ instance Yesod App where isAuthorized (CompareFormR _ _) _ = regularAuthorization - isAuthorized (TestProgressR _) _ = isTrustedAuthorized + isAuthorized (TestProgressR _ _) _ = isTrustedAuthorized isAuthorized SwaggerR _ = return Authorized diff --git a/Handler/ShowChallenge.hs b/Handler/ShowChallenge.hs index a5612de..8dd686e 100644 --- a/Handler/ShowChallenge.hs +++ b/Handler/ShowChallenge.hs @@ -1333,13 +1333,13 @@ challengeLayout withHeader challenge widget = do setTitle "Challenge" $(widgetFile "challenge") -getTestProgressR :: Int -> Handler TypedContent -getTestProgressR m = runViewProgress $ doTestProgress m +getTestProgressR :: Int -> Int -> Handler TypedContent +getTestProgressR m d = runViewProgress $ doTestProgress m d -doTestProgress :: Int -> Channel -> Handler () -doTestProgress m chan = do +doTestProgress :: Int -> Int -> Channel -> Handler () +doTestProgress m d chan = do forM [1..m] $ (\i -> do msg chan $ (Data.Text.pack $ ("GO\n" ++ show i)) - liftIO $ threadDelay 1000000 + liftIO $ threadDelay (d * 1000000) return ()) return () diff --git a/config/routes b/config/routes index 85d0100..e760592 100644 --- a/config/routes +++ b/config/routes @@ -10,7 +10,7 @@ /view-progress/#Int ViewProgressR GET /open-view-progress/#Int OpenViewProgressR GET /view-progress-with-web-sockets/#Int ViewProgressWithWebSocketsR GET -/test-progress/#Int TestProgressR GET +/test-progress/#Int/#Int TestProgressR GET /list-challenges ListChallengesR GET /api/list-challenges ListChallengesJsonR GET