Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added HTMLFIle transport.

  • Loading branch information...
commit fe1a2e82fee0bd4fa3c862fef090dc331eedcaae 1 parent 87d26a2
@Palmik authored
View
13 README.md
@@ -1,12 +1,15 @@
## About
+This project is still work in progress.
+
## Other implementations
There are other SockJS implementations for Haskell (under construction), the two I know of are:
-https://github.com/yihuang/wai-sockjs
-https://github.com/bitonic/sockjs-haskell
+* https://github.com/yihuang/wai-sockjs
+* https://github.com/bitonic/sockjs-haskell
+
+This project was originally fork of Yihuang's work (check out [this branch](https://github.com/Palmik/wai-sockjs/tree/old)).
+I have also toyed with Bitonic's code (check out [this branch](https://github.com/Palmik/wai-sockjs/tree/old2)).
-This project was originally fork of Yihuang's work (you can find that code on the branch 'old').
-I have also toyed with Bitonic's code (you can that code on the branch 'old2').
-Now the project is independent of these two.
+I have borrowed some of their ideas, but the project itself is a rewrite from the ground up.
View
4 sock.cabal
@@ -29,6 +29,7 @@ library
, Control.Concurrent.MVar.Extra.Lifted
, Control.Concurrent.STM.TMChan.Extra
, Data.ByteString.Extra
+ , Data.Conduit.List.Extra
, Network.Sock.Application
, Network.Sock.Frame
, Network.Sock.Handler
@@ -36,6 +37,8 @@ library
, Network.Sock.Request
, Network.Sock.Session
, Network.Sock.Transport.XHR
+ , Network.Sock.Transport.Streaming
+ , Network.Sock.Transport.Polling
, Network.Sock.Transport.WebSocket
, Network.Sock.Types.Application
, Network.Sock.Types.Frame
@@ -72,6 +75,7 @@ library
, tagged == 0.4.*
, transformers
, transformers-base == 0.4.*
+ , timers == 0.1.*
, unordered-containers == 0.2.*
, vector
, wai == 1.3.*
View
67 src/Data/Conduit/List/Extra.hs
@@ -0,0 +1,67 @@
+module Data.Conduit.List.Extra
+( isolateWhile
+, ignoreWhile
+, takeWhile
+, dropWhile
+) where
+
+import Prelude hiding (takeWhile, dropWhile)
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as C
+
+-- | Constructs list from upstream values while the predicate holds (and while there are any values left).
+-- If you want to pipe the values instead of accumulating them, use isolateWhile.
+-- This function is semantically equivalent to:
+--
+-- > isolateWhile pr =$ consume
+--
+takeWhile :: Monad m => (a -> Bool) -> C.Sink a m [a]
+takeWhile pr = isolateWhile pr C.=$ C.consume
+
+-- | Constructs list from upstream values, discarding them while the predicate holds (and while there are any values left).
+-- This function is semantically equivalent to:
+--
+-- > takeWhile pr >> return ()
+--
+-- This function is consistent with `Data.Conduit.List.drop`, if you want it
+-- to be consistent with `Data.List.drop` instead use:
+--
+-- > dropWhile pr >> consume
+--
+-- Or alternatively:
+--
+-- > ignoreWhile pr =$ consume
+--
+dropWhile :: Monad m => (a -> Bool) -> C.Sink a m ()
+dropWhile pr = loop
+ where loop = C.await >>= maybe (return ())
+ (\val -> if pr val
+ then loop
+ else C.leftover val
+ )
+
+-- | Ignores the values from upstream while the predicate holds, after that pipes all the values. Complement to `isolateWhile`.
+-- Example:
+--
+-- >>> sourceList [1..10] $= ignoreWhile (< 3) $$ consume
+-- [3,4,5,6,7,8,9,10]
+ignoreWhile :: Monad m => (a -> Bool) -> C.Conduit a m a
+ignoreWhile pr = loop
+ where loop = C.await >>= maybe (return ())
+ (\val -> if pr val
+ then loop
+ else C.leftover val >> C.awaitForever C.yield
+ )
+
+-- | Pipes all the the values from upstream while the predicate holds. Complement to `ignoreWhile`.
+-- Example:
+--
+-- >>> sourceList [1..10] $= isolateWhile (< 3) $$ consume
+-- [1, 2]
+isolateWhile :: Monad m => (a -> Bool) -> C.Conduit a m a
+isolateWhile pr = loop
+ where loop = C.await >>= maybe (return ())
+ (\val -> if pr val
+ then C.yield val >> loop
+ else C.leftover val
+ )
View
3  src/Network/Sock/Handler.hs
@@ -35,6 +35,7 @@ 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
@@ -99,7 +100,7 @@ responseTransport trans req =
"xhr_streaming" -> handle (Proxy :: Proxy XHRStreaming) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-83
"xhr_send" -> handle (Proxy :: Proxy XHRSend) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-74
"eventsource" -> handle (Proxy :: Proxy EventSource) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-91
- "htmlfile" -> return H.response404 -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-100
+ "htmlfile" -> handle (Proxy :: Proxy HTMLFile) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-100
"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
View
7 src/Network/Sock/Protocol.hs
@@ -3,21 +3,24 @@ module Network.Sock.Protocol
, ProtocolControl(..)
, isMessage
+, isRaw
, fromMessage
) where
------------------------------------------------------------------------------
import qualified Data.ByteString.Lazy as BL
-import Data.Proxy
------------------------------------------------------------------------------
import Network.Sock.Types.Protocol
-import Network.Sock.Types.Transport
------------------------------------------------------------------------------
isMessage :: Protocol -> Bool
isMessage (Message _) = True
isMessage _ = False
+isRaw :: Protocol -> Bool
+isRaw (Raw _) = True
+isRaw _ = False
+
fromMessage :: Protocol -> BL.ByteString
fromMessage (Message s) = s
fromMessage _ = error "Used fromMessage on non-message."
View
62 src/Network/Sock/Transport/EventSource.hs
@@ -6,15 +6,12 @@ module Network.Sock.Transport.EventSource
) where
------------------------------------------------------------------------------
-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.Conduit as C
-import qualified Data.Conduit.TMChan as C (sourceTMChan)
-import Data.Monoid ((<>))
-import qualified Data.ByteString.Lazy as BL (ByteString, length)
+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
@@ -25,10 +22,10 @@ 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
------------------------------------------------------------------------------
@@ -44,7 +41,7 @@ data EventSource = EventSource
instance Transport EventSource where
handleIncoming tag req =
case requestMethod req of
- "GET" -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
+ "GET" -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
"OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
_ -> return H.response404
@@ -53,60 +50,33 @@ instance Transport EventSource where
handleF ses = do
-- TODO: Start the timers.
lift $ forkApplication app ses
- return (SessionOpened, respond tag H.responseSource H.status200 source req)
+ 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 FrameOpen req
+ 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
- streamSource :: Session -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
- streamSource ses = C.sourceTMChan (sessionOutgoingBuffer ses) C.$= loop 0
- where loop n = C.await >>=
- maybe (return ())
- (\x ->
- case x of
- Message s -> do
- let load = format tag (FrameMessages [s]) req
- 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 (FrameClose 3000 "Go away!") req
- C.yield $ C.Chunk $ B.fromLazyByteString load
- C.yield C.Flush
- closeSession ses
- _ -> closeSession ses
- )
- limit = 4096
-
-
-
handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req)
+ handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return $ respondFrame200 tag (FrameClose 2010 "Another connection still open") req
+ 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"
+ format _ _ fr = "data: " <> encodeFrame fr <> "\r\n\r\n"
- respond _ f st str req = f st headers str
- where headers = H.headerEventStream
- <> H.headerNotCached
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
+ headers _ req = H.headerEventStream
+ <> H.headerNotCached
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
View
105 src/Network/Sock/Transport/HTMLFile.hs
@@ -0,0 +1,105 @@
+{-# 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
40 src/Network/Sock/Transport/JSONP.hs
@@ -50,7 +50,7 @@ instance Transport JSONPPolling where
"GET" ->
case lookup "c" $ requestQuery req of
Just _ -> getSession sid >>= handleByStatus tag handleF handleO handleC handleW
- Nothing -> return $ respondLBS tag H.status500 "\"callback\" parameter required.\n" req
+ Nothing -> return $ respondLBS tag req H.status500 "\"callback\" parameter required.\n"
"OPTIONS" -> return $! responseOptions ["OPTIONS", "GET"] req
_ -> return H.response404
@@ -59,7 +59,7 @@ instance Transport JSONPPolling where
handleF ses = do
-- TODO: Start the timers.
lift $ forkApplication app ses
- return (SessionOpened, respondFrame200 tag FrameOpen req)
+ return (SessionOpened, respondFrame200 tag req FrameOpen)
handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
handleO ses = do
@@ -68,28 +68,27 @@ instance Transport JSONPPolling where
when (null msgs || not (null rest))
(closeSession ses)
case msgs of
- [] -> return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req) -- This should not happen since it means that the channel is closed.
- xs | not $ null rest -> return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req)
- | otherwise -> return (SessionOpened, respondFrame200 tag (FrameMessages (map fromMessage xs)) req)
+ [] -> 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 (FrameClose 3000 "Go away!") req)
+ handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return $ respondFrame200 tag (FrameClose 2010 "Another connection still open") req
+ handleW _ = return . respondFrame200 tag req $ FrameClose 2010 "Another connection still open"
sid = requestSessionID req
app = requestApplication req
- format _ fr 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"
- respond _ f st str req = f st headers str
- where headers = H.headerJS
- <> H.headerNotCached
- <> H.headerJSESSIONID req
+ headers _ req = H.headerJS
+ <> H.headerNotCached
+ <> H.headerJSESSIONID req
------------------------------------------------------------------------------
-- |
@@ -117,7 +116,7 @@ instance Transport JSONPSend where
handleO ses = (\x -> (SessionOpened, x)) <$> handleW ses
handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req)
+ handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
handleW :: H.IsResponse res => Session -> Server res
handleW ses = do
@@ -132,9 +131,9 @@ instance Transport JSONPSend where
case decode body of
Just xs -> do
atomically $ writeTMChanList (sessionIncomingBuffer ses) xs
- return $ respondLBS tag H.status200 "ok" req
- Nothing | body == "" -> return $ respondLBS tag H.status500 "Payload expected.\n" req -- 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 H.status500 "Broken JSON encoding.\n" req -- If the body of request is not valid JSON, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
+ 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
@@ -142,10 +141,9 @@ instance Transport JSONPSend where
sid = requestSessionID req
app = requestApplication req
- format _ fr _ = encodeFrame fr <> "\n"
+ format _ _ fr = encodeFrame fr <> "\n"
- respond _ f st str req = f st headers str
- where headers = H.headerPlain
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
+ headers _ req = H.headerPlain
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
View
34 src/Network/Sock/Transport/Polling.hs
@@ -0,0 +1,34 @@
+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
@@ -0,0 +1,60 @@
+{-# 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
26 src/Network/Sock/Transport/Utility.hs
@@ -5,6 +5,7 @@ module Network.Sock.Transport.Utility
( respondFrame
, respondFrame200
, respondLBS
+, respondSource
, handleByStatus
, responseOptions
@@ -15,6 +16,7 @@ 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)
@@ -22,6 +24,8 @@ 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
@@ -45,26 +49,34 @@ responseOptions methods req = H.response204 headers ""
respondFrame :: (H.IsResponse res, Transport tag)
=> Proxy tag
+ -> Request
-> H.Status
-> Frame
- -> Request
-> res
-respondFrame tag st fr req = respondLBS tag st (format tag fr req) req
+respondFrame tag req st fr = respondLBS tag req st (format tag req fr)
respondFrame200 :: (H.IsResponse res, Transport tag)
=> Proxy tag
- -> Frame
-> Request
+ -> Frame
-> res
-respondFrame200 tag = respondFrame tag H.status200
+respondFrame200 tag req = respondFrame tag req H.status200
respondLBS :: (H.IsResponse res, Transport tag)
=> Proxy tag
- -> H.Status
- -> BL.ByteString
-> Request
+ -> H.Status
+ -> BL.ByteString
-> res
-respondLBS tag = respond tag H.responseLBS
+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
View
92 src/Network/Sock/Transport/XHR.hs
@@ -17,10 +17,8 @@ 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 qualified Data.Conduit.TMChan as C (sourceTMChan)
import Data.Monoid ((<>))
-import qualified Data.ByteString.Lazy as BL (ByteString, length)
+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)
@@ -36,6 +34,7 @@ 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
------------------------------------------------------------------------------
@@ -60,7 +59,7 @@ instance Transport XHRPolling where
handleF ses = do
-- TODO: Start the timers.
lift $ forkApplication app ses
- return (SessionOpened, respondFrame200 tag FrameOpen req)
+ return (SessionOpened, respondFrame200 tag req FrameOpen)
handleO :: H.IsResponse res => Session -> Server (SessionStatus, res)
handleO ses = do
@@ -69,25 +68,24 @@ instance Transport XHRPolling where
when (null msgs || not (null rest))
(closeSession ses)
case msgs of
- [] -> return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req) -- This should not happen since it means that the channel is closed.
- xs | not $ null rest -> return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req)
- | otherwise -> return (SessionOpened, respondFrame200 tag (FrameMessages (map fromMessage xs)) req)
+ [] -> 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 (FrameClose 3000 "Go away!") req)
+ handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return $ respondFrame200 tag (FrameClose 2010 "Another connection still open") req
+ handleW _ = return . respondFrame200 tag req $ FrameClose 2010 "Another connection still open"
sid = requestSessionID req
app = requestApplication req
- format _ fr _ = encodeFrame fr <> "\n"
+ format _ _ fr = encodeFrame fr <> "\n"
- respond _ f st str req = f st headers str
- where headers = H.headerJS
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
+ headers _ req = H.headerJS
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
------------------------------------------------------------------------------
-- |
@@ -107,61 +105,34 @@ instance Transport XHRStreaming where
handleF ses = do
-- TODO: Start the timers.
lift $ forkApplication app ses
- return (SessionOpened, respond tag H.responseSource H.status200 source req)
+ 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 FrameOpen req
+ 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
- streamSource :: Session -> C.Source (C.ResourceT IO) (C.Flush B.Builder)
- streamSource ses = C.sourceTMChan (sessionOutgoingBuffer ses) C.$= loop 0
- where loop n = C.await >>=
- maybe (return ())
- (\x ->
- case x of
- Message s -> do
- let load = format tag (FrameMessages [s]) req
- 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 (FrameClose 3000 "Go away!") req
- C.yield $ C.Chunk $ B.fromLazyByteString load
- C.yield C.Flush
- closeSession ses
- _ -> closeSession ses
- )
- limit = 4096
-
-
-
handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req)
+ handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
handleW :: H.IsResponse res => Session -> Server res
- handleW _ = return $ respondFrame200 tag (FrameClose 2010 "Another connection still open") req
+ 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"
+ format _ _ fr = encodeFrame fr <> "\n"
- respond _ f st str req = f st headers str
- where headers = H.headerJS
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
+ headers _ req = H.headerJS
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
------------------------------------------------------------------------------
-- |
@@ -189,7 +160,7 @@ instance Transport XHRSend where
handleO ses = (\x -> (SessionOpened, x)) <$> handleW ses
handleC :: H.IsResponse res => Session -> Server (SessionStatus, res)
- handleC _ = return (SessionClosed, respondFrame200 tag (FrameClose 3000 "Go away!") req)
+ handleC _ = return (SessionClosed, respondFrame200 tag req $ FrameClose 3000 "Go away!")
handleW :: H.IsResponse res => Session -> Server res
handleW ses = do
@@ -197,9 +168,9 @@ instance Transport XHRSend where
case cont of
Just xs -> do
atomically $ writeTMChanList (sessionIncomingBuffer ses) xs
- return $ respondLBS tag H.status204 "" req
- Nothing | body == "" -> return $ respondLBS tag H.status500 "Payload expected." req -- 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 H.status500 "Broken JSON encoding." req -- If the body of request is not valid JSON, report it. (http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-80)
+ 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
@@ -207,10 +178,9 @@ instance Transport XHRSend where
sid = requestSessionID req
app = requestApplication req
- format _ fr _ = encodeFrame fr <> "\n"
+ format _ _ fr = encodeFrame fr <> "\n"
- respond _ f st str req = f st headers str
- where headers = H.headerPlain
- <> H.headerCORS "*" req
- <> H.headerJSESSIONID req
+ headers _ req = H.headerPlain
+ <> H.headerCORS "*" req
+ <> H.headerJSESSIONID req
View
2  src/Network/Sock/Types/Request.hs
@@ -15,7 +15,7 @@ import Network.Sock.Types.Application
-- | Request wrapper type.
data Request where
- Request :: H.IsRequest req =>
+ Request :: H.IsRequest req =>
{ requestRaw :: req
, requestSessionID :: SessionID
, requestApplication :: Application (C.ResourceT IO)
View
31 src/Network/Sock/Types/Transport.hs
@@ -9,7 +9,7 @@ module Network.Sock.Types.Transport
import qualified Data.ByteString.Lazy as BL (ByteString)
import Data.Proxy
------------------------------------------------------------------------------
-import qualified Network.HTTP.Types as H (Status, ResponseHeaders)
+import qualified Network.HTTP.Types as H (ResponseHeaders)
import qualified Network.HTTP.Types.Response as H (IsResponse(..))
import qualified Network.HTTP.Types.Request as H (IsRequest(..))
------------------------------------------------------------------------------
@@ -28,34 +28,11 @@ class Transport tag where
-- | Formats the Frame (different protocols may format frames differently).
format :: H.IsRequest req
=> Proxy tag
- -> Frame
-> req
+ -> Frame
-> BL.ByteString
-- | Used to create a response (headers might be transport & request dependent).
- respond :: H.IsResponse res
- => Proxy tag
- -> (H.Status -> H.ResponseHeaders -> a -> res)
- -> H.Status
- -> a
+ headers :: Proxy tag
-> Request
- -> res
-
- {-
- -- | Used for _ => 'Application' communication.
- -- Awaits a message from the Session's buffer (or empties the whole buffer if there are multiple messages in it).
- -- In case of WebSocket, we call receive (WS is the only transport why this function is neccessary).
- -- The '_' could stand for e.g. some web app communication with out server Application
- -- This function is used to create the Source for the 'Application'.
- receive :: Proxy tag
- -> Session
- -> Server [BL.ByteString]
-
- -- | Used for 'Application' => _ communication
- -- The '_' could stand for e.g. some web app communication with out server Application
- -- This function is used to create the Sink for the 'Application'.
- send :: Proxy tag
- -> Session
- -> BL.ByteString
- -> Server ()
- -}
+ -> H.ResponseHeaders
View
1  src/Test.hs
@@ -19,7 +19,6 @@ import qualified Network.Sock.Application as S
import qualified Network.Sock.Server as S
import qualified Network.Sock.Protocol as S
import qualified Network.Wai.Sock as S
-import Network.Wai.Handler.Warp as W
------------------------------------------------------------------------------
close = S.Application
Please sign in to comment.
Something went wrong with that request. Please try again.