filipg/gonito
1
0
Fork 1
Code Issues 1 Pull Requests Releases Wiki Activity

Improve diagnostics of generating output

Browse Source
This commit is contained in:
Filip Gralinski 2021-03-01 08:25:08 +01:00
parent 04beeffbb4
commit c176c65393
3 changed files with 7 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Foundation.hs
View File

@ -225,7 +225,7 @@ instance Yesod App where
isAuthorized (CompareFormR _ _) _ = regularAuthorization isAuthorized (CompareFormR _ _) _ = regularAuthorization
isAuthorized (TestProgressR _) _ = isTrustedAuthorized isAuthorized (TestProgressR _ _) _ = isTrustedAuthorized
isAuthorized SwaggerR _ = return Authorized isAuthorized SwaggerR _ = return Authorized

10
Handler/ShowChallenge.hs
View File

@ -1333,13 +1333,13 @@ challengeLayout withHeader challenge widget = do
setTitle "Challenge" setTitle "Challenge"
$(widgetFile "challenge") $(widgetFile "challenge")
getTestProgressR :: Int -> Handler TypedContent getTestProgressR :: Int -> Int -> Handler TypedContent
getTestProgressR m = runViewProgress $ doTestProgress m getTestProgressR m d = runViewProgress $ doTestProgress m d
doTestProgress :: Int -> Channel -> Handler () doTestProgress :: Int -> Int -> Channel -> Handler ()
doTestProgress m chan = do doTestProgress m d chan = do
forM [1..m] $ (\i -> do forM [1..m] $ (\i -> do
msg chan $ (Data.Text.pack $ ("GO\n" ++ show i)) msg chan $ (Data.Text.pack $ ("GO\n" ++ show i))
liftIO $ threadDelay 1000000 liftIO $ threadDelay (d * 1000000)
return ()) return ())
return () return ()

2
config/routes
View File

@ -10,7 +10,7 @@
/view-progress/#Int ViewProgressR GET /view-progress/#Int ViewProgressR GET
/open-view-progress/#Int OpenViewProgressR GET /open-view-progress/#Int OpenViewProgressR GET
/view-progress-with-web-sockets/#Int ViewProgressWithWebSocketsR GET /view-progress-with-web-sockets/#Int ViewProgressWithWebSocketsR GET
/test-progress/#Int TestProgressR GET /test-progress/#Int/#Int TestProgressR GET
/list-challenges ListChallengesR GET /list-challenges ListChallengesR GET
/api/list-challenges ListChallengesJsonR GET /api/list-challenges ListChallengesJsonR GET