Permalink
Browse files

For now disabled WebSockets. Added JSONP and EventSource transports.

  • Loading branch information...
Palmik committed Jul 11, 2012
1 parent dd01968 commit d6514dd293ccf6b045f05ca806df90373c83eab4
View
@@ -32,12 +32,14 @@ library
, 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.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
@@ -14,6 +14,7 @@ module Network.HTTP.Types.Extra
, headerJSON
, headerJSESSIONID
, headerJS
+, headerEventStream
, headerPlain
) where
@@ -32,17 +33,17 @@ import Web.Cookie as H
------------------------------------------------------------------------------
-- | Response utility functions.
-response200 :: H.ResponseHeaders -> BL.ByteString -> H.Response
-response200 = H.response H.status200
+response200 :: H.IsResponse res => H.ResponseHeaders -> BL.ByteString -> res
+response200 = H.responseLBS H.status200
-response204 :: H.ResponseHeaders -> BL.ByteString -> H.Response
-response204 = H.response H.status204
+response204 :: H.IsResponse res => H.ResponseHeaders -> BL.ByteString -> res
+response204 = H.responseLBS H.status204
-response304 :: H.Response
-response304 = H.response H.status304 [] mempty
+response304 :: H.IsResponse res => res
+response304 = H.responseLBS H.status304 [] mempty
-response404 :: H.Response
-response404 = H.response H.status404 headerPlain mempty
+response404 :: H.IsResponse res => res
+response404 = H.responseLBS H.status404 headerPlain mempty
------------------------------------------------------------------------------
-- | Header utility functions.
@@ -65,16 +66,19 @@ headerJSON = [("Content-Type", "application/json; charset=UTF-8")]
headerJS :: H.ResponseHeaders
headerJS = [("Content-Type", "application/javascript; charset=UTF-8")]
+headerEventStream :: H.ResponseHeaders
+headerEventStream = [("Content-Type", "text/event-stream; charset=UTF-8")]
+
headerPlain :: H.ResponseHeaders
headerPlain = [("Content-Type", "text/plain; charset=UTF-8")]
-headerJSESSIONID :: H.Request -> H.ResponseHeaders
+headerJSESSIONID :: H.IsRequest req => req -> H.ResponseHeaders
headerJSESSIONID req = [("Set-Cookie", "JSESSIONID=" <> jsessionID <> "; path=/")]
where jsessionID = fromMaybe "dummy" $
lookup "Cookie" (H.requestHeaders req) >>=
lookup "JSESSIONID" . H.parseCookies
-headerCORS :: BS.ByteString -> H.Request -> H.ResponseHeaders
+headerCORS :: H.IsRequest req => BS.ByteString -> req -> H.ResponseHeaders
headerCORS def req = allowHeaders ++ allowOrigin ++ allowCredentials
where allowCredentials = [("Access-Control-Allow-Credentials", "true")]
allowHeaders =
@@ -1,17 +1,26 @@
module Network.HTTP.Types.Request
-( Request(..)
+( IsRequest(..)
+, requestBodyConsumed
) where
------------------------------------------------------------------------------
-import qualified Data.ByteString.Lazy as BL (ByteString)
+import Control.Applicative
+------------------------------------------------------------------------------
+import qualified Data.ByteString as BS (ByteString)
+import qualified Data.ByteString.Lazy as BL (ByteString, fromChunks)
+import qualified Data.Conduit as C
+import qualified Data.Conduit.List as C
import qualified Data.Text as TS (Text)
------------------------------------------------------------------------------
import Network.HTTP.Types
------------------------------------------------------------------------------
-data Request = Request
- { requestMethod :: Method
- , requestHeaders :: RequestHeaders
- , requestPath :: [TS.Text]
- , requestBody :: BL.ByteString
- }
+class IsRequest req where
+ requestMethod :: req -> Method
+ requestHeaders :: req -> RequestHeaders
+ requestQuery :: req -> Query
+ requestPath :: req -> [TS.Text]
+ requestBody :: req -> C.Source (C.ResourceT IO) BS.ByteString
+
+requestBodyConsumed :: IsRequest req => req -> C.ResourceT IO BL.ByteString
+requestBodyConsumed req = BL.fromChunks <$> (requestBody req C.$$ C.consume)
@@ -1,20 +1,25 @@
module Network.HTTP.Types.Response
-( Response(..)
-, response
+( IsResponse(..)
+, responseLBS
) where
------------------------------------------------------------------------------
import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.Conduit as C (Source, ResourceT, Flush)
+------------------------------------------------------------------------------
+import qualified Blaze.ByteString.Builder as B
------------------------------------------------------------------------------
import Network.HTTP.Types
------------------------------------------------------------------------------
-data Response = Response
- { responseStatus :: Status
- , responseHeaders :: ResponseHeaders
- , responseBody :: BL.ByteString
- }
+class IsResponse res where
+ responseBuilder :: Status -> ResponseHeaders -> B.Builder -> res
+ responseSource :: Status -> ResponseHeaders -> (C.Source (C.ResourceT IO) (C.Flush B.Builder)) -> res
-response :: Status -> ResponseHeaders -> BL.ByteString -> Response
-response = Response
+responseLBS :: IsResponse res
+ => Status
+ -> ResponseHeaders
+ -> BL.ByteString
+ -> res
+responseLBS s h = responseBuilder s h . B.fromLazyByteString
View
@@ -1,25 +1,53 @@
module Network.Sock
-( send
+( message
+, close
+
+, mapMessage
+
+, send
, receive
) where
------------------------------------------------------------------------------
import Data.ByteString.Lazy as BL
import Data.Conduit as C
+import Data.Conduit.List as C
+------------------------------------------------------------------------------
+import Network.Sock.Protocol
------------------------------------------------------------------------------
-import Network.Sock.Message
+
------------------------------------------------------------------------------
+-- |
+
+message :: Monad m
+ => BL.ByteString
+ -> C.Pipe i Protocol m ()
+message = C.yield . Message
+
+close :: Monad m
+ => C.Pipe i Protocol m ()
+close = C.yield $ Control Close
+------------------------------------------------------------------------------
+-- |
+
+mapMessage :: Monad m
+ => C.Conduit BL.ByteString m Protocol
+mapMessage = C.map Message
+
+------------------------------------------------------------------------------
+-- |
+
receive :: Monad m
=> C.Source m BL.ByteString
-> m (Maybe BL.ByteString)
receive source = source C.$$ C.await
send :: Monad m
- => C.Sink Message m ()
- -> Message
+ => C.Sink Protocol m ()
+ -> BL.ByteString
-> m ()
-send sink m = C.yield m C.$$ sink
+send sink m = C.yield (Message m) C.$$ sink
@@ -35,12 +35,14 @@ import Network.Sock.Server
import Network.Sock.Session
import Network.Sock.Transport
import Network.Sock.Transport.XHR
+import Network.Sock.Transport.JSONP
import Network.Sock.Transport.WebSocket
+import Network.Sock.Transport.EventSource
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- |
-sock :: H.Request -> Server H.Response
+sock :: (H.IsRequest req, H.IsResponse res) => req -> Server res
sock req = do
router <- getServerApplicationRouter
case router $ H.requestPath req of
@@ -59,9 +61,10 @@ sockWS state req = do
------------------------------------------------------------------------------
-- |
-handleSubroutes :: Application (C.ResourceT IO)
- -> H.Request
- -> Server H.Response
+handleSubroutes :: (H.IsRequest req, H.IsResponse res)
+ => Application (C.ResourceT IO)
+ -> req
+ -> Server res
handleSubroutes app req =
case (H.requestMethod req, suffix) of
-- TODO: Add OPTIONS response.
@@ -85,19 +88,20 @@ handleSubroutes app req =
-- | 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-36 and the following sections.
-responseTransport :: TS.Text
+responseTransport :: H.IsResponse res
+ => TS.Text
-> Request
- -> Server H.Response
+ -> Server res
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
- "xhr_send" -> handle (Proxy :: Proxy XHRSend) -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-74
- "xhr_streaming" -> return H.response404 -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-83
- "eventsource" -> return H.response404 -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-91
+ "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
- "jsonp" -> return H.response404 -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-108
- "jsonp_send" -> return H.response404 -- http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-108
+ "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
@@ -108,16 +112,17 @@ responseTransport trans req =
-- * http://example.com/<application_prefix>
--
-- Documentation: http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-12
-responseGreeting :: H.Response
+responseGreeting :: H.IsResponse res => res
responseGreeting = H.response200 H.headerPlain "Welcome to SockJS!\n"
------------------------------------------------------------------------------
-- | Used as a response to http://example.com/<application_prefix>/iframe*.html
--
-- Documentation: http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-15
-responseIframe :: ApplicationSettings
- -> H.Request
- -> H.Response
+responseIframe :: (H.IsRequest req, H.IsResponse res)
+ => ApplicationSettings
+ -> req
+ -> res
responseIframe appSet req = go . convertTS2BL $ settingsSockURL appSet
where
go url = case lookup "If-None-Match" (H.requestHeaders req) of
@@ -148,9 +153,10 @@ responseIframe appSet req = go . convertTS2BL $ settingsSockURL appSet
-- | Used as a response to http://example.com/info
--
-- Documentation: http://sockjs.github.com/sockjs-protocol/sockjs-protocol-0.3.html#section-26
-responseInfo :: ApplicationSettings
- -> H.Request
- -> Server H.Response
+responseInfo :: (H.IsRequest req, H.IsResponse res)
+ => ApplicationSettings
+ -> req
+ -> Server res
responseInfo appSet req = do
ent <- liftIO $ randomRIO ((0, 4294967295) :: (Int, Int))
return . H.response200 (H.headerJSON <> H.headerNotCached <> H.headerCORS "*" req) . AE.encode $ AE.object
@@ -1,32 +0,0 @@
-module Network.Sock.Message
-( Message(..)
-, ControlMessage(..)
-
-, isDataMessage
-, isControlMessage
-, isCloseSessionMessage
-
-, fromDataMessage
-) where
-
-------------------------------------------------------------------------------
-import qualified Data.ByteString.Lazy as BL
-------------------------------------------------------------------------------
-import Network.Sock.Types.Message
-------------------------------------------------------------------------------
-
-fromDataMessage :: Message -> BL.ByteString
-fromDataMessage (DataMessage x) = x
-fromDataMessage _ = error "fromDataMessage used on ControlMessage"
-
-isControlMessage :: Message -> Bool
-isControlMessage (ControlMessage _) = True
-isControlMessage _ = False
-
-isDataMessage :: Message -> Bool
-isDataMessage (DataMessage _) = True
-isDataMessage _ = False
-
-isCloseSessionMessage :: Message -> Bool
-isCloseSessionMessage (ControlMessage CloseSession) = True
-isCloseSessionMessage _ = False
@@ -0,0 +1,24 @@
+module Network.Sock.Protocol
+( Protocol(..)
+, ProtocolControl(..)
+
+, isMessage
+, 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
+
+fromMessage :: Protocol -> BL.ByteString
+fromMessage (Message s) = s
+fromMessage _ = error "Used fromMessage on non-message."
+
@@ -4,28 +4,21 @@ module Network.Sock.Request
, requestMethod
, requestHeaders
, requestPath
+, requestQuery
, requestBody
+, requestBodyConsumed
) where
------------------------------------------------------------------------------
-import qualified Data.ByteString.Lazy as BL (ByteString)
-import qualified Data.Text as TS (Text)
-------------------------------------------------------------------------------
-import qualified Network.HTTP.Types as H (RequestHeaders, Method)
-import qualified Network.HTTP.Types.Request as H
+import Network.HTTP.Types.Request
------------------------------------------------------------------------------
import Network.Sock.Types.Request
------------------------------------------------------------------------------
-requestMethod :: Request -> H.Method
-requestMethod = H.requestMethod . requestRaw
-
-requestHeaders :: Request -> H.RequestHeaders
-requestHeaders = H.requestHeaders . requestRaw
-
-requestPath :: Request -> [TS.Text]
-requestPath = H.requestPath . requestRaw
-
-requestBody :: Request -> BL.ByteString
-requestBody = H.requestBody . requestRaw
+instance IsRequest Request where
+ requestMethod (Request raw _ _) = requestMethod raw
+ requestHeaders (Request raw _ _) = requestHeaders raw
+ requestQuery (Request raw _ _) = requestQuery raw
+ requestPath (Request raw _ _) = requestPath raw
+ requestBody (Request raw _ _) = requestBody raw
Oops, something went wrong.

0 comments on commit d6514dd

Please sign in to comment.