module Network.Pusher.Data (
AppID
, AppKey
, AppSecret
, Pusher(..)
, Credentials(..)
, Cluster(..)
, clusterMt1
, clusterEu
, clusterAp1
, clusterAp2
, getPusher
, getPusherWithHost
, getPusherWithConnManager
, Channel(..)
, ChannelName
, ChannelType(..)
, renderChannel
, renderChannelPrefix
, parseChannel
, Event
, EventData
, SocketID
, Notification(..)
, Interest
, mkInterest
, WebhookURL
, WebhookLevel(..)
, APNSPayload(..)
, GCMPayload(..)
, FCMPayload(..)
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson ((.:), (.:?), (.=))
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import Data.Char (isAlphaNum)
import Data.Foldable (asum)
import qualified Data.HashSet as HS
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Vector as V
import GHC.Generics (Generic)
import Network.HTTP.Client
(Manager, defaultManagerSettings, newManager)
import Network.Pusher.Internal.Util
(failExpectArray, failExpectObj, failExpectSingletonArray,
failExpectStr, show')
type AppID = Integer
type AppKey = B.ByteString
type AppSecret = B.ByteString
data Pusher = Pusher
{ pusherHost :: T.Text
, pusherPath :: T.Text
, pusherNotifyHost :: T.Text
, pusherNotifyPath :: T.Text
, pusherCredentials :: Credentials
, pusherConnectionManager :: Manager
}
data Credentials = Credentials
{ credentialsAppID :: AppID
, credentialsAppKey :: AppKey
, credentialsAppSecret :: AppSecret
, credentialsCluster :: Maybe Cluster
}
instance A.FromJSON Credentials where
parseJSON (A.Object v) =
Credentials <$> v .: "app-id" <*> (encodeUtf8 <$> v .: "app-key") <*>
(encodeUtf8 <$> v .: "app-secret") <*>
v .:? "app-cluster"
parseJSON v2 = failExpectObj v2
newtype Cluster = Cluster
{ clusterName :: T.Text
}
clusterMt1, clusterEu, clusterAp1, clusterAp2 :: Cluster
clusterMt1 = Cluster "mt1"
clusterEu = Cluster "eu"
clusterAp1 = Cluster "ap1"
clusterAp2 = Cluster "ap2"
renderClusterSuffix :: Cluster -> T.Text
renderClusterSuffix cluster = "-" <> clusterName cluster
instance A.FromJSON Cluster where
parseJSON v =
case v of
A.String txt -> return . Cluster $ txt
_ -> failExpectStr v
getPusher :: MonadIO m => Credentials -> m Pusher
getPusher cred = do
connManager <- getConnManager
return $ getPusherWithConnManager connManager Nothing Nothing cred
getPusherWithHost :: MonadIO m => T.Text -> T.Text -> Credentials -> m Pusher
getPusherWithHost apiHost notifyHost cred = do
connManager <- getConnManager
return $
getPusherWithConnManager connManager (Just apiHost) (Just notifyHost) cred
getPusherWithConnManager ::
Manager -> Maybe T.Text -> Maybe T.Text -> Credentials -> Pusher
getPusherWithConnManager connManager apiHost notifyAPIHost cred =
let path = "/apps/" <> show' (credentialsAppID cred) <> "/"
mCluster = credentialsCluster cred
notifyPath =
"/server_api/v1/apps/" <> show' (credentialsAppID cred) <> "/"
in Pusher
{ pusherHost = fromMaybe (mkHost mCluster) apiHost
, pusherPath = path
, pusherNotifyHost =
fromMaybe "http://nativepush-cluster1.pusher.com" notifyAPIHost
, pusherNotifyPath = notifyPath
, pusherCredentials = cred
, pusherConnectionManager = connManager
}
mkHost :: Maybe Cluster -> T.Text
mkHost mCluster =
case mCluster of
Nothing -> "http://api.pusherapp.com"
Just c -> "http://api" <> renderClusterSuffix c <> ".pusher.com"
getConnManager :: MonadIO m => m Manager
getConnManager = liftIO $ newManager defaultManagerSettings
type ChannelName = T.Text
data ChannelType
= Public
| Private
| Presence
deriving (Eq, Generic, Show)
instance Hashable ChannelType
renderChannelPrefix :: ChannelType -> T.Text
renderChannelPrefix Public = ""
renderChannelPrefix Private = "private-"
renderChannelPrefix Presence = "presence-"
data Channel = Channel
{ channelType :: ChannelType
, channelName :: ChannelName
} deriving (Eq, Generic, Show)
instance Hashable Channel
instance A.FromJSON Channel where
parseJSON s =
case s of
A.String txt -> return $ parseChannel txt
_ -> failExpectStr s
renderChannel :: Channel -> T.Text
renderChannel (Channel cType cName) = renderChannelPrefix cType <> cName
parseChannel :: T.Text -> Channel
parseChannel chan
=
fromMaybe
(Channel Public chan)
(asum [parseChanAs Private, parseChanAs Presence])
where
parseChanAs chanType =
let split = T.splitOn (renderChannelPrefix chanType) chan
in if length split > 1 && T.null (head split)
then Just $ Channel chanType (T.concat $ tail split)
else Nothing
type Event = T.Text
type EventData = T.Text
type SocketID = T.Text
newtype Interest =
Interest T.Text
deriving (Eq, Show)
mkInterest :: T.Text -> Maybe Interest
mkInterest txt
| 0 < T.length txt &&
T.length txt <= 164 &&
T.all (\c -> isAlphaNum c || HS.member c permitted) txt =
Just . Interest $ txt
| otherwise = Nothing
where
permitted = HS.fromList "_=@,.;"
instance A.FromJSON Interest where
parseJSON v =
case v of
A.String s ->
case mkInterest s of
Nothing ->
fail $
"An Interest contains invalid characters or is too long: " ++ show s
Just istr -> pure istr
_ -> failExpectStr v
instance A.ToJSON Interest where
toJSON (Interest txt) = A.String txt
type WebhookURL = T.Text
data WebhookLevel
= Info
| Debug
deriving (Eq, Show)
instance A.FromJSON WebhookLevel where
parseJSON v =
case v of
A.String s
| s == "INFO" -> pure Info
| s == "DEBUG" -> pure Debug
_ -> failExpectStr v
instance A.ToJSON WebhookLevel where
toJSON w =
A.String $
case w of
Info -> "INFO"
Debug -> "DEBUG"
data APNSPayload =
APNSPayload A.Object
deriving (Eq, Show)
instance A.FromJSON APNSPayload where
parseJSON v =
case v of
A.Object o -> pure . APNSPayload $ o
_ -> failExpectObj v
instance A.ToJSON APNSPayload where
toJSON (APNSPayload o) = A.Object o
data GCMPayload =
GCMPayload A.Object
deriving (Eq, Show)
instance A.FromJSON GCMPayload where
parseJSON v =
case v of
A.Object o -> pure . GCMPayload $ o
_ -> failExpectObj v
instance A.ToJSON GCMPayload where
toJSON (GCMPayload o) = A.Object o
data FCMPayload =
FCMPayload A.Object
deriving (Eq, Show)
instance A.FromJSON FCMPayload where
parseJSON v =
case v of
A.Object o -> pure . FCMPayload $ o
_ -> failExpectObj v
instance A.ToJSON FCMPayload where
toJSON (FCMPayload o) = A.Object o
data Notification = Notification
{ notificationInterest :: Interest
, notificationWebhookURL :: Maybe WebhookURL
, notificationWebhookLevel :: Maybe WebhookLevel
, notificationAPNSPayload :: Maybe APNSPayload
, notificationGCMPayload :: Maybe GCMPayload
, notificationFCMPayload :: Maybe FCMPayload
} deriving (Eq, Show)
instance A.FromJSON Notification where
parseJSON (A.Object v) =
Notification <$>
(do interests <- v A..: "interests"
case interests of
A.Array arr
| V.length arr == 1 -> A.parseJSON $ V.head arr
| otherwise -> failExpectSingletonArray interests
v' -> failExpectArray v') <*>
v .:? "webhook_url" <*>
v .:? "webhook_level" <*>
v .:? "apns" <*>
v .:? "gcm" <*>
v .:? "fcm"
parseJSON v = failExpectObj v
instance A.ToJSON Notification where
toJSON (Notification interests mWebhookURL mWebhookLevel mAPNS mGCMP mFCMP) =
let requiredFields = ["interests" .= [interests]]
consOptionals =
consJust "webhook_level" mWebhookLevel .
consJust "webhook_url" mWebhookURL .
consJust "apns" mAPNS . consJust "gcm" mGCMP . consJust "fcm" mFCMP
fields = consOptionals requiredFields
in A.object fields
where
consJust attr = maybe id ((:) . (attr .=))