Init

LICENSE

@@ -1,4 +1,4 @@
-Copyright (c) 2011, Palmik, yihuang
+Copyright (c) 2011, Palmik
 
 All rights reserved.
 

src/Network/Wai/Sock/Application.hs

@@ -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]
+    }

src/Network/Wai/Sock/Environment.hs

@@ -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)
+
+
+

src/Network/Wai/Sock/Frame.hs

@@ -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

src/Network/Wai/Sock/Handler.hs

@@ -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

src/Network/Wai/Sock/Server.hs

@@ -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"
+              }

src/Network/Wai/Sock/Session.hs

@@ -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".