Some cosmetic things

src/Network/Sock/Transport/WebSocket.hs

@@ -2,4 +2,10 @@ module Network.Wai.Sock.Transport.WebSocket
 ( WebSocket
 ) where
 
-data WebSocket = WebSocket
+data WebSocket = WebSocket
+
+-- | Goals:
+--
+--     1. Tie WS connection with Session value (each WS connection should have it's own Session, so WS does not care about SessionIDs, see: http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-61).
+--     2. Feed incoming data (from WS' receive) to the Session's incoming buffer.
+--     3. Feed data from Session's outgoing buffer to WS' sendSink function.

src/Network/Sock/Transport/XHR.hs

@@ -98,6 +98,54 @@ instance Transport XHRPolling where
     send _ ses = atomically . writeTMChan (sessionOutgoingBuffer ses)
     -}
 
+------------------------------------------------------------------------------
+-- |
+data XHRStreaming = XHRStreaming
+
+-- | XHRStreaming Transport represents the /xhr_streaming route.
+--   The /xhr_streaming route serves to open the session and to read the streamed data.
+instance Transport XHRStreaming where
+    handleIncoming tag req =
+        case requestMethod req of
+             "POST"    -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
+             "OPTIONS" -> return . responseOptions ["OPTIONS", "POST"] $ requestRaw req
+             _         -> return H.response404 -- ^ TODO: Handle OPTIONS
+
+        where
+            handleF :: Session -> Server (SessionStatus, H.Response)
+            handleF ses = do
+                -- TODO: Start the timers.
+                lift $ forkApplication app ses
+                return (SessionOpened, respondFrame200 tag FrameOpen req)
+
+            handleO :: Session -> Server (SessionStatus, H.Response)
+            handleO ses = do
+                -- TODO: Reset the timeout timer.
+                let ch = sessionOutgoingBuffer ses
+                liftBase . atomically $ do
+                    closed <- isClosedTMChan ch
+                    empty  <- isEmptyTMChan ch
+                    case () of
+                         _ | closed    -> return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req) -- This should not happen (we close the channel only when we close the session)
+                           | empty     -> (\x -> (SessionOpened, respondFrame200 tag (FrameMessages [convertBL2BS $ fromJust x]) req)) <$> readTMChan ch
+                           | otherwise -> (\x -> (SessionOpened, respondFrame200 tag (FrameMessages (map convertBL2BS x)) req)) <$> getTMChanContents ch
+
+            handleC :: Session -> Server (SessionStatus, H.Response)
+            handleC _ = return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req)
+
+            handleW :: Session -> Server H.Response
+            handleW _ = return $ respondFrame200 tag (FrameClose 2010 "Another connection still open") req
+
+            sid = requestSessionID req
+            app = requestApplication req
+
+    format _ str = encodeFrame str <> "\n"
+
+    respond _ st str req = H.response st headers str
+        where headers =    H.headerJS
+                        <> H.headerCORS "*" (requestRaw req)
+                        <> H.headerJSESSIONID (requestRaw req)
+
 ------------------------------------------------------------------------------
 -- |
 data XHRSend = XHRSend

src/Network/Sock/Types/Application.hs

@@ -6,7 +6,7 @@ module Network.Sock.Types.Application
 ) where
 
 ------------------------------------------------------------------------------
-import qualified Data.Conduit as C (Source, Sink)
+import qualified Data.Conduit         as C (Source, Sink)
 import qualified Data.ByteString.Lazy as BL (ByteString)
 import qualified Data.Text            as TS (Text)
 ------------------------------------------------------------------------------

src/Network/Wai/Sock.hs

@@ -4,7 +4,6 @@ module Network.Wai.Sock
 
 ------------------------------------------------------------------------------
 import           Control.Applicative
-import           Control.Monad.Trans.Class
 ------------------------------------------------------------------------------
 import qualified Data.ByteString.Lazy   as BL (fromChunks)
 import qualified Data.Conduit           as C
@@ -21,10 +20,12 @@ import qualified Network.Sock.Server  as S
 sock :: S.ServerState
      -> W.Request
      -> C.ResourceT IO W.Response
-sock state req = S.runServer (convertRequest req >>= S.sock >>= convertResponse) state
+sock state r = do
+    req <- convertRequest r
+    convertResponse <$> (S.runServer (S.sock req) state)
 
-convertRequest :: W.Request -> S.Server H.Request
-convertRequest req = lift $ do
+convertRequest :: W.Request -> C.ResourceT IO H.Request
+convertRequest req = do
     body <- BL.fromChunks <$> (W.requestBody req C.$$ C.consume)
     return $ H.Request
                  { H.requestBody = body
@@ -33,8 +34,7 @@ convertRequest req = lift $ do
                  , H.requestMethod = W.requestMethod req
                  }
 
-convertResponse :: H.Response -> S.Server W.Response
-convertResponse res = lift $
-    return $ W.responseLBS (H.responseStatus res)
-                           (H.responseHeaders res)
-                           (H.responseBody res)
+convertResponse :: H.Response -> W.Response
+convertResponse res = W.responseLBS (H.responseStatus res)
+                                    (H.responseHeaders res)
+                                    (H.responseBody res)

src/Test.hs

@@ -3,10 +3,12 @@
 ------------------------------------------------------------------------------
 import           Control.Concurrent.MVar.Lifted
 ------------------------------------------------------------------------------
-import qualified Data.HashMap.Lazy as HM
+import qualified Data.HashMap.Strict as HM
 import           Data.Conduit
+import qualified Data.Conduit.List   as C
 import           Data.Default
 import           Data.List
+import           Data.Monoid
 import qualified Data.Text as TS
 ------------------------------------------------------------------------------
 import qualified Network.Sock.Application as S
@@ -23,6 +25,15 @@ echo = S.Application
     }
     where definition source sink = source $$ sink
 
+harrEcho = S.Application
+    { S.applicationSettings = def
+          { S.settingsApplicationPrefix = ["harr_echo"]
+          }
+    , S.applicationDefinition = definition
+    }
+    where definition source sink = source $= C.map foo $$ sink
+              where foo x = "Harr! " <> x
+
 disabledWebsocketEcho = S.Application
     { S.applicationSettings = def
           { S.settingsApplicationPrefix = ["disabled_websocket_echo"]
@@ -49,4 +60,4 @@ runSockServer p r = do
                 }
     W.runSettings W.defaultSettings { W.settingsPort = p } (S.sock state)
 
-main = runSockServer 8080 (router [echo, disabledWebsocketEcho])
+main = runSockServer 8080 (router [echo, harrEcho, disabledWebsocketEcho])