{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Facebook.Pager
  ( Pager(..)
  , fetchNextPage
  , fetchPreviousPage
  , fetchAllNextPages
  , fetchAllPreviousPages
  ) where

import Control.Monad (mzero)
import Control.Monad.IO.Class (liftIO)
import Data.Typeable (Typeable)

import qualified Control.Monad.Trans.Resource as R
import qualified Data.Aeson as A
import qualified Data.Conduit as C
import qualified Network.HTTP.Conduit as H

import Facebook.Base
import Facebook.Monad

-- | Many Graph API results are returned as a JSON object with
-- the following structure:
--
-- @
-- {
--   \"data\": [
--     ...item 1...,
--          :
--     ...item n...
--   ],
--   \"paging\": {
--     \"previous\": \"http://...link to previous page...\",
--     \"next\":     \"http://...link to next page...\"
--   }
-- }
-- @
--
-- Only the @\"data\"@ field is required, the others may or may
-- not appear.
--
-- A @Pager a@ datatype encodes such result where each item has
-- type @a@.  You may use functions 'fetchNextPage' and
-- 'fetchPreviousPage' to navigate through the results.
data Pager a = Pager
  { Pager a -> [a]
pagerData :: [a]
  , Pager a -> Maybe String
pagerPrevious :: Maybe String
  , Pager a -> Maybe String
pagerNext :: Maybe String
  } deriving (Pager a -> Pager a -> Bool
(Pager a -> Pager a -> Bool)
-> (Pager a -> Pager a -> Bool) -> Eq (Pager a)
forall a. Eq a => Pager a -> Pager a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pager a -> Pager a -> Bool
$c/= :: forall a. Eq a => Pager a -> Pager a -> Bool
== :: Pager a -> Pager a -> Bool
$c== :: forall a. Eq a => Pager a -> Pager a -> Bool
Eq, Eq (Pager a)
Eq (Pager a)
-> (Pager a -> Pager a -> Ordering)
-> (Pager a -> Pager a -> Bool)
-> (Pager a -> Pager a -> Bool)
-> (Pager a -> Pager a -> Bool)
-> (Pager a -> Pager a -> Bool)
-> (Pager a -> Pager a -> Pager a)
-> (Pager a -> Pager a -> Pager a)
-> Ord (Pager a)
Pager a -> Pager a -> Bool
Pager a -> Pager a -> Ordering
Pager a -> Pager a -> Pager a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Pager a)
forall a. Ord a => Pager a -> Pager a -> Bool
forall a. Ord a => Pager a -> Pager a -> Ordering
forall a. Ord a => Pager a -> Pager a -> Pager a
min :: Pager a -> Pager a -> Pager a
$cmin :: forall a. Ord a => Pager a -> Pager a -> Pager a
max :: Pager a -> Pager a -> Pager a
$cmax :: forall a. Ord a => Pager a -> Pager a -> Pager a
>= :: Pager a -> Pager a -> Bool
$c>= :: forall a. Ord a => Pager a -> Pager a -> Bool
> :: Pager a -> Pager a -> Bool
$c> :: forall a. Ord a => Pager a -> Pager a -> Bool
<= :: Pager a -> Pager a -> Bool
$c<= :: forall a. Ord a => Pager a -> Pager a -> Bool
< :: Pager a -> Pager a -> Bool
$c< :: forall a. Ord a => Pager a -> Pager a -> Bool
compare :: Pager a -> Pager a -> Ordering
$ccompare :: forall a. Ord a => Pager a -> Pager a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Pager a)
Ord, Int -> Pager a -> ShowS
[Pager a] -> ShowS
Pager a -> String
(Int -> Pager a -> ShowS)
-> (Pager a -> String) -> ([Pager a] -> ShowS) -> Show (Pager a)
forall a. Show a => Int -> Pager a -> ShowS
forall a. Show a => [Pager a] -> ShowS
forall a. Show a => Pager a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pager a] -> ShowS
$cshowList :: forall a. Show a => [Pager a] -> ShowS
show :: Pager a -> String
$cshow :: forall a. Show a => Pager a -> String
showsPrec :: Int -> Pager a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Pager a -> ShowS
Show, ReadPrec [Pager a]
ReadPrec (Pager a)
Int -> ReadS (Pager a)
ReadS [Pager a]
(Int -> ReadS (Pager a))
-> ReadS [Pager a]
-> ReadPrec (Pager a)
-> ReadPrec [Pager a]
-> Read (Pager a)
forall a. Read a => ReadPrec [Pager a]
forall a. Read a => ReadPrec (Pager a)
forall a. Read a => Int -> ReadS (Pager a)
forall a. Read a => ReadS [Pager a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Pager a]
$creadListPrec :: forall a. Read a => ReadPrec [Pager a]
readPrec :: ReadPrec (Pager a)
$creadPrec :: forall a. Read a => ReadPrec (Pager a)
readList :: ReadS [Pager a]
$creadList :: forall a. Read a => ReadS [Pager a]
readsPrec :: Int -> ReadS (Pager a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Pager a)
Read, Typeable)

instance A.FromJSON a =>
         A.FromJSON (Pager a) where
  parseJSON :: Value -> Parser (Pager a)
parseJSON (A.Object Object
v) =
    let paging :: Key -> Parser (Maybe a)
paging Key
f = Object
v Object -> Key -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
A..:? Key
"paging" Parser (Maybe Object)
-> (Maybe Object -> Parser (Maybe a)) -> Parser (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser (Maybe a)
-> (Object -> Parser (Maybe a)) -> Maybe Object -> Parser (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> Parser (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) (Object -> Key -> Parser (Maybe a)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
A..:? Key
f)
    in [a] -> Maybe String -> Maybe String -> Pager a
forall a. [a] -> Maybe String -> Maybe String -> Pager a
Pager ([a] -> Maybe String -> Maybe String -> Pager a)
-> Parser [a] -> Parser (Maybe String -> Maybe String -> Pager a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser [a]
forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"data" Parser (Maybe String -> Maybe String -> Pager a)
-> Parser (Maybe String) -> Parser (Maybe String -> Pager a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Key -> Parser (Maybe String)
forall a. FromJSON a => Key -> Parser (Maybe a)
paging Key
"previous" Parser (Maybe String -> Pager a)
-> Parser (Maybe String) -> Parser (Pager a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Key -> Parser (Maybe String)
forall a. FromJSON a => Key -> Parser (Maybe a)
paging Key
"next"
  parseJSON Value
_ = Parser (Pager a)
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Tries to fetch the next page of a 'Pager'.  Returns
-- 'Nothing' whenever the current @Pager@ does not have a
-- 'pagerNext'.
fetchNextPage
  :: (R.MonadResource m, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m)
  => Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchNextPage :: Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchNextPage = (Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (Maybe (Pager a))
forall (m :: * -> *) a anyAuth.
(MonadResource m, FromJSON a, MonadThrow m, MonadUnliftIO m) =>
(Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchHelper Pager a -> Maybe String
forall a. Pager a -> Maybe String
pagerNext

-- | Tries to fetch the previous page of a 'Pager'.  Returns
-- 'Nothing' whenever the current @Pager@ does not have a
-- 'pagerPrevious'.
fetchPreviousPage
  :: (R.MonadResource m, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m)
  => Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchPreviousPage :: Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchPreviousPage = (Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (Maybe (Pager a))
forall (m :: * -> *) a anyAuth.
(MonadResource m, FromJSON a, MonadThrow m, MonadUnliftIO m) =>
(Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchHelper Pager a -> Maybe String
forall a. Pager a -> Maybe String
pagerPrevious

-- | (Internal) See 'fetchNextPage' and 'fetchPreviousPage'.
fetchHelper
  :: (R.MonadResource m, A.FromJSON a, R.MonadThrow m, R.MonadUnliftIO m)
  => (Pager a -> Maybe String)
  -> Pager a
  -> FacebookT anyAuth m (Maybe (Pager a))
fetchHelper :: (Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (Maybe (Pager a))
fetchHelper Pager a -> Maybe String
pagerRef Pager a
pager =
  case Pager a -> Maybe String
pagerRef Pager a
pager of
    Maybe String
Nothing -> Maybe (Pager a) -> FacebookT anyAuth m (Maybe (Pager a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Pager a)
forall a. Maybe a
Nothing
    Just String
url -> do
      Request
req <- IO Request -> FacebookT anyAuth m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
H.parseRequest String
url)
      Pager a -> Maybe (Pager a)
forall a. a -> Maybe a
Just (Pager a -> Maybe (Pager a))
-> FacebookT anyAuth m (Pager a)
-> FacebookT anyAuth m (Maybe (Pager a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (Response (ConduitT () ByteString m ())
-> FacebookT anyAuth m (Pager a)
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(MonadIO m, MonadTrans t, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> t m a
asJson (Response (ConduitT () ByteString m ())
 -> FacebookT anyAuth m (Pager a))
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
-> FacebookT anyAuth m (Pager a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
         Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
forall (m :: * -> *) anyAuth.
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Request
-> FacebookT anyAuth m (Response (ConduitT () ByteString m ()))
fbhttp
           Request
req
           { redirectCount :: Int
H.redirectCount = Int
3
           })

-- | Tries to fetch all next pages and returns a 'C.Source' with
-- all results.  The 'C.Source' will include the results from
-- this page as well.  Previous pages will not be considered.
-- Next pages will be fetched on-demand.
fetchAllNextPages
  :: (Monad m, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n)
  => Pager a -> FacebookT anyAuth m (C.ConduitT () a n ())
fetchAllNextPages :: Pager a -> FacebookT anyAuth m (ConduitT () a n ())
fetchAllNextPages = (Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (ConduitT () a n ())
forall (m :: * -> *) a (n :: * -> *) anyAuth.
(Monad m, FromJSON a, MonadUnliftIO n, MonadThrow n) =>
(Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (ConduitT () a n ())
fetchAllHelper Pager a -> Maybe String
forall a. Pager a -> Maybe String
pagerNext

-- | Tries to fetch all previous pages and returns a 'C.Source'
-- with all results.  The 'C.Source' will include the results
-- from this page as well.  Next pages will not be
-- considered.  Previous pages will be fetched on-demand.
fetchAllPreviousPages
  :: (Monad m, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n)
  => Pager a -> FacebookT anyAuth m (C.ConduitT () a n ())
fetchAllPreviousPages :: Pager a -> FacebookT anyAuth m (ConduitT () a n ())
fetchAllPreviousPages = (Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (ConduitT () a n ())
forall (m :: * -> *) a (n :: * -> *) anyAuth.
(Monad m, FromJSON a, MonadUnliftIO n, MonadThrow n) =>
(Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (ConduitT () a n ())
fetchAllHelper Pager a -> Maybe String
forall a. Pager a -> Maybe String
pagerPrevious

-- | (Internal) See 'fetchAllNextPages' and 'fetchAllPreviousPages'.
fetchAllHelper
  :: (Monad m, A.FromJSON a, R.MonadUnliftIO n, R.MonadThrow n)
  => (Pager a -> Maybe String)
  -> Pager a
  -> FacebookT anyAuth m (C.ConduitT () a n ())
fetchAllHelper :: (Pager a -> Maybe String)
-> Pager a -> FacebookT anyAuth m (ConduitT () a n ())
fetchAllHelper Pager a -> Maybe String
pagerRef Pager a
pager = do
  Manager
manager <- FacebookT anyAuth m Manager
forall (m :: * -> *) anyAuth.
Monad m =>
FacebookT anyAuth m Manager
getManager
  let go :: [a] -> Maybe String -> ConduitT i a m ()
go (a
x:[a]
xs) Maybe String
mnext = a -> ConduitT i a m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
C.yield a
x ConduitT i a m () -> ConduitT i a m () -> ConduitT i a m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> Maybe String -> ConduitT i a m ()
go [a]
xs Maybe String
mnext
      go [] Maybe String
Nothing = () -> ConduitT i a m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      go [] (Just String
next) = do
        Request
req <- IO Request -> ConduitT i a m Request
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
H.parseRequest String
next)
        let get :: ResourceT m (Response (ConduitT () ByteString (ResourceT m) ()))
get =
              Manager
-> Request
-> ResourceT m (Response (ConduitT () ByteString (ResourceT m) ()))
forall (m :: * -> *).
(MonadResource m, MonadUnliftIO m, MonadThrow m) =>
Manager -> Request -> m (Response (ConduitT () ByteString m ()))
fbhttpHelper
                Manager
manager
                Request
req
                { redirectCount :: Int
H.redirectCount = Int
3
                }
        Pager a -> ConduitT i a m ()
start (Pager a -> ConduitT i a m ())
-> ConduitT i a m (Pager a) -> ConduitT i a m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Pager a) -> ConduitT i a m (Pager a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ResourceT m (Pager a) -> m (Pager a)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
R.runResourceT (ResourceT m (Pager a) -> m (Pager a))
-> ResourceT m (Pager a) -> m (Pager a)
forall a b. (a -> b) -> a -> b
$ Response (ConduitT () ByteString (ResourceT m) ())
-> ResourceT m (Pager a)
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m, FromJSON a) =>
Response (ConduitT () ByteString m ()) -> m a
asJsonHelper (Response (ConduitT () ByteString (ResourceT m) ())
 -> ResourceT m (Pager a))
-> ResourceT m (Response (ConduitT () ByteString (ResourceT m) ()))
-> ResourceT m (Pager a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ResourceT m (Response (ConduitT () ByteString (ResourceT m) ()))
get)
      start :: Pager a -> ConduitT i a m ()
start Pager a
p = [a] -> Maybe String -> ConduitT i a m ()
go (Pager a -> [a]
forall a. Pager a -> [a]
pagerData Pager a
p) (Maybe String -> ConduitT i a m ())
-> Maybe String -> ConduitT i a m ()
forall a b. (a -> b) -> a -> b
$! Pager a -> Maybe String
pagerRef Pager a
p
  ConduitT () a n () -> FacebookT anyAuth m (ConduitT () a n ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Pager a -> ConduitT () a n ()
forall (m :: * -> *) i.
(MonadThrow m, MonadUnliftIO m) =>
Pager a -> ConduitT i a m ()
start Pager a
pager)