it works, well kinda

Author: banacorn

SocketIO.cabal

@@ -69,6 +69,7 @@ library
     build-depends:    base                  >=4.6   && <5.0
                     , text                  >=1.1   && <2.0
                     , bytestring            >=0.10  && <1.0
+                    , blaze-builder         >=0.3   && <1.0
                     , aeson                 >=0.7   && <1.0
                     , conduit               >=1.1   && <2.0
                     , conduit-extra         >=1.1   && <2.0
@@ -102,6 +103,7 @@ test-suite socketio-test
     build-depends:    base                  >=4.6   && <5.0
                     , text                  >=1.1   && <2.0
                     , bytestring            >=0.10  && <1.0
+                    , blaze-builder         >=0.3   && <1.0
                     , aeson                 >=0.7   && <1.0
                     , conduit               >=1.1   && <2.0
                     , conduit-extra         >=1.1   && <2.0

Web/SocketIO/Server.hs

@@ -16,6 +16,11 @@ import              Web.SocketIO.Types
 
 --------------------------------------------------------------------------------
 import              Control.Monad.Trans             (liftIO)
+import              Blaze.ByteString.Builder        (Builder)
+import qualified    Blaze.ByteString.Builder        as Builder
+import              Data.Conduit
+import qualified    Data.Conduit.List               as CL
+import qualified    Data.ByteString               as B
 import              Network.HTTP.Types              (Status, status200, status403)
 import              Network.HTTP.Types.Header       (ResponseHeaders)
 import qualified    Network.Wai                     as Wai
@@ -45,6 +50,26 @@ serverConfig port config handler = do
     -- run it with Warp
     Warp.run port (httpApp vorspann (runConnection env))
 
+
+banana :: Wai.Request -> (Request -> IO Message) -> Source IO (Flush Builder)
+banana request runConnection' = sourceRequest request $= CL.mapM runConnection' =$= serializeMessage =$= toFlushBuilder
+    where   serializeMessage = do
+                m <- await
+                n <- await
+                case (m, n) of
+                    (Nothing, Nothing) -> yield (serialize (Framed [] :: Framed Message))
+                    (Just m', Nothing) -> yield (serialize m')
+                    (Just m', Just n') -> do
+                        yield ("�" <> serialize size <> "�" <> m'')
+                        leftover n'
+                        serializeMessage
+                        where   m'' = serialize m'
+                                size = B.length m''
+            toFlushBuilder = do
+                b <- await
+                case b of
+                    Just b' -> yield $ Chunk $ Builder.fromByteString b'
+                    Nothing -> yield $ Flush
 --------------------------------------------------------------------------------
 -- | Wrapped as a HTTP app
 httpApp :: ResponseHeaders -> (Request -> IO Message) -> Wai.Application
@@ -53,8 +78,7 @@ httpApp headerFields runConnection' httpRequest = liftIO $ do
     let origin = lookupOrigin httpRequest
     let headerFields' = insertOrigin headerFields origin
 
-    reqs <- parseHTTPRequest httpRequest
-    mapM runConnection' reqs >>= waiResponse headerFields' 
+    return $ Wai.responseSource status200 headerFields' (banana httpRequest runConnection')
 
     where   lookupOrigin req = case lookup "Origin" (Wai.requestHeaders req) of
                 Just origin -> origin