pub/sub implemented

This commit is contained in:
Filip Gralinski 2015-08-29 18:24:01 +02:00
parent f00df0797f
commit d1b56dba55
6 changed files with 81 additions and 5 deletions

View File

@ -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

View File

@ -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

View File

@ -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
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "creating-challenge")
runViewProgress doSomething
sampleForm :: Form (Text, Text, Text, Text, Text)
sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,)

66
Handler/Shared.hs Normal file
View File

@ -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

View File

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

View File

@ -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)