From d1b56dba55c348605c60b8163bf4a5ef9db4ebbd Mon Sep 17 00:00:00 2001 From: Filip Gralinski Date: Sat, 29 Aug 2015 18:24:01 +0200 Subject: [PATCH] pub/sub implemented --- Application.hs | 6 ++++ Foundation.hs | 2 ++ Handler/CreateChallenge.hs | 9 +++--- Handler/Shared.hs | 66 ++++++++++++++++++++++++++++++++++++++ config/routes | 1 + gonito.cabal | 2 ++ 6 files changed, 81 insertions(+), 5 deletions(-) create mode 100644 Handler/Shared.hs diff --git a/Application.hs b/Application.hs index 38f4af7..b112579 100644 --- a/Application.hs +++ b/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 diff --git a/Foundation.hs b/Foundation.hs index d436751..73df144 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/CreateChallenge.hs b/Handler/CreateChallenge.hs index 6690ae1..5cd1914 100644 --- a/Handler/CreateChallenge.hs +++ b/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 - aDomId <- newIdent - setTitle "Welcome To Yesod!" - $(widgetFile "creating-challenge") + runViewProgress doSomething sampleForm :: Form (Text, Text, Text, Text, Text) sampleForm = renderBootstrap3 BootstrapBasicForm $ (,,,,) diff --git a/Handler/Shared.hs b/Handler/Shared.hs new file mode 100644 index 0000000..8b5989d --- /dev/null +++ b/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 diff --git a/config/routes b/config/routes index 7f5616e..abaf2fc 100644 --- a/config/routes +++ b/config/routes @@ -8,3 +8,4 @@ / HomeR GET POST /create-challenge CreateChallengeR GET POST +/view-progress/#Int ViewProgressR GET diff --git a/gonito.cabal b/gonito.cabal index 4b0d1d3..e055d14 100644 --- a/gonito.cabal +++ b/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)