module Facebook.RealTime
( RealTimeUpdateObject(..)
, RealTimeUpdateField
, RealTimeUpdateUrl
, RealTimeUpdateToken
, modifySubscription
, RealTimeUpdateSubscription(..)
, listSubscriptions
, verifyRealTimeUpdateNotifications
, getRealTimeUpdateNotifications
, RealTimeUpdateNotification(..)
, RealTimeUpdateNotificationUserEntry(..)
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad (liftM, mzero)
import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import Data.Typeable (Typeable)
import qualified Crypto.Classes as Crypto
import qualified Crypto.HMAC as Crypto
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.Aeson as A
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Conduit as C
import qualified Data.Text.Encoding as TE
import Facebook.Types
import Facebook.Monad
import Facebook.Graph
import Facebook.OpenGraph
data RealTimeUpdateObject =
UserRTUO
| PermissionsRTUO
| PageRTUO
| ErrorsRTUO
| OtherRTUO Text
deriving (Eq, Ord, Show, Typeable)
rtuoToBS :: RealTimeUpdateObject -> ByteString
rtuoToBS (UserRTUO) = "user"
rtuoToBS (PermissionsRTUO) = "permissions"
rtuoToBS (PageRTUO) = "page"
rtuoToBS (ErrorsRTUO) = "errors"
rtuoToBS (OtherRTUO other) = TE.encodeUtf8 other
instance A.FromJSON RealTimeUpdateObject where
parseJSON (A.String "user") = return UserRTUO
parseJSON (A.String "permissions") = return PermissionsRTUO
parseJSON (A.String "page") = return PageRTUO
parseJSON (A.String "errors") = return ErrorsRTUO
parseJSON (A.String other) = return (OtherRTUO other)
parseJSON _ = mzero
instance A.ToJSON RealTimeUpdateObject where
toJSON = A.String . TE.decodeUtf8 . rtuoToBS
type RealTimeUpdateField = ByteString
type RealTimeUpdateUrl = Text
type RealTimeUpdateToken = ByteString
modifySubscription :: (C.MonadResource m, MonadBaseControl IO m) =>
RealTimeUpdateObject
-> [RealTimeUpdateField]
-> RealTimeUpdateUrl
-> RealTimeUpdateToken
-> AppAccessToken
-> FacebookT Auth m ()
modifySubscription object fields callbackUrl verifyToken apptoken = do
path <- getSubscriptionsPath
let args = [ "object" #= rtuoToBS object
, "fields" #= fields
, "callback_url" #= callbackUrl
, "verify_token" #= verifyToken
]
postObject path args apptoken
getSubscriptionsPath :: Monad m => FacebookT Auth m ByteString
getSubscriptionsPath = do
creds <- getCreds
return $ B.concat ["/", appId creds, "/subscriptions"]
data RealTimeUpdateSubscription =
RealTimeUpdateSubscription {
rtusObject :: RealTimeUpdateObject
, rtusCallbackUrl :: RealTimeUpdateUrl
, rtusFields :: [RealTimeUpdateField]
, rtusActive :: Bool
} deriving (Eq, Ord, Show, Typeable)
instance A.FromJSON RealTimeUpdateSubscription where
parseJSON (A.Object v) =
RealTimeUpdateSubscription
<$> v A..: "object"
<*> v A..: "callback_url"
<*> v A..: "fields"
<*> v A..: "active"
parseJSON _ = mzero
listSubscriptions ::
(C.MonadResource m, MonadBaseControl IO m) =>
AppAccessToken -> FacebookT Auth m [RealTimeUpdateSubscription]
listSubscriptions apptoken = do
path <- getSubscriptionsPath
FQLResult ret <- getObject path [] (Just apptoken)
return ret
verifyRealTimeUpdateNotifications ::
Monad m =>
ByteString
-> L.ByteString
-> FacebookT Auth m (Maybe L.ByteString)
verifyRealTimeUpdateNotifications sig body = do
creds <- getCreds
let key :: Crypto.MacKey SHA1.Ctx SHA1.SHA1
key = Crypto.MacKey (appSecret creds)
hash = Crypto.hmac key body
expected = "sha1=" <> Base16.encode (Crypto.encode hash)
return $! if sig `Crypto.constTimeEq` expected then Just body else Nothing
getRealTimeUpdateNotifications ::
(Monad m, A.FromJSON a) =>
ByteString
-> L.ByteString
-> FacebookT Auth m (Maybe (RealTimeUpdateNotification a))
getRealTimeUpdateNotifications =
(liftM (>>= A.decode) .) . verifyRealTimeUpdateNotifications
data RealTimeUpdateNotification a =
RealTimeUpdateNotification {
rtunObject :: RealTimeUpdateObject
, rtunEntries :: [a]
} deriving (Eq, Ord, Show, Typeable)
instance A.FromJSON a => A.FromJSON (RealTimeUpdateNotification a) where
parseJSON (A.Object v) =
RealTimeUpdateNotification
<$> v A..: "object"
<*> v A..: "entry"
parseJSON _ = mzero
data RealTimeUpdateNotificationUserEntry =
RealTimeUpdateNotificationUserEntry {
rtuneUserId :: Id
, rtuneChangedFields :: [RealTimeUpdateField]
, rtuneTime :: Integer
} deriving (Eq, Ord, Show, Typeable)
instance A.FromJSON RealTimeUpdateNotificationUserEntry where
parseJSON (A.Object v) =
RealTimeUpdateNotificationUserEntry
<$> v A..: "uid"
<*> v A..: "changed_fields"
<*> v A..: "time"
parseJSON _ = mzero