pub/sub implemented

Application.hs

@@ -29,12 +29,15 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
 import Yesod.Fay                            (getFaySite)
 
+import qualified Data.IntMap as IntMap
+
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
 import Handler.Common
 import Handler.Fay
 import Handler.Home
 import Handler.CreateChallenge
+import Handler.Shared
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -56,6 +59,9 @@ makeFoundation appSettings = do
         (appStaticDir appSettings)
     let appFayCommandHandler = onCommand
 
+    jobs <- newTVarIO IntMap.empty
+    nextJob <- newTVarIO 1
+
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
     -- logging function. To get out of this loop, we initially create a

Foundation.hs

@@ -21,6 +21,8 @@ data App = App
     , appHttpManager       :: Manager
     , appLogger            :: Logger
     , appFayCommandHandler :: CommandHandler App
+    , jobs                 :: TVar (IntMap (TChan (Maybe Text)))
+    , nextJob              :: TVar Int
     }
 
 instance HasHttpManager App where

Handler/CreateChallenge.hs

@@ -4,6 +4,8 @@ import Import
 import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3,
                               withSmallInput)
 
+import Handler.Shared
+
 getCreateChallengeR :: Handler Html
 getCreateChallengeR = do
     (formWidget, formEnctype) <- generateFormPost sampleForm
@@ -14,7 +16,7 @@ getCreateChallengeR = do
         setTitle "Welcome To Yesod!"
         $(widgetFile "create-challenge")
 
-postCreateChallengeR :: Handler Html
+postCreateChallengeR :: Handler TypedContent
 postCreateChallengeR = do
     ((result, formWidget), formEnctype) <- runFormPost sampleForm
     let handlerName = "postCreateChallengeR" :: Text
@@ -22,10 +24,7 @@ postCreateChallengeR = do
             FormSuccess res -> Just res
             _ -> Nothing
 
-    defaultLayout $ do
+    runViewProgress doSomething
-        aDomId <- newIdent
-        setTitle "Welcome To Yesod!"
-        $(widgetFile "creating-challenge")
 
 sampleForm :: Form (Text, Text, Text, Text, Text)
 sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,)

Handler/Shared.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE RecordWildCards   #-}
+
+module Handler.Shared where
+
+import Import
+
+import           Control.Concurrent     (forkIO, threadDelay)
+import           Control.Concurrent.STM
+import           Data.IntMap            (IntMap)
+import qualified Data.IntMap            as IntMap
+
+atom = Control.Concurrent.STM.atomically
+
+type Channel = TChan (Maybe Text)
+
+runViewProgress :: (Channel -> IO ()) -> Handler TypedContent
+runViewProgress action = do
+  App {..} <- getYesod
+  (jobId, chan) <- liftIO $ atom $ do
+    jobId <- readTVar nextJob
+    writeTVar nextJob $! jobId + 1
+    chan <- newBroadcastTChan
+    m <- readTVar jobs
+    writeTVar jobs $ IntMap.insert jobId chan m
+    return (jobId, chan)
+  liftIO $ forkIO $ do
+    action chan
+    atom $ do
+      writeTChan chan $ Just "All done\n"
+      writeTChan chan Nothing
+      m <- readTVar jobs
+      writeTVar jobs $ IntMap.delete jobId m
+  redirect $ ViewProgressR jobId
+
+msg :: Channel -> Text -> IO ()
+msg chan m = atom $ writeTChan chan $ Just m
+
+doSomething :: Channel -> IO ()
+doSomething chan = do
+  threadDelay 1000000
+  msg chan "Did something\n"
+  threadDelay 1000000
+  msg chan "Did something else\n"
+  threadDelay 1000000
+
+
+getViewProgressR :: Int -> Handler TypedContent
+getViewProgressR 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 -> notFound
+        Just chan -> respondSource typePlain $ do
+            let loop = do
+                    mtext <- liftIO $ atom $ readTChan chan
+                    case mtext of
+                        Nothing -> return ()
+                        Just text -> do
+                            sendChunkText text
+                            sendFlush
+                            loop
+            loop

config/routes

@@ -8,3 +8,4 @@
 / HomeR GET POST
 
 /create-challenge CreateChallengeR GET POST
+/view-progress/#Int ViewProgressR GET

gonito.cabal

@@ -26,6 +26,7 @@ library
                      Handler.CreateChallenge
                      Handler.Fay
                      Handler.Home
+                     Handler.Shared
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -88,6 +89,7 @@ library
                  , containers
                  , vector
                  , time
+                 , stm
 
 executable         gonito
     if flag(library-only)