[happstack-longpoll: proof of concept for XHR long polling
jeremy@n-heptane.com**20120525193813
 Ignore-this: e6aff1aa736e06b8adff5b070c6af119
] adddir ./happstack-longpoll
addfile ./happstack-longpoll/LongPoll.hs
hunk ./happstack-longpoll/LongPoll.hs 1
+{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes #-}
+module LongPoll where
+
+import Control.Applicative ((<$>))
+import Control.Concurrent (forkIO, ThreadId)
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TVar
+import Control.Monad.Trans (liftIO)
+import Data.Aeson (ToJSON, encode, toJSON)
+import Data.ByteString.Char8 (unpack)
+import Data.Map (Map)
+import Data.String (fromString)
+import Data.Text (Text)
+import qualified Data.Map as Map
+import Happstack.Server
+import Language.Javascript.JMacro
+import System.Entropy (getEntropy)
+import qualified Data.ByteString.Base64.URL as Base64
+
+newtype PollId = PollId { unPollId :: String }
+    deriving (Eq, Ord, Show, ToJExpr)
+
+newtype PollMap a = PollMap { unPollMap :: TVar (Map PollId (ThreadId, TChan a)) }
+
+initPolling :: IO (PollMap a)
+initPolling =
+    atomically $ PollMap <$> newTVar Map.empty
+
+forkPoll :: PollMap a
+         -> (TChan a -> IO ())
+         -> IO PollId
+forkPoll (PollMap pm) proc =
+    do pid <- PollId . unpack . Base64.encode <$> getEntropy 8
+       tc  <- atomically $ newTChan
+       tid <- forkIO $ proc tc
+       atomically $ modifyTVar pm (\m -> Map.insert pid (tid, tc) m)
+       return pid
+
+pollUpdate :: (Happstack m, ToJSON a) =>
+              PollMap a
+           -> m Response
+pollUpdate pm =
+    do pid <- PollId <$> look "pollId"
+       pollUpdate' pm pid
+
+
+pollUpdate' :: (Happstack m, ToJSON a) =>
+              PollMap a
+           -> PollId
+           -> m Response
+pollUpdate' (PollMap pm) pid =
+    do m <- liftIO $ atomically $ readTVar pm
+       case Map.lookup pid m of
+         Nothing -> notFound $ toResponse ("Invalid PollId: " ++ show pid)
+         (Just (_, tc)) ->
+             do a <- liftIO $ atomically $ readTChan tc
+                ok $ toResponse (toResponseBS (fromString "application/json") (encode a))
+
+clientLoop :: String -- ^ url to POST requests to
+           -> JExpr   -- ^ expression to apply to JSON value.
+           -> PollId -- ^ PollId
+           -> JStat
+clientLoop url f pid =
+    [jmacro|
+             function longPoll () {
+                            jQuery.post(`(url)`, { 'pollId' : `(pid)` }, function(d) { `(f)`(d); longPoll(); }, 'json');
+                          }
+             $(document).ready(longPoll);
+           |]
+
addfile ./happstack-longpoll/Test.hs
hunk ./happstack-longpoll/Test.hs 1
+{-# LANGUAGE FlexibleInstances, TemplateHaskell, QuasiQuotes #-}
+{-# OPTIONS_GHC -F -pgmFtrhsx #-}
+module Main where
hunk ./happstack-longpoll/Test.hs 5
+import Control.Applicative
+import Control.Concurrent
+import Control.Monad
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TChan
+import Control.Monad.Trans
+import Data.Aeson.TH
+import Data.Unique
+import Happstack.Server
+import Happstack.Server.HSP.HTML
+import HSP
+import HSP.ServerPartT
+import HSX.JMacro (IntegerSupply(..), nextInteger')
+import Language.Javascript.JMacro
+import LongPoll
+
+instance IntegerSupply (ServerPartT IO) where
+    nextInteger = fmap (fromIntegral . (`mod` 1024) . hashUnique) (liftIO newUnique)
+
+data Msg = Msg { message :: String }
+
+$(deriveJSON id ''Msg)
+
+main =
+    do pm <- initPolling
+       simpleHTTP nullConf (route pm)
+
+
+route :: PollMap Msg -> ServerPart Response
+route pm =
+    do decodeBody (defaultBodyPolicy "/tmp/" 0 1000 1000)
+       msum [ dir "jquery.js" $ serveFile (asContentType "text/javascript") "/usr/share/javascript/jquery/jquery.min.js"
+            , nullDir >> counter pm
+            , dir "update" $ pollUpdate pm
+            ]
+
+
+counter :: PollMap Msg
+        -> ServerPart Response
+counter pm =
+    do pid <- liftIO $ forkPoll pm counterProc
+       toResponse <$>
+         defaultTemplate "counter" <%><script type="text/javascript" src="jquery.js"></script><% clientLoop "update" callback pid %></%>
+           <%>
+             <h1>Messages</h1>
+             <ol id="msgs"></ol>
+           </%>
+    where
+      callback =
+          [jmacroE| function(d) { $("#msgs").append($(document.createElement('li')).append(d.message)); } |]
+
+counterProc :: TChan Msg
+            -> IO ()
+counterProc tchan =
+    mapM_ (\s -> do threadDelay 2000000 ; atomically $ writeTChan tchan (Msg s)) ["one","two","three","four"]
addfile ./happstack-longpoll/happstack-longpoll.cabal