{-# 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.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


-- | 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 :: (R.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"
      <*> fmap (map encodeUtf8) (v A..: "fields")
      <*> v A..: "active"
  parseJSON _ = mzero


-- | List current real-time update subscriptions.
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


-- | 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"
      <*> fmap (map encodeUtf8) (v A..: "changed_fields")
      <*> v A..: "time"

  parseJSON _ = mzero