Skip to content
Browse files

Refactored the code (removed most of the code duplication, plus the t…

…ranports are more conduit based).
  • Loading branch information...
1 parent fe1a2e8 commit 309768dbf09131992fecd1df2b8c91c156dff5a1 @Palmik committed Jul 21, 2012
View
3 .gitignore
@@ -0,0 +1,3 @@
+*.hi
+*.o
+*.*~
View
12 sock.cabal
@@ -18,7 +18,7 @@ library
exposed-modules:
Network.Sock
, Network.Sock.Server
- , Network.Sock.Transport
+ , Network.Sock.Handler
, Network.HTTP.Types.Extra
, Network.HTTP.Types.Request
, Network.HTTP.Types.Response
@@ -32,21 +32,19 @@ library
, Data.Conduit.List.Extra
, Network.Sock.Application
, Network.Sock.Frame
- , Network.Sock.Handler
, Network.Sock.Protocol
, Network.Sock.Request
, Network.Sock.Session
- , Network.Sock.Transport.XHR
- , Network.Sock.Transport.Streaming
- , Network.Sock.Transport.Polling
- , Network.Sock.Transport.WebSocket
+ , Network.Sock.Handler.Common
+ , Network.Sock.Handler.XHR
+ , Network.Sock.Handler.WebSocket
, Network.Sock.Types.Application
, Network.Sock.Types.Frame
, Network.Sock.Types.Protocol
, Network.Sock.Types.Request
, Network.Sock.Types.Server
, Network.Sock.Types.Session
- , Network.Sock.Types.Transport
+ , Network.Sock.Types.Handler
build-depends:
attoparsec
View
2 src/Network/HTTP/Types/Extra.hs
@@ -54,7 +54,7 @@ headerCached = [("Cache-Control", "public; max-age=31536000;"),("Expires", "3153
headerNotCached :: H.ResponseHeaders
headerNotCached = [("Cache-Control", "no-store, no-cache, must-revalidate, max-age=0")]
-headerETag :: H.Ascii -> H.ResponseHeaders
+headerETag :: BS.ByteString -> H.ResponseHeaders
headerETag etag = [("ETag", etag)]
headerHTML :: H.ResponseHeaders
View
8 src/Network/Sock/Application.hs
@@ -15,7 +15,7 @@ import Control.Concurrent.MVar.Lifted
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
------------------------------------------------------------------------------
-import qualified Data.Conduit.TMChan as C (sourceTMChan, sinkTMChan)
+import qualified Data.Conduit.TMChan as C (sourceTMChan, sinkTMChan)
import Data.Default
------------------------------------------------------------------------------
import Network.Sock.Types.Application
@@ -35,10 +35,10 @@ instance Default ApplicationSettings where
-- and if noone is trying to fork one (the MVar is not empty), forks the
-- given Application and saves the `ThreadId` into the MVar.
forkApplication :: (MonadBaseControl IO m, MonadIO m)
- => Application m
- -> Session
+ => Session
+ -> Application m
-> m Bool
-forkApplication Application{..} Session{..} =
+forkApplication Session{..} Application{..} =
modifyMVar sessionApplicationThread $ \mt ->
case mt of
Nothing -> (\ti -> (Just ti, True)) <$> fork runApplication
View
18 src/Network/Sock/Handler.hs
@@ -33,12 +33,14 @@ import Network.Sock.Application
import Network.Sock.Request
import Network.Sock.Server
import Network.Sock.Session
-import Network.Sock.Transport
-import Network.Sock.Transport.XHR
-import Network.Sock.Transport.HTMLFile
-import Network.Sock.Transport.JSONP
-import Network.Sock.Transport.WebSocket
-import Network.Sock.Transport.EventSource
+import Network.Sock.Types.Handler
+
+import Network.Sock.Handler.Common (responseOptions)
+import Network.Sock.Handler.EventSource
+import Network.Sock.Handler.HTMLFile
+import Network.Sock.Handler.JSONP
+import Network.Sock.Handler.WebSocket
+import Network.Sock.Handler.XHR
------------------------------------------------------------------------------
------------------------------------------------------------------------------
@@ -93,7 +95,7 @@ responseTransport :: H.IsResponse res
=> TS.Text
-> Request
-> Server res
-responseTransport trans req =
+responseTransport trans req =
case trans of
"websocket" -> return H.response404 -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-50
"xhr" -> handle (Proxy :: Proxy XHRPolling) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-74
@@ -104,7 +106,7 @@ responseTransport trans req =
"jsonp" -> handle (Proxy :: Proxy JSONPPolling) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-108
"jsonp_send" -> handle (Proxy :: Proxy JSONPSend) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-108
_ -> return H.response404
- where handle tag = handleIncoming tag req
+ where handle tag = handleReuqest tag req
------------------------------------------------------------------------------
-- | Used as a response to:
View
176 src/Network/Sock/Handler/Common.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Sock.Handler.Common
+( respondSource
+, respondLBS
+, respondFrame
+
+, responseOptions
+
+, pollingSource
+, streamingSource
+
+, yieldAndFlush
+, liftSTM
+) where
+
+------------------------------------------------------------------------------
+import Control.Concurrent.MVar.Lifted
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMChan
+import Control.Concurrent.STM.TMChan.Extra
+import Control.Monad.Trans (MonadIO, liftIO, lift)
+------------------------------------------------------------------------------
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString as BS
+import qualified Data.Conduit as C
+import Data.Proxy
+import Data.Int (Int64)
+------------------------------------------------------------------------------
+import qualified Network.HTTP.Types as H (Status)
+import qualified Network.HTTP.Types.Request as H
+import qualified Network.HTTP.Types.Response as H
+import qualified Network.HTTP.Types.Extra as H
+------------------------------------------------------------------------------
+import qualified Blaze.ByteString.Builder as B
+------------------------------------------------------------------------------
+import Network.Sock.Frame
+import Network.Sock.Request
+import Network.Sock.Session
+import Network.Sock.Types.Protocol
+import Network.Sock.Types.Handler
+------------------------------------------------------------------------------
+
+-- | The default Source for polling transports.
+-- It assumes that the SessionStatus MVar is empty (as it should be).
+pollingSource :: Handler tag
+ => Proxy tag -- ^ Handler tag.
+ -> Request -- ^ Request we are responsing to.
+ -> Session -- ^ Associated session.
+ -> Maybe SessionStatus -- ^ Status the session was in.
+ -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
+pollingSource tag req ses status =
+ case status of
+ Just SessionFresh -> initialize >> yieldAndFlush (format' FrameOpen) >> setOpened
+ Just SessionOpened -> liftSTM (getTMChanContents $ sessionOutgoingBuffer ses) >>= loop id
+ Just SessionClosed -> do
+ yieldAndFlush (format' $ FrameClose 3000 "Go away!")
+ setClosed
+ Nothing -> yieldAndFlush $ format' $ FrameClose 2010 "Another connection still open"
+ where loop front [] = yieldAndFlush (format' $ FrameMessages $ front []) >> setOpened
+ loop front (x:xs) =
+ case x of
+ Message s -> loop (front . (s:)) xs
+ Raw s -> yieldAndFlush s >> setOpened
+ Control Close -> do
+ -- yieldAndFlush (format' $ FrameMessages $ front []) -- ^ We mimic the way sockjs-node behaves.
+ yieldAndFlush (format' $ FrameClose 3000 "Go away!")
+ finalize >> setClosed
+
+ format' = format tag req
+ setClosed = lift $ putMVar (sessionStatus ses) SessionClosed
+ setOpened = lift $ putMVar (sessionStatus ses) SessionOpened
+ initialize = lift $ initializeSession ses $ requestApplication req
+ finalize = lift $ finalizeSession ses
+{-# INLINE pollingSource #-}
+
+-- | The default Source for streaming transports.
+-- It assumes that the SessionStatus MVar is empty (as it should be).
+streamingSource :: Handler tag
+ => Proxy tag -- ^ Handler tag.
+ -> Request -- ^ Request we are responsing to.
+ -> Int64 -- ^ Maximum amount of bytes to be transfered (we can exceed the maximum if the last message is long, but the loop will stop).
+ -> C.Source (C.ResourceT IO) (C.Flush B.Builder) -- ^ Prelude sent before any other data.
+ -> Session -- ^ Associated session.
+ -> Maybe SessionStatus -- ^ Status the session was in.
+ -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
+streamingSource tag req limit prelude ses status =
+ case status of
+ Just SessionFresh -> initialize >> prelude >> yieldOpenFrame >> loop 0
+ Just SessionOpened -> prelude >> yieldOpenFrame >> loop 0
+ Just SessionClosed -> do
+ prelude
+ yieldAndFlush (format' $ FrameClose 3000 "Go away!")
+ setClosed
+ Nothing -> prelude >> yieldAndFlush (format' $ FrameClose 2010 "Another connection still open")
+ where loop n = liftSTM (readTMChan $ sessionOutgoingBuffer ses) >>=
+ maybe (return ())
+ (\x -> do
+ case x of
+ Message s -> do
+ let load = format' (FrameMessages [s])
+ let newn = n + BL.length load
+ yieldAndFlush load
+ if newn < limit
+ then loop newn
+ else setOpened
+ Raw s -> do
+ let load = s
+ let newn = n + BL.length load
+ yieldAndFlush load
+ if newn < limit
+ then loop newn
+ else setOpened
+ Control Close -> do
+ yieldAndFlush (format' $ FrameClose 3000 "Go away!")
+ finalize >> setClosed
+ )
+ format' = format tag req
+ setClosed = lift $ putMVar (sessionStatus ses) SessionClosed
+ setOpened = lift $ putMVar (sessionStatus ses) SessionOpened
+ initialize = lift $ initializeSession ses $ requestApplication req
+ finalize = lift $ finalizeSession ses
+ yieldOpenFrame = yieldAndFlush $ format' FrameOpen
+{-# INLINE streamingSource #-}
+
+liftSTM :: MonadIO m => STM a -> m a
+liftSTM = liftIO . atomically
+{-# INLINE liftSTM #-}
+
+------------------------------------------------------------------------------
+-- | Used as a response to http://example.com/<application_prefix>/<server_id>/<session_id>/<transport>
+--
+-- Documentation: http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-7
+-- TODO: Put somewhere else.
+responseOptions :: (H.IsResponse res, H.IsRequest req)
+ => [BS.ByteString]
+ -> req
+ -> res
+responseOptions methods req = H.response204 headers ""
+ where headers = [("Access-Control-Allow-Methods", BS.intercalate ", " methods)]
+ ++ H.headerCached
+ ++ H.headerCORS "*" req
+{-# INLINE responseOptions #-}
+
+respondSource :: (H.IsResponse res, Handler tag)
+ => Proxy tag
+ -> Request
+ -> H.Status
+ -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
+ -> res
+respondSource tag req status source = H.responseSource status (headers tag req) source
+{-# INLINE respondSource #-}
+
+respondFrame :: (H.IsResponse res, Handler tag)
+ => Proxy tag
+ -> Request
+ -> H.Status
+ -> Frame
+ -> res
+respondFrame tag req st fr = respondLBS tag req st (format tag req fr)
+{-# INLINE respondFrame #-}
+
+respondLBS :: (H.IsResponse res, Handler tag)
+ => Proxy tag
+ -> Request
+ -> H.Status
+ -> BL.ByteString
+ -> res
+respondLBS tag req status body = H.responseLBS status (headers tag req) body
+{-# INLINE respondLBS #-}
+
+-- | Yields a Chunk (a ByteString) and then Flushes.
+yieldAndFlush :: Monad m => BL.ByteString -> C.Pipe l i (C.Flush B.Builder) u m ()
+yieldAndFlush load = C.yield (C.Chunk $ B.fromLazyByteString load) >> C.yield C.Flush
+{-# INLINE yieldAndFlush #-}
View
45 src/Network/Sock/Handler/EventSource.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Network.Sock.Handler.EventSource
+( EventSource
+) where
+
+------------------------------------------------------------------------------
+import Control.Concurrent.MVar.Lifted
+------------------------------------------------------------------------------
+import Data.Monoid ((<>))
+------------------------------------------------------------------------------
+import qualified Network.HTTP.Types as H (status200)
+import qualified Network.HTTP.Types.Extra as H
+------------------------------------------------------------------------------
+import Network.Sock.Types.Handler
+import Network.Sock.Frame
+import Network.Sock.Session
+import Network.Sock.Request
+import Network.Sock.Handler.Common
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- |
+data EventSource = EventSource
+
+-- | EventSource Handler represents the /eventsource route.
+-- The /eventsource route serves only to open sessions and to receive stream of incoming messages.
+instance Handler EventSource where
+ handleReuqest tag req =
+ case requestMethod req of
+ "GET" -> do
+ let prelude = yieldAndFlush "\r\n"
+ session <- getSession $ requestSessionID req
+ status <- tryTakeMVar $ sessionStatus session
+ return $ respondSource tag req H.status200 $ streamingSource tag req 4096 prelude session status
+ "OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
+ _ -> return H.response404
+
+ format _ _ fr = "data: " <> encodeFrame fr <> "\r\n\r\n"
+
+ headers _ req = H.headerEventStream
+ <> H.headerNotCached
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
View
70 src/Network/Sock/Handler/HTMLFile.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module Network.Sock.Handler.HTMLFile
+( HTMLFile
+) where
+
+------------------------------------------------------------------------------
+import Control.Concurrent.MVar.Lifted
+------------------------------------------------------------------------------
+import qualified Data.Aeson as AE
+import Data.Monoid ((<>))
+import qualified Data.ByteString as BS (ByteString)
+import qualified Data.ByteString.Extra as BS (convertBS2BL)
+import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as BL (replicate)
+------------------------------------------------------------------------------
+import qualified Network.HTTP.Types as H (status500, status200)
+import qualified Network.HTTP.Types.Extra as H
+------------------------------------------------------------------------------
+import Network.Sock.Types.Handler
+import Network.Sock.Frame
+import Network.Sock.Session
+import Network.Sock.Request
+import Network.Sock.Handler.Common
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- |
+data HTMLFile = HTMLFile
+
+-- | HTMLFile Handler represents the /htmlfile route.
+-- The /htmlfile route serves only to open sessions and to receive stream of incoming messages.
+instance Handler HTMLFile where
+ handleReuqest tag req =
+ case requestMethod req of
+ "GET" ->
+ case lookup "c" $ requestQuery req of
+ Just (Just c) -> do
+ let prelude = yieldAndFlush $ htmlHead c
+ session <- getSession $ requestSessionID req
+ status <- tryTakeMVar $ sessionStatus session
+ return $ respondSource tag req H.status200 $ streamingSource tag req 4096 prelude session status
+ Nothing -> return $ respondLBS tag req H.status500 "\"callback\" parameter required.\n"
+ "OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
+ _ -> return H.response404
+
+ format _ _ fr = "<script>\np(" <> AE.encode (encodeFrame fr) <> ");\n</script>\r\n"
+
+ headers _ req = H.headerHTML
+ <> H.headerNotCached
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
+
+htmlHead :: BS.ByteString
+ -> BL.ByteString
+htmlHead callback =
+ "<!doctype html>\n\
+ \<html><head>\n\
+ \ <meta http-equiv=\"X-UA-Compatible\" content=\"IE=edge\" />\n\
+ \ <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n\
+ \</head><body><h2>Don't panic!</h2>\n\
+ \ <script>\n\
+ \ document.domain = document.domain;\n\
+ \ var c = parent." <> BS.convertBS2BL callback <> ";\n\
+ \ c.start();\n\
+ \ function p(d) {c.message(d);};\n\
+ \ window.onload = function() {c.stop();};\n\
+ \ </script>\n" <> BL.replicate 1024 ' '
+
View
119 src/Network/Sock/Handler/JSONP.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Network.Sock.Handler.JSONP
+( JSONPPolling
+, JSONPSend
+) where
+
+------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Concurrent.STM.TMChan.Extra
+import Control.Concurrent.MVar.Lifted
+import Control.Monad.Trans (lift)
+------------------------------------------------------------------------------
+import qualified Data.Aeson as AE
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as C
+import Data.Monoid ((<>))
+import qualified Data.ByteString.Extra as BS (convertBS2BL)
+import qualified Data.ByteString.Lazy as BL (ByteString, fromChunks, splitAt)
+------------------------------------------------------------------------------
+import qualified Network.HTTP.Types as H (status500, status204, status200, urlDecode)
+import qualified Network.HTTP.Types.Extra as H
+------------------------------------------------------------------------------
+import Network.Sock.Types.Handler
+import Network.Sock.Frame
+import Network.Sock.Session
+import Network.Sock.Request
+import Network.Sock.Handler.Common
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- |
+data JSONPPolling = JSONPPolling
+
+-- | JSONPPolling Handler represents the /jsonp route.
+-- The /jsonp route serves only to open sessions and to request data from them.
+instance Handler JSONPPolling where
+ handleReuqest tag req =
+ case requestMethod req of
+ "GET" ->
+ case lookup "c" $ requestQuery req of
+ Just (Just c) -> do
+ session <- getSession $ requestSessionID req
+ status <- tryTakeMVar $ sessionStatus session
+ return $ respondSource tag req H.status200 $ pollingSource tag req session status
+ Nothing -> return $ respondLBS tag req H.status500 "\"callback\" parameter required.\n"
+ "OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
+ _ -> return H.response404
+
+ format _ req fr =
+ case lookup "c" $ requestQuery req of
+ Just (Just c) -> BS.convertBS2BL c <> "(" <> AE.encode (encodeFrame fr) <> ");\r\n"
+ _ -> "\"callback\" parameter required.\n" -- ^ This should never happen, since we check for callback before we use this function. Maybe we should pass format and headers in record ADT instead of them being part of the typeclass?
+
+ headers _ req = H.headerJS
+ <> H.headerNotCached
+ <> H.headerJSESSIONID req
+
+------------------------------------------------------------------------------
+-- |
+data JSONPSend = JSONPSend
+
+-- | JSONPPolling Handler represents the /jsonp_send route.
+-- The /jsonp_send route serves only to send data to a session (Application).
+instance Handler JSONPSend where
+ handleReuqest tag req =
+ case requestMethod req of
+ "POST" -> do
+ ms <- lookupSession $ requestSessionID req
+ case ms of
+ Nothing -> return H.response404 -- ^ Sending to non-existing session results in 404. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-79)
+ Just s -> handle s
+ "OPTIONS" -> return $! responseOptions ["OPTIONS", "POST"] req
+ _ -> return H.response404
+
+ where
+ handle session = do
+ status <- tryTakeMVar $ sessionStatus session
+ case status of
+ Just SessionFresh -> return H.response404 -- ^ This should never happen, since we do not create sessions in this handler.
+ Just SessionOpened -> do
+ res <- processIncoming session
+ putMVar (sessionStatus session) SessionOpened
+ return res
+ Just SessionClosed -> return $ respondFrame' H.status200 $ FrameClose 3000 "Go away!"
+ Nothing -> processIncoming session
+
+ processIncoming session = do
+ (empty, decoded) <- lift $ (\x -> (x == "", decode x)) <$> requestBodyConsumedJSONP req
+ case decoded of
+ Just msgs -> do
+ liftSTM $ writeTMChanList (sessionIncomingBuffer session) msgs
+ return $ respondLBS' H.status200 "ok" -- ^ Everything went OK, we respond with empty body and status 204.
+ Nothing | empty -> return $ respondLBS' H.status500 "Payload expected.\n" -- ^ If the body of request is empty, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
+ | otherwise -> return $ respondLBS' H.status500 "Broken JSON encoding.\n" -- ^ If the body of request is not valid JSON, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
+
+ decode :: BL.ByteString -> Maybe [BL.ByteString]
+ decode = AE.decode
+
+ respondLBS' = respondLBS tag req
+ respondFrame' = respondFrame tag req
+
+ format _ _ fr = encodeFrame fr <> "\n"
+
+ headers _ req = H.headerPlain
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
+
+requestBodyConsumedJSONP :: Request -> C.ResourceT IO BL.ByteString
+requestBodyConsumedJSONP req =
+ case lookup "Content-Type" $ requestHeaders req of
+ Just "application/x-www-form-urlencoded" -> do
+ (d, b) <- BL.splitAt 2 . BL.fromChunks <$> (requestBody req C.$= C.map (H.urlDecode True) C.$$ C.consume)
+ case d of
+ "d=" -> return b
+ _ -> return ""
+ _ -> requestBodyConsumed req
+
View
4 src/Network/Sock/Transport/WebSocket.hs → src/Network/Sock/Handler/WebSocket.hs
@@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-module Network.Sock.Transport.WebSocket
+module Network.Sock.Handler.WebSocket
( runApplicationWS
) where
@@ -64,7 +64,7 @@ runApplicationWS app@Application{..} ses@Session{..} req = do
-- | Kill the threads.
liftIO $ killThread atid
liftIO $ killThread stid
- closeSession ses
+ finalizeSession ses
where -- | Send data until the buffer is closed.
sendIteration sink baton = do
View
125 src/Network/Sock/Handler/XHR.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Network.Sock.Handler.XHR
+( XHRPolling
+, XHRStreaming
+, XHRSend
+) where
+
+------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Concurrent.STM.TMChan.Extra
+import Control.Concurrent.MVar.Lifted
+import Control.Monad.Trans (lift)
+------------------------------------------------------------------------------
+import qualified Data.Aeson as AE
+import Data.Monoid ((<>))
+import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as BL (replicate)
+------------------------------------------------------------------------------
+import qualified Network.HTTP.Types as H (status500, status204, status200)
+import qualified Network.HTTP.Types.Extra as H
+------------------------------------------------------------------------------
+import Network.Sock.Types.Handler
+import Network.Sock.Frame
+import Network.Sock.Session
+import Network.Sock.Request
+import Network.Sock.Handler.Common
+------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
+-- |
+data XHRPolling = XHRPolling
+
+-- | XHRPolling Handler represents the /xhr route.
+-- The /xhr route serves only to open sessions and to request data from them.
+instance Handler XHRPolling where
+ handleReuqest tag req =
+ case requestMethod req of
+ "POST" -> do
+ session <- getSession $ requestSessionID req
+ status <- tryTakeMVar $ sessionStatus session
+ return $ respondSource tag req H.status200 $ pollingSource tag req session status
+ "OPTIONS" -> return $! responseOptions ["OPTIONS", "POST"] req
+ _ -> return H.response404
+
+ format _ _ fr = encodeFrame fr <> "\n"
+
+ headers _ req = H.headerJS
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
+
+------------------------------------------------------------------------------
+-- |
+data XHRStreaming = XHRStreaming
+
+-- | XHRStreaming Handler represents the /xhr_streaming route.
+-- The /xhr_streaming route serves only to open sessions and to receive stream of incoming messages.
+instance Handler XHRStreaming where
+ handleReuqest tag req =
+ case requestMethod req of
+ "POST" -> do
+ let prelude = yieldAndFlush $ BL.replicate 2048 'h' <> "\n"
+ session <- getSession $ requestSessionID req
+ status <- tryTakeMVar $ sessionStatus session
+ return $ respondSource tag req H.status200 $ streamingSource tag req 4096 prelude session status
+ "OPTIONS" -> return $! responseOptions ["OPTIONS", "POST"] req
+ _ -> return H.response404
+
+ format _ _ fr = encodeFrame fr <> "\n"
+
+ headers _ req = H.headerJS
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
+
+------------------------------------------------------------------------------
+-- |
+data XHRSend = XHRSend
+
+-- | XHRPolling Handler represents the /xhr_send route.
+-- The /xhr_send route serves only to send data to a session (Application).
+instance Handler XHRSend where
+ handleReuqest tag req =
+ case requestMethod req of
+ "POST" -> do
+ ms <- lookupSession $ requestSessionID req
+ case ms of
+ Nothing -> return H.response404 -- ^ Sending to non-existing session results in 404. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-79)
+ Just s -> handle s
+ "OPTIONS" -> return $! responseOptions ["OPTIONS", "POST"] req
+ _ -> return H.response404
+
+ where
+ handle session = do
+ status <- tryTakeMVar $ sessionStatus session
+ case status of
+ Just SessionFresh -> return H.response404 -- ^ This should never happen, since we do not create sessions in this handler.
+ Just SessionOpened -> do
+ res <- processIncoming session
+ putMVar (sessionStatus session) SessionOpened
+ return res
+ Just SessionClosed -> return $ respondFrame' H.status200 $ FrameClose 3000 "Go away!"
+ Nothing -> processIncoming session
+
+ processIncoming session = do
+ (empty, decoded) <- lift $ (\x -> (x == "", decode x)) <$> requestBodyConsumed req
+ case decoded of
+ Just msgs -> do
+ liftSTM $ writeTMChanList (sessionIncomingBuffer session) msgs
+ return $ respondLBS' H.status204 "" -- ^ Everything went OK, we respond with empty body and status 204.
+ Nothing | empty -> return $ respondLBS' H.status500 "Payload expected.\n" -- ^ If the body of request is empty, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
+ | otherwise -> return $ respondLBS' H.status500 "Broken JSON encoding.\n" -- ^ If the body of request is not valid JSON, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
+
+ decode :: BL.ByteString -> Maybe [BL.ByteString]
+ decode = AE.decode
+
+ respondLBS' = respondLBS tag req
+ respondFrame' = respondFrame tag req
+
+ format _ _ fr = encodeFrame fr <> "\n"
+
+ headers _ req = H.headerPlain
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
+
View
34 src/Network/Sock/Session.hs
@@ -8,7 +8,8 @@ module Network.Sock.Session
, SessionID
, newSession
-, closeSession
+, initializeSession
+, finalizeSession
, insertSession
, lookupSession
@@ -22,25 +23,38 @@ import Control.Concurrent.MVar.Lifted
import qualified Control.Concurrent.MVar as MV
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TMChan
+import Control.Monad.IO.Class
import Control.Monad.Base
+import Control.Monad.Trans.Control
------------------------------------------------------------------------------
import qualified Data.HashMap.Strict as HM (insert, lookup)
------------------------------------------------------------------------------
import Network.Sock.Types.Session
import Network.Sock.Server
+import Network.Sock.Application
------------------------------------------------------------------------------
-closeSession :: MonadBase IO m
- => Session
- -> m ()
-closeSession ses@Session{..} = do
+initializeSession :: (MonadBaseControl IO m, MonadIO m)
+ => Session
+ -> Application m
+ -> m ()
+initializeSession ses app = do
+ -- TODO: Start the timers.
+ -- Start the application thread
+ forkApplication ses app
+ return ()
+
+finalizeSession :: MonadBase IO m
+ => Session
+ -> m ()
+finalizeSession ses@Session{..} = do
-- TODO: Stop the timers.
-- Stop the application thread.
liftBase $ MV.withMVar sessionApplicationThread (maybe (return ()) killThread)
-- Close the buffers.
- liftBase . atomically $ do
- closeTMChan sessionIncomingBuffer
+ liftBase . atomically $
+ closeTMChan sessionIncomingBuffer >>
closeTMChan sessionOutgoingBuffer
-- | Clever constructor. Sessions should be created using this function only.
@@ -52,7 +66,6 @@ newSession sid = Session sid <$> newMVar SessionFresh
<*> liftBase newTMChanIO
<*> newMVar Nothing
-
-- | Inserts a new Session under the given SessionID.
insertSession :: SessionID
-> Session
@@ -77,6 +90,5 @@ getSession sid = do
mms <- lookupSession sid
case mms of
Just ms -> return ms
- Nothing -> do
- s <- newSession sid
- insertSession sid s
+ Nothing -> newSession sid >>= insertSession sid
+
View
11 src/Network/Sock/Transport.hs
@@ -1,12 +1,3 @@
module Network.Sock.Transport
-( Transport(..)
-, XHRPolling
-
-, responseOptions
+(
) where
-
-------------------------------------------------------------------------------
-import Network.Sock.Types.Transport
-import Network.Sock.Transport.Utility
-import Network.Sock.Transport.XHR
-------------------------------------------------------------------------------
View
82 src/Network/Sock/Transport/EventSource.hs
@@ -1,82 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-module Network.Sock.Transport.EventSource
-( EventSource
-) where
-
-------------------------------------------------------------------------------
-import Control.Monad.Base (MonadBase, liftBase)
-import qualified Control.Monad.STM as STM (STM, atomically)
-import Control.Monad.Trans.Class (lift)
-------------------------------------------------------------------------------
-import qualified Data.Conduit as C
-import Data.Monoid ((<>))
-------------------------------------------------------------------------------
-import qualified Network.HTTP.Types as H (status200)
-import qualified Network.HTTP.Types.Response as H
-import qualified Network.HTTP.Types.Extra as H
-------------------------------------------------------------------------------
-import qualified Blaze.ByteString.Builder as B
-------------------------------------------------------------------------------
-import Network.Sock.Types.Transport
-import Network.Sock.Application
-import Network.Sock.Frame
-import Network.Sock.Session
-import Network.Sock.Server
-import Network.Sock.Request
-import Network.Sock.Transport.Streaming
-import Network.Sock.Transport.Utility
-------------------------------------------------------------------------------
-
-atomically :: MonadBase IO m => STM.STM a -> m a
-atomically = liftBase . STM.atomically
-
-------------------------------------------------------------------------------
--- |
-data EventSource = EventSource
-
--- | EventSource Transport represents the /eventsource route.
--- The /eventsource route serves only to open sessions and to receive stream of incoming messages.
-instance Transport EventSource where
- handleIncoming tag req =
- case requestMethod req of
- "GET" -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
- "OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
- _ -> return H.response404
-
- where
- handleF :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleF ses = do
- -- TODO: Start the timers.
- lift $ forkApplication app ses
- return (SessionOpened, respondSource tag req H.status200 source)
- where source = do
- C.yield $ C.Chunk $ B.fromLazyByteString $ "\r\n"
- C.yield C.Flush
- C.yield $ C.Chunk $ B.fromLazyByteString $ format tag req FrameOpen
- C.yield C.Flush
- streamSource ses
-
- handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleO = handleF
-
- handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
-
- handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return . respondFrame200 tag req $ FrameClose 2010 "Another connection still open"
-
- streamSource :: Session -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
- streamSource ses = streamingSource tag 4096 ses req
-
- sid = requestSessionID req
- app = requestApplication req
-
- format _ _ fr = "data: " <> encodeFrame fr <> "\r\n\r\n"
-
- headers _ req = H.headerEventStream
- <> H.headerNotCached
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
-
View
105 src/Network/Sock/Transport/HTMLFile.hs
@@ -1,105 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-module Network.Sock.Transport.HTMLFile
-( HTMLFile
-) where
-
-------------------------------------------------------------------------------
-import Control.Monad.Base (MonadBase, liftBase)
-import qualified Control.Monad.STM as STM (STM, atomically)
-import Control.Monad.Trans.Class (lift)
-------------------------------------------------------------------------------
-import qualified Data.Aeson as AE
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy.Char8 as BL
-import Data.ByteString.Extra
-import qualified Data.Conduit as C
-import Data.Monoid ((<>))
-------------------------------------------------------------------------------
-import qualified Network.HTTP.Types as H (status200, status500)
-import qualified Network.HTTP.Types.Response as H
-import qualified Network.HTTP.Types.Extra as H
-------------------------------------------------------------------------------
-import qualified Blaze.ByteString.Builder as B
-------------------------------------------------------------------------------
-import Network.Sock.Types.Transport
-import Network.Sock.Application
-import Network.Sock.Frame
-import Network.Sock.Session
-import Network.Sock.Server
-import Network.Sock.Request
-import Network.Sock.Transport.Streaming
-import Network.Sock.Transport.Utility
-------------------------------------------------------------------------------
-
-atomically :: MonadBase IO m => STM.STM a -> m a
-atomically = liftBase . STM.atomically
-
-------------------------------------------------------------------------------
--- |
-data HTMLFile = HTMLFile
-
--- | HTMLFile Transport represents the /htmlfile route.
--- The /htmlfile route serves only to open sessions and to receive stream of incoming messages.
-instance Transport HTMLFile where
- handleIncoming tag req =
- case requestMethod req of
- "GET" -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
- "OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
- _ -> return H.response404
-
- where
- handleF :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleF ses =
- -- TODO: Start the timers.
- case lookup "c" $ requestQuery req of
- Just (Just c) -> do
- lift $ forkApplication app ses
- return (SessionOpened, respondSource tag req H.status200 (source c))
- _ -> return $ (SessionOpened, respondLBS tag req H.status500 "\"callback\" parameter required.\n")
- where source c = do
- C.yield $ C.Chunk $ htmlHead c
- C.yield C.Flush
- C.yield $ C.Chunk $ B.fromLazyByteString $ format tag req FrameOpen
- C.yield C.Flush
- streamSource ses
-
- handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleO = handleF
-
- handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
-
- handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return $ respondFrame200 tag req $ FrameClose 2010 "Another connection still open"
-
- streamSource :: Session -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
- streamSource ses = streamingSource tag 4096 ses req
-
- sid = requestSessionID req
- app = requestApplication req
-
- format _ _ fr = "<script>\np(" <> AE.encode (encodeFrame fr) <> ");\n</script>\r\n"
-
- headers _ req = H.headerHTML
- <> H.headerNotCached
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
-
-htmlHead :: BS.ByteString
- -> B.Builder
-htmlHead callback = B.fromLazyByteString $
- "<!doctype html>\n\
- \<html><head>\n\
- \ <meta http-equiv=\"X-UA-Compatible\" content=\"IE=edge\" />\n\
- \ <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n\
- \</head><body><h2>Don't panic!</h2>\n\
- \ <script>\n\
- \ document.domain = document.domain;\n\
- \ var c = parent." <> convertBS2BL callback <> ";\n\
- \ c.start();\n\
- \ function p(d) {c.message(d);};\n\
- \ window.onload = function() {c.stop();};\n\
- \ </script>\n" <> BL.replicate 1024 ' '
-
View
149 src/Network/Sock/Transport/JSONP.hs
@@ -1,149 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-module Network.Sock.Transport.JSONP
-( JSONPPolling
-, JSONPSend
-) where
-
-------------------------------------------------------------------------------
-import Control.Applicative
-import Control.Concurrent.STM.TMChan.Extra
-import Control.Monad
-import Control.Monad.Base (MonadBase, liftBase)
-import qualified Control.Monad.STM as STM (STM, atomically)
-import Control.Monad.Trans.Class (lift)
-------------------------------------------------------------------------------
-import qualified Data.Aeson as AE
-import qualified Data.Conduit as C
-import qualified Data.Conduit.List as C
-import Data.Monoid ((<>))
-import Data.ByteString.Extra
-import qualified Data.ByteString.Lazy as BL (ByteString, fromChunks, splitAt)
-------------------------------------------------------------------------------
-import qualified Network.HTTP.Types as H (status500, status200, urlDecode)
-import qualified Network.HTTP.Types.Response as H
-import qualified Network.HTTP.Types.Extra as H
-------------------------------------------------------------------------------
-import Network.Sock.Types.Transport
-import Network.Sock.Application
-import Network.Sock.Frame
-import Network.Sock.Protocol
-import Network.Sock.Session
-import Network.Sock.Server
-import Network.Sock.Request
-import Network.Sock.Transport.Utility
-------------------------------------------------------------------------------
-
-atomically :: MonadBase IO m => STM.STM a -> m a
-atomically = liftBase . STM.atomically
-
-------------------------------------------------------------------------------
--- |
-data JSONPPolling = JSONPPolling
-
--- | JSONPPolling Transport represents the /jsonp route.
--- The /jsonp route serves only to open sessions and to request data from them.
-instance Transport JSONPPolling where
- handleIncoming tag req =
- case requestMethod req of
- "GET" ->
- case lookup "c" $ requestQuery req of
- Just _ -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
- Nothing -> return $ respondLBS tag req H.status500 "\"callback\" parameter required.\n"
- "OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
- _ -> return H.response404
-
- where
- handleF :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleF ses = do
- -- TODO: Start the timers.
- lift $ forkApplication app ses
- return (SessionOpened, respondFrame200 tag req FrameOpen)
-
- handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleO ses = do
- -- TODO: Reset the timeout timer.
- (msgs, rest) <- span isMessage <$> atomically (getTMChanContents $ sessionOutgoingBuffer ses)
- when (null msgs || not (null rest))
- (closeSession ses)
- case msgs of
- [] -> return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!") -- This should not happen since it means that the channel is closed.
- xs | not $ null rest -> return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
- | otherwise -> return (SessionOpened, respondFrame200 tag req $ FrameMessages (map fromMessage xs))
-
- handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
-
- handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return . respondFrame200 tag req $ FrameClose 2010 "Another connection still open"
-
- sid = requestSessionID req
- app = requestApplication req
-
- format _ req fr =
- case lookup "c" $ requestQuery req of
- Just (Just c) -> convertBS2BL c <> "(" <> AE.encode (encodeFrame fr) <> ");\r\n"
- _ -> "\"callback\" parameter required.\n"
-
- headers _ req = H.headerJS
- <> H.headerNotCached
- <> H.headerJSESSIONID req
-
-------------------------------------------------------------------------------
--- |
-data JSONPSend = JSONPSend
-
--- | JSONPPolling Transport represents the /jsonp_send route.
--- The /jsonp_send route serves only to send data to a session (Application).
-instance Transport JSONPSend where
- handleIncoming tag req =
- case requestMethod req of
- "POST" -> do
- ms <- lookupSession sid
- case ms of
- Nothing -> return H.response404 -- ^ Sending to non-existing session results in 404. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-79)
- Just s -> handleByStatus tag handleF handleO handleC handleW s
- "OPTIONS" -> return $! responseOptions ["OPTIONS", "POST"] req
- _ -> return H.response404
-
- where
- -- | It should never come to this handler, since JSONPSend never creates a session.
- handleF :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleF = handleC
-
- handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleO ses = (\x -> (SessionOpened, x)) <$> handleW ses
-
- handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
-
- handleW :: H.IsResponse res => Session -> Server res
- handleW ses = do
- body <- lift $
- case lookup "Content-Type" $ requestHeaders req of
- Just "application/x-www-form-urlencoded" -> do
- (d, b) <- BL.splitAt 2 . BL.fromChunks <$> (requestBody req C.$= C.map (H.urlDecode True) C.$$ C.consume)
- case d of
- "d=" -> return b
- _ -> return ""
- _ -> requestBodyConsumed req
- case decode body of
- Just xs -> do
- atomically $ writeTMChanList (sessionIncomingBuffer ses) xs
- return $ respondLBS tag req H.status200 "ok"
- Nothing | body == "" -> return $ respondLBS tag req H.status500 "Payload expected.\n" -- If the body of request is empty, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
- | otherwise -> return $ respondLBS tag req H.status500 "Broken JSON encoding.\n" -- If the body of request is not valid JSON, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
-
- decode :: BL.ByteString -> Maybe [BL.ByteString]
- decode = AE.decode
-
- sid = requestSessionID req
- app = requestApplication req
-
- format _ _ fr = encodeFrame fr <> "\n"
-
- headers _ req = H.headerPlain
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
-
View
34 src/Network/Sock/Transport/Polling.hs
@@ -1,34 +0,0 @@
-module Network.Sock.Transport.Polling
-(
-) where
-
-------------------------------------------------------------------------------
-import Control.Concurrent.STM
-import Control.Concurrent.STM.TMChan
-import Control.Monad
-import Control.Monad.Trans (MonadIO, liftIO)
-------------------------------------------------------------------------------
-import qualified Data.ByteString.Lazy as BL (length)
-import qualified Data.Conduit as C
-import qualified Data.Conduit.List.Extra as C
-import Data.Int (Int64)
-import Data.Proxy
-------------------------------------------------------------------------------
-import qualified Blaze.ByteString.Builder as B
-------------------------------------------------------------------------------
-import Network.Sock.Request
-import Network.Sock.Session
-import Network.Sock.Types.Frame
-import Network.Sock.Types.Protocol
-import Network.Sock.Types.Transport
-------------------------------------------------------------------------------
-
-pollingSource :: Transport tag
- => Proxy tag
- -> Session
- -> Request
- -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
-pollingSource ses req = undefined
-
-
-{-# INLINE pollingSource #-}
View
60 src/Network/Sock/Transport/Streaming.hs
@@ -1,60 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Network.Sock.Transport.Streaming
-( streamingSource
-) where
-
-------------------------------------------------------------------------------
-import Control.Concurrent.STM
-import Control.Concurrent.STM.TMChan
-import Control.Monad
-import Control.Monad.Trans (MonadIO, liftIO)
-------------------------------------------------------------------------------
-import qualified Data.ByteString.Lazy as BL (length)
-import qualified Data.Conduit as C
-import Data.Int (Int64)
-import Data.Proxy
-------------------------------------------------------------------------------
-import qualified Blaze.ByteString.Builder as B
-------------------------------------------------------------------------------
-import Network.Sock.Request
-import Network.Sock.Session
-import Network.Sock.Types.Frame
-import Network.Sock.Types.Protocol
-import Network.Sock.Types.Transport
-------------------------------------------------------------------------------
-
-streamingSource :: Transport tag
- => Proxy tag
- -> Int64
- -> Session
- -> Request
- -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
-streamingSource tag limit ses req = loop 0
- where loop n = liftSTM (readTMChan $ sessionOutgoingBuffer ses) >>=
- maybe (return ())
- (\x ->
- case x of
- Message s -> do
- let load = format tag req (FrameMessages [s])
- let newn = n + BL.length load
- C.yield $ C.Chunk $ B.fromLazyByteString load
- C.yield C.Flush
- when (newn < limit) $ loop newn
- Raw s -> do
- let load = s
- let newn = n + BL.length load
- C.yield $ C.Chunk $ B.fromLazyByteString load
- C.yield C.Flush
- when (newn < limit) $ loop newn
- Control Close -> do
- let load = format tag req (FrameClose 3000 "Go away!")
- C.yield $ C.Chunk $ B.fromLazyByteString load
- C.yield C.Flush
- closeSession ses
- _ -> return ()
- )
-{-# INLINE streamingSource #-}
-
-liftSTM :: MonadIO m => STM a -> m a
-liftSTM = liftIO . atomically
View
95 src/Network/Sock/Transport/Utility.hs
@@ -1,95 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Network.Sock.Transport.Utility
-( respondFrame
-, respondFrame200
-, respondLBS
-, respondSource
-, handleByStatus
-
-, responseOptions
-) where
-
-------------------------------------------------------------------------------
-import Control.Concurrent.MVar.Extra.Lifted
-------------------------------------------------------------------------------
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.ByteString as BS
-import qualified Data.Conduit as C
-import Data.Proxy
-------------------------------------------------------------------------------
-import qualified Network.HTTP.Types as H (Status, status200)
-import qualified Network.HTTP.Types.Request as H
-import qualified Network.HTTP.Types.Response as H
-import qualified Network.HTTP.Types.Extra as H
-------------------------------------------------------------------------------
-import qualified Blaze.ByteString.Builder as B
-------------------------------------------------------------------------------
-import Network.Sock.Frame
-import Network.Sock.Request
-import Network.Sock.Server
-import Network.Sock.Session
-import Network.Sock.Types.Transport
-------------------------------------------------------------------------------
-
-------------------------------------------------------------------------------
--- | Used as a response to http://example.com/<application_prefix>/<server_id>/<session_id>/<transport>
---
--- Documentation: http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-7
-responseOptions :: (H.IsResponse res, H.IsRequest req)
- => [BS.ByteString]
- -> req
- -> res
-responseOptions methods req = H.response204 headers ""
- where headers = [("Access-Control-Allow-Methods", BS.intercalate ", " methods)]
- ++ H.headerCached
- ++ H.headerCORS "*" req
-
-
-respondFrame :: (H.IsResponse res, Transport tag)
- => Proxy tag
- -> Request
- -> H.Status
- -> Frame
- -> res
-respondFrame tag req st fr = respondLBS tag req st (format tag req fr)
-
-respondFrame200 :: (H.IsResponse res, Transport tag)
- => Proxy tag
- -> Request
- -> Frame
- -> res
-respondFrame200 tag req = respondFrame tag req H.status200
-
-respondLBS :: (H.IsResponse res, Transport tag)
- => Proxy tag
- -> Request
- -> H.Status
- -> BL.ByteString
- -> res
-respondLBS tag req status body = H.responseLBS status (headers tag req) body
-
-respondSource :: (H.IsResponse res, Transport tag)
- => Proxy tag
- -> Request
- -> H.Status
- -> (C.Source (C.ResourceT IO) (C.Flush B.Builder))
- -> res
-respondSource tag req status source = H.responseSource status (headers tag req) source
-
-handleByStatus :: (H.IsResponse res, Transport tag)
- => Proxy tag
- -> (Session -> Server (SessionStatus, res)) -- ^ SessionFresh handler
- -> (Session -> Server (SessionStatus, res)) -- ^ SessionOpened handler
- -> (Session -> Server (SessionStatus, res)) -- ^ SessionClosed handler
- -> (Session -> Server res) -- ^ Handler for when the session is "Waiting", that is the session status MVar is empty.
- -> Session
- -> Server res
-handleByStatus tag handleF handleO handleC handleW ses =
- mvar (handleW ses) -- The MVar is empty, which means there is another connection still open.
- (\s -> case s of
- SessionFresh -> handleF ses
- SessionOpened -> handleO ses
- SessionClosed -> handleC ses
- ) $ sessionStatus ses
View
186 src/Network/Sock/Transport/XHR.hs
@@ -1,186 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-module Network.Sock.Transport.XHR
-( XHRPolling
-, XHRStreaming
-, XHRSend
-) where
-
-------------------------------------------------------------------------------
-import Control.Applicative
-import Control.Concurrent.STM.TMChan.Extra
-import Control.Monad
-import Control.Monad.Base (MonadBase, liftBase)
-import qualified Control.Monad.STM as STM (STM, atomically)
-import Control.Monad.Trans.Class (lift)
-------------------------------------------------------------------------------
-import qualified Data.Aeson as AE
-import qualified Data.Conduit as C
-import Data.Monoid ((<>))
-import qualified Data.ByteString.Lazy as BL (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as BL (replicate)
-------------------------------------------------------------------------------
-import qualified Network.HTTP.Types as H (status500, status204, status200)
-import qualified Network.HTTP.Types.Response as H
-import qualified Network.HTTP.Types.Extra as H
-------------------------------------------------------------------------------
-import qualified Blaze.ByteString.Builder as B
-------------------------------------------------------------------------------
-import Network.Sock.Types.Transport
-import Network.Sock.Application
-import Network.Sock.Frame
-import Network.Sock.Protocol
-import Network.Sock.Session
-import Network.Sock.Server
-import Network.Sock.Request
-import Network.Sock.Transport.Streaming
-import Network.Sock.Transport.Utility
-------------------------------------------------------------------------------
-
-atomically :: MonadBase IO m => STM.STM a -> m a
-atomically = liftBase . STM.atomically
-
-------------------------------------------------------------------------------
--- |
-data XHRPolling = XHRPolling
-
--- | XHRPolling Transport represents the /xhr route.
--- The /xhr route serves only to open sessions and to request data from them.
-instance Transport XHRPolling where
- handleIncoming tag req =
- case requestMethod req of
- "POST" -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
- "OPTIONS" -> return $! responseOptions ["OPTIONS", "POST"] req
- _ -> return H.response404
-
- where
- handleF :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleF ses = do
- -- TODO: Start the timers.
- lift $ forkApplication app ses
- return (SessionOpened, respondFrame200 tag req FrameOpen)
-
- handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleO ses = do
- -- TODO: Reset the timeout timer.
- (msgs, rest) <- span isMessage <$> atomically (getTMChanContents $ sessionOutgoingBuffer ses)
- when (null msgs || not (null rest))
- (closeSession ses)
- case msgs of
- [] -> return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!") -- This should not happen since it means that the channel is closed.
- xs | not $ null rest -> return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
- | otherwise -> return (SessionOpened, respondFrame200 tag req $ FrameMessages (map fromMessage xs))
-
- handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
-
- handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return . respondFrame200 tag req $ FrameClose 2010 "Another connection still open"
-
- sid = requestSessionID req
- app = requestApplication req
-
- format _ _ fr = encodeFrame fr <> "\n"
-
- headers _ req = H.headerJS
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
-
-------------------------------------------------------------------------------
--- |
-data XHRStreaming = XHRStreaming
-
--- | XHRStreaming Transport represents the /xhr_streaming route.
--- The /xhr_streaming route serves only to open sessions and to receive stream of incoming messages.
-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"] req
- _ -> return H.response404
-
- where
- handleF :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleF ses = do
- -- TODO: Start the timers.
- lift $ forkApplication app ses
- return (SessionOpened, respondSource tag req H.status200 source)
- where source = do
- C.yield $ C.Chunk $ B.fromLazyByteString $ BL.replicate 2048 'h' <> "\n"
- C.yield C.Flush
- C.yield $ C.Chunk $ B.fromLazyByteString $ format tag req FrameOpen
- C.yield C.Flush
- streamSource ses
-
- handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleO = handleF
-
- handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
-
- handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return . respondFrame200 tag req $ FrameClose 2010 "Another connection still open"
-
- streamSource :: Session -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
- streamSource ses = streamingSource tag 4096 ses req
-
- sid = requestSessionID req
- app = requestApplication req
-
- format _ _ fr = encodeFrame fr <> "\n"
-
- headers _ req = H.headerJS
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
-
-------------------------------------------------------------------------------
--- |
-data XHRSend = XHRSend
-
--- | XHRPolling Transport represents the /xhr_send route.
--- The /xhr_send route serves only to send data to a session (Application).
-instance Transport XHRSend where
- handleIncoming tag req =
- case requestMethod req of
- "POST" -> do
- ms <- lookupSession sid
- case ms of
- Nothing -> return H.response404 -- ^ Sending to non-existing session results in 404. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-79)
- Just s -> handleByStatus tag handleF handleO handleC handleW s
- "OPTIONS" -> return $! responseOptions ["OPTIONS", "POST"] req
- _ -> return H.response404
-
- where
- -- | It should never come to this handler, since XHRSend never creates a session.
- handleF :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleF = handleC
-
- handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleO ses = (\x -> (SessionOpened, x)) <$> handleW ses
-
- handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
-
- handleW :: H.IsResponse res => Session -> Server res
- handleW ses = do
- (body, cont) <- lift $ (\x -> (x, decode x)) <$> requestBodyConsumed req
- case cont of
- Just xs -> do
- atomically $ writeTMChanList (sessionIncomingBuffer ses) xs
- return $ respondLBS tag req H.status204 ""
- Nothing | body == "" -> return $ respondLBS tag req H.status500 "Payload expected." -- If the body of request is empty, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
- | otherwise -> return $ respondLBS tag req H.status500 "Broken JSON encoding." -- If the body of request is not valid JSON, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
-
- decode :: BL.ByteString -> Maybe [BL.ByteString]
- decode = AE.decode
-
- sid = requestSessionID req
- app = requestApplication req
-
- format _ _ fr = encodeFrame fr <> "\n"
-
- headers _ req = H.headerPlain
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
-
View
16 src/Network/Sock/Types/Transport.hs → src/Network/Sock/Types/Handler.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
-module Network.Sock.Types.Transport
-( Transport(..)
+module Network.Sock.Types.Handler
+( Handler(..)
) where
------------------------------------------------------------------------------
@@ -18,12 +18,12 @@ import Network.Sock.Types.Server
import Network.Sock.Types.Request
------------------------------------------------------------------------------
--- | Transport
-class Transport tag where
- handleIncoming :: H.IsResponse res
- => Proxy tag
- -> Request
- -> Server res
+-- | Handler
+class Handler tag where
+ handleReuqest :: H.IsResponse res
+ => Proxy tag
+ -> Request
+ -> Server res
-- | Formats the Frame (different protocols may format frames differently).
format :: H.IsRequest req

0 comments on commit 309768d

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