module Network.Pusher (
trigger
, channels
, channel
, users
, authenticatePresence
, authenticatePrivate
) where
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.Except (throwError)
import Control.Monad.Reader (MonadReader, asks)
import Data.Maybe (maybeToList)
import Data.Monoid ((<>))
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import Control.Monad.Pusher (MonadPusher)
import Control.Monad.Pusher.Time (MonadTime, getPOSIXTime)
import Data.Pusher (Credentials(..), Pusher(..))
import Network.Pusher.Internal.Auth
( authenticatePresence
, authenticatePrivate
, makeQS
)
import Network.Pusher.Internal.HTTP (get, post)
import Network.Pusher.Internal.Util (show')
import Network.Pusher.Protocol
( Channel
, ChannelInfo
, ChannelInfoQuery
, ChannelsInfo
, ChannelsInfoQuery
, ChannelType
, FullChannelInfo
, Users
, toURLParam
)
trigger
:: MonadPusher m
=> [Channel]
-> T.Text
-> T.Text
-> Maybe T.Text
-> m ()
trigger chans event dat socketId = do
when
(length chans > 10)
(throwError "Must be less than 10 channels")
let
body = A.object $
[ ("name", A.String event)
, ("channels", A.toJSON (map (A.String . show') chans))
, ("data", A.String dat)
] ++ maybeToList (fmap (\sID -> ("socket_id", A.String sID)) socketId)
bodyBS = BL.toStrict $ A.encode body
when
(B.length bodyBS > 10000)
(throwError "Body must be less than 10000KB")
(ep, path) <- getEndpoint "events"
qs <- makeQSWithTS "POST" path [] bodyBS
connManager <- asks pusherConnectionManager
post connManager (encodeUtf8 ep) qs body
channels
:: MonadPusher m
=> Maybe ChannelType
-> T.Text
-> ChannelsInfoQuery
-> m ChannelsInfo
channels channelTypeFilter prefixFilter attributes = do
let
prefix = maybe "" show' channelTypeFilter <> prefixFilter
params =
[ ("info", encodeUtf8 $ toURLParam attributes)
, ("filter_by_prefix", encodeUtf8 prefix)
]
(ep, path) <- getEndpoint "channels"
qs <- makeQSWithTS "GET" path params ""
connManager <- asks pusherConnectionManager
get connManager (encodeUtf8 ep) qs
channel
:: MonadPusher m
=> Channel
-> ChannelInfoQuery
-> m FullChannelInfo
channel chan attributes = do
let params = [("info", encodeUtf8 $ toURLParam attributes)]
(ep, path) <- getEndpoint $ "channels/" <> show' chan
qs <- makeQSWithTS "GET" path params ""
connManager <- asks pusherConnectionManager
get connManager (encodeUtf8 ep) qs
users
:: MonadPusher m
=> Channel
-> m Users
users chan = do
(ep, path) <- getEndpoint $ "channels/" <> show' chan <> "/users"
qs <- makeQSWithTS "GET" path [] ""
connManager <- asks pusherConnectionManager
get connManager (encodeUtf8 ep) qs
getEndpoint
:: (MonadReader Pusher m)
=> T.Text
-> m (T.Text, T.Text)
getEndpoint subPath = do
host <- asks pusherHost
path <- asks pusherPath
let
fullPath = path <> subPath
endpoint = host <> fullPath
return (endpoint, fullPath)
makeQSWithTS
:: (Functor m, MonadTime m, MonadReader Pusher m)
=> T.Text
-> T.Text
-> [(B.ByteString, B.ByteString)]
-> B.ByteString
-> m [(B.ByteString, B.ByteString)]
makeQSWithTS method path params body = do
appKey <- asks $ credentialsAppKey . pusherCredentials
appSecret <- asks $ credentialsAppSecret . pusherCredentials
makeQS appKey appSecret method path params body <$> getPOSIXTime