├── .gitignore
├── Makefile
├── ruby
└── msg.rb
├── static
├── index.html
├── eventsource.js
├── eshq.js
├── iframe.html
└── eventsource.polyfill.js
├── src
├── Models
│ ├── User.hs
│ └── Connection.hs
├── DB.hs
├── AMQPEvents.hs
├── EventStream.hs
└── Main.hs
├── eventsource-broker.cabal
├── templates
└── eshq.js.st
└── README.md
/.gitignore:
--------------------------------------------------------------------------------
1 | dist
2 | log
3 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | RELEASE_DIR = dist/app
2 |
3 | all:
4 | mkdir -p $(RELEASE_DIR)
5 | cabal install -flibev
6 | cp dist/build/eventsource-broker/eventsource-broker $(RELEASE_DIR)/eventsource-broker
7 | cp -r static $(RELEASE_DIR)
8 | cp -r templates $(RELEASE_DIR)
9 | cd dist && tar -czf eventsource-broker.tar.gz app/
10 |
--------------------------------------------------------------------------------
/ruby/msg.rb:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env ruby
2 | require 'json'
3 | require 'bunny'
4 |
5 | chan = ARGV.first || "test"
6 |
7 | client = Bunny.new
8 |
9 | client.start
10 |
11 | exchange = client.exchange("eventsource.fanout", :type => :fanout)
12 | queue = client.queue
13 |
14 | #puts "Enter messages (channell message)"
15 | loop do
16 | # msg = gets.strip
17 | # _, chan, msg = *msg.match(/(\w+) (.+)/)
18 | msg = Time.now.to_s
19 | exchange.publish({
20 | :channel => chan,
21 | :data => msg
22 | }.to_json)
23 | sleep 1
24 | end
25 |
--------------------------------------------------------------------------------
/static/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Event source broker
4 |
5 |
6 | Event source broker
7 |
8 |
18 |
19 |
20 |
21 |
23 |
24 |
25 |
--------------------------------------------------------------------------------
/static/eventsource.js:
--------------------------------------------------------------------------------
1 | var output = document.getElementById("output");
2 |
3 | if (typeof(console) == "undefined") {
4 | console = {log: function() {}};
5 | }
6 |
7 | setTimeout(function() {
8 | console.log("Loaded");
9 |
10 | var evtSrc = new EventSource( "/eventsource?channel=test" );
11 |
12 | evtSrc.onopen = function(e) {
13 | console.log("Open %o", e);
14 | };
15 |
16 | evtSrc.onerror = function(e) {
17 | console.log("Error %o", e);
18 | };
19 |
20 | evtSrc.onmessage = function(e) {
21 | console.log("Got event %o", e);
22 | var el = document.createElement("p")
23 | el.appendChild(document.createTextNode(e.data))
24 | output.insertBefore(el, output.firstChild);
25 | };
26 | },50);
27 |
--------------------------------------------------------------------------------
/src/Models/User.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Models.User where
3 |
4 | import Prelude hiding (lookup)
5 | import Data.UString (UString)
6 | import qualified Data.UString as US
7 | import Data.ByteString (ByteString)
8 | import qualified Data.ByteString.Char8 as BS
9 | import qualified Data.ByteString.Lazy as LBS
10 | import Data.Digest.Pure.SHA (sha1)
11 | import DB
12 |
13 | data User = User { apiKey :: UString, apiSecret :: UString }
14 |
15 | get :: DB -> UString -> IO (Either Failure (Maybe User))
16 | get db key = do
17 | result <- run db $ findOne (select ["key" =: key] "users")
18 | return $ returnModel constructor result
19 |
20 | authenticate :: User -> ByteString -> ByteString -> Bool
21 | authenticate user token timestamp =
22 | let key = US.toByteString $ apiKey user
23 | secret = US.toByteString $ apiSecret user
24 | digest = sha1 $ LBS.fromChunks [key, ":", secret, ":", timestamp] in
25 | show digest == BS.unpack token
26 |
27 | constructor :: Document -> User
28 | constructor doc = User (at "key" doc) (at "secret" doc)
29 |
--------------------------------------------------------------------------------
/static/eshq.js:
--------------------------------------------------------------------------------
1 | (function() {
2 | var origin = "$origin$";
3 |
4 | var Sub = function(channel, options) {
5 | for (var i in options) {
6 | this[i] = options[i];
7 | };
8 | this.channel = channel;
9 | }
10 |
11 | var subs = {};
12 |
13 | var onMessage = function(event) {
14 | if (event.origin !== origin) { return; }
15 |
16 | var data = JSON.parse(event.data);
17 | if (!data.eshqEvent) { return; }
18 |
19 | var sub = subs[data.channel];
20 | if (!sub) { return; }
21 |
22 | if (sub[data.eshqEvent]) { sub[data.eshqEvent].call(null, data.originalEvent); }
23 | };
24 |
25 | window.addEventListener("message", onMessage, false);
26 |
27 | var openChannel = function(channel) {
28 | var iframe = document.createElement("iframe");
29 | iframe.setAttribute("style", "display: none;");
30 | iframe.setAttribute("src", origin + "/iframe?channel="+channel);
31 | document.body.appendChild(iframe);
32 | };
33 |
34 | window.eshq = {
35 | subscribe: function(channel, options) {
36 | subs[channel] = new Sub(channel, options || {});
37 | openChannel(channel);
38 | }
39 | };
40 | })();
41 |
--------------------------------------------------------------------------------
/eventsource-broker.cabal:
--------------------------------------------------------------------------------
1 | Name: eventsource-broker
2 | Version: 0.9
3 | Synopsis: EventSource Broker
4 | Description: Bridges EventSource and AMQP
5 | License: AllRightsReserved
6 | Author: Mathias Biilmann Christensen
7 | Maintainer: info@mathias-biilmann.net
8 | Stability: Alpha
9 | Category: Web
10 | Build-type: Simple
11 | Cabal-version: >=1.2
12 |
13 | Executable eventsource-broker
14 | hs-source-dirs: src
15 | main-is: Main.hs
16 |
17 | Build-depends:
18 | base >= 4.3 && < 5,
19 | bytestring >= 0.9.1 && < 0.10,
20 | blaze-builder >= 0.3,
21 | MonadCatchIO-transformers >= 0.2.1 && < 0.3,
22 | mtl >= 2 && < 3,
23 | snap-core == 0.5.*,
24 | snap-server == 0.5.*,
25 | enumerator == 0.4.*,
26 | MissingH == 1.1.*,
27 | unix == 2.5.*,
28 | uri == 0.1.*,
29 | amqp == 0.3.*,
30 | aeson == 0.3.*,
31 | attoparsec == 0.9.*,
32 | system-uuid == 2.1.*,
33 | HStringTemplate == 0.6.*,
34 | bson == 0.1.*,
35 | mongoDB == 1.1.*,
36 | time == 1.2.*,
37 | SHA == 1.5.*
38 |
39 | if impl(ghc >= 6.12.0)
40 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
41 | -fno-warn-unused-do-bind
42 | else
43 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
44 |
--------------------------------------------------------------------------------
/static/iframe.html:
--------------------------------------------------------------------------------
1 |
2 | EventSource IFrame
3 |
10 |
11 |
55 |
--------------------------------------------------------------------------------
/templates/eshq.js.st:
--------------------------------------------------------------------------------
1 | (function() {
2 | var origin = "$origin$";
3 |
4 | if (typeof(window.addEventListener) == "undefined") {
5 | window.addEventListener = function(name, fn) {
6 | window.attachEvent("on" + name, fn);
7 | };
8 | }
9 |
10 | var post = function(path, data, callback) {
11 | var xhr = new XMLHttpRequest();
12 | xhr.open('POST', path, true);
13 | xhr.setRequestHeader('Content-Type', 'application/x-www-form-urlencoded');
14 | xhr.onreadystatechange = callback;
15 | xhr.send(data);
16 | };
17 |
18 | var Sub = function(channel, options) {
19 | for (var i in options) {
20 | this[i] = options[i];
21 | };
22 | this.channel = channel;
23 | }
24 |
25 | var subs = {};
26 |
27 | var onMessage = function(event) {
28 | if (event.origin !== origin) { return; }
29 |
30 | var data = JSON.parse(event.data);
31 | if (!data.eshqEvent) { return; }
32 |
33 | var sub = subs[data.channel];
34 | if (!sub) { return; }
35 |
36 | if (sub[data.eshqEvent]) { sub[data.eshqEvent].call(null, data.originalEvent); }
37 | };
38 |
39 | window.addEventListener("message", onMessage, false);
40 |
41 | var getSocket = function(channel, url) {
42 | post(url, "channel=" + channel, function() {
43 | if (this.readyState == 4 && this.status == 200) {
44 | var resp = JSON.parse(this.responseText);
45 | openChannel(channel, resp.socket);
46 | }
47 | });
48 | };
49 |
50 | var openChannel = function(channel, socket) {
51 | var iframe = document.createElement("iframe");
52 | iframe.setAttribute("style", "display: none;");
53 | iframe.setAttribute("src", origin + "/iframe?channel=" + channel + "&socket=" + socket + "&t=" + new Date().getTime());
54 | document.body.appendChild(iframe);
55 | subs[channel].frame = iframe;
56 | };
57 |
58 | window.eshq = {
59 | open: function(channel, options) {
60 | subs[channel] = new Sub(channel, options || {});
61 | getSocket(channel, options.auth_url || "/eshq/socket");
62 | },
63 | send: function(channel, data) {
64 | var sub = subs[channel];
65 | if (!sub) throw "You must open a channel before sending to it";
66 |
67 | sub.frame.contentWindow.postMessage(data, "*");
68 | }
69 | };
70 | })();
71 |
--------------------------------------------------------------------------------
/src/DB.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module DB
3 | (
4 | DB,
5 | Document,
6 | Failure,
7 | withDB,
8 | openDB,
9 | closeDB,
10 | returnModel,
11 | run,
12 | repsert,
13 | modify,
14 | delete,
15 | select,
16 | findOne,
17 | count,
18 | lookup,
19 | at,
20 | (=:)
21 | ) where
22 |
23 | import Prelude hiding (lookup)
24 |
25 | import Control.Exception (bracket)
26 |
27 | import System.Posix.Env(getEnvDefault)
28 | import Data.String.Utils(split)
29 | import Text.URI(URI(..), parseURI)
30 |
31 | import Data.UString (UString, u)
32 | import Data.Maybe (fromJust)
33 |
34 | import Database.MongoDB (
35 | Action, Pipe, Database, Document, Failure, runIOE, connect, auth, access, master,
36 | readHostPort, close, repsert, modify, delete, (=:), select,
37 | findOne, count, lookup, at
38 | )
39 |
40 | -- |A connection to a mongoDB
41 | data DB = DB { mongoPipe :: Pipe, mongoDB :: Database }
42 |
43 |
44 | -- |Credentials for authenticating with a mongoDB
45 | data Credentials = NoAuth
46 | | Credentials { crUser :: UString, crPass :: UString }
47 |
48 |
49 |
50 | -- |Opens a connection to the database speficied in the MONGO_URL
51 | -- environment variable
52 | openDB :: IO DB
53 | openDB = do
54 | mongoURI <- getEnvDefault "MONGO_URL" "mongodb://127.0.0.1:27017/eventsourcehq"
55 | openConn mongoURI
56 |
57 |
58 | -- |Close the connection to the database
59 | closeDB :: DB -> IO ()
60 | closeDB = do
61 | closeConn
62 |
63 |
64 | -- |Bracket around opening and closing the DB connection
65 | withDB :: (DB -> IO ()) -> IO ()
66 | withDB f = do
67 | mongoURI <- getEnvDefault "MONGO_URL" "mongodb://127.0.0.1:27017/eventsourcehq"
68 |
69 | bracket (openConn mongoURI) closeConn f
70 |
71 |
72 | returnModel :: (Document -> a) -> Either Failure (Maybe Document) -> Either Failure (Maybe a)
73 | returnModel constructor (Right result) = return (fmap constructor result)
74 | returnModel _ (Left failure) = Left failure
75 |
76 |
77 | openConn :: String -> IO DB
78 | openConn mongoURI = do
79 | let uri = fromJust $ parseURI mongoURI
80 | let creds = case fmap (split ":") (uriUserInfo uri) of
81 | Nothing -> NoAuth
82 | Just [us, pw] -> Credentials (u us) (u pw)
83 | let hostname = fromJust $ uriRegName uri
84 | let port = case uriPort uri of
85 | Just p -> show p
86 | Nothing -> "27017"
87 |
88 | let dbName = u $ drop 1 (uriPath uri)
89 |
90 | pipe <- runIOE $ connect (readHostPort (hostname ++ ":" ++ port))
91 |
92 | let db = DB pipe dbName
93 |
94 | authenticate db creds
95 |
96 | return db
97 |
98 |
99 | authenticate :: DB -> Credentials -> IO (Either Failure Bool)
100 | authenticate db NoAuth = return (Right True)
101 | authenticate db (Credentials user pass) = run db (auth user pass)
102 |
103 |
104 | run :: DB -> Action IO a -> IO (Either Failure a)
105 | run (DB pipe db) action =
106 | access pipe master db action
107 |
108 |
109 | closeConn :: DB -> IO ()
110 | closeConn db = close (mongoPipe db)
111 |
--------------------------------------------------------------------------------
/src/Models/Connection.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Models.Connection where
3 |
4 | import Prelude hiding (lookup)
5 |
6 | import Data.Time.Clock (UTCTime, getCurrentTime)
7 | import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
8 | import Data.UString (UString)
9 |
10 | import DB
11 |
12 | -- |An eventSource connection to the broker persisted in mongoDB
13 | data Connection = Connection
14 | { socketId :: UString
15 | , brokerId :: UString
16 | , userId :: UString
17 | , channel :: UString
18 | , presenceId :: Maybe UString
19 | , disconnectAt :: Maybe Int -- Seconds from current time
20 | }
21 |
22 | -- |Store a "connection" to the broker in the database
23 | -- If the disconnect is set, the connection will be marked for
24 | -- disconnection during a coming sweep
25 | store :: DB -> Connection -> IO (Either Failure ())
26 | store db conn= do
27 | time <- disconnectTime (disconnectAt conn)
28 | run db $ repsert (select s "connections") (d time)
29 | where
30 | s = ["_id" =: socketId conn, "channel" =: channel conn, "user_id" =: userId conn]
31 | d (Just time) = s ++ presence ++ ["broker" =: brokerId conn, "disconnect_at" =: time]
32 | d Nothing = s ++ presence ++ ["broker" =: brokerId conn]
33 | presence = case presenceId conn of
34 | Just pid -> ["presence_id" =: pid]
35 | Nothing -> []
36 |
37 |
38 | -- |Mark a connection. Marked connections will be removed by a later
39 | -- sweep
40 | mark :: DB -> Connection -> IO (Either Failure ())
41 | mark db conn = do
42 | case disconnectAt conn of
43 | Just offset -> do
44 | time <- disconnectTime (Just offset)
45 | run db $ modify (select s "connections") (m time)
46 | Nothing -> return $ Right ()
47 | where
48 | s = ["_id" =: (socketId conn), "user_id" =: userId conn]
49 | m time = ["$set" =: ["disconnect_at" =: time]]
50 |
51 |
52 | -- |Sweep connections. All marked connections with a disconnect_at less
53 | -- than the current time will be removed.
54 | sweep :: DB -> UString -> IO (Either Failure ())
55 | sweep db bid = do
56 | time <- getCurrentTime
57 | run db $ delete (select ["broker" =: bid, "disconnect_at" =: ["$lte" =: time]] "connections")
58 |
59 |
60 | -- |Remove all connections from a broker from the db
61 | remove :: DB -> UString -> IO (Either Failure ())
62 | remove db bid =
63 | run db $ delete (select ["broker" =: bid] "connections")
64 |
65 |
66 | get :: DB -> UString -> IO (Either Failure (Maybe Connection))
67 | get db sid = do
68 | result <- run db $ findOne (select ["_id" =: sid] "connections")
69 | return $ returnModel constructor result
70 |
71 |
72 | constructor :: Document -> Connection
73 | constructor doc = Connection {
74 | brokerId = at "broker" doc
75 | , socketId = at "_id" doc
76 | , userId = at "user_id" doc
77 | , channel = at "channel" doc
78 | , presenceId = lookup "presence_id" doc
79 | , disconnectAt = Nothing
80 | }
81 |
82 |
83 | count :: DB -> UString -> IO (Either Failure Int)
84 | count db bid =
85 | run db $ DB.count (select ["broker" =: bid] "connections")
86 |
87 |
88 | disconnectTime :: Maybe Int -> IO (Maybe UTCTime)
89 | disconnectTime (Just offset) = fmap (Just . posixSecondsToUTCTime . (+ (fromIntegral offset))) getPOSIXTime
90 | disconnectTime Nothing = return Nothing
91 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | EvenSource Broker
2 | =================
3 |
4 | A simple bridge between EventSource and an AMQP fanout exchange.
5 |
6 | EventSource is a new browser standard released as part of the HTML5
7 | spec.
8 |
9 | It lets the browser send a never-ending HTTP request to a server and
10 | provides a javascript API for binding to events pushed from the server.
11 |
12 | EventSource is very handy when you don't need the full bidirectional
13 | communication that Websockets offers. it plays well with load-balancers,
14 | intermediary proxies and HTTPS termination.
15 |
16 | This library sets up an EventSource that clients can connect to
17 | specifying a channel to listen to in the query string. The server
18 | connects to a fanout AMQP exchange and routes AMQP messages as events to
19 | the javascript clients.
20 |
21 | MongoDB is used to store user and connection information.
22 |
23 | The server expects the AMQP messages to be JSON following the format:
24 |
25 | {
26 | "channel": "some-channel", // Required
27 | "data": "{/"msg/": /"data/"}", // Required
28 | "id": "event-id", // optional
29 | "name": "event-name" // optional
30 | }
31 |
32 | To open connections to a channel a user with an key and a secret is
33 | expected to exist in the database. Before opening a connection a socket
34 | id must be aquired from by calling POST /socket
35 |
36 | A simple example of how to interact with this API can be found in the
37 | [https://github.com/eshq/eshq-gem](eshq ruby gem).
38 |
39 | Installation
40 | ============
41 |
42 | Clone the repository, cd to the root of it and execute
43 |
44 | cabal install
45 |
46 | Run as:
47 |
48 | eventsource-broker -p
49 |
50 | The broker will look for an AMQP_URL environment variable for a broker
51 | to connect to. It also takes a MONGO_URL for configuring the database
52 | connection and an ORIGIN variable that should be a url the server runs
53 | on for cross domain requests.
54 |
55 | License
56 | =======
57 |
58 | Copyright (c)2011, Mathias Biilmann
59 |
60 | All rights reserved.
61 |
62 | Redistribution and use in source and binary forms, with or without
63 | modification, are permitted provided that the following conditions are met:
64 |
65 | * Redistributions of source code must retain the above copyright
66 | notice, this list of conditions and the following disclaimer.
67 |
68 | * Redistributions in binary form must reproduce the above
69 | copyright notice, this list of conditions and the following
70 | disclaimer in the documentation and/or other materials provided
71 | with the distribution.
72 |
73 | * Neither the name of Mathias Biilman
74 | nor the names of other contributors may be used to endorse or
75 | promote products derived from this software without specific prior
76 | written permission.
77 |
78 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
79 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
80 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
81 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
82 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
83 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
84 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
85 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
86 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
87 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
88 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE
89 |
--------------------------------------------------------------------------------
/src/AMQPEvents.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module AMQPEvents
3 | (
4 | AMQPEvent(..)
5 | , Channel
6 | , openEventChannel
7 | , publishEvent
8 | ) where
9 |
10 | import Control.Applicative((<$>), (<*>))
11 | import Control.Monad(mzero)
12 | import Control.Monad.Fix(fix)
13 | import Control.Concurrent(forkIO)
14 | import Control.Concurrent.Chan(Chan, newChan, readChan, writeChan)
15 |
16 | import Data.Aeson(FromJSON(..), ToJSON(..), Value(..), Result(..), fromJSON, toJSON, object, json, encode, (.:), (.:?), (.=))
17 | import Data.Attoparsec(parse, maybeResult)
18 |
19 | import qualified Data.ByteString as B
20 | import qualified Data.ByteString.Lazy as LB
21 |
22 | import Data.Maybe(fromJust, fromMaybe)
23 | import Data.String.Utils(split)
24 |
25 | import Text.URI(URI(..), parseURI)
26 | import System.Posix.Env(getEnvDefault)
27 | import Network.AMQP
28 |
29 | -- |Wraps a AMQPChannel to publish on and a listerner chan to read from
30 | type AMQPConn = (Channel, Chan AMQPEvent)
31 |
32 | -- |The AMQPEvent represents and incomming message that should be
33 | -- mapped to an EventSource event.
34 | data AMQPEvent = AMQPEvent
35 | { amqpChannel :: B.ByteString
36 | , amqpUser :: B.ByteString
37 | , amqpData :: B.ByteString
38 | , amqpId :: Maybe B.ByteString
39 | , amqpName :: Maybe B.ByteString
40 | }
41 |
42 | instance FromJSON AMQPEvent where
43 | parseJSON (Object v) = AMQPEvent <$>
44 | v .: "channel" <*>
45 | v .: "user" <*>
46 | v .: "data" <*>
47 | v .:? "id" <*>
48 | v .:? "name"
49 | parseJSON _ = mzero
50 |
51 | instance ToJSON AMQPEvent where
52 | toJSON (AMQPEvent c u d i n) = object ["channel" .= c, "user" .= u, "data" .= d, "id" .= i, "name" .= n]
53 |
54 | exchange = "eventsource.fanout"
55 |
56 | -- |Connects to an AMQP broker.
57 | -- Tries to get credentials, host and vhost from the AMQP_URL
58 | -- environment variable
59 | -- Take an exchange name and a queue name
60 | openEventChannel :: String -> IO AMQPConn
61 | openEventChannel queue = do
62 | amqpURI <- getEnvDefault "AMQP_URL" "amqp://guest:guest@127.0.0.1/"
63 |
64 | let uri = fromJust $ parseURI amqpURI
65 | let auth = fromMaybe "guest:guest" $ uriUserInfo uri
66 | let host = fromMaybe "127.0.0.1" $ uriRegName uri
67 | let vhost = uriPath uri
68 |
69 | let [user,password] = split ":" auth
70 |
71 | conn <- openConnection host vhost user password
72 | chan <- openChannel conn
73 |
74 | declareQueue chan newQueue {queueName = queue, queueAutoDelete = True, queueDurable = False}
75 | declareExchange chan newExchange {exchangeName = exchange, exchangeType = "fanout", exchangeDurable = False}
76 | bindQueue chan queue exchange queue
77 |
78 | listener <- newChan
79 | forkIO $ fix $ \loop -> readChan listener >> loop
80 | consumeMsgs chan queue NoAck (sendTo listener)
81 | return (chan, listener)
82 |
83 |
84 | publishEvent chan queue event =
85 | publishMsg chan exchange queue
86 | newMsg {msgBody = encode event}
87 |
88 |
89 | -- |Write messages from AMQP to a channel
90 | sendTo :: Chan AMQPEvent -> (Message, Envelope) -> IO ()
91 | sendTo chan (msg, _) =
92 | case maybeResult $ parse json (B.concat $ LB.toChunks (msgBody msg)) of
93 | Just value -> case fromJSON value of
94 | Success event -> do
95 | writeChan chan event
96 | Error _ -> do
97 | return ()
98 | Nothing -> return ()
99 |
--------------------------------------------------------------------------------
/src/EventStream.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | {-
4 | Based on https://github.com/cdsmith/gloss-web
5 |
6 | Copyright (c)2011, Chris Smith
7 |
8 | All rights reserved.
9 |
10 | Redistribution and use in source and binary forms, with or without
11 | modification, are permitted provided that the following conditions are met:
12 |
13 | * Redistributions of source code must retain the above copyright
14 | notice, this list of conditions and the following disclaimer.
15 |
16 | * Redistributions in binary form must reproduce the above
17 | copyright notice, this list of conditions and the following
18 | disclaimer in the documentation and/or other materials provided
19 | with the distribution.
20 |
21 | * Neither the name of Chris Smith nor the names of other
22 | contributors may be used to endorse or promote products derived
23 | from this software without specific prior written permission.
24 |
25 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
26 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
27 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
28 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
29 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
30 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
31 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
32 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
33 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
34 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
35 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 | -}
37 |
38 | {-|
39 | A Snap adapter to the HTML5 Server-Sent Events API. Push-mode and
40 | pull-mode interfaces are both available.
41 | -}
42 | module EventStream (
43 | ServerEvent(..),
44 | eventSourceStream,
45 | eventSourceResponse
46 | ) where
47 |
48 | import Blaze.ByteString.Builder
49 | import Blaze.ByteString.Builder.Char8
50 | import Control.Monad.Trans
51 | import Control.Concurrent
52 | import Control.Exception (onException)
53 | import Data.Monoid
54 | import Data.Enumerator (Step(..), Stream(..), (>>==), returnI)
55 | -- import Data.Enumerator.List (generateM)
56 | import Snap.Types
57 | import System.Timeout
58 |
59 | {-|
60 | Type representing a communication over an event stream. This can be an
61 | actual event, a comment, a modification to the retry timer, or a special
62 | "close" event indicating the server should close the connection.
63 | -}
64 | data ServerEvent
65 | = ServerEvent {
66 | eventName :: Maybe Builder,
67 | eventId :: Maybe Builder,
68 | eventData :: [Builder]
69 | }
70 | | CommentEvent {
71 | eventComment :: Builder
72 | }
73 | | RetryEvent {
74 | eventRetry :: Int
75 | }
76 | | CloseEvent
77 |
78 |
79 | {-|
80 | Newline as a Builder.
81 | -}
82 | nl = fromChar '\n'
83 |
84 |
85 | {-|
86 | Field names as Builder
87 | -}
88 | nameField = fromString "event:"
89 | idField = fromString "id:"
90 | dataField = fromString "data:"
91 | retryField = fromString "retry:"
92 | commentField = fromChar ':'
93 |
94 |
95 | {-|
96 | Wraps the text as a labeled field of an event stream.
97 | -}
98 | field l b = l `mappend` b `mappend` nl
99 |
100 |
101 | {-|
102 | Appends a buffer flush to the end of a Builder.
103 | -}
104 | flushAfter b = b `mappend` flush
105 |
106 | {-|
107 | Send a comment with the string "ping" to the client.
108 | -}
109 | pingEvent = flushAfter $ field commentField (fromString "ping")
110 |
111 |
112 | {-|
113 | Converts a 'ServerEvent' to its wire representation as specified by the
114 | @text/event-stream@ content type.
115 | -}
116 | eventSourceBuilder :: ServerEvent -> Maybe Builder
117 | eventSourceBuilder (CommentEvent txt) = Just $ flushAfter $ field commentField txt
118 | eventSourceBuilder (RetryEvent n) = Just $ flushAfter $ field retryField (fromShow n)
119 | eventSourceBuilder (CloseEvent) = Nothing
120 | eventSourceBuilder (ServerEvent n i d)= Just $ flushAfter $
121 | (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl
122 | where
123 | name Nothing = id
124 | name (Just n) = mappend (field nameField n)
125 | evid Nothing = id
126 | evid (Just i) = mappend (field idField i)
127 |
128 |
129 | eventSourceEnum source builder timeoutAction finalizer = withInitialPing
130 | where
131 | withInitialPing (Continue k) = k (Chunks [pingEvent]) >>== go
132 | go (Continue k) = do
133 | liftIO $ timeoutAction 10
134 | event <- liftIO $ timeout 9000000 source
135 | case fmap builder event of
136 | Just (Just b) -> k (Chunks [b]) >>== go
137 | Just Nothing -> k EOF
138 | Nothing -> do
139 | k (Chunks [pingEvent]) >>== go
140 | go step = do
141 | liftIO finalizer
142 | returnI step
143 |
144 |
145 | {-|
146 | Send a stream of events to the client. Takes a function to convert an
147 | event to a builder. If that function returns Nothing the stream is closed.
148 | -}
149 | eventStream :: IO ServerEvent -> (ServerEvent -> Maybe Builder) -> IO () -> Snap ()
150 | eventStream source builder finalizer = do
151 | timeoutAction <- getTimeoutAction
152 | modifyResponse $ setResponseBody $
153 | eventSourceEnum source builder timeoutAction finalizer
154 |
155 |
156 | {-|
157 | Return a single response when the source returns an event. Takes a function
158 | used to convert the event to a builder.
159 | -}
160 | eventResponse :: IO ServerEvent -> (ServerEvent -> Maybe Builder) -> IO () -> Snap ()
161 | eventResponse source builder finalizer = do
162 | event <- liftIO $ source `onException` finalizer
163 | case builder event of
164 | Just b -> writeBuilder b
165 | Nothing -> do
166 | liftIO finalizer
167 | response <- getResponse
168 | finishWith response
169 |
170 |
171 | {-|
172 | Sets up this request to act as an event stream, obtaining its events from
173 | polling the given IO action.
174 | -}
175 | eventSourceStream source finalizer = do
176 | modifyResponse $ setContentType "text/event-stream"
177 | . setHeader "Cache-Control" "no-cache"
178 | eventStream source eventSourceBuilder finalizer
179 |
180 |
181 | -- |Long polling fallback - sends a single response when an event is pulled
182 | eventSourceResponse source finalizer = do
183 | modifyResponse $ setContentType "text/event-stream"
184 | . setHeader "Cache-Control" "no-cache"
185 | eventResponse source eventSourceBuilder finalizer
186 |
--------------------------------------------------------------------------------
/static/eventsource.polyfill.js:
--------------------------------------------------------------------------------
1 | /*
2 | * From https://github.com/remy/polyfills.git
3 | *
4 | * Copyright (c) 2010 Remy Sharp, http://remysharp.com
5 | *
6 | * Permission is hereby granted, free of charge, to any person obtaining
7 | * a copy of this software and associated documentation files (the
8 | * "Software"), to deal in the Software without restriction, including
9 | * without limitation the rights to use, copy, modify, merge, publish,
10 | * distribute, sublicense, and/or sell copies of the Software, and to
11 | * permit persons to whom the Software is furnished to do so, subject to
12 | * the following conditions:
13 | *
14 | * The above copyright notice and this permission notice shall be
15 | * included in all copies or substantial portions of the Software.
16 | *
17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
18 | * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
19 | * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
20 | * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
21 | * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
22 | * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
23 | * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
24 | *
25 | */
26 |
27 | ;(function (global) {
28 |
29 | if ("EventSource" in window) return;
30 |
31 | var reTrim = /^(\s|\u00A0)+|(\s|\u00A0)+$/g;
32 | var onProgressSupport = navigator.userAgent.match(/Firefox/);
33 |
34 | var EventSource = function (url) {
35 | var eventsource = this,
36 | interval = 500, // polling interval
37 | lastEventId = null,
38 | cache = '';
39 |
40 | if (!url || typeof url != 'string') {
41 | throw new SyntaxError('Not enough arguments');
42 | }
43 |
44 | this.URL = url;
45 | this.readyState = this.CONNECTING;
46 | this._pollTimer = null;
47 | this._xhr = null;
48 |
49 | function pollAgain() {
50 | eventsource._pollTimer = setTimeout(function () {
51 | poll.call(eventsource);
52 | }, interval);
53 | }
54 |
55 | function poll() {
56 | try { // force hiding of the error message... insane?
57 | if (eventsource.readyState == eventsource.CLOSED) return;
58 |
59 | var xhr = new XMLHttpRequest();
60 | xhr.open('GET', eventsource.URL, true);
61 | xhr.setRequestHeader('Accept', 'text/event-stream');
62 | xhr.setRequestHeader('Cache-Control', 'no-cache');
63 |
64 | // we must make use of this on the server side unlesss we're using firefox - because they don't trigger
65 | // readychange until the server connection is closed
66 | if (!onProgressSupport) {
67 | xhr.setRequestHeader('X-Requested-With', 'XMLHttpRequest');
68 | }
69 |
70 | if (lastEventId != null) xhr.setRequestHeader('Last-Event-ID', lastEventId);
71 | cache = '';
72 |
73 | xhr.timeout = 50000;
74 | xhr.onreadystatechange = function () {
75 | if (eventsource.readyState == eventsource.CONNECTING) {
76 | eventsource.readyState = eventsource.OPEN;
77 | eventsource.dispatchEvent('open', { type: 'open' });
78 | }
79 |
80 | if (((onProgressSupport && this.readyState == 3) || this.readyState == 4) && this.status == 200) {
81 | // process this.responseText
82 | var parts = this.responseText.substr(cache.length).split("\n"),
83 | data = [],
84 | i = 0,
85 | line = '';
86 |
87 | cache = this.responseText;
88 |
89 | // TODO handle 'event' (for buffer name), retry
90 | for (; i < parts.length; i++) {
91 | line = parts[i].replace(reTrim, '');
92 | if (line.indexOf('data') == 0) {
93 | data.push(line.replace(/data:?\s*/, ''));
94 | } else if (line.indexOf('id:') == 0) {
95 | lastEventId = line.replace(/id:?\s*/, '');
96 | } else if (line.indexOf('id') == 0) { // this resets the id
97 | lastEventId = null;
98 | } else if (line == '') {
99 | if (data.length) {
100 | var event = new MessageEvent(data.join('\n'), eventsource.url, lastEventId);
101 | eventsource.dispatchEvent('message', event);
102 | data = [];
103 | }
104 | }
105 | }
106 |
107 | if (this.readyState == 4) pollAgain();
108 | // don't need to poll again, because we're long-loading
109 | } else if (eventsource.readyState !== eventsource.CLOSED) {
110 | if (this.readyState == 4) { // and some other status
111 | // dispatch error
112 | eventsource.readyState = eventsource.CONNECTING;
113 | eventsource.dispatchEvent('error', { type: 'error' });
114 | pollAgain();
115 | } else if (this.readyState == 0) { // likely aborted
116 | pollAgain();
117 | }
118 | }
119 | };
120 |
121 | xhr.send();
122 |
123 | setTimeout(function () {
124 | if (true || xhr.readyState == 3) xhr.abort();
125 | }, xhr.timeout);
126 |
127 | eventsource._xhr = xhr;
128 |
129 | } catch (e) { // in an attempt to silence the errors
130 | eventsource.dispatchEvent('error', { type: 'error', data: e.message }); // ???
131 | }
132 | };
133 |
134 | poll(); // init now
135 | };
136 |
137 | EventSource.prototype = {
138 | close: function () {
139 | // closes the connection - disabling the polling
140 | this.readyState = this.CLOSED;
141 | clearInterval(this._pollTimer);
142 | this._xhr.abort();
143 | },
144 | CONNECTING: 0,
145 | OPEN: 1,
146 | CLOSED: 2,
147 | dispatchEvent: function (type, event) {
148 | var handlers = this['_' + type + 'Handlers'];
149 | if (handlers) {
150 | for (var i = 0; i < handlers.length; i++) {
151 | handlers.call(this, event);
152 | }
153 | }
154 |
155 | if (this['on' + type]) {
156 | this['on' + type].call(this, event);
157 | }
158 | },
159 | addEventListener: function (type, handler) {
160 | if (!this['_' + type + 'Handlers']) {
161 | this['_' + type + 'Handlers'] = [];
162 | }
163 |
164 | this['_' + type + 'Handlers'].push(handler);
165 | },
166 | removeEventListener: function () {
167 | // TODO
168 | },
169 | onerror: null,
170 | onmessage: null,
171 | onopen: null,
172 | readyState: 0,
173 | URL: ''
174 | };
175 |
176 | var MessageEvent = function (data, origin, lastEventId) {
177 | this.data = data;
178 | this.origin = origin;
179 | this.lastEventId = lastEventId || '';
180 | };
181 |
182 | MessageEvent.prototype = {
183 | data: null,
184 | type: 'message',
185 | lastEventId: '',
186 | origin: ''
187 | };
188 |
189 | if ('module' in global) module.exports = EventSource;
190 | global.EventSource = EventSource;
191 |
192 | })(this);
193 |
--------------------------------------------------------------------------------
/src/Main.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Main where
3 |
4 | import Control.Applicative ((<|>))
5 | import Control.Monad.Trans (liftIO)
6 | import Control.Concurrent (forkIO, threadDelay)
7 | import Control.Concurrent.Chan (Chan, readChan, dupChan)
8 | import Control.Exception (bracket)
9 |
10 | import Snap.Types
11 | import Snap.Util.FileServe (serveFile, serveDirectory)
12 | import Snap.Http.Server( quickHttpServe)
13 |
14 | import Data.ByteString(ByteString)
15 | import qualified Data.ByteString.Char8 as BS
16 | import Data.UString (UString, u)
17 | import qualified Data.UString as US
18 | import Data.Digest.Pure.SHA (sha1, bytestringDigest)
19 | import Data.Time.Clock.POSIX (POSIXTime)
20 | import Blaze.ByteString.Builder(fromByteString)
21 |
22 | import qualified System.UUID.V4 as UUID
23 |
24 | import AMQPEvents(AMQPEvent(..), Channel, openEventChannel, publishEvent)
25 | import EventStream(ServerEvent(..), eventSourceStream, eventSourceResponse)
26 |
27 | import DB
28 |
29 | import qualified Models.Connection as Conn
30 | import qualified Models.User as User
31 |
32 | import System.Posix.Env(getEnvDefault)
33 | import Data.Time.Clock.POSIX (getPOSIXTime)
34 |
35 | import Text.StringTemplate
36 |
37 |
38 | -- |Setup a channel listening to an AMQP exchange and start Snap
39 | main :: IO ()
40 | main = do
41 | uuid <- fmap (u . show) UUID.uuid
42 | origin <- getEnvDefault "ORIGIN" "http://127.0.0.1"
43 | templates <- directoryGroup "templates" :: IO (STGroup ByteString)
44 |
45 | let queue = US.append "eventsource." uuid
46 | let Just js = fmap (render . (setAttribute "origin" origin)) (getStringTemplate "eshq.js" templates)
47 |
48 | (publisher, listener) <- openEventChannel (show queue)
49 |
50 | bracket openDB (\db -> Conn.remove db uuid >> closeDB db) $ \db -> do
51 | forkIO $ connectionSweeper db uuid
52 | quickHttpServe $
53 | ifTop (serveFile "static/index.html") <|>
54 | path "iframe" (serveFile "static/iframe.html") <|>
55 | path "es.js" (serveJS js) <|>
56 | dir "static" (serveDirectory "static") <|>
57 | method POST (route [
58 | ("event", postEvent db publisher queue),
59 | ("socket", createSocket db uuid),
60 | ("socket/:socket", postEventFromSocket db publisher queue)
61 | ]) <|>
62 | method GET (route [
63 | ("broker", brokerInfo db uuid),
64 | ("eventsource", eventSource db uuid listener)
65 | ])
66 |
67 |
68 | -- |Clean up disconnected connections for this broker at regular intervals
69 | connectionSweeper :: DB -> UString -> IO ()
70 | connectionSweeper db uuid = do
71 | threadDelay 15000000
72 | Conn.sweep db uuid
73 | connectionSweeper db uuid
74 |
75 |
76 | brokerInfo :: DB -> UString -> Snap ()
77 | brokerInfo db uuid = do
78 | result <- liftIO $ Conn.count db uuid
79 | case result of
80 | Right count ->
81 | sendJSON $ BS.pack $ "{\"brokerId\": " ++ (show uuid) ++ ", \"connections\": " ++ (show count) ++ "}"
82 | Left e -> do
83 | modifyResponse $ setResponseCode 500
84 | writeBS $ BS.pack $ "Database Connection Problem: " ++ (show e)
85 |
86 | -- |Create a new socket and return the ID
87 | createSocket :: DB -> UString -> Snap ()
88 | createSocket db uuid = do
89 | withAuth db $ \user -> do
90 | withParam "channel" $ \channel -> do
91 | socketId <- liftIO $ fmap show UUID.uuid
92 | presenceId <- getParam "presence_id"
93 | result <- liftIO $ Conn.store db Conn.Connection {
94 | Conn.socketId = u socketId
95 | , Conn.brokerId = uuid
96 | , Conn.userId = User.apiKey user
97 | , Conn.channel = channel
98 | , Conn.presenceId = fmap ufrombs presenceId
99 | , Conn.disconnectAt = Just 10
100 | }
101 | case result of
102 | Left failure -> do
103 | logError (BS.pack $ show failure)
104 | showError 500 "Database Connection Error"
105 | Right _ ->
106 | sendJSON $ BS.pack ("{\"socket\": \"" ++ socketId ++ "\"}")
107 |
108 |
109 | postEvent :: DB -> Channel -> UString -> Snap ()
110 | postEvent db chan queue =
111 | withAuth db $ \user ->
112 | withParam "channel" $ \channel ->
113 | withParam "data" $ \dataParam -> do
114 | liftIO $ publishEvent chan (show queue) $
115 | AMQPEvent (utobs channel) (utobs $ User.apiKey user) (utobs dataParam) Nothing Nothing
116 | writeBS "Ok"
117 |
118 | -- |Post a new event from a socket.
119 | postEventFromSocket :: DB -> Channel -> UString -> Snap ()
120 | postEventFromSocket db chan queue =
121 | withConnection db $ \conn ->
122 | withParam "data" $ \dataParam -> do
123 | liftIO $ publishEvent chan (show queue) $
124 | AMQPEvent (utobs $ Conn.channel conn) (utobs $ Conn.userId conn) (utobs dataParam) Nothing Nothing
125 | writeBS "Ok"
126 |
127 |
128 | -- |Stream events from a channel of AMQPEvents to EventSource
129 | eventSource :: DB -> UString -> Chan AMQPEvent -> Snap ()
130 | eventSource db uuid chan = do
131 | chan' <- liftIO $ dupChan chan
132 | withConnection db $ \conn -> do
133 | liftIO $ before conn
134 | transport <- getTransport
135 | transport (filterEvents conn chan') (after conn)
136 | where
137 | before conn = Conn.store db conn { Conn.brokerId = uuid } >> return ()
138 | after conn = Conn.mark db (conn { Conn.disconnectAt = Just 10 } ) >> return ()
139 |
140 | serveJS :: ByteString -> Snap ()
141 | serveJS js = do
142 | modifyResponse $ setContentType "text/javascript; charset=UTF-8"
143 | writeBS js
144 |
145 |
146 | withParam :: UString -> (UString -> Snap ()) -> Snap ()
147 | withParam param fn = do
148 | param' <- getParam (utobs param)
149 | case param' of
150 | Just value -> fn (ufrombs value)
151 | Nothing -> showError 400 $ BS.concat ["Missing param: ", utobs param]
152 |
153 |
154 | withConnection :: DB -> (Conn.Connection -> Snap ()) -> Snap ()
155 | withConnection db fn = do
156 | withParam "socket" $ \sid -> do
157 | withDBResult (Conn.get db sid) (showError 404 "Socket Not Found") fn
158 |
159 |
160 | withAuth :: DB -> (User.User -> Snap ()) -> Snap ()
161 | withAuth db handler = do
162 | key <- getParam "key"
163 | token <- getParam "token"
164 | timestamp <- getParam "timestamp"
165 | case (key, token, timestamp) of
166 | (Just key', Just token', Just timestamp') -> do
167 | currentTime <- liftIO getPOSIXTime
168 | withDBResult (User.get db (ufrombs key')) (showError 404 "User not found") $ \user ->
169 | if validTime timestamp' currentTime && User.authenticate user token' timestamp'
170 | then handler user
171 | else showError 401 "Access Denied"
172 |
173 |
174 | withDBResult :: IO (Either Failure (Maybe a)) -> Snap () -> (a -> Snap ()) -> Snap ()
175 | withDBResult f notFound found= do
176 | result <- liftIO f
177 | case result of
178 | Right (Just model) -> found model
179 | Right Nothing -> notFound
180 | Left failure -> do
181 | logError (BS.pack $ show failure)
182 | showError 500 "Database Connection Error"
183 |
184 |
185 | validTime :: ByteString -> POSIXTime -> Bool
186 | validTime timestamp currentTime =
187 | let t1 = read $ BS.unpack timestamp
188 | t2 = floor currentTime in
189 | abs (t1 - t2) < 5 * 60
190 |
191 |
192 | showError :: Int -> ByteString -> Snap ()
193 | showError code msg = do
194 | modifyResponse $ setResponseCode code
195 | writeBS msg
196 | r <- getResponse
197 | finishWith r
198 |
199 |
200 | sendJSON :: ByteString -> Snap ()
201 | sendJSON json = do
202 | modifyResponse $ setContentType "application/json"
203 | writeBS json
204 |
205 |
206 | -- |Returns the transport method to use for this request
207 | getTransport :: Snap (IO ServerEvent -> IO () -> Snap ())
208 | getTransport = withRequest $ \request ->
209 | case getHeader "X-Requested-With" request of
210 | Just "XMLHttpRequest" -> return eventSourceResponse
211 | _ -> return eventSourceStream
212 |
213 |
214 | -- |Filter AMQPEvents by channelId
215 | filterEvents :: Conn.Connection -> Chan AMQPEvent -> IO ServerEvent
216 | filterEvents conn chan = do
217 | event <- readChan chan
218 | if amqpUser event == userId && amqpChannel event == channel
219 | then return $ ServerEvent (toBS $ amqpName event) (toBS $ amqpId event) [fromByteString $ amqpData event]
220 | else filterEvents conn chan
221 | where
222 | toBS = fmap fromByteString
223 | userId = utobs $ Conn.userId conn
224 | channel = utobs $ Conn.channel conn
225 |
226 |
227 | ufrombs :: ByteString -> UString
228 | ufrombs = US.fromByteString_
229 |
230 |
231 | utobs :: UString -> ByteString
232 | utobs = US.toByteString
233 |
--------------------------------------------------------------------------------