module Network.Pusher.WebSockets.Event
( eventType
, eventChannel
, Binding
, bind
, bindAll
, unbind
, triggerEvent
, localEvent
) where
import Data.Maybe (fromMaybe)
import Control.Concurrent.STM (atomically, readTVar)
import Control.Lens ((^?), (.~), (&), ix)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value(..), decodeStrict')
import Data.Aeson.Lens (_String)
import qualified Data.HashMap.Strict as H
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Network.Pusher.WebSockets.Internal
eventType :: Value -> Text
eventType event = fromMaybe "" (event ^? ix "event" . _String)
eventChannel :: Value -> Maybe Channel
eventChannel event = fmap Channel (event ^? ix "channel" . _String)
bind :: Text
-> Maybe Channel
-> (Value -> PusherClient ())
-> PusherClient Binding
bind = bindGeneric . Just
bindAll :: Maybe Channel -> (Value -> PusherClient ()) -> PusherClient Binding
bindAll = bindGeneric Nothing
bindGeneric :: Maybe Text -> Maybe Channel -> (Value -> PusherClient ())
-> PusherClient Binding
bindGeneric event channel handler = do
pusher <- ask
liftIO . atomically $ do
b@(Binding i) <- readTVar (nextBinding pusher)
let b' = Binding (i+1)
strictModifyTVar (nextBinding pusher) (const b')
let h = Handler event channel wrappedHandler
strictModifyTVar (eventHandlers pusher) (H.insert b h)
pure b
where
wrappedHandler ev@(Object o) = handler $
case H.lookup "data" o >>= attemptDecode of
Just decoded -> ev & ix "data" .~ decoded
Nothing -> ev
wrappedHandler ev = handler ev
attemptDecode (String s) = decodeStrict' (encodeUtf8 s)
attemptDecode _ = Nothing
unbind :: Binding -> PusherClient ()
unbind binding = do
pusher <- ask
strictModifyTVarIO (eventHandlers pusher) (H.delete binding)
triggerEvent :: Text -> Maybe Channel -> Value -> PusherClient ()
triggerEvent = sendMessage SendMessage
localEvent :: Text -> Maybe Channel -> Value -> PusherClient ()
localEvent = sendMessage SendLocalMessage
sendMessage :: (Value -> PusherCommand)
-> Text -> Maybe Channel -> Value -> PusherClient ()
sendMessage cmd event channel data_ = do
pusher <- ask
liftIO (sendCommand pusher (cmd json))
where
json = Object . H.fromList $ concat
[ [("event", String event)]
, [("channel", String chan) | Just (Channel chan) <- [channel]]
, [("data", data_)]
]