Initial yesod-websockets

Pinging @gregwebs and @meteficha. Greg: I know you were talking about
Sockets.IO support, and Felipe: I thought you might be curious about
this relative to yesod-eventsource. Comments welcome :)

yesod-websockets/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2014 Michael Snoyman, http://www.yesodweb.com/
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

yesod-websockets/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

yesod-websockets/Yesod/WebSockets.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Yesod.WebSockets
+    ( WebsocketsT
+    , webSockets
+    , receiveData
+    , sendTextData
+    , sendBinaryData
+    ) where
+
+import           Control.Monad                  (when)
+import           Control.Monad.IO.Class         (MonadIO (liftIO))
+import           Control.Monad.Trans.Control    (control)
+import           Control.Monad.Trans.Reader     (ReaderT (ReaderT, runReaderT))
+import qualified Network.Wai.Handler.WebSockets as WaiWS
+import qualified Network.WebSockets             as WS
+import qualified Yesod.Core                     as Y
+
+-- | A transformer for a WebSockets handler.
+--
+-- Since 0.1.0
+type WebsocketsT = ReaderT WS.Connection
+
+-- | Attempt to run a WebSockets handler. This function first checks if the
+-- client initiated a WebSockets connection and, if so, runs the provided
+-- application, short-circuiting the rest of your handler. If the client did
+-- not request a WebSockets connection, the rest of your handler will be called
+-- instead.
+--
+-- Since 0.1.0
+webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebsocketsT m () -> m ()
+webSockets inner = do
+    req <- Y.waiRequest
+    when (WaiWS.isWebSocketsReq req) $
+        Y.sendRawResponse $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
+            WS.defaultConnectionOptions
+            (WaiWS.getRequestHead req)
+            (\pconn -> do
+                conn <- WS.acceptRequest pconn
+                runInIO $ runReaderT inner conn)
+            src
+            sink
+
+-- | Receive a piece of data from the client.
+--
+-- Since 0.1.0
+receiveData :: (MonadIO m, WS.WebSocketsData a) => WebsocketsT m a
+receiveData = ReaderT $ liftIO . WS.receiveData
+
+-- | Send a textual messsage to the client.
+--
+-- Since 0.1.0
+sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebsocketsT m ()
+sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x
+
+-- | Send a binary messsage to the client.
+--
+-- Since 0.1.0
+sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebsocketsT m ()
+sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x

yesod-websockets/sample.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
+import Yesod.Core
+import Yesod.WebSockets
+import qualified Data.Text.Lazy as TL
+import Control.Monad (forever)
+
+data App = App
+
+instance Yesod App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+getHomeR :: Handler Html
+getHomeR = do
+    webSockets $ forever $ do
+        msg <- receiveData
+        sendTextData $ TL.toUpper msg
+    defaultLayout $
+        toWidget
+            [julius|
+                var conn = new WebSocket("ws://localhost:3000/");
+                conn.onopen = function() {
+                    document.write("<p>open!</p>");
+                    document.write("<button id=button>Send another message</button>")
+                    document.getElementById("button").addEventListener("click", function(){
+                        var msg = prompt("Enter a message for the server");
+                        conn.send(msg);
+                    });
+                    conn.send("hello world");
+                };
+                conn.onmessage = function(e) {
+                    document.write("<p>" + e.data + "</p>");
+                };
+            |]
+
+main :: IO ()
+main = warp 3000 App

yesod-websockets/yesod-websockets.cabal

@@ -0,0 +1,28 @@
+-- Initial yesod-websockets.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                yesod-websockets
+version:             0.1.0.0
+synopsis:            WebSockets support for Yesod
+description:         WebSockets support for Yesod
+homepage:            https://github.com/yesodweb/yesod
+license:             MIT
+license-file:        LICENSE
+author:              Michael Snoyman
+maintainer:          michael@snoyman.com
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     Yesod.WebSockets
+  build-depends:       base              >= 4.5 && < 5
+                     , wai-websockets    >= 2.1
+                     , websockets        >= 0.8
+                     , transformers      >= 0.2
+                     , yesod-core        >= 1.2.7
+                     , monad-control     >= 0.3
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod