pusher-http-haskell-1.3.0.0: src/Network/Pusher/Data.hs

{-# LANGUAGE DeriveGeneric #-}

{-|
Module      : Network.Pusher.Data
Description : Data structure representing Pusher concepts and config
Copyright   : (c) Will Sewell, 2016
Licence     : MIT
Maintainer  : me@willsewell.com
Stability   : experimental

You must create an instance of the Pusher datatype with your particular Pusher
app credentials in order to run the main API functions.

The other types represent Pusher channels and Pusher event fields.
-}
module Network.Pusher.Data
  -- * Pusher config data type
  ( AppID
  , AppKey
  , AppSecret
  , Pusher(..)
  , Credentials(..)
  , Cluster(..)
  , clusterMt1
  , clusterEu
  , clusterAp1
  , clusterAp2
  , getPusher
  , getPusherWithHost
  , getPusherWithConnManager
  -- * Channels
  , Channel(..)
  , ChannelName
  , ChannelType(..)
  , renderChannel
  , renderChannelPrefix
  , parseChannel
  -- Events
  , Event
  , EventData
  , SocketID
  ) 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.Foldable (asum)
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import GHC.Generics (Generic)
import Network.HTTP.Client
       (Manager, defaultManagerSettings, newManager)

import Network.Pusher.Internal.Util
       (failExpectObj, failExpectStr, show')

type AppID = Integer

type AppKey = B.ByteString

type AppSecret = B.ByteString

-- |All the required configuration needed to interact with the API.
data Pusher = Pusher
  { pusherHost :: T.Text
  , pusherPath :: T.Text
  , pusherCredentials :: Credentials
  , pusherConnectionManager :: Manager
  }

-- |The credentials for the current app.
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

-- | The cluster the current app resides on. Common clusters include: mt1,eu,ap1,ap2
newtype Cluster = Cluster
  { clusterName :: T.Text
  }

clusterMt1, clusterEu, clusterAp1, clusterAp2 :: Cluster
clusterMt1 = Cluster "mt1"

clusterEu = Cluster "eu"

clusterAp1 = Cluster "ap1"

clusterAp2 = Cluster "ap2"

-- The possible cluster suffix given in a host name
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

-- |Use this to get an instance Pusher. This will fill in the host and path
-- automatically.
getPusher
  :: MonadIO m
  => Credentials -> m Pusher
getPusher cred = do
  connManager <- getConnManager
  return $ getPusherWithConnManager connManager Nothing cred

-- |Get a Pusher instance that uses a specific API endpoint.
getPusherWithHost
  :: MonadIO m
  => T.Text -> Credentials -> m Pusher
getPusherWithHost apiHost cred = do
  connManager <- getConnManager
  return $ getPusherWithConnManager connManager (Just apiHost) cred

-- |Get a Pusher instance with a given connection manager. This can be useful
-- if you want to share a connection with your application code.
getPusherWithConnManager :: Manager -> Maybe T.Text -> Credentials -> Pusher
getPusherWithConnManager connManager apiHost cred =
  let path = "/apps/" <> show' (credentialsAppID cred) <> "/"
      mCluster = credentialsCluster cred
  in Pusher
     { pusherHost = fromMaybe (mkHost mCluster) apiHost
     , pusherPath = path
     , pusherCredentials = cred
     , pusherConnectionManager = connManager
     }

-- |Given a possible cluster, return the corresponding host
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

-- |The possible types of Pusher channe.
data ChannelType
  = Public
  | Private
  | Presence
  deriving (Eq, Generic, Show)

instance Hashable ChannelType

renderChannelPrefix :: ChannelType -> T.Text
renderChannelPrefix Public = ""
renderChannelPrefix Private = "private-"
renderChannelPrefix Presence = "presence-"

-- |The channel name (not including the channel type prefix) and its type.
data Channel = Channel
  { channelType :: ChannelType
  , channelName :: ChannelName
  } deriving (Eq, Generic, Show)

instance Hashable Channel

renderChannel :: Channel -> T.Text
renderChannel (Channel cType cName) = renderChannelPrefix cType <> cName

-- |Convert string representation, e.g. private-chan into the datatype
parseChannel :: T.Text -> Channel
parseChannel chan
  -- Attempt to parse it as a private or presence channel; default to public
 =
  fromMaybe
    (Channel Public chan)
    (asum [parseChanAs Private, parseChanAs Presence])
  where
    parseChanAs chanType =
      let split = T.splitOn (renderChannelPrefix chanType) chan
    -- If the prefix appears at the start, then the first element will be empty
      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