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, void)
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.Lazy.Char8 as L
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import Facebook.Types
import Facebook.Monad
import Facebook.Base
import Facebook.Graph
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
]
runResourceInFb $ do
req <- fbreq path (Just apptoken) args
void $ fbhttp req { H.method = HT.methodPost }
return ()
getSubscriptionsPath :: Monad m => FacebookT Auth m Text
getSubscriptionsPath = do
creds <- getCreds
return $ T.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
pager <- getObject path [] (Just apptoken)
src <- fetchAllNextPages pager
lift $ src C.$$ CL.consume
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 (appSecretBS 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