{-# LANGUAGE TypeFamilies #-}

module Servant.Pagination
  (
  -- * Types
    Range(..)
  , RangeOrder(..)
  , AcceptRanges (..)
  , ContentRange (..)
  , NextRange (..)
  , PageHeaders
  , TotalCount

  -- * Declare Ranges
  , FromRange(..)
  , FromHttpApiData(..)
  , FromRangeOptions(..)
  , defaultOptions
  , defaultRange

  -- * Use Ranges
  , HasPagination(..)
  , applyRange

  -- * Combine Ranges
  , (:|:)(..)
  ) where

import           Data.List                   (filter, find)
import           Data.Maybe                  (fromMaybe, listToMaybe)
import           Data.Proxy                  (Proxy (..))
import           Data.Semigroup              ((<>))
import           Data.Text                   (Text)
import           GHC.Generics                (Generic)
import           GHC.TypeLits                (KnownSymbol, Symbol, symbolVal)
import           Numeric.Natural             (Natural)
import           Servant

import qualified Data.List                   as List
import qualified Data.Text                   as Text
import qualified Safe

import           Servant.Pagination.Internal


--
-- TYPES
--

-- An actual Range parsed from a `Range` header. A Range
data Range (field :: Symbol) typ = Range
  { rangeValue  :: Maybe typ   -- ^ The value of that field, beginning of the range
  , rangeLimit  :: Int         -- ^ Maximum number of resources to return
  , rangeOffset :: Int         -- ^ Offset, number of resources to skip after the starting value
  , rangeOrder  :: RangeOrder  -- ^ The order of sorting (ascending or descending)
  } deriving (Eq, Show, Generic)

instance Functor (Range field) where
  fmap f r =
    r { rangeValue = f <$> rangeValue r }

instance (ToHttpApiData typ, KnownSymbol field) => ToHttpApiData (Range field typ) where
  toUrlPiece Range{..} =
    Text.pack (symbolVal (Proxy :: Proxy field))
    <> maybe "" (\v -> " " <> toUrlPiece v) rangeValue
    <> ";limit "  <> toUrlPiece rangeLimit
    <> ";offset " <> toUrlPiece rangeOffset
    <> ";order "  <> toUrlPiece rangeOrder

instance (KnownSymbol field) => ToAcceptRanges (Range field typ) where
  toAcceptRanges _ =
    Text.pack (symbolVal (Proxy :: Proxy field))


-- | Define the sorting order of the paginated resources (ascending or descending)
data RangeOrder
  = RangeAsc
  | RangeDesc
  deriving (Eq, Show, Ord, Generic)

instance ToHttpApiData RangeOrder where
  toUrlPiece order =
    case order of
      RangeAsc  -> "asc"
      RangeDesc -> "desc"

instance FromHttpApiData RangeOrder where
  parseUrlPiece txt =
    case txt of
      "asc"  -> pure RangeAsc
      "desc" -> pure RangeDesc
      _      -> Left "Invalid Range Order"


-- | Accepted Ranges in the `Accept-Ranges` response's header
data AcceptRanges range = AcceptRanges

instance (ToAcceptRanges a) => ToHttpApiData (AcceptRanges a) where
  toUrlPiece _ =
    toAcceptRanges (Proxy :: Proxy a)


-- | Actual range returned, in the `Content-Range` response's header
data ContentRange range = ContentRange
  { contentRangeStart :: range
  , contentRangeEnd   :: range
  }

instance (ToHttpApiData typ, KnownSymbol field) => ToHttpApiData (ContentRange (Range field typ)) where
  toUrlPiece (ContentRange start end) =
    Text.pack (symbolVal (Proxy :: Proxy field))
    <> " "  <> (fromMaybe "" (toUrlPiece <$> rangeValue start))
    <> ".." <> (fromMaybe "" (toUrlPiece <$> rangeValue end))

instance (ToHttpApiData (ContentRange a), ToHttpApiData (ContentRange b)) => ToHttpApiData (ContentRange (a :|: b)) where
  toUrlPiece (ContentRange (InL sa) (InL ea)) =
    toUrlPiece (ContentRange sa ea)

  toUrlPiece (ContentRange (InR sb) (InR eb)) =
    toUrlPiece (ContentRange sb eb)

  toUrlPiece _ =
    error "impossible"


-- | Range to provide to retrieve the next batch of resource, in the `Next-Range` response's header
data NextRange range = NextRange range

instance (ToHttpApiData typ, KnownSymbol field) => ToHttpApiData (NextRange (Range field typ)) where
  toUrlPiece (NextRange r) =
    toUrlPiece r

instance (ToHttpApiData (NextRange a), ToHttpApiData (NextRange b)) => ToHttpApiData (NextRange (a :|: b)) where
  toUrlPiece (NextRange (InL a)) =
    toUrlPiece (NextRange a)

  toUrlPiece (NextRange (InR b)) =
    toUrlPiece (NextRange b)


-- | Type alias to declare response headers related to pagination
type PageHeaders range =
  '[ Header "Accept-Ranges" (AcceptRanges range)
   , Header "Content-Range" (ContentRange range)
   , Header "Next-Range"    (NextRange range)
   , Header "Total-Count"   Natural
   ]


--
-- DECLARE RANGES
--

-- | Default values to apply when parsing a Range
data FromRangeOptions  = FromRangeOptions
  { defaultRangeLimit  :: Int
  , defaultRangeOffset :: Int
  , defaultRangeOrder  :: RangeOrder
  } deriving (Eq, Show)


-- | Some default options of default values for a Range (limit 100; offset 0; order desc)
defaultOptions :: FromRangeOptions
defaultOptions =
  FromRangeOptions 100 0 RangeDesc


-- | Some default range based on the default options
defaultRange :: Maybe a -> FromRangeOptions -> Range field a
defaultRange val opts =
  let
    (FromRangeOptions lim off ord) =
      opts
  in
    Range val lim off ord


-- | Parse a Range object from a `Range` request's header. Any `Range field typ` and combinations
-- of any `Range field typ` provide instance of this class. It is a signature similar to
-- `parseUrlPiece` from the `FromHttpApiData` class and can be used as a drop-in replacement to
-- define instance of this class.
--
-- > type MyRange = Range "created_at" UTCTime
-- >
-- > instance FromHttpApiData UTCTime => FromHttpApiData MyRange where
-- >     parseUrlPiece =
-- >         fromRange defaultOptions
class FromRange a where
  parseRange :: FromRangeOptions -> Text -> Either Text a

instance (FromHttpApiData typ, KnownSymbol field) => FromRange (Range field typ) where
  parseRange FromRangeOptions{..} txt =
    let
      toTuples =
        filter (/= "") . Text.splitOn (Text.singleton ' ')

      args =
        map toTuples $ Text.splitOn (Text.singleton ';') txt

      field =
        Text.pack $ symbolVal (Proxy :: Proxy field)
    in
      case args of
        (field' : value) : rest | field == field' -> do
          opts <-
            traverse parseOpt rest

          Range
            <$> sequence (fmap parseQueryParam (listToMaybe value))
            <*> ifOpt "limit" defaultRangeLimit opts
            <*> ifOpt "offset"  defaultRangeOffset opts
            <*> ifOpt "order" defaultRangeOrder opts

        _ ->
          Left "Invalid Range"
    where
      parseOpt :: [Text] -> Either Text (Text, Text)
      parseOpt piece =
        case piece of
          [opt, arg] ->
            pure (opt, arg)

          _ ->
            Left "Invalid Range Options"

      ifOpt :: FromHttpApiData o => Text -> o -> [(Text, Text)] -> Either Text o
      ifOpt opt def =
        maybe (pure def) (parseQueryParam . snd) . find ((== opt) . fst)

instance {-# Overlappable #-} (FromHttpApiData typ, KnownSymbol field) => FromHttpApiData (Range field typ) where
  parseUrlPiece =
    parseRange defaultOptions


type TotalCount =
  Maybe Natural

--
-- USE RANGES
--

-- | In addition to the `FromHttpApiData` instance, one can provide an instance for this
-- type-class to easily lift a list of response to a Servant handler.
-- By providing a getter to retrieve the value of an actual range from a resource, the
-- `HasPagination` class provides `returnPage` to handle the plumbering of declaring
-- response headers related to pagination.
class KnownSymbol field => HasPagination resource field where
  type RangeType resource field :: *

  getRangeField :: Proxy field -> resource -> RangeType resource field

  returnPage_ :: forall m ranges.
    ( Monad m
    , (Range field (RangeType resource field)) :<: ranges
    , ToAcceptRanges ranges
    , ToHttpApiData (ContentRange ranges)
    , ToHttpApiData (NextRange ranges)
    , Ord (RangeType resource field)
    ) => (Range field (RangeType resource field)) -> [resource] -> m (Headers (PageHeaders ranges) [resource])
  returnPage_ =
    returnPage Nothing
  {-# INLINE returnPage_ #-}

  returnPage :: forall m ranges.
    ( Monad m
    , (Range field (RangeType resource field)) :<: ranges
    , ToAcceptRanges ranges
    , ToHttpApiData (ContentRange ranges)
    , ToHttpApiData (NextRange ranges)
    , Ord (RangeType resource field)
    ) => TotalCount -> (Range field (RangeType resource field)) -> [resource] -> m (Headers (PageHeaders ranges) [resource])
  returnPage count range rs = do
    let field =
          Proxy :: Proxy field

    let boundaries = (,)
          <$> fmap (getRangeField field) (Safe.headMay rs)
          <*> fmap (getRangeField field) (Safe.lastMay rs)

    let acceptRanges =
          addHeader (AcceptRanges :: AcceptRanges ranges)

    let totalCount =
          maybe noHeader addHeader count

    case boundaries of
      Nothing ->
        return $
          acceptRanges $ noHeader $ noHeader $ totalCount rs

      Just (start, end) -> do
        let rangeStart =
              liftRange $ (range { rangeValue = Just start } :: Range field (RangeType resource field))

        let rangeEnd =
              liftRange $ (range { rangeValue = Just end } :: Range field (RangeType resource field))

        let nextOffset | rangeValue range `compare` Just end == EQ = rangeOffset range + length rs
                       | otherwise = length $ takeWhile (\r -> getRangeField field r `compare` end == EQ) $ reverse rs
        
        let rangeNext =
              liftRange $ (range { rangeValue = Just end, rangeOffset = nextOffset } :: Range field (RangeType resource field))

        let contentRange =
              addHeader $ ContentRange
                { contentRangeStart = rangeStart
                , contentRangeEnd   = rangeEnd
                }

        let nextRange =
              addHeader $ NextRange $ rangeNext

        return
          $ acceptRanges $ contentRange $ nextRange $ totalCount rs


-- | Apply a range to a list of element
applyRange :: forall b field. (HasPagination b field, Ord (RangeType b field)) => Range field (RangeType b field) -> [b] -> [b]
applyRange Range{..} =
  let
    field =
      Proxy :: Proxy (field :: Symbol)

    sortRel =
      case rangeOrder of
        RangeDesc ->
          \a b -> compare (getRangeField field b) (getRangeField field a)

        RangeAsc ->
          \a b -> compare (getRangeField field a) (getRangeField field b)

    dropRel =
      case (rangeValue, rangeOrder) of
        (Nothing, _) ->
          const False

        (Just a, RangeDesc) ->
          (> a) . (getRangeField field)

        (Just a, RangeAsc) ->
          (< a) . (getRangeField field)
  in
      List.take rangeLimit
    . List.drop rangeOffset
    . List.dropWhile dropRel
    . List.sortBy sortRel