{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeApplications #-}

-- | Opinionated Pagination Helpers for Servant APIs
--
--
-- Client can provide a `Range` header with their request with the following format
--
-- > Range: <field> [<value>][; offset <o>][; limit <l>][; order <asc|desc>]
--
-- Available ranges are declared using type-level list of accepted fields, bound to a given
-- resource and type using the 'HasPagination' type-class. The library provides unobtrusive
-- types and abstract away all the plumbing to hook that on an existing Servant API.
--
-- The 'IsRangeType' constraints summarize all constraints that must apply to a possible field
-- and heavily rely on the 'Web.Internal.FromHttpApiData' and 'Web.Internal.ToHttpApiData'.
--
-- > $ curl -v http://localhost:1337/colors -H 'Range: name; limit 10'
-- >
-- > > GET /colors HTTP/1.1
-- > > Host: localhost:1337
-- > > User-Agent: curl/7.47.0
-- > > Accept: */*
-- > >
-- > < HTTP/1.1 206 Partial Content
-- > < Transfer-Encoding: chunked
-- > < Date: Tue, 30 Jan 2018 12:45:17 GMT
-- > < Server: Warp/3.2.13
-- > < Content-Type: application/json;charset=utf-8
-- > < Accept-Ranges: name
-- > < Content-Range: name Yellow..Purple
-- > < Next-Range: name Purple;limit 10;offset 1;order desc
--
-- The 'Range' header is totally optional, but when provided, it indicates to the server what
-- parts of the collection is requested. As a reponse and in addition to the data, the server may
-- provide 3 headers to the client:
--
-- - @Accept-Ranges@: A comma-separated list of field upon which a range can be defined
-- - @Content-Range@: Actual range corresponding to the content being returned
-- - @Next-Range@: Indicate what should be the next `Range` header in order to retrieve the next range
--
-- This allows the client to work in a very _dumb_ mode where it simply consumes data from the server
-- using the value of the 'Next-Range' header to fetch each new batch of data. The 'Accept-Ranges'
-- comes in handy to self-document the API telling the client about the available filtering and sorting options
-- of a resource.
--
-- Here's a minimal example used to obtained the previous behavior; Most of the magic happens in the
-- 'returnRange' function which lift a collection of resources into a Servant handler, computing the
-- corresponding ranges from the range used to retrieve the resources.
--
-- @
-- -- Resource Type
--
-- data Color = Color
--   { name :: 'String'
--   , rgb  :: ['Int']
--   , hex  :: 'String'
--   } deriving ('Eq', 'Show', 'GHC.Generics.Generic')
--
-- colors :: [Color]
-- colors = [ {- ... -} ]
--
-- -- Ranges definitions
--
-- instance 'HasPagination' Color "name" where
--   type 'RangeType' Color "name" = 'String'
--   'getFieldValue' _ = name
--
--
-- -- API
--
-- type API =
--   "colors"
--     :> 'Servant.Header' \"Range\" ('Ranges' '["name"] Color)
--     :> 'Servant.GetPartialContent' '['Servant.JSON'] ('Servant.Headers' ('PageHeaders' '["name"] Color) [Color])
--
--
-- -- Application
--
-- defaultRange :: 'Range' "name" 'String'
-- defaultRange =
--   'getDefaultRange' ('Data.Proxy.Proxy' \@Color)
--
-- server :: 'Servant.Server.Server' API
-- server mrange = do
--   let range =
--         'Data.Maybe.fromMaybe' defaultRange (mrange >>= 'extractRange')
--
--   'returnRange' range ('applyRange' range colors)
--
-- main :: 'IO' ()
-- main =
--   'Network.Wai.Handler.Warp.run' 1337 ('Servant.Server.serve' ('Data.Proxy.Proxy' \@API) server)
-- @
module Servant.Pagination
  (
  -- * Types
  Ranges
  , Range(..)
  , RangeOrder(..)
  , AcceptRanges (..)
  , ContentRange (..)
  , PageHeaders
  , IsRangeType

  -- * Declare Ranges
  , HasPagination(..)
  , RangeOptions(..)
  , defaultOptions

  -- * Use Ranges
  , extractRange
  , putRange
  , returnRange
  , applyRange
  ) where

import           Data.List          (filter, find, intercalate)
import           Data.Maybe         (listToMaybe)
import           Data.Proxy         (Proxy (..))
import           Data.Semigroup     ((<>))
import           Data.Text          (Text)
import           GHC.Generics       (Generic)
import           GHC.TypeLits       (KnownSymbol, Symbol, symbolVal)
import           Network.URI.Encode (decodeText, encodeText)
import           Servant

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


--
-- TYPES
--

-- | Set of constraints that must apply to every type target of a 'Range'
type IsRangeType a =
  ( Show a
  , Ord a
  , Eq a
  , FromHttpApiData a
  , ToHttpApiData a
  )

-- | A type to specify accepted Ranges via the @Range@ HTTP Header. For example:
--
-- @
-- type API = "resources"
--   :> 'Servant.Header' \"Range\" ('Ranges' '["created_at"] Resource)
--   :> 'Servant.Get' '['Servant.JSON'] [Resource]
-- @
data Ranges :: [Symbol] -> * -> * where
  Lift   :: Ranges fields resource -> Ranges (y ': fields) resource
  Ranges
    :: HasPagination resource field
    => Range field (RangeType resource field)
    -> Ranges (field ': fields) resource

instance (Show (Ranges '[] res)) where
  showsPrec _ _ = flip mappend "Ranges"

instance (Show (Ranges fields res)) => Show (Ranges (field ': fields) res) where
  showsPrec prec (Lift r)   s = showsPrec prec r s
  showsPrec prec (Ranges r) s =
    let
      inner = "Ranges@" ++ showsPrec 11 r s
    in
      if prec > 10 then "(" ++ inner ++ ")" else inner


-- | An actual 'Range' instance obtained from parsing / to generate a @Range@ HTTP Header.
data Range (field :: Symbol) (a :: *) =
  (KnownSymbol field, IsRangeType a) => Range
  { rangeValue  :: Maybe a     -- ^ 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)
  , rangeField  :: Proxy field -- ^ Actual field this Range actually refers to
  }

instance Eq (Range field a) where
  (Range val0 lim0 off0 ord0 _) == (Range val1 lim1 off1 ord1 _) =
       val0 == val1
    && lim0 == lim1
    && off0 == off1
    && ord0 == ord1

instance Show (Range field a) where
  showsPrec prec Range{..} =
    let
      inner = "Range {" ++ args ++ "}"
      args  = intercalate ", "
        [ "rangeValue = "  ++ show rangeValue
        , "rangeLimit = "  ++ show rangeLimit
        , "rangeOffset = " ++ show rangeOffset
        , "rangeOrder = "  ++ show rangeOrder
        , "rangeField = "  ++ "\"" ++ symbolVal rangeField ++ "\""
        ]
    in
      flip mappend $ if prec > 10 then
        "(" ++ inner ++ ")"
      else
        inner


-- | Extract a 'Range' from a 'Ranges'
class ExtractRange (fields :: [Symbol]) (field :: Symbol) where
  -- | Extract a 'Range' from a 'Ranges'. Works like a safe 'read', trying to coerce a 'Range' instance to
  -- an expected type. Type annotation are most likely necessary to remove ambiguity. Note that a 'Range'
  -- can only be extracted to a type bound by the allowed 'fields' on a given 'resource'.
  --
  -- @
  -- extractDateRange :: 'Ranges' '["created_at", "name"] Resource -> 'Range' "created_at" 'Data.Time.Clock.UTCTime'
  -- extractDateRange =
  --   'extractRange'
  -- @
  extractRange
    :: HasPagination resource field
    => Ranges fields resource                         -- ^ A list of accepted Ranges for the API
    -> Maybe (Range field (RangeType resource field)) -- ^ A Range instance of the expected type, if it matches

instance ExtractRange (field ': fields) field where
  extractRange (Ranges r) = Just r
  extractRange (Lift _)   = Nothing
  {-# INLINE extractRange #-}

instance {-# OVERLAPPABLE #-} ExtractRange fields field => ExtractRange (y ': fields) field where
  extractRange (Ranges _) = Nothing
  extractRange (Lift r)   = extractRange r
  {-# INLINE extractRange #-}


-- | Put a 'Range' in a 'Ranges'
class PutRange (fields :: [Symbol]) (field :: Symbol) where
  putRange
    :: HasPagination resource field
    => Range field (RangeType resource field)
    -> Ranges fields resource

instance PutRange (field ': fields) field where
  putRange = Ranges
  {-# INLINE putRange #-}

instance {-# OVERLAPPABLE #-} (PutRange fields field) => PutRange (y ': fields) field where
  putRange = Lift . putRange
  {-# INLINE putRange #-}


instance ToHttpApiData (Ranges fields resource) where
  toUrlPiece (Lift range) =
    toUrlPiece range

  toUrlPiece (Ranges Range{..}) =
    Text.pack (symbolVal rangeField)
    <> maybe "" (\v -> " " <> (encodeText . toUrlPiece) v) rangeValue
    <> ";limit "  <> toUrlPiece rangeLimit
    <> ";offset " <> toUrlPiece rangeOffset
    <> ";order "  <> toUrlPiece rangeOrder


instance FromHttpApiData (Ranges '[] resource) where
  parseUrlPiece _ =
    Left "Invalid Range"

instance
  ( FromHttpApiData (Ranges fields resource)
  , HasPagination resource field
  , KnownSymbol field
  , IsRangeType (RangeType resource field)
  ) => FromHttpApiData (Ranges (field ': fields) resource) where
  parseUrlPiece txt =
    let
      RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource)

      toTuples =
        filter (/= "") . Text.splitOn (Text.singleton ' ')

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

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

          range <- Range
            <$> mapM (parseUrlPiece . decodeText) (listToMaybe value)
            <*> (ifOpt "limit"  defaultRangeLimit opts >>= checkLimit)
            <*> ifOpt "offset" defaultRangeOffset opts
            <*> ifOpt "order"  defaultRangeOrder opts
            <*> pure (Proxy @field)

          pure $ Ranges range

        _ ->
          Lift <$> (parseUrlPiece txt :: Either Text (Ranges fields resource))
    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)

      checkLimit :: Int -> Either Text Int
      checkLimit n
        | n < 0     = Left "Limit must be non-negative"
        | otherwise = return n

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


-- | Type alias to declare response headers related to pagination
--
-- @
-- type MyHeaders =
--   'PageHeaders' '["created_at"] Resource
--
-- type API = "resources"
--   :> 'Servant.Header' \"Range\" ('Ranges' '["created_at"] Resource)
--   :> 'Servant.Get' '['Servant.JSON'] ('Servant.Headers' MyHeaders [Resource])
-- @
type PageHeaders (fields :: [Symbol]) (resource :: *) =
  '[ Header "Accept-Ranges" (AcceptRanges fields)
   , Header "Content-Range" (ContentRange fields resource)
   , Header "Next-Range"    (Ranges fields resource)
   ]

-- | Accepted Ranges in the `Accept-Ranges` response's header
data AcceptRanges (fields :: [Symbol]) = AcceptRanges

instance (KnownSymbol field) => ToHttpApiData (AcceptRanges '[field]) where
  toUrlPiece AcceptRanges =
    Text.pack (symbolVal (Proxy @field))

instance (ToHttpApiData (AcceptRanges (f ': fs)), KnownSymbol field) => ToHttpApiData (AcceptRanges (field ': f ': fs)) where
  toUrlPiece AcceptRanges =
    Text.pack (symbolVal (Proxy @field)) <> "," <> toUrlPiece (AcceptRanges @(f ': fs))


-- | Actual range returned, in the `Content-Range` response's header
data ContentRange (fields :: [Symbol]) resource =
  forall field. (KnownSymbol field, ToHttpApiData (RangeType resource field)) => ContentRange
  { contentRangeStart :: RangeType resource field
  , contentRangeEnd   :: RangeType resource field
  , contentRangeField :: Proxy field
  }

instance ToHttpApiData (ContentRange fields res) where
  toUrlPiece (ContentRange start end field) =
    Text.pack (symbolVal field) <> " " <> (encodeText . toUrlPiece) start <> ".." <> (encodeText . toUrlPiece) end


--
-- USE RANGES
--

-- | Available 'Range' on a given @resource@ must implements the 'HasPagination' type-class.
-- This class defines how the library can interact with a given @resource@ to access the value
-- to which a @field@ refers.
class KnownSymbol field => HasPagination resource field where
  type RangeType resource field :: *

  -- | Get the corressponding value of a Resource
  getFieldValue :: Proxy field -> resource -> RangeType resource field

  -- | Get parsing options for the 'Range' defined on this 'field'
  getRangeOptions :: Proxy field -> Proxy resource -> RangeOptions
  getRangeOptions _ _ = defaultOptions

  -- | Create a default 'Range' from a value and default 'RangeOptions'. Typical use-case
  -- is for when no or an invalid 'Range' header was provided.
  getDefaultRange
    :: IsRangeType (RangeType resource field)
    => Proxy resource
    -> Range field (RangeType resource field)
  getDefaultRange _ =
    let
      RangeOptions{..} = getRangeOptions (Proxy @field) (Proxy @resource)
    in Range
      { rangeValue  = Nothing @(RangeType resource field)
      , rangeLimit  = defaultRangeLimit
      , rangeOffset = defaultRangeOffset
      , rangeOrder  = defaultRangeOrder
      , rangeField  = Proxy @field
      }

-- | Lift an API response in a 'Monad', typically a 'Servant.Server.Handler'. 'Ranges' headers can be quite cumbersome to
-- declare and can be deduced from the resources returned and the previous 'Range'. This is exactly what this function
-- does.
--
-- @
-- myHandler
--  :: 'Maybe' ('Ranges' '["created_at"] Resource)
--  -> 'Servant.Server.Handler' ('Servant.Headers' ('PageHeaders' '["created_at"] Resource) [Resource])
-- myHandler mrange =
--  let range =
--        'Data.Maybe.fromMaybe' ('getDefaultRange' ('Data.Proxy.Proxy' \@Resource)) (mrange >>= 'extractRange')
--
--  'returnRange' range ('applyRange' range resources)
-- @
returnRange
  :: ( Monad m
     , ToHttpApiData (AcceptRanges fields)
     , KnownSymbol field
     , HasPagination resource field
     , IsRangeType (RangeType resource field)
     , PutRange fields field
     )
  => Range field (RangeType resource field)               -- ^ Actual 'Range' used to retrieve the results
  -> [resource]                                           -- ^ Resources to return, fetched from a db or a local store
  -> m (Headers (PageHeaders fields resource) [resource]) -- ^ Resources embedded in a given 'Monad' (typically a 'Servant.Server.Handler', with pagination headers)
returnRange Range{..} rs = do
  let boundaries = (,)
        <$> fmap (getFieldValue rangeField) (Safe.headMay rs)
        <*> fmap (getFieldValue rangeField) (Safe.lastMay rs)

  case boundaries of
    Nothing ->
      return $ addHeader AcceptRanges $ noHeader $ noHeader rs

    Just (start, end) -> do
      let nextOffset | rangeValue == Just end = rangeOffset + length rs
                     | otherwise              = length $ takeWhile ((==) end . getFieldValue rangeField) (reverse rs)

      let nextRange = putRange Range
            { rangeValue  = Just end
            , rangeLimit  = rangeLimit
            , rangeOffset = nextOffset
            , rangeOrder  = rangeOrder
            , rangeField  = rangeField
            }

      let contentRange = ContentRange
            { contentRangeStart = start
            , contentRangeEnd   = end
            , contentRangeField = rangeField
            }

      return $ addHeader AcceptRanges $ addHeader contentRange $ addHeader nextRange rs

-- | Default values to apply when parsing a 'Range'
data RangeOptions  = RangeOptions
  { defaultRangeLimit  :: Int         -- ^ Default limit if not provided, default to @100@
  , defaultRangeOffset :: Int         -- ^ Default offset if not provided, default to @0@
  , defaultRangeOrder  :: RangeOrder  -- ^ Default order if not provided, default to 'RangeDesc'
  } deriving (Eq, Show)


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


-- | Helper to apply a 'Range' to a list of values. Most likely useless in practice
-- as results may come more realistically from a database, but useful for debugging or
-- testing.
applyRange
  :: HasPagination resource field
  => Range field (RangeType resource field) -- ^ A 'Range' instance on a given @resource@
  -> [resource]                             -- ^ A full-list of @resource@
  -> [resource]                             -- ^ The sublist obtained by applying the 'Range'
applyRange Range{..} =
  let
    sortRel =
      case rangeOrder of
        RangeDesc ->
          \a b -> compare (getFieldValue rangeField b) (getFieldValue rangeField a)

        RangeAsc ->
          \a b -> compare (getFieldValue rangeField a) (getFieldValue rangeField b)

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

        (Just a, RangeDesc) ->
          (> a) . getFieldValue rangeField

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