Skip to content
Browse files

websockets, xhr-streaming, xhr-polling works now.

  • Loading branch information...
1 parent 64295f0 commit f37db26874bb136248e4601eedb331fa7a24a5ba @yihuang committed Nov 26, 2011
Showing with 170 additions and 125 deletions.
  1. +19 −24 Apps.hs
  2. +30 −0 LICENSE
  3. +3 −3 Main.hs
  4. +2 −0 Setup.hs
  5. +66 −44 Sockjs.hs
  6. +17 −6 Types.hs
  7. +27 −40 sockjs.cabal
  8. +2 −2 static/client.html
  9. +3 −5 static/client.js
  10. +1 −1 static/sockjs.js
View
43 Apps.hs
@@ -3,23 +3,18 @@ module Apps where
import Data.Char
import Data.Monoid
-import Data.Text (Text)
-import qualified Data.Text as T
import Data.ByteString (ByteString)
-import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as S
import Data.Map (Map)
import qualified Data.Map as M
import Control.Exception
-import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Concurrent
import Network.WebSockets
-import qualified Blaze.ByteString.Builder as B
-
import Types
import Sockjs
@@ -29,57 +24,57 @@ echo req = do
sendSockjs SockjsOpen
forever $ do
msg <- receiveSockjs
- when (not $ null msg) $ sendSockjs $ SockjsData (msg::[ByteString])
+ when (not $ S.null msg) $ sendSockjsData msg
close :: TextProtocol p => Request -> WebSockets p ()
close req = do
acceptRequest req
sendSockjs SockjsOpen
sendSockjs $ SockjsClose 3000 "Go away!"
-type ServerState p = Map Text (Sink p)
+type ServerState p = Map ByteString (Sink p)
-clientExists :: Protocol p => Text -> ServerState p -> Bool
+clientExists :: Protocol p => ByteString -> ServerState p -> Bool
clientExists name = maybe False (const True) . M.lookup name
chat :: TextProtocol p => MVar (ServerState p) -> Request -> WebSockets p ()
chat state req = do
acceptRequest req
sendSockjs SockjsOpen
sink <- getSink
- msg <- receiveData
+ msg <- receiveSockjs
clients <- liftIO $ readMVar state
case msg of
- _ | not (prefix `T.isPrefixOf` msg) ->
- sendTextData ("Wrong Annoucement!"::Text)
+ _ | not (prefix `S.isPrefixOf` msg) ->
+ sendSockjsData "Wrong Annoucement!"
| any ($ name)
- [T.null, T.any isPunctuation, T.any isSpace] ->
- sendTextData $
+ [S.null, S.any isPunctuation, S.any isSpace] ->
+ sendSockjsData $
"Name cannot " `mappend`
"contain punctuation or whitespace, and " `mappend`
- ("cannot be empty"::Text)
+ "cannot be empty"
| clientExists name clients ->
- sendTextData ("User already exists"::Text)
+ sendSockjsData "User already exists"
| otherwise -> do
liftIO $ modifyMVar_ state $ \s -> do
let s' = M.insert name sink s
- sendSink sink $ textData $
+ sendSink sink $ sockjsData $
"Welcome! Users: " `mappend`
- T.intercalate ", " (M.keys s)
+ S.intercalate ", " (M.keys s)
broadcast (name `mappend` " joined") s'
return s'
talk state name
where
- prefix = "Hi! I'm "
- name = T.drop (T.length prefix) msg
+ prefix = "Hi! I am "
+ name = S.drop (S.length prefix) msg
-broadcast :: TextProtocol p => Text -> ServerState p -> IO ()
+broadcast :: TextProtocol p => ByteString -> ServerState p -> IO ()
broadcast message clients =
- mapM_ (flip sendSink (textData message)) $ M.elems clients
+ mapM_ (flip sendSink (sockjsData message)) $ M.elems clients
-talk :: TextProtocol p => MVar (ServerState p) -> Text -> WebSockets p ()
+talk :: TextProtocol p => MVar (ServerState p) -> ByteString -> WebSockets p ()
talk state user = flip catchWsError catchDisconnect $ do
- msg <- receiveData
+ msg <- receiveSockjs
liftIO $ readMVar state >>= broadcast
(user `mappend` ": " `mappend` msg)
talk state user
View
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2011, yihuang
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of yihuang nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
6 Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
import Debug.Trace
import System.IO.Unsafe (unsafePerformIO)
@@ -29,8 +29,8 @@ serverState = unsafePerformIO $ newMVar M.empty
staticApp :: Application
staticApp = Static.staticApp Static.defaultFileServerSettings
- -- { Static.ssFolder = Static.embeddedLookup $ Static.toEmbedded $(embedDir "static") }
- { Static.ssFolder = Static.fileSystemLookup "static" }
+ { Static.ssFolder = Static.embeddedLookup $ Static.toEmbedded $(embedDir "static") }
+ -- { Static.ssFolder = Static.fileSystemLookup "static" }
wsApps :: TextProtocol p => AppRoute p
wsApps = [ ( ["echo"], echo )
View
2 Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
110 Sockjs.hs
@@ -5,6 +5,8 @@ module Sockjs
, wsRoute
, httpRoute
, sendSockjs
+ , sendSockjsData
+ , sockjsData
, receiveSockjs
, deliverRsp
, deliverReq
@@ -32,7 +34,7 @@ import Data.Text (Text)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
-import Data.Enumerator hiding (map, foldl)
+import Data.Enumerator hiding (map, foldl, mapM)
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
@@ -41,10 +43,7 @@ import qualified Blaze.ByteString.Builder as B
import qualified Blaze.ByteString.Builder.Char8 as B
import Data.Attoparsec.Lazy (parse, eitherResult)
-import qualified Data.Attoparsec.Enumerator as AE
-import qualified Data.Attoparsec.Lazy as L
import Data.Aeson
-import Data.Aeson.Parser (value)
import Network.HTTP.Types
import Network.Wai
@@ -62,22 +61,23 @@ import Types
sendSockjs :: TextProtocol p => SockjsMessage -> WebSockets p ()
sendSockjs = sendTextData . B.toLazyByteString . renderSockjs
-decodeValue :: (FromJSON a) => L.ByteString -> Maybe a
-decodeValue s = case L.parse value s of
- L.Done _ v -> case fromJSON v of
- Success a -> Just a
- _ -> Nothing
- _ -> Nothing
+sendSockjsData :: TextProtocol p => ByteString -> WebSockets p ()
+sendSockjsData = sendSockjs . SockjsData . (:[])
-receiveSockjs :: (TextProtocol p, FromJSON a) => WebSockets p [a]
-receiveSockjs = do
+sockjsData :: (TextProtocol p, WebSocketsData a) => a -> Message p
+sockjsData = textData . B.toLazyByteString . renderSockjs . SockjsData . (:[]) . mconcat . L.toChunks . toLazyByteString
+
+receiveSockjs :: (TextProtocol p, FromJSON a, Monoid a) => WebSockets p a
+receiveSockjs = mconcat <$> receiveSockjs'
+
+receiveSockjs' :: (TextProtocol p, FromJSON a) => WebSockets p [a]
+receiveSockjs' = do
msg <- receiveData
- liftIO $ print ("msg:", msg)
if L.null msg
then return []
else maybe (throwWsError $ SockjsError "Broken JSON encoding.")
return
- (unSockjsRequest <$> decodeValue msg)
+ (unSockjsRequest <$> decode msg)
-- }}}
-- enumerator utils {{{
@@ -99,17 +99,10 @@ deliverReq ch = atomically
. encodeFrame EmulateProtocol Nothing
. Frame True BinaryFrame
-deliverRsp :: StreamChan ByteString -> IO (Either SockjsException L.ByteString)
-deliverRsp ch = do
- stream <- atomically $ readTChan ch
- case stream of
- EOF -> return $ Left SockjsReadEOF
- Chunks xs -> return $ decodeRsp $ L.fromChunks xs
-
-decodeRsp :: L.ByteString -> Either SockjsException L.ByteString
-decodeRsp s = either (Left . SockjsError . ("internal broken encoding:"++) . show)
- (Right . (`mappend` "\n") . framePayload)
- (eitherResult . parse (decodeFrame EmulateProtocol) $ s)
+parseFrame :: L.ByteString -> Either SockjsException L.ByteString
+parseFrame s = either (Left . SockjsError . ("internal broken encoding:"++) . show)
+ (Right . framePayload)
+ (eitherResult . parse (decodeFrame EmulateProtocol) $ s)
readAllTChan :: TChan a -> STM [a]
readAllTChan ch = loop []
@@ -121,21 +114,43 @@ readAllTChan ch = loop []
x <- readTChan ch
loop (x:acc)
+deliverRsp :: StreamChan ByteString -> IO (Either SockjsException L.ByteString)
+deliverRsp ch = do
+ stream <- atomically $ readTChan ch
+ case stream of
+ EOF -> return $ Left SockjsReadEOF
+ Chunks xs -> return $ (`mappend` "\n") <$> parseFrame (L.fromChunks xs)
+
deliverAllRsp :: StreamChan ByteString -> IO (Either SockjsException L.ByteString)
deliverAllRsp ch = do
msgs <- atomically $ readAllTChan ch
let lbs = map eitherLBS msgs
- results = map (>>= decodeRsp) lbs
+ results = map (>>= parseFrame) lbs
case partitionEithers results of
( (e:_), [] ) -> return $ Left e
- ( _, xs ) -> return $ maybe (Left $ SockjsError ("internal broken encoding.")) Right $ reEncode xs
+ ( _, xs ) -> return $ maybe (Left $ SockjsError ("internal broken encoding."))
+ (Right . (`mappend` "\n"))
+ (reEncode xs)
where
eitherLBS :: Stream ByteString -> Either SockjsException L.ByteString
eitherLBS EOF = Left SockjsReadEOF
eitherLBS (Chunks xs) = Right $ L.fromChunks xs
+ isData :: SockjsMessage -> Bool
+ isData (SockjsData _) = True
+ isData _ = False
+
+ concatData :: [SockjsMessage] -> SockjsMessage
+ concatData datas = SockjsData $ concat $ map extract datas
+ where extract :: SockjsMessage -> [ByteString]
+ extract (SockjsData xs) = xs
+ extract _ = error "[concatData] impossible."
+
reEncode :: [L.ByteString] -> Maybe L.ByteString
- reEncode msgs = mapM decodeSockjsMessage msgs
+ reEncode msgs = do
+ msgs' <- mapM decodeSockjsMessage msgs
+ let (datas, others) = partition isData msgs'
+ return $ B.toLazyByteString . mconcat . map renderSockjs $ concatData datas : others
msgStream :: StreamChan ByteString -> Enumerator Builder IO b
msgStream ch = checkContinue0 $ \loop f -> do
@@ -148,11 +163,21 @@ msgStream ch = checkContinue0 $ \loop f -> do
-- response utils {{{
-response :: L.ByteString -> Response
-response s = ResponseBuilder statusOK [("Content-Type", "text/plain")] (B.fromLazyByteString s)
+hsJavascript, hsCookie, hsCache :: Headers
+hsJavascript = [("Content-Type", "application/javascript; charset=UTF-8")]
+hsCookie = [("Set-Cookie", "JSESSIONID=dummy; path=/")]
+hsCache = [("Cache-Control", "public; max-age=31536000;")
+ ,("Expires", "31536000")]
+hsAC :: ByteString -> Headers
+hsAC origin = [("access-control-max-age", "31536000")
+ ,("access-control-allow-origin", origin)
+ ,("access-control-allow-credentials", "true")]
+
+jsRsp :: L.ByteString -> Response
+jsRsp = ResponseBuilder statusOK hsJavascript . B.fromLazyByteString
sockjsRsp :: SockjsMessage -> Response
-sockjsRsp msg = ResponseBuilder statusOK [("Content-Type", "application/javascript; charset=UTF-8")] $
+sockjsRsp msg = ResponseBuilder statusOK hsJavascript $
renderSockjs msg
notFoundRsp :: Response
@@ -169,14 +194,11 @@ serverErrorRsp msg = ResponseBuilder statusServerError [] (B.fromString msg)
optionsRsp :: Maybe ByteString -> Response
optionsRsp morigin = ResponseBuilder statusNoContent
- [ ("Cache-Control", "public; max-age=31536000;")
- , ("Expires", "31536000")
- , ("Allow", "OPTIONS, POST")
- , ("access-control-max-age", "31536000")
- , ("access-control-allow-origin", fromMaybe "*" morigin)
- , ("access-control-allow-credentials", "true")
- , ("Set-Cookie", "JSESSIONID=dummy; path=/")
- ] mempty
+ ( ("Allow", "OPTIONS, POST")
+ : hsCache
+ ++ hsCookie
+ ++ hsAC (fromMaybe "*" morigin)
+ ) mempty
-- }}}
@@ -223,14 +245,14 @@ sockjsRoute msm apps req = case (requestMethod req, msum (map match apps)) of
liftIO (ensureSession msm sid app req) >>=
either (\(_, outChan) ->
either (const $ sockjsRsp $ SockjsClose 3000 "Go away")
- (response)
+ (jsRsp)
<$> liftIO (deliverAllRsp outChan)
)
(\(_, outChan) -> liftIO $ do
- rsp <- atomically $ readTChan outChan
+ _ <- atomically $ readTChan outChan
-- TODO parse response
either (const $ sockjsRsp $ SockjsClose 3000 "Go away")
- (response)
+ (jsRsp)
<$> liftIO (deliverRsp outChan)
)
@@ -242,7 +264,7 @@ sockjsRoute msm apps req = case (requestMethod req, msum (map match apps)) of
when (L.null msg) $ error "payload expected."
liftIO $ deliverReq inChan msg
return $ noContentRsp
- `E.catchError` (\err -> return $ serverErrorRsp $ show err)
+ `E.catchError` (\err -> trace "exc send" $ return $ serverErrorRsp $ show err)
)
"xhr_streaming" ->
@@ -251,7 +273,7 @@ sockjsRoute msm apps req = case (requestMethod req, msum (map match apps)) of
either (const $ run_ $ liftIO (putStrLn "exists") >> f statusBadRequest [])
(\(_, outChan) -> do
-- read response
- rsp <- S.concat . toChunks <$> atomically (readTChan outChan)
+ _ <- S.concat . toChunks <$> atomically (readTChan outChan)
-- TODO parse response
let iter = f statusOK
[ ("Content-Type", "application/javascript; charset=UTF-8")
View
23 Types.hs
@@ -4,6 +4,7 @@ module Types
, renderSockjs
, SockjsException (..)
, SockjsRequest (..)
+ , decodeSockjsMessage
) where
import Prelude hiding ( (++) )
@@ -15,11 +16,13 @@ import qualified Blaze.ByteString.Builder.Char8 as B
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Aeson
-import Data.Aeson.Encode
-import qualified Data.Vector as V
+import Data.Aeson.Encode (fromValue)
+import Data.Aeson.Parser (value)
+import qualified Data.Attoparsec.Lazy as L
import Control.Exception
import Control.Applicative
+(++) :: Monoid a => a -> a -> a
(++) = mappend
data SockjsRequest a = SockjsRequest { unSockjsRequest :: [a] }
@@ -30,7 +33,7 @@ instance FromJSON a => FromJSON (SockjsRequest a) where
data SockjsMessage = SockjsOpen
| SockjsHeartbeat
- | forall a. ToJSON a => SockjsData [a]
+ | SockjsData [ByteString]
| SockjsClose Int ByteString
renderSockjs :: SockjsMessage -> Builder
@@ -46,12 +49,20 @@ renderSockjs msg = case msg of
++ B.fromByteString reason
++ B.fromByteString "\"]"
+decodeValue :: (FromJSON a) => L.ByteString -> Maybe a
+decodeValue s = case L.parse value s of
+ L.Done _ v -> case fromJSON v of
+ Success a -> Just a
+ _ -> Nothing
+ _ -> Nothing
+
decodeSockjsMessage :: L.ByteString -> Maybe SockjsMessage
decodeSockjsMessage s = case L.uncons s of
Just ('o', _) -> Just SockjsOpen
- Just ('a', s') -> SockjsData <$> decode s'
- Just ('c', s') -> SockjsClose <$> decode s' <*>
-
+ Just ('a', s') -> SockjsData <$> decodeValue s'
+ Just ('c', s') -> do (code, reason) <- decodeValue s'
+ return $ SockjsClose code reason
+ _ -> Nothing
data SockjsException = SockjsReadEOF
| SockjsInvalidJson
View
67 sockjs.cabal
@@ -1,55 +1,41 @@
--- Initial sockjs.cabal generated by cabal init. For further documentation,
--- see http://haskell.org/cabal/users-guide/
-
--- The name of the package.
name: sockjs
-
--- The package version. See the Haskell package versioning policy
--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
--- standards guiding when and how versions should be incremented.
version: 0.1.0.0
-
--- A short (one-line) description of the package.
synopsis: sockjs server side, using warp and websockets
-
--- A longer description of the package.
--- description:
-
--- URL for the project homepage or repository.
homepage: https://github.com/yihuang/wai-sockjs
-
--- The license under which the package is released.
license: BSD3
-
--- The file containing the license text.
license-file: LICENSE
-
--- The package author(s).
author: yihuang
-
--- An email address to which users can send suggestions, bug reports, and
--- patches.
maintainer: yi.codeplayer@gmail.com
-
--- A copyright notice.
--- copyright:
-
category: Web
-
build-type: Simple
-
--- Constraint on the version of Cabal needed to build this package.
cabal-version: >=1.8
-
-
library
- -- Modules exported by the library.
- exposed-modules: Sockjs, Main
-
- -- Modules included in this library but not exported.
- -- other-modules:
-
- -- Other library packages from which modules are imported.
+ exposed-modules: Sockjs, Types
+ other-modules: Apps
+ ghc-options: -Wall
+ build-depends: base >= 4.0 && < 5.0
+ , transformers
+ , bytestring
+ , text
+ , blaze-builder
+ , vector
+ , containers
+ , http-types
+ , wai
+ , warp
+ , websockets
+ , wai-websockets
+ , wai-app-static
+ , file-embed
+ , enumerator
+ , attoparsec
+ , attoparsec-enumerator
+ , aeson
+ , stm
+
+executable sockjs-example
+ ghc-options: -Wall -O3 -threaded
+ main-is: Main.hs
build-depends: base >= 4.0 && < 5.0
, transformers
, bytestring
@@ -68,4 +54,5 @@ library
, attoparsec
, attoparsec-enumerator
, aeson
+ , stm
View
4 static/client.html
@@ -1,6 +1,6 @@
<html>
<head>
- <title>Haskell WebSockets example</title>
+ <title>Haskell Sockjs example</title>
<script type="text/JavaScript"
src="http://code.jquery.com/jquery-1.6.3.min.js"></script>
<script type="text/JavaScript"
@@ -9,7 +9,7 @@
<link rel="stylesheet" type="text/css" href="screen.css"></script>
</head>
<body>
- <h1>Haskell WebSockets example</h1>
+ <h1>Haskell Sockjs example</h1>
<div id="main">
<div id="warnings">
</div>
View
8 static/client.js
@@ -1,11 +1,8 @@
-function createWebSocket(path) {
+function createSockjs(path) {
var host = window.location.host;
if(host == '') host = 'localhost';
var uri = 'http://' + host + path;
return new SockJS(uri);
-
- // var Socket = "MozWebSocket" in window ? MozWebSocket : WebSocket;
- // return new Socket(uri);
}
var users = [];
@@ -18,6 +15,7 @@ function refreshUsers() {
}
function onMessage(event) {
+ console.log(event);
var p = $(document.createElement('p')).text(event.data);
$('#messages').append(p);
@@ -41,7 +39,7 @@ $(document).ready(function () {
$('#join-form').submit(function () {
$('#warnings').html('');
var user = $('#user').val();
- var ws = createWebSocket('/chat');
+ var ws = createSockjs('/chat');
ws.onopen = function() {
console.log('open');
View
2 static/sockjs.js
@@ -697,7 +697,7 @@ var WebSocketTransport = SockJS.websocket = function(ri, trans_url) {
};
WebSocketTransport.prototype.doSend = function(data) {
- this.ws.send(data);
+ this.ws.send('['+data+']');
};
WebSocketTransport.prototype.doCleanup = function() {

0 comments on commit f37db26

Please sign in to comment.
Something went wrong with that request. Please try again.