Permalink
Browse files

Init

  • Loading branch information...
1 parent f1ce1d8 commit 2f23c822413af31f71958428155ae6f904840fbd @Palmik committed Jun 21, 2012
View
@@ -1,4 +1,4 @@
-Copyright (c) 2011, Palmik, yihuang
+Copyright (c) 2011, Palmik
All rights reserved.
@@ -1,11 +1,19 @@
module Network.Wai.Sock.Application
-( Application
+( Application(..)
+, ApplicationSettings(..)
) where
------------------------------------------------------------------------------
-import qualified Data.ByteString.Lazy as LB (ByteString)
-import qualified Data.ByteString as SB (ByteString)
-import qualified Data.Conduit as C (Source, Sink)
+import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.Conduit as C (Source, Sink)
+import qualified Data.Text as TS (Text)
------------------------------------------------------------------------------
-type Application m = C.Source m LB.ByteString -> C.Sink LB.ByteString m () -> m ()
+data Application m = Application
+ { applicationDefinition :: C.Source m BL.ByteString -> C.Sink BL.ByteString m () -> m ()
+ , applicationSettings :: ApplicationSettings
+ }
+
+data ApplicationSettings = ApplicationSettings
+ { appSettingsPrefix :: [TS.Text]
+ }
@@ -0,0 +1,60 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Network.Wai.Sock.Environment
+( Environment
+) where
+
+------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Concurrent.MVar.Lifted
+import Control.Monad.Base
+import Control.Monad.Trans.Control
+------------------------------------------------------------------------------
+import qualified Data.ByteString.Lazy as LB (ByteString)
+import qualified Data.Conduit as C (Source, Sink)
+import qualified Data.HashMap.Strict as HM (HashMap, insert, lookup)
+------------------------------------------------------------------------------
+import Network.Wai.Sock.Session
+------------------------------------------------------------------------------
+
+newtype Environment = Environment
+ { envSessions :: MVar (HM.HashMap SessionID (MVar Session))
+ }
+
+addSession :: MonadBaseControl IO m
+ => SessionID
+ -> Session
+ -> Environment
+ -> m ()
+addSession sid s Environment{..} = do
+ ms <- newMVar s
+ modifyMVar_ envSessions (return . HM.insert sid ms)
+
+-- | Applies the given function on session with given ID and saves the new value.
+-- If session with the supplied ID does not exist, it's virtually no-op.
+modifySession :: MonadBaseControl IO m
+ => (Session -> m Session)
+ -> SessionID
+ -> Environment
+ -> m ()
+modifySession f sid Environment{..} = withMVar envSessions go
+ where go smap = case HM.lookup sid smap of
+ Just ms -> modifyMVar_ ms f
+ Nothing -> return ()
+
+
+-- | Retrieves session with the given ID, if there is no such session, it's created first.
+getSession :: MonadBaseControl IO m
+ => SessionID
+ -> Environment
+ -> m (MVar Session)
+getSession sid Environment{..} = modifyMVar envSessions go
+ where go smap = case HM.lookup sid smap of
+ Just ms -> return (smap, ms)
+ Nothing -> do
+ ms <- newSession sid >>= newMVar
+ return (HM.insert sid ms smap, ms)
+
+
+
@@ -0,0 +1,13 @@
+module Network.Wai.Sock.Frame
+( Frame(..)
+) where
+
+------------------------------------------------------------------------------
+import qualified Data.Text as TS (Text, unpack)
+------------------------------------------------------------------------------
+
+data Frame
+ = FrameOpen
+ | FrameHeartbeat
+ | FrameMessage TS.Text
+ | FrameClose Int TS.Text
@@ -1,3 +1,6 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
module Network.Wai.Sock.Handler
(
) where
@@ -8,25 +11,117 @@ import System.Random (randomRIO)
import Control.Applicative
import Control.Monad.IO.Class
------------------------------------------------------------------------------
-import qualified Data.Aeson as AE (encode)
+import qualified Data.Aeson as AE (encode, object)
+import Data.Aeson ((.=))
import qualified Data.Binary as BI (encode)
-import qualified Data.ByteString.Lazy as LB (ByteString, toChunks)
-import qualified Data.ByteString as SB (ByteString, empty)
+import qualified Data.ByteString.Lazy as BL (ByteString, toChunks, fromChunks)
+import qualified Data.ByteString as BS (ByteString, empty, concat)
import Data.Digest.Pure.MD5 (md5)
import Data.Int (Int64)
import Data.Maybe
import Data.Monoid
-import qualified Data.Text as ST (Text, isPrefixOf, isSuffixOf)
+import qualified Data.Text as TS (Text, isPrefixOf, isSuffixOf)
+import qualified Data.Text.Encoding as TS (encodeUtf8)
------------------------------------------------------------------------------
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder.ByteString as B (fromLazyByteString)
import qualified Blaze.ByteString.Builder.Char.Utf8 as B (fromString, fromLazyText)
------------------------------------------------------------------------------
import qualified Network.HTTP.Types as H
-import qualified Network.Wai as W (Application)
+import qualified Network.Wai as W (Application, Request(..), Response(..), responseLBS)
------------------------------------------------------------------------------
import Network.Wai.Sock.Application
+import Network.Wai.Sock.Environment
+import Network.Wai.Sock.Frame
+import Network.Wai.Sock.Server
+import Network.Wai.Sock.Session
+------------------------------------------------------------------------------
+
+sock :: Environment -> ([TS.Text] -> Maybe (Application m, [TS.Text], [TS.Text])) -> W.Application
+sock mvsm r req = undefined
+
+------------------------------------------------------------------------------
+-- | Standard responses (greeting, info, iframe)
+
+responseGreeting :: W.Response
+responseGreeting = response200 headerPlain "Welcome to SockJS!\n"
+
+responseIframe :: ServerSettings -- ^ Server Settings
+ -> W.Request
+ -> W.Response
+responseIframe ServerSettings{..} req =
+ case lookup "If-None-Match" (W.requestHeaders req) of
+ (Just s) | s == hashed -> response304
+ _ -> response200 headers content
+ where
+ content =
+ "<!DOCTYPE html>\n\
+ \<html>\n\
+ \<head>\n\
+ \ <meta http-equiv=\"X-UA-Compatible\" content=\"IE=edge\" />\n\
+ \ <meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n\
+ \ <script>\n\
+ \ document.domain = document.domain;\n\
+ \ _sockjs_onload = function(){SockJS.bootstrap_iframe();};\n\
+ \ </script>\n\
+ \ <script src=\"" <> convertTS2BL serverSettingsSockURL <> "\"></script>\n\
+ \</head>\n\
+ \<body>\n\
+ \ <h2>Don't panic!</h2>\n\
+ \ <p>This is a SockJS hidden iframe. It's used for cross domain magic.</p>\n\
+ \</body>\n\
+ \</html>"
+ hashed = convertBL2BS . BI.encode $ md5 content
+ headers = headerHTML ++ headerCache ++ headerETag hashed
+
+responseInfo :: ServerSettings -- ^ Server Settings
+ -> Int64 -- ^ Entropy
+ -> W.Response
+responseInfo ServerSettings{..} ent = response200 headerJSON . AE.encode $ AE.object
+ [ "websocket" .= serverSettingsWebsocketsEnabled
+ , "cookie_needed" .= serverSettingsCookiesNeeded
+ , "origins" .= serverSettingsAllowedOrigins
+ , "entropy" .= ent
+ ]
+
------------------------------------------------------------------------------
+-- | Response utility functions.
+
+response404 :: W.Response
+response404 = W.responseLBS H.status404 headerPlain mempty
+
+response200 :: H.ResponseHeaders -> BL.ByteString -> W.Response
+response200 = W.responseLBS H.status200
+
+response304 :: W.Response
+response304 = W.responseLBS H.status304 [] mempty
+
+------------------------------------------------------------------------------
+-- | Header utility functions.
+
+headerPlain :: H.ResponseHeaders
+headerPlain = [("Content-Type", "text/plain; charset=UTF-8")]
+
+headerHTML :: H.ResponseHeaders
+headerHTML = [("Content-Type", "text/html; charset=UTF-8")]
+
+headerJSON :: H.ResponseHeaders
+headerJSON = [("Content-Type", "application/json; charset=UTF-8")]
+
+headerCache :: H.ResponseHeaders
+headerCache = [("Cache-Control", "public; max-age=31536000;"),("Expires", "31536000")]
+
+headerETag :: H.Ascii -> H.ResponseHeaders
+headerETag etag = [("ETag", etag)]
+
+------------------------------------------------------------------------------
+-- | Other utility functions.
+
+convertBS2BL :: BS.ByteString -> BL.ByteString
+convertBS2BL = BL.fromChunks . (:[])
+
+convertBL2BS :: BL.ByteString -> BS.ByteString
+convertBL2BS = BS.concat . BL.toChunks
-handler :: Monad m => (ST.Text -> Application m) -> W.Application
-handler = undefined
+convertTS2BL :: TS.Text -> BL.ByteString
+convertTS2BL = convertBS2BL . TS.encodeUtf8
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Network.Wai.Sock.Server
+( ServerSettings(..)
+) where
+
+------------------------------------------------------------------------------
+import qualified Data.Text as TS (Text)
+import Data.Default
+------------------------------------------------------------------------------
+
+data ServerSettings = ServerSettings
+ { serverSettingsWebsocketsEnabled :: Bool
+ , serverSettingsCookiesNeeded :: Bool
+ , serverSettingsAllowedOrigins :: TS.Text
+ , serverSettingsSockURL :: TS.Text
+ , serverSettingsSockVersion :: TS.Text
+ }
+
+instance Default ServerSettings where
+ def = ServerSettings
+ { serverSettingsWebsocketsEnabled = True
+ , serverSettingsCookiesNeeded = True
+ , serverSettingsAllowedOrigins = "*:*"
+ , serverSettingsSockURL = "http://cdn.sockjs.org/sockjs-0.3.min.js"
+ , serverSettingsSockVersion = "0.3"
+ }
@@ -0,0 +1,40 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Network.Wai.Sock.Session
+( Session(..)
+, SessionStatus(..)
+, SessionID
+
+, newSession
+) where
+
+------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Concurrent.Chan.Lifted
+import Control.Monad.Base
+------------------------------------------------------------------------------
+import qualified Data.ByteString.Lazy as BL (ByteString)
+import qualified Data.ByteString as BS (ByteString)
+import qualified Data.Conduit as C (Source, Sink)
+import qualified Data.Text as TS (Text)
+------------------------------------------------------------------------------
+
+newSession :: MonadBase IO m
+ => SessionID
+ -> m Session
+newSession sid = Session sid SessionFresh <$> newChan
+
+data Session = Session
+ { sessionID :: SessionID
+ , sessionStatus :: SessionStatus
+ , sessionIncomingBuffer :: Chan BS.ByteString
+ }
+
+-- | SessionID
+type SessionID = TS.Text
+
+-- | SessionStatus
+data SessionStatus
+ = SessionFresh -- ^ Right after creation, Session is "Fresh"
+ | SessionOpened -- ^ Right after we send opening frame, Session is "Opened". We also start the timeout & heartbeat timer at this point.
+ | SessionClosed -- ^ Right after we send closing frame, Session if "Closed".
View
@@ -1,44 +0,0 @@
-<html>
- <head>
- <title>Haskell Sockjs example</title>
- <script type="text/JavaScript"
- src="http://code.jquery.com/jquery-1.6.3.min.js"></script>
- <script type="text/JavaScript"
- src="sockjs.js"></script>
- <script type="text/JavaScript" src="client.js"></script>
- <link rel="stylesheet" type="text/css" href="screen.css"></script>
- </head>
- <body>
- <h1>Haskell Sockjs example</h1>
- <div id="main">
- <div id="warnings">
- </div>
- <div id="join-section">
- <h2>Join</h2>
- <form id="join-form" action="">
- <label for="user">Username: </label>
- <input id="user" type="text" size="12" />
- <input id="send" type="submit" value="Join" />
- </form>
- </div>
- <div id="users-section" style="display: none">
- <h2>Users</h2>
- <ul id="users">
- </ul>
- </div>
- <div id="chat-section" style="display: none">
- <h2>Chat</h2>
- <div id="messages">
- </div>
- <br />
- <form id="message-form" action="">
- <input id="text" type="text" size="40" />
- <input id="send" type="submit" value="Send" />
- </form>
- </div>
- </div>
- <div id="footer">
- Source code available <a href="https://github.com/yihuang/wai-sockjs/blob/master/Apps.hs">here</a>, origin websockets version available <a href="http://github.com/jaspervdj/websockets/tree/master/example">here</a>
- </div>
- </body>
-</html>
Oops, something went wrong.

0 comments on commit 2f23c82

Please sign in to comment.