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 Crypto.Hash.CryptoAPI (SHA1)
import Data.ByteString.Char8 (ByteString)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Typeable (Typeable)
import qualified Control.Monad.Trans.Resource as R
import qualified Crypto.Classes as Crypto
import qualified Crypto.HMAC as Crypto
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
import Facebook.Pager
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 :: (R.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"
<*> fmap (map encodeUtf8) (v A..: "fields")
<*> v A..: "active"
parseJSON _ = mzero
listSubscriptions ::
(R.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 ctx 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"
<*> fmap (map encodeUtf8) (v A..: "changed_fields")
<*> v A..: "time"
parseJSON _ = mzero