XHR Polling is now basically working, what remains to be done are pro…

…per response headers, decode incoming JSON, more importantly add timeouts and heartbeats, but most importatnly -- make the code prettier (adding a Server monad containing environment, settings, Request wrapper containing (Maybe) Application, Session, SessionID, etc. might help a bit, but there are some disgustingly long lines in Transports.XHR)

src/Data/ByteString/Extra.hs

@@ -0,0 +1,21 @@
+module Data.ByteString.Extra
+( convertBS2BL
+, convertBL2BS
+, convertTS2BL
+) where
+
+------------------------------------------------------------------------------
+import qualified Data.ByteString.Lazy as BL (ByteString, toChunks, fromChunks)
+import qualified Data.ByteString      as BS (ByteString, concat)
+import qualified Data.Text            as TS (Text)
+import qualified Data.Text.Encoding   as TS (encodeUtf8)
+------------------------------------------------------------------------------
+
+convertBS2BL :: BS.ByteString -> BL.ByteString
+convertBS2BL = BL.fromChunks . (:[])
+
+convertBL2BS :: BL.ByteString -> BS.ByteString
+convertBL2BS = BS.concat . BL.toChunks
+
+convertTS2BL :: TS.Text -> BL.ByteString
+convertTS2BL = convertBS2BL . TS.encodeUtf8

src/Network/Wai/Sock.hs

@@ -1,4 +1,11 @@
 module Network.Wai.Sock
-(
+( Application(..)
+, ApplicationSettings(..)
+, ServerSettings(..)
+, Environment(..)
+, sock
 ) where
 
+import Network.Wai.Sock.Internal.Types
+import Network.Wai.Sock.Handler
+

src/Network/Wai/Sock/Application.hs

@@ -1,9 +1,27 @@
+{-# LANGUAGE RecordWildCards  #-}
+{-# LANGUAGE FlexibleContexts #-}
+
 module Network.Wai.Sock.Application
 ( Application(..)
 , ApplicationSettings(..)
+, runApplication
 ) where
 
 ------------------------------------------------------------------------------
-import           Network.Wai.Sock.Internal.Types (Application(..), ApplicationSettings(..))
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Control
+------------------------------------------------------------------------------
+import qualified Data.Conduit           as C
+import qualified Data.Conduit.TMChan    as C (sourceTMChan, sinkTMChan)
 ------------------------------------------------------------------------------
+import           Network.Wai.Sock.Internal.Types (Application(..), ApplicationSettings(..), Session(..))
+------------------------------------------------------------------------------
+
+runApplication :: (MonadBaseControl IO m, MonadIO m)
+               => Application m
+               -> Session
+               -> m ()
+runApplication Application{..} Session{..} =
+    applicationDefinition (C.sourceTMChan sessionIncomingBuffer)
+                          (C.sinkTMChan sessionOutgoingBuffer)
 

src/Network/Wai/Sock/Handler.hs

@@ -1,23 +1,28 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE FlexibleContexts  #-}
 
 module Network.Wai.Sock.Handler
-(
+( sock
 ) where
 
 ------------------------------------------------------------------------------
 import           System.Random (randomRIO)
 ------------------------------------------------------------------------------
 import           Control.Applicative
+import           Control.Concurrent.Lifted      (fork)
+import           Control.Concurrent.MVar.Lifted
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Control
+import           Control.Monad.Base
 ------------------------------------------------------------------------------
 import qualified Data.Aeson           as AE (encode, object)
 import           Data.Aeson                 ((.=))
 import qualified Data.Binary          as BI (encode)
 import qualified Data.ByteString.Lazy as BL (ByteString, toChunks, fromChunks)
 import qualified Data.ByteString      as BS (ByteString, empty, concat)
 import           Data.ByteString.Extra      (convertBL2BS, convertTS2BL)
+import qualified Data.Conduit         as C
 import           Data.Digest.Pure.MD5       (md5)
 import           Data.Int                   (Int64)
 import           Data.Maybe
@@ -48,15 +53,17 @@ import           Network.Wai.Sock.Transport.XHR
 
 sock :: ServerSettings
      -> Environment
-     -> ([TS.Text] -> Maybe (Application m))
+     -> ([TS.Text] -> Maybe (Application (C.ResourceT IO)))
      -> W.Application
-sock set mvsm find req = undefined
+sock set env find req = do
+    maybe (return response404) run . find $ W.pathInfo req
+    where run app = handleSubroutes set env app req
 
 handleSubroutes :: ServerSettings
                 -> Environment
-                -> Application m
+                -> Application (C.ResourceT IO)
                 -> W.Application
-handleSubroutes set@ServerSettings{..} env app@Application{..} req =
+handleSubroutes set@ServerSettings{..} env app@Application{..} req = 
     case (W.requestMethod req, suffix) of
         -- TODO: Add OPTIONS response.
         ("GET", [])          -> return responseGreeting
@@ -74,21 +81,31 @@ handleSubroutes set@ServerSettings{..} env app@Application{..} req =
 handleTransport :: TS.Text
                 -> ServerSettings
                 -> Environment
-                -> Application m
+                -> Application (C.ResourceT IO)
                 -> SessionID
                 -> W.Application
 handleTransport trans set env app sid req =
     case trans of
         "websocket"     -> return response404
         "xhr"           -> handle (Proxy :: Proxy XHRPolling)
-        "xhr_send"      -> return response404
+        "xhr_send"      -> handle (Proxy :: Proxy XHRSend)
         "xhr_streaming" -> return response404
         "eventsource"   -> return response404
         "htmlfile"      -> return response404
         "jsonp"         -> return response404
         "jsonp_send"    -> return response404
         _               -> return response404
-    where handle tag = handleIncoming tag env req >> return response404 -- ^ Run the application here.
+    where handle tag = do
+              resp <- handleIncoming tag env req
+              -- TODO: The application should be started by one of the transport functions (when the session is first created).
+              ms <- lookupSession sid env
+              case ms of
+                   Just s -> modifyMVar_ (sessionApplicationThread s) $ \mt ->
+                                 case mt of
+                                      Nothing -> Just <$> fork (runApplication app s)
+                                      Just ti -> return (Just ti)
+                   _      -> return ()
+              return resp
 
 ------------------------------------------------------------------------------
 -- | Standard responses (greeting, info, iframe)
@@ -132,4 +149,4 @@ responseInfo ServerSettings{..} ent = response200 headerJSON . AE.encode $ AE.ob
     , "cookie_needed" .= serverSettingsCookiesNeeded
     , "origins"       .= serverSettingsAllowedOrigins
     , "entropy"       .= ent
-    ]
+    ]

src/Network/Wai/Sock/Internal/Types.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE GADTs            #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Network.Wai.Sock.Internal.Types
 ( Environment(..)
@@ -8,16 +9,24 @@ module Network.Wai.Sock.Internal.Types
 , SessionID
 , SessionStatus(..)
 
+, Server(..)
+, ServerState(..)
+, ServerSettings(..)
+
 , Transport(..)
 
 , Application(..)
 , ApplicationSettings(..)
 ) where
 
 ------------------------------------------------------------------------------
+import           Control.Applicative
+import           Control.Concurrent.Lifted      (ThreadId)
 import           Control.Concurrent.MVar.Lifted
 import           Control.Concurrent.STM.TMChan
 import           Control.Monad.Base
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.State.Lazy
 import           Control.Monad.Trans.Control
 ------------------------------------------------------------------------------
 import qualified Data.ByteString.Lazy as BL (ByteString)
@@ -60,10 +69,11 @@ class Transport tag where
            -> Frame
            -> BL.ByteString
 
-    -- | Used to create a response (headers might be transport dependent).
+    -- | Used to create a response (headers might be transport & request dependent).
     respond :: Proxy tag
             -> H.Status
             -> BL.ByteString
+            -> W.Request
             -> W.Response
 
     -- | Used for _ => 'Application' communication.
@@ -81,6 +91,25 @@ class Transport tag where
          -> Session
          -> BL.ByteString
          -> C.ResourceT IO ()
+
+------------------------------------------------------------------------------
+-- | Server related types.
+
+type Server = StateT ServerState (C.ResourceT IO)
+
+data ServerState = ServerState
+    { serverSettings :: ServerSettings
+    , serverEnvironment :: Environment
+    --, serverApplicationRouter :: ([TS.Text] -> Maybe (Application m))
+    }
+
+data ServerSettings = ServerSettings
+    { serverSettingsWebsocketsEnabled :: Bool
+    , serverSettingsCookiesNeeded :: Bool
+    , serverSettingsAllowedOrigins :: TS.Text
+    , serverSettingsSockURL :: TS.Text
+    , serverSettingsSockVersion :: TS.Text
+    }
 
 ------------------------------------------------------------------------------
 -- | Environment related types.
@@ -101,6 +130,9 @@ data Session where
         , sessionStatus :: MVar SessionStatus           
         , sessionIncomingBuffer :: TMChan BL.ByteString -- ^ This buffer is filled by calls to handleIncoming and later, we transform it into Source for the Application.
         , sessionOutgoingBuffer :: TMChan BL.ByteString -- ^ This buffer is filled by calls to send.
+        , sessionApplicationThread :: MVar (Maybe ThreadId) -- ^ If the MVar is empty, some thread is already trying to fork application.
+                                                            --   If it contains Nothing, noone is forking nor has anyone forked yet.
+                                                            --   If it contains Just a value, application was already forked.
         } -> Session
 
 -- | SessionID

src/Network/Wai/Sock/Server.hs

@@ -2,20 +2,16 @@
 
 module Network.Wai.Sock.Server
 ( ServerSettings(..)
+, ServerState(..)
+, Server(..)
 ) where
 
 ------------------------------------------------------------------------------
 import qualified Data.Text    as TS (Text)
 import           Data.Default
 ------------------------------------------------------------------------------
-
-data ServerSettings = ServerSettings
-    { serverSettingsWebsocketsEnabled :: Bool
-    , serverSettingsCookiesNeeded :: Bool
-    , serverSettingsAllowedOrigins :: TS.Text
-    , serverSettingsSockURL :: TS.Text
-    , serverSettingsSockVersion :: TS.Text
-    }
+import           Network.Wai.Sock.Internal.Types (ServerSettings(..), ServerState(..), Server(..))
+------------------------------------------------------------------------------
 
 instance Default ServerSettings where
     def = ServerSettings

src/Network/Wai/Sock/Session.hs

@@ -30,4 +30,5 @@ newSession :: (MonadBase IO m, Transport tag)
            -> m Session
 newSession sid tr = Session sid tr <$> newMVar SessionFresh
                                    <*> liftBase newTMChanIO
-                                   <*> liftBase newTMChanIO
+                                   <*> liftBase newTMChanIO
+                                   <*> newMVar Nothing

src/Network/Wai/Sock/Transport.hs

@@ -4,7 +4,8 @@
 module Network.Wai.Sock.Transport
 ( Transport(..)
 , sendFrame
-, frameResponse
+, respondFrame
+, respondFrame200
 , handleByStatus
 ) where
 
@@ -16,7 +17,8 @@ import           Control.Monad.Trans.Control
 import           Data.Proxy
 import qualified Data.Conduit as C
 ------------------------------------------------------------------------------
-import qualified Network.Wai as W (Request(..), Response(..))
+import qualified Network.HTTP.Types as H (Status, status200, status204)
+import qualified Network.Wai        as W (Request(..), Response(..))
 ------------------------------------------------------------------------------
 import           Network.Wai.Sock.Internal.Types (Transport(..), Session(..), SessionStatus(..))
 import           Network.Wai.Sock.Frame
@@ -29,22 +31,30 @@ sendFrame :: Transport tag
           -> C.ResourceT IO ()
 sendFrame tag ses = send tag ses . format tag
 
-frameResponse :: Proxy tag
-              -> W.Request
-              -> Frame
-              -> W.Response
-frameResponse tag = undefined
+respondFrame :: Transport tag
+             => Proxy tag
+             -> H.Status
+             -> Frame
+             -> W.Request
+             -> W.Response
+respondFrame tag st fr = respond tag st (format tag fr)
+
+respondFrame200 :: Transport tag
+                => Proxy tag
+                -> Frame
+                -> W.Request
+                -> W.Response
+respondFrame200 tag fr = respond tag H.status200 (format tag fr)
 
 handleByStatus :: (MonadBaseControl IO m, Transport tag)
                => Proxy tag
                -> (Session -> m (SessionStatus, W.Response)) -- ^ SessionFresh handler
                -> (Session -> m (SessionStatus, W.Response)) -- ^ SessionOpened handler
                -> (Session -> m (SessionStatus, W.Response)) -- ^ SessionClosed handler
                -> (Session -> m W.Response) -- ^ Handler for when the session is "Waiting", that is the session status MVar is empty.
-               -> W.Request
                -> Session
                -> m W.Response
-handleByStatus tag handleF handleO handleC handleW req ses = do
+handleByStatus tag handleF handleO handleC handleW ses = do
     mvar (handleW ses) -- The MVar is empty, which means there is another connection still open.
          (\s -> case s of
                      SessionFresh   -> handleF ses