Add experimental handling of outputs via Web Sockets

Foundation.hs

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

Handler/Shared.hs

@@ -7,6 +7,8 @@ import Import
 
 import qualified Data.IntMap            as IntMap
 
+import Yesod.WebSockets
+
 import Handler.Runner
 import System.Exit
 
@@ -99,6 +101,88 @@ runViewProgress = runViewProgress' ViewProgressR
 runOpenViewProgress :: (Channel -> Handler ()) -> Handler TypedContent
 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 action = runViewProgressGeneralized getJobIdAsJson action
 --  where getJobIdAsJson jobId = return $ Number (scientific (toInteger jobId) 0)

Handler/ShowChallenge.hs

@@ -15,6 +15,8 @@ import qualified Data.HashMap.Strict as HMS
 
 import qualified Yesod.Table as Table
 
+import Control.Concurrent.Lifted (threadDelay)
+
 import Handler.Extract
 import Handler.Shared
 import Handler.Runner
@@ -1330,3 +1332,14 @@ challengeLayout withHeader challenge widget = do
   defaultLayout $ do
     setTitle "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 ()

config/routes

@@ -9,6 +9,8 @@
 /create-challenge CreateChallengeR GET POST
 /view-progress/#Int ViewProgressR GET
 /open-view-progress/#Int OpenViewProgressR GET
+/view-progress-with-web-sockets/#Int ViewProgressWithWebSocketsR GET
+/test-progress/#Int TestProgressR GET
 /list-challenges ListChallengesR GET
 
 /api/list-challenges ListChallengesJsonR GET

gonito.cabal

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