diff --git a/Web/SocketIO.hs b/Web/SocketIO.hs --- a/Web/SocketIO.hs +++ b/Web/SocketIO.hs @@ -40,6 +40,8 @@ , Subscriber(..) , Publisher(..) , reply + , msg + , msg' , getEventName , HasSessionID(..) , EventName diff --git a/Web/SocketIO/Connection.hs b/Web/SocketIO/Connection.hs --- a/Web/SocketIO/Connection.hs +++ b/Web/SocketIO/Connection.hs @@ -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 diff --git a/Web/SocketIO/Event.hs b/Web/SocketIO/Event.hs --- a/Web/SocketIO/Event.hs +++ b/Web/SocketIO/Event.hs @@ -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 diff --git a/Web/SocketIO/Log.hs b/Web/SocketIO/Log.hs new file mode 100644 --- /dev/null +++ b/Web/SocketIO/Log.hs @@ -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) diff --git a/Web/SocketIO/Session.hs b/Web/SocketIO/Session.hs --- a/Web/SocketIO/Session.hs +++ b/Web/SocketIO/Session.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/Web/SocketIO/Timeout.hs b/Web/SocketIO/Timeout.hs --- a/Web/SocketIO/Timeout.hs +++ b/Web/SocketIO/Timeout.hs @@ -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 diff --git a/Web/SocketIO/Types/Base.hs b/Web/SocketIO/Types/Base.hs --- a/Web/SocketIO/Types/Base.hs +++ b/Web/SocketIO/Types/Base.hs @@ -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. diff --git a/Web/SocketIO/Types/Event.hs b/Web/SocketIO/Types/Event.hs --- a/Web/SocketIO/Types/Event.hs +++ b/Web/SocketIO/Types/Event.hs @@ -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 [] -------------------------------------------------------------------------------- diff --git a/Web/SocketIO/Util.hs b/Web/SocketIO/Util.hs deleted file mode 100644 --- a/Web/SocketIO/Util.hs +++ /dev/null @@ -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) diff --git a/socketio.cabal b/socketio.cabal --- a/socketio.cabal +++ b/socketio.cabal @@ -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