socketio 0.1.1 → 0.1.2
raw patch · 10 files changed
+171/−137 lines, 10 filesdep +scientificdep +vectordep ~HUnitdep ~QuickCheckdep ~aeson
Dependencies added: scientific, vector
Dependency ranges changed: HUnit, QuickCheck, aeson, ansi-terminal, base, bytestring, http-types, lifted-base, monad-control, mtl, parsec, random, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers-base, unordered-containers, wai, warp
Files
- Web/SocketIO.hs +2/−0
- Web/SocketIO/Connection.hs +17/−18
- Web/SocketIO/Event.hs +23/−5
- Web/SocketIO/Log.hs +38/−0
- Web/SocketIO/Session.hs +11/−11
- Web/SocketIO/Timeout.hs +4/−4
- Web/SocketIO/Types/Base.hs +9/−9
- Web/SocketIO/Types/Event.hs +24/−10
- Web/SocketIO/Util.hs +0/−38
- socketio.cabal +43/−42
Web/SocketIO.hs view
@@ -40,6 +40,8 @@ , Subscriber(..) , Publisher(..) , reply+ , msg+ , msg' , getEventName , HasSessionID(..) , EventName
Web/SocketIO/Connection.hs view
@@ -12,7 +12,7 @@ import Web.SocketIO.Session import Web.SocketIO.Timeout import Web.SocketIO.Types-import Web.SocketIO.Util+import Web.SocketIO.Log -------------------------------------------------------------------------------- import Control.Applicative ((<$>))@@ -54,7 +54,6 @@ lookupSession sessionID = do tableRef <- getSessionTableRef table <- liftIO (readIORef tableRef)- --debug Debug $ sessionID <> " [Session] Lookup" return (H.lookup sessionID table) --------------------------------------------------------------------------------@@ -99,8 +98,8 @@ -- session table management updateSession (H.insert sessionID session)- debugLog Debug session "[Session] Created"- debugLog Debug session "[Request] Handshake"+ logWithSessionID Debug sessionID "[Session] Created"+ logWithSessionID Debug sessionID "[Request] Handshake" -- timeout setTimeout session@@ -121,45 +120,45 @@ return $ Session sessionID Connecting channelHub listeners timeoutVar handleConnection (Connect sessionID, Just (session, Connecting)) = do- debugLog Debug session "[Request] Connect: ACK"+ logWithSessionID Debug sessionID "[Request] Connect: ACK" extendTimeout session let session' = session { sessionState = Connected } updateSession (H.insert sessionID session') runSession SessionConnect session' -handleConnection (Connect _, Just (session, Connected)) = do- debugLog Debug session "[Request] Connect: Polling"+handleConnection (Connect sessionID, Just (session, Connected)) = do+ logWithSessionID Debug sessionID "[Request] Connect: Polling" extendTimeout session runSession SessionPolling session handleConnection (Connect sessionID, Nothing) = do- debug Warn $ sessionID <> " [Request] Connect: Session not found" + logWithSessionID Warn sessionID "[Request] Connect: Session not found" return $ MsgError NoEndpoint NoData handleConnection (Disconnect sessionID, Just (session, _)) = do - debugLog Debug session "[Request] Disconnect: By client"+ logWithSessionID Debug sessionID "[Request] Disconnect: By client" clearTimeout session updateSession (H.delete sessionID)- debugLog Debug session "[Session] Destroyed"+ logWithSessionID Debug sessionID "[Session] Destroyed" runSession SessionDisconnectByClient session handleConnection (Disconnect sessionID, Nothing) = do- debug Warn $ sessionID <> " [Request] Disconnect: Session not found" + logWithSessionID Warn sessionID "[Request] Disconnect: Session not found" return MsgNoop -handleConnection (Emit _ _, Just (session, Connecting)) = do+handleConnection (Emit sessionID _, Just (session, Connecting)) = do extendTimeout session- debugLog Warn session "[Request] Emit: Session still connecting, not ACKed" + logWithSessionID Warn sessionID "[Request] Emit: Session still connecting, not ACKed" return $ MsgError NoEndpoint NoData -handleConnection (Emit _ event@(Event eventName payloads), Just (session, Connected)) = do- debugLog Debug session $ "[Request] Emit: " <> serialize eventName <> " " <> serialize payloads+handleConnection (Emit sessionID event@(Event eventName (Payload payloads)), Just (session, Connected)) = do+ logWithSessionID Debug sessionID $ "[Request] Emit: " <> serialize eventName <> " " <> serialize payloads runSession (SessionEmit event) session -handleConnection (Emit _ NoEvent, Just (session, Connected)) = do- debugLog Warn session $ "[Request] Emit: event malformed"+handleConnection (Emit sessionID NoEvent, Just (_, Connected)) = do+ logWithSessionID Warn sessionID "[Request] Emit: event malformed" return $ MsgError NoEndpoint NoData handleConnection (Emit sessionID _, Nothing) = do- debug Warn $ sessionID <> " [Request] Emit: Session not found" + logWithSessionID Warn sessionID "[Request] Emit: Session not found" return $ MsgError NoEndpoint NoData
Web/SocketIO/Event.hs view
@@ -8,20 +8,38 @@ import Web.SocketIO.Types ---------------------------------------------------------------------------------import Control.Applicative ((<$>))-import Control.Monad.Reader+import Control.Applicative ((<$>))+import Control.Monad.Reader+import qualified Data.ByteString.Lazy as BL +{-# DEPRECATED reply "use msg instead" #-} --------------------------------------------------------------------------------+-- | This function is deprecated; use 'msg' instead+reply :: CallbackM [Text]+reply = do+ Payload p <- callbackEnvPayload <$> ask+ return p++-------------------------------------------------------------------------------- -- | Extracts payload carried by the event -- -- @ -- `on` \"echo\" $ do--- payload <- reply+-- payload <- msg -- liftIO $ print payload -- emit "echo" payload -- @-reply :: CallbackM [Text]-reply = callbackEnvPayload <$> ask+msg :: CallbackM [Text]+msg = do+ Payload p <- callbackEnvPayload <$> ask+ return p++--------------------------------------------------------------------------------+-- | Lazy ByteString version of `msg`, convenient for Aeson decoding.+msg' :: CallbackM [BL.ByteString]+msg' = do+ Payload p <- callbackEnvPayload <$> ask+ return (map serialize p) -------------------------------------------------------------------------------- -- | Name of the event
+ Web/SocketIO/Log.hs view
@@ -0,0 +1,38 @@+--------------------------------------------------------------------------------+-- | Exports some logging utilities.+{-# LANGUAGE OverloadedStrings #-}++module Web.SocketIO.Log ((<>), logRaw, logWithSession, logWithSessionID) where++--------------------------------------------------------------------------------+import Web.SocketIO.Types++--------------------------------------------------------------------------------+import Control.Concurrent.Chan+import Control.Monad.Trans (liftIO, MonadIO)+ +--------------------------------------------------------------------------------+-- | Write log to channel according to log level and configurations+logRaw :: (Functor m, MonadIO m, ConnectionLayer m) => (ByteString -> Log) -> ByteString -> m ()+logRaw logType message = do+ logLevel' <- fmap logLevel getConfiguration+ logChannel <- fmap envLogChannel getEnv+ if level <= logLevel' then liftIO $ writeChan logChannel (serialize log') else return ()+ where log' = logType message+ levelOf (Error _) = 0+ levelOf (Warn _) = 1+ levelOf (Info _) = 2+ levelOf (Debug _) = 3+ level = levelOf log' ++--------------------------------------------------------------------------------+-- | Attaches `Web.SocketIO.Types.Base.SessionID`+logWithSessionID :: (Functor m, MonadIO m, ConnectionLayer m) => (ByteString -> Log) -> SessionID -> ByteString -> m ()+logWithSessionID logType sessionID message = logRaw logType (sessionID <> " " <> serialize message) ++--------------------------------------------------------------------------------+-- | Attaches `Web.SocketIO.Types.Base.SessionID` automatically+logWithSession :: (Functor m, MonadIO m, ConnectionLayer m, SessionLayer m) => (ByteString -> Log) -> ByteString -> m ()+logWithSession logType message = do+ Session sessionID _ _ _ _ <- getSession+ logRaw logType $ fromByteString (sessionID <> " " <> message)
Web/SocketIO/Session.hs view
@@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- import Web.SocketIO.Types-import Web.SocketIO.Util+import Web.SocketIO.Log -------------------------------------------------------------------------------- import Control.Monad.Reader @@ -33,7 +33,7 @@ handleSession SessionConnect = do- debugSession Info $ "Connected"+ logWithSession Info $ "Connected" return $ MsgConnect NoEndpoint handleSession SessionPolling = do@@ -45,16 +45,16 @@ case result of -- private Just (Private, Event eventName payloads) -> do- debugSession Info $ "Emit: " <> serialize eventName+ logWithSession Info $ "Emit: " <> serialize eventName return $ MsgEvent NoID NoEndpoint (Event eventName payloads) -- broadcast Just (Broadcast _, Event eventName payloads) -> do -- this log will cause massive overhead, need to be removed- debugSession Info $ "Broadcast: " <> serialize eventName+ logWithSession Info $ "Broadcast: " <> serialize eventName return $ MsgEvent NoID NoEndpoint (Event eventName payloads) -- wtf Just (_, NoEvent) -> do- debugSession Error $ "Event malformed"+ logWithSession Error $ "Event malformed" return $ MsgEvent NoID NoEndpoint NoEvent -- no output, keep polling Nothing -> do@@ -62,19 +62,19 @@ handleSession (SessionEmit event) = do case event of- Event eventName _ -> debugSession Info $ "On: " <> serialize eventName- NoEvent -> debugSession Error $ "Event malformed"+ Event eventName _ -> logWithSession Info $ "On: " <> serialize eventName+ NoEvent -> logWithSession Error $ "Event malformed" triggerEvent event return $ MsgConnect NoEndpoint handleSession SessionDisconnectByClient = do- debugSession Info $ "Disconnected by client"- triggerEvent (Event "disconnect" [])+ logWithSession Info $ "Disconnected by client"+ triggerEvent (Event "disconnect" (Payload [])) return $ MsgNoop handleSession SessionDisconnectByServer = do- debugSession Info $ "Disconnected by server"- triggerEvent (Event "disconnect" [])+ logWithSession Info $ "Disconnected by server"+ triggerEvent (Event "disconnect" (Payload [])) return $ MsgNoop --------------------------------------------------------------------------------
Web/SocketIO/Timeout.hs view
@@ -10,7 +10,7 @@ -------------------------------------------------------------------------------- import Web.SocketIO.Types-import Web.SocketIO.Util+import Web.SocketIO.Log import Web.SocketIO.Session --------------------------------------------------------------------------------@@ -37,8 +37,8 @@ duration <- getTimeoutDuration if firstTime - then debug Debug $ sessionID <> " [Session] Set timeout"- else debug Debug $ sessionID <> " [Session] Extend timeout"+ then logWithSessionID Debug sessionID "[Session] Set timeout"+ else logWithSessionID Debug sessionID "[Session] Extend timeout" result <- timeout duration $ takeMVar timeoutVar case result of@@ -51,7 +51,7 @@ -- remove session tableRef <- getSessionTableRef liftIO (modifyIORef tableRef (H.delete sessionID))- debug Debug $ sessionID <> " [Session] Destroyed: close timeout"+ logWithSessionID Debug sessionID "[Session] Destroyed: close timeout" ---------------------------------------------------------------------------------- -- | Set timeout
Web/SocketIO/Types/Base.hs view
@@ -119,7 +119,7 @@ -- | Environment carried by `CallbackM` data CallbackEnv = CallbackEnv { callbackEnvEventName :: EventName- , callbackEnvPayload :: [Payload]+ , callbackEnvPayload :: Payload , callbackEnvChannelHub :: ChannelHub , callbackEnvSessionID :: SessionID }@@ -168,22 +168,22 @@ -- | instance Publisher HandlerM where- emit event reply = do+ emit eventName reply = do channel <- channelHubLocal . handlerEnvChannelHub <$> ask- writeChan channel (Private, Event event reply)- broadcast event reply = do+ writeChan channel (Private, Event eventName (Payload reply))+ broadcast eventName reply = do channel <- channelHubGlobal . handlerEnvChannelHub <$> ask sessionID <- handlerEnvSessionID <$> ask- writeChan channel (Broadcast sessionID, Event event reply)+ writeChan channel (Broadcast sessionID, Event eventName (Payload reply)) instance Publisher CallbackM where- emit event reply = do+ emit eventName reply = do channel <- CallbackM . lift $ channelHubLocal . callbackEnvChannelHub <$> ask- writeChan channel (Private, Event event reply)- broadcast event reply = do+ writeChan channel (Private, Event eventName (Payload reply))+ broadcast eventName reply = do channel <- CallbackM . lift $ channelHubGlobal . callbackEnvChannelHub <$> ask sessionID <- CallbackM . lift $ callbackEnvSessionID <$> ask- writeChan channel (Broadcast sessionID, Event event reply)+ writeChan channel (Broadcast sessionID, Event eventName (Payload reply)) -------------------------------------------------------------------------------- -- | Receives events.
Web/SocketIO/Types/Event.hs view
@@ -8,8 +8,8 @@ module Web.SocketIO.Types.Event ( Event(..) , EventName+ , Payload(..) , EventType(..)- , Payload , Package ) where @@ -19,33 +19,47 @@ ---------------------------------------------------------------------------------- import Control.Applicative import Data.Aeson -+import Data.Aeson.Encode (encodeToTextBuilder)+import Data.List (intersperse) +import Data.Text.Internal.Builder (toLazyText)+import qualified Data.Text.Lazy as TL+import Data.Vector (toList) -------------------------------------------------------------------------------- -- | Name of an Event type EventName = Text -------------------------------------------------------------------------------- -- | Payload carried by an Event-type Payload = Text+data Payload = Payload [Text] deriving (Eq, Show) +instance Serializable Payload where+ serialize (Payload payload) = serialize $ '[' `TL.cons` (TL.concat $ intersperse "," payload) `TL.snoc` ']'+ -------------------------------------------------------------------------------- -- | Event-data Event = Event EventName [Payload] +data Event = Event EventName Payload | NoEvent -- ^ some malformed shit deriving (Show, Eq) instance Serializable Event where- serialize = serialize . encode+ serialize (Event name (Payload [])) = serialize $ "{\"name\":\"" `TL.append` name `TL.append` "\"}"+ serialize (Event name payload) = serialize $ "{\"name\":\"" `TL.append` name `TL.append` "\",\"args\":" `TL.append` serialize payload `TL.append` "}"+ serialize NoEvent = "" instance FromJSON Event where- parseJSON (Object v) = Event <$>- v .: "name" <*>- v .:? "args" .!= []+ parseJSON (Object v) = Event <$>+ v .: "name" <*>+ (toArgumentList <$> v .:? "args")+ where toArgumentList :: Maybe Value -> Payload+ toArgumentList Nothing = Payload []+ toArgumentList (Just (Array a)) = Payload $ filter (/= "null") . map (toLazyText . encodeToTextBuilder) . toList $ a+ toArgumentList _ = Payload []+ parseJSON _ = return NoEvent instance ToJSON Event where- toJSON (Event name []) = object ["name" .= name]- toJSON (Event name args) = object ["name" .= name, "args" .= args]+ toJSON (Event name (Payload [])) = object ["name" .= name]+ toJSON (Event name (Payload payload)) = object ["name" .= name, "args" .= payload] toJSON NoEvent = object [] --------------------------------------------------------------------------------
− Web/SocketIO/Util.hs
@@ -1,38 +0,0 @@------------------------------------------------------------------------------------ | Exports some logging utilities and other useful functions-{-# LANGUAGE OverloadedStrings #-}--module Web.SocketIO.Util ((<>), debugLog, debugSession, debug) where-----------------------------------------------------------------------------------import Web.SocketIO.Types-----------------------------------------------------------------------------------import Control.Concurrent.Chan-import Control.Monad.Trans (liftIO, MonadIO)------------------------------------------------------------------------------------- | Write log to channel according to log level and configurations-debug :: (Functor m, MonadIO m, ConnectionLayer m) => (ByteString -> Log) -> ByteString -> m ()-debug logType message = do- logLevel' <- fmap logLevel getConfiguration- logChannel <- fmap envLogChannel getEnv- if level <= logLevel' then liftIO $ writeChan logChannel (serialize log') else return ()- where log' = logType message- levelOf (Error _) = 0- levelOf (Warn _) = 1- levelOf (Info _) = 2- levelOf (Debug _) = 3- level = levelOf log' ------------------------------------------------------------------------------------- | Attaches `Web.SocketIO.Types.Base.SessionID`-debugLog :: (Functor m, MonadIO m, ConnectionLayer m) => (ByteString -> Log) -> Session -> ByteString -> m ()-debugLog logType (Session sessionID _ _ _ _) message = debug logType (sessionID <> " " <> serialize message) ------------------------------------------------------------------------------------- | Attaches `Web.SocketIO.Types.Base.SessionID` automatically-debugSession :: (Functor m, MonadIO m, ConnectionLayer m, SessionLayer m) => (ByteString -> Log) -> ByteString -> m ()-debugSession logType message = do- Session sessionID _ _ _ _ <- getSession- debug logType $ fromByteString (sessionID <> " " <> message)
socketio.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: socketio-version: 0.1.1+version: 0.1.2 synopsis: Socket.IO server description: Socket.IO for Haskell folks.@@ -22,8 +22,8 @@     \-\- ping pong     on "ping" $ emit "pong" [] .-     \-\- reply :: CallbackM [Text]-     on "echo" $ reply >>= emit "pong"+     \-\- msg :: CallbackM [Text]+     on "echo" $ msg >>= emit "pong" .     \-\- do some IO     on "Kim Jong-Un" $ liftIO launchMissile@@ -64,24 +64,24 @@ Web.SocketIO.Server Web.SocketIO.Session Web.SocketIO.Timeout- Web.SocketIO.Util-- build-depends: base ==4.6.*- , text ==1.1.*- , bytestring ==0.10.*- , aeson ==0.7.*- , parsec ==3.1.*- , ansi-terminal ==0.6.*- , unordered-containers ==0.2.*- , random ==1.0.*- , wai ==2.0.*- , warp ==2.0.*- , http-types ==0.8.*- , mtl ==2.1.*- , transformers-base ==0.4.*- , monad-control ==0.3.*- , lifted-base ==0.2.*+ Web.SocketIO.Log + build-depends: base >=4.6 && <5.0+ , text >=1.1 && <2.0+ , bytestring >=0.10 && <1.0+ , aeson >=0.7 && <1.0+ , parsec >=3.1 && <4.0+ , ansi-terminal >=0.6 && <1.0+ , unordered-containers >=0.2 && <1.0+ , random >=1.0 && <2.0+ , wai >=2.0 && <3.0+ , warp >=2.0 && <3.0+ , http-types >=0.8 && <1.0+ , mtl >=2.1 && <3.0+ , transformers-base >=0.4 && <1.0+ , monad-control >=0.3 && <1.0+ , lifted-base >=0.2 && <1.0+ , vector >=0.10 && <1.0 test-suite socketio-test type: exitcode-stdio-1.0@@ -89,25 +89,26 @@ main-is: main.hs ghc-options: -Wall -fno-warn-unused-do-bind - build-depends: base ==4.6.*- , QuickCheck ==2.6.*- , HUnit ==1.2.*- , test-framework ==0.8.*- , test-framework-quickcheck2 ==0.3.*- , test-framework-hunit ==0.3.*- - build-depends: base ==4.6.*- , text ==1.1.*- , bytestring ==0.10.*- , aeson ==0.7.*- , parsec ==3.1.*- , ansi-terminal ==0.6.*- , unordered-containers ==0.2.*- , random ==1.0.*- , wai ==2.0.*- , warp ==2.0.*- , http-types ==0.8.*- , mtl ==2.1.*- , transformers-base ==0.4.*- , monad-control ==0.3.*- , lifted-base ==0.2.*+ build-depends: base >=4.6 && <5.0+ , QuickCheck >=2.6 && <3.0+ , HUnit >=1.2 && <2.0+ , test-framework >=0.8 && <1.0+ , test-framework-quickcheck2 >=0.3 && <1.0+ , test-framework-hunit >=0.3 && <1.0+ , scientific >=0.2 && <1.0+ build-depends: base >=4.6 && <5.0+ , text >=1.1 && <2.0+ , bytestring >=0.10 && <1.0+ , aeson >=0.7 && <1.0+ , parsec >=3.1 && <4.0+ , ansi-terminal >=0.6 && <1.0+ , unordered-containers >=0.2 && <1.0+ , random >=1.0 && <2.0+ , wai >=2.0 && <3.0+ , warp >=2.0 && <3.0+ , http-types >=0.8 && <1.0+ , mtl >=2.1 && <3.0+ , transformers-base >=0.4 && <1.0+ , monad-control >=0.3 && <1.0+ , lifted-base >=0.2 && <1.0+ , vector >=0.10 && <1.0