module Facebook.RealTime
( RealTimeUpdateObject(..)
, RealTimeUpdateField
, RealTimeUpdateUrl
, RealTimeUpdateToken
, modifySubscription
, RealTimeUpdateSubscription(..)
, listSubscriptions
, verifyRealTimeUpdateNotifications
, getRealTimeUpdateNotifications
, RealTimeUpdateNotification(..)
, RealTimeUpdateNotificationUserEntry(..)
) where
import Control.Applicative ((<$>), (<*>))
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, R.MonadUnliftIO m, R.MonadThrow 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, R.MonadUnliftIO m, R.MonadThrow m)
=> AppAccessToken -> FacebookT Auth m [RealTimeUpdateSubscription]
listSubscriptions apptoken = do
path <- getSubscriptionsPath
pager <- getObject path [] (Just apptoken)
src <- fetchAllNextPages pager
lift $ C.runConduit $ 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