Add experimental handling of outputs via Web Sockets

This commit is contained in:
Filip Gralinski 2021-02-27 18:38:38 +01:00
parent 7fdeeda0a6
commit 0bc680c7ae
5 changed files with 105 additions and 0 deletions

View File

@ -225,8 +225,12 @@ instance Yesod App where
isAuthorized (CompareFormR _ _) _ = regularAuthorization isAuthorized (CompareFormR _ _) _ = regularAuthorization
isAuthorized (TestProgressR _) _ = isTrustedAuthorized
isAuthorized SwaggerR _ = return Authorized isAuthorized SwaggerR _ = return Authorized
isAuthorized (ViewProgressWithWebSocketsR _) _ = isTrustedAuthorized
-- Default to Authorized for now. -- Default to Authorized for now.
isAuthorized _ _ = isTrustedAuthorized isAuthorized _ _ = isTrustedAuthorized

View File

@ -7,6 +7,8 @@ import Import
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import Yesod.WebSockets
import Handler.Runner import Handler.Runner
import System.Exit import System.Exit
@ -99,6 +101,88 @@ runViewProgress = runViewProgress' ViewProgressR
runOpenViewProgress :: (Channel -> Handler ()) -> Handler TypedContent runOpenViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
runOpenViewProgress = runViewProgress' OpenViewProgressR runOpenViewProgress = runViewProgress' OpenViewProgressR
runViewProgressWithWebSockets :: (Channel -> Handler ()) -> Handler TypedContent
runViewProgressWithWebSockets = runViewProgress' ViewProgressWithWebSocketsR
consoleApp :: Int -> WebSocketsT Handler ()
consoleApp jobId = do
App {..} <- getYesod
mchan <- liftIO $ atom $ do
m <- readTVar jobs
case IntMap.lookup jobId m of
Nothing -> return Nothing
Just chan -> fmap Just $ dupTChan chan
case mchan of
Nothing -> do
sendTextData ("CANNOT FIND THE OUTPUT (ALREADY SHOWN??)" :: Text)
sendCloseE ("" :: Text)
return ()
Just chan -> do
let loop = do
mtext <- liftIO $ atom $ readTChan chan
case mtext of
Nothing -> sendCloseE ("" :: Text)
Just text -> do
sendTextData text
loop
loop
return ()
getViewProgressWithWebSocketsR :: Int -> Handler Html
getViewProgressWithWebSocketsR jobId = do
webSockets $ consoleApp jobId
defaultLayout $ do
[whamlet|
<div #outwindow>
<div #output>
<div #wait>
... PLEASE WAIT ...
|]
toWidget [lucius|
#outwindow {
border: 1px solid black;
margin-bottom: 1em;
color: white;
background-color: black;
padding: 10pt;
}
#wait {
animation: blink 1s linear infinite;
}
@keyframes blink {
0% {
opacity: 0;
}
50% {
opacity: .5;
}
100% {
opacity: 1;
}
}
|]
toWidget [julius|
var url = document.URL,
output = document.getElementById("output"),
wait = document.getElementById("wait"),
conn;
url = url.replace("http:", "ws:").replace("https:", "wss:");
conn = new WebSocket(url);
conn.onmessage = function(e) {
var p = document.createElement("p");
p.appendChild(document.createTextNode(e.data));
output.appendChild(p);
};
conn.onclose = function(e) {
wait.parentNode.removeChild(wait);
};
|]
runViewProgressAsynchronously :: (Channel -> Handler ()) -> Handler Value runViewProgressAsynchronously :: (Channel -> Handler ()) -> Handler Value
runViewProgressAsynchronously action = runViewProgressGeneralized getJobIdAsJson action runViewProgressAsynchronously action = runViewProgressGeneralized getJobIdAsJson action
-- where getJobIdAsJson jobId = return $ Number (scientific (toInteger jobId) 0) -- where getJobIdAsJson jobId = return $ Number (scientific (toInteger jobId) 0)

View File

@ -15,6 +15,8 @@ import qualified Data.HashMap.Strict as HMS
import qualified Yesod.Table as Table import qualified Yesod.Table as Table
import Control.Concurrent.Lifted (threadDelay)
import Handler.Extract import Handler.Extract
import Handler.Shared import Handler.Shared
import Handler.Runner import Handler.Runner
@ -1330,3 +1332,14 @@ challengeLayout withHeader challenge widget = do
defaultLayout $ do defaultLayout $ do
setTitle "Challenge" setTitle "Challenge"
$(widgetFile "challenge") $(widgetFile "challenge")
getTestProgressR :: Int -> Handler TypedContent
getTestProgressR m = runViewProgressWithWebSockets $ doTestProgress m
doTestProgress :: Int -> Channel -> Handler ()
doTestProgress m chan = do
forM [1..m] $ (\i -> do
msg chan $ (Data.Text.pack $ show i)
liftIO $ threadDelay 1000000
return ())
return ()

View File

@ -9,6 +9,8 @@
/create-challenge CreateChallengeR GET POST /create-challenge CreateChallengeR GET POST
/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
/test-progress/#Int TestProgressR GET
/list-challenges ListChallengesR GET /list-challenges ListChallengesR GET
/api/list-challenges ListChallengesJsonR GET /api/list-challenges ListChallengesJsonR GET

View File

@ -160,6 +160,7 @@ library
, swagger2 , swagger2
, lens , lens
, insert-ordered-containers , insert-ordered-containers
, yesod-websockets
executable gonito executable gonito
if flag(library-only) if flag(library-only)
@ -223,3 +224,4 @@ test-suite test
, wai , wai
, containers , containers
, unordered-containers , unordered-containers
, yesod-websockets