{-# 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
  { pagerData :: [a]
  , pagerPrevious :: Maybe String
  , pagerNext :: Maybe String
  } deriving (Eq, Ord, Show, Read, Typeable)

instance A.FromJSON a =>
         A.FromJSON (Pager a) where
  parseJSON (A.Object v) =
    let paging f = v A..:? "paging" >>= maybe (return Nothing) (A..:? f)
    in Pager <$> v A..: "data" <*> paging "previous" <*> paging "next"
  parseJSON _ = 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 = fetchHelper 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 = fetchHelper 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 pagerRef pager =
  case pagerRef pager of
    Nothing -> return Nothing
    Just url -> do
      req <- liftIO (H.parseRequest url)
      Just <$>
        (asJson =<<
         fbhttp
           req
           { H.redirectCount = 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 = fetchAllHelper 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 = fetchAllHelper 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 pagerRef pager = do
  manager <- getManager
  let go (x:xs) mnext = C.yield x >> go xs mnext
      go [] Nothing = return ()
      go [] (Just next) = do
        req <- liftIO (H.parseRequest next)
        let get =
              fbhttpHelper
                manager
                req
                { H.redirectCount = 3
                }
        start =<< lift (R.runResourceT $ asJsonHelper =<< get)
      start p = go (pagerData p) $! pagerRef p
  return (start pager)