{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
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 Control.Monad.IO.Class
import qualified Control.Monad.Trans.Resource as R
import Crypto.Hash.Algorithms (SHA1)
import Crypto.MAC.HMAC (HMAC(..), hmac)
import qualified Data.Aeson as A
import Data.ByteArray (ScrubbedBytes, convert)
import Data.ByteArray.Encoding (Base(..), convertToBase)
import qualified Data.ByteString as B
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import Facebook.Base
import Facebook.Graph
import Facebook.Monad
import Facebook.Pager
import Facebook.Types
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, MonadIO 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, MonadIO m)
=> ByteString
-> L.ByteString
-> FacebookT Auth m (Maybe L.ByteString)
verifyRealTimeUpdateNotifications sig body = do
creds <- getCreds
let hmacData :: HMAC SHA1
hmacData = hmac (appSecretBS creds) (L.toStrict body)
hash :: B.ByteString
hash = convertToBase Base16 hmacData
expected = "sha1=" <> hash
return $!
if ((convert sig :: ScrubbedBytes) == (convert expected))
then Just body
else Nothing
getRealTimeUpdateNotifications ::
(Monad m, A.FromJSON a, MonadIO m)
=> 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