diff --git a/Foundation.hs b/Foundation.hs index 93b4a0e..34ec1db 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Shared.hs b/Handler/Shared.hs index 03fe643..41f2e92 100644 --- a/Handler/Shared.hs +++ b/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| +