    {-# 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, void)
    import Crypto.Hash.CryptoAPI (SHA1)
    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 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

    -- | 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
                 ]
      runResourceInFb $ do
        req <- fbreq path (Just apptoken) args
        void $ fbhttp req { H.method = HT.methodPost }
      return ()

    -- | (Internal)  Get the subscription's path.
    getSubscriptionsPath :: Monad m => FacebookT Auth m Text
    getSubscriptionsPath = do
      creds <- getCreds
      return $ T.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
      pager <- getObject path [] (Just apptoken)
      src <- fetchAllNextPages pager
      lift $ src C.$$ CL.consume

    -- | 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 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

    -- | 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