diff --git a/fb.cabal b/fb.cabal --- a/fb.cabal +++ b/fb.cabal @@ -1,5 +1,5 @@ name: fb -version: 0.11 +version: 0.11.1 license: BSD3 license-file: LICENSE author: Felipe Lessa @@ -54,6 +54,7 @@ Facebook.Object.User Facebook.Object.Page Facebook.OpenGraph + Facebook.RealTime build-depends: base >= 4 && < 5 , lifted-base >= 0.1 && < 0.2 @@ -68,6 +69,7 @@ , attoparsec >= 0.10 && < 0.11 , attoparsec-conduit >= 0.5 && < 0.6 , aeson >= 0.5 && < 0.7 + , base16-bytestring == 0.1.* , base64-bytestring >= 0.1.1 && < 0.2 , time >= 1.2 && < 1.5 , old-locale @@ -103,7 +105,7 @@ -- Test-only dependencies , HUnit , QuickCheck - , hspec >= 0.9.1 && < 1.3 + , hspec == 1.3.* , fb extensions: TypeFamilies diff --git a/src/Facebook.hs b/src/Facebook.hs --- a/src/Facebook.hs +++ b/src/Facebook.hs @@ -58,6 +58,21 @@ , (#=) , SimpleType(..) + -- * Real-time update notifications + -- ** Subscriptions + , modifySubscription + , listSubscriptions + , RealTimeUpdateObject(..) + , RealTimeUpdateField + , RealTimeUpdateUrl + , RealTimeUpdateToken + , RealTimeUpdateSubscription(..) + -- ** Notifications + , verifyRealTimeUpdateNotifications + , getRealTimeUpdateNotifications + , RealTimeUpdateNotification(..) + , RealTimeUpdateNotificationUserEntry(..) + -- * Raw access to the Graph API , getObject , postObject @@ -81,3 +96,4 @@ import Facebook.Object.Page import Facebook.Object.User import Facebook.OpenGraph +import Facebook.RealTime diff --git a/src/Facebook/Graph.hs b/src/Facebook/Graph.hs --- a/src/Facebook/Graph.hs +++ b/src/Facebook/Graph.hs @@ -28,8 +28,7 @@ import Facebook.Base --- | Make a raw @GET@ request to Facebook's Graph API. Returns a --- raw JSON 'A.Value'. +-- | Make a raw @GET@ request to Facebook's Graph API. getObject :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => ByteString -- ^ Path (should begin with a slash @\/@) -> [Argument] -- ^ Arguments to be passed to Facebook @@ -40,8 +39,7 @@ asJson =<< fbhttp =<< fbreq path mtoken query --- | Make a raw @POST@ request to Facebook's Graph API. Returns --- a raw JSON 'A.Value'. +-- | Make a raw @POST@ request to Facebook's Graph API. postObject :: (C.MonadResource m, MonadBaseControl IO m, A.FromJSON a) => ByteString -- ^ Path (should begin with a slash @\/@) -> [Argument] -- ^ Arguments to be passed to Facebook diff --git a/src/Facebook/OpenGraph.hs b/src/Facebook/OpenGraph.hs --- a/src/Facebook/OpenGraph.hs +++ b/src/Facebook/OpenGraph.hs @@ -219,6 +219,9 @@ -- | Facebook's simple type @String@. instance SimpleType Text where encodeFbParam = TE.encodeUtf8 +-- | Facebook's simple type @String@. +instance SimpleType ByteString where + encodeFbParam = id -- | An object's 'Id' code. instance SimpleType Id where diff --git a/src/Facebook/RealTime.hs b/src/Facebook/RealTime.hs new file mode 100644 --- /dev/null +++ b/src/Facebook/RealTime.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +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 + + +-- | The type of objects that a real-time update refers to. +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 + + +-- | A field of a 'RealTimeUpdateObject' that you would like to +-- receive notifications when changed. +type RealTimeUpdateField = ByteString + + +-- | The URL on your server that will receive the real-time +-- updates. Please refer to Facebook's documentation in order to +-- see what this URL needs to implement. +type RealTimeUpdateUrl = Text + + +-- | A token that is sent back by Facebook's servers to your +-- server in order to verify that you really were trying to +-- modify your subscription. +type RealTimeUpdateToken = ByteString + + +-- | Add or modify a subscription for real-time updates. If +-- there were no previous subscriptions for the given +-- 'RealTimeUpdateObject', then a new subscription is created. +-- If there was any previous subscription for the given +-- 'RealTimeUpdateObject', it's overriden by this one (even if +-- the other subscription had a different callback URL). +modifySubscription :: (C.MonadResource m, MonadBaseControl IO m) => + RealTimeUpdateObject + -- ^ Type of objects whose subscription you + -- and to add or modify. + -> [RealTimeUpdateField] + -- ^ Fields that you are interested in + -- receiving updates. + -> RealTimeUpdateUrl + -- ^ Your callback URL. + -> RealTimeUpdateToken + -- ^ A verification token. + -> AppAccessToken + -- ^ Access token for your app. + -> 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 + + +-- | (Internal) Get the subscription's path. +getSubscriptionsPath :: Monad m => FacebookT Auth m ByteString +getSubscriptionsPath = do + creds <- getCreds + return $ B.concat ["/", appId creds, "/subscriptions"] + + +-- | Information returned by Facebook about a real-time update +-- notification subscription. +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 + + +-- | List current real-time update subscriptions. +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 + + +-- | Verifies the input's authenticity (i.e. it comes from +-- Facebook) and integrity by calculating its HMAC-SHA1 (using +-- your application secret as the key) and verifying that it +-- matches the value from the HTTP request's @X-Hub-Signature@ +-- header's value. If it's not valid, @Nothing@ is returned, +-- otherwise @Just data@ is returned where @data@ is the original +-- data. +verifyRealTimeUpdateNotifications :: + Monad m => + ByteString + -- ^ @X-Hub-Signature@ HTTP header's value. + -> L.ByteString + -- ^ Request body with JSON-encoded notifications. + -> 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 + + +-- | Same as 'verifyRealTimeUpdateNotifications' but also parses +-- the response as JSON. Returns @Nothing@ if either the +-- signature is invalid or the data can't be parsed (use +-- 'verifyRealTimeUpdateNotifications' if you need to distinguish +-- between these two error conditions). +getRealTimeUpdateNotifications :: + (Monad m, A.FromJSON a) => + ByteString + -- ^ @X-Hub-Signature@ HTTP header's value. + -> L.ByteString + -- ^ Request body with JSON-encoded notifications. + -> FacebookT Auth m (Maybe (RealTimeUpdateNotification a)) +getRealTimeUpdateNotifications = + (liftM (>>= A.decode) .) . verifyRealTimeUpdateNotifications + + +-- | When data changes and there's a valid subscription, Facebook +-- will @POST@ to your 'RealTimeUpdateUrl' with a JSON-encoded +-- object containing the notifications. A +-- 'RealTimeUpdateNotification a' represents such object where +-- 'a' is type of the entries (e.g., +-- 'RealTimeUpdateNotificationUserEntry'). +-- +-- If you have a single 'RealTimeUpdateUrl' for different kinds +-- of notifications, you may parse a @RealTimeUpdateNotification +-- 'A.Value'@ and then manually parse the 'A.Value' depending on +-- the value of 'rtunObject'. +-- +-- We recommend using 'getRealTimeUpdateNotifications'. +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 + + +-- | A notification for the 'UserRTUO' object. +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 diff --git a/tests/runtests.hs b/tests/runtests.hs --- a/tests/runtests.hs +++ b/tests/runtests.hs @@ -167,6 +167,13 @@ r <- FB.fqlQuery "SELECT name FROM page WHERE page_id = 20531316728" Nothing r &?= FB.FQLResult [PageName "Facebook"] + describe' "listSubscriptions" $ do + it "returns something" $ do + runAuth $ do + token <- FB.getAppAccessToken + val <- FB.listSubscriptions token + length val `seq` return () + newtype PageName = PageName Text deriving (Eq, Show) instance A.FromJSON PageName where parseJSON (A.Object v) = PageName <$> (v A..: "name")