-- |
-- Module: PostgREST.Request.Preferences
-- Description: Track client preferences to be employed when processing requests
--
-- Track client prefences set in HTTP 'Prefer' headers according to RFC7240[1].
--
-- [1] https://datatracker.ietf.org/doc/html/rfc7240
--
module PostgREST.Request.Preferences
  ( Preferences(..)
  , PreferCount(..)
  , PreferParameters(..)
  , PreferRepresentation(..)
  , PreferResolution(..)
  , PreferTransaction(..)
  , fromHeaders
  , ToAppliedHeader(..)
  ) where

import qualified Data.ByteString.Char8     as BS
import qualified Data.Map                  as Map
import qualified Network.HTTP.Types.Header as HTTP

import Protolude


-- $setup
-- Setup for doctests
-- >>> import Text.Pretty.Simple (pPrint)
-- >>> deriving instance Show PreferResolution
-- >>> deriving instance Show PreferRepresentation
-- >>> deriving instance Show PreferParameters
-- >>> deriving instance Show PreferCount
-- >>> deriving instance Show PreferTransaction
-- >>> deriving instance Show Preferences

-- | Preferences recognized by the application.
data Preferences
  = Preferences
    { Preferences -> Maybe PreferResolution
preferResolution     :: Maybe PreferResolution
    , Preferences -> Maybe PreferRepresentation
preferRepresentation :: Maybe PreferRepresentation
    , Preferences -> Maybe PreferParameters
preferParameters     :: Maybe PreferParameters
    , Preferences -> Maybe PreferCount
preferCount          :: Maybe PreferCount
    , Preferences -> Maybe PreferTransaction
preferTransaction    :: Maybe PreferTransaction
    }

-- |
-- Parse HTTP headers based on RFC7240[1] to identify preferences.
--
-- One header with comma-separated values can be used to set multiple preferences:
--
-- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates, count=exact")]
-- Preferences
--     { preferResolution = Just IgnoreDuplicates
--     , preferRepresentation = Nothing
--     , preferParameters = Nothing
--     , preferCount = Just ExactCount
--     , preferTransaction = Nothing
--     }
--
-- Multiple headers can also be used:
--
-- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact")]
-- Preferences
--     { preferResolution = Just IgnoreDuplicates
--     , preferRepresentation = Nothing
--     , preferParameters = Nothing
--     , preferCount = Just ExactCount
--     , preferTransaction = Nothing
--     }
--
-- If a preference is set more than once, only the first is used:
--
-- >>> preferTransaction $ fromHeaders [("Prefer", "tx=commit, tx=rollback")]
-- Just Commit
--
-- This is also the case across multiple headers:
--
-- >>> :{
--   preferResolution . fromHeaders $
--     [ ("Prefer", "resolution=ignore-duplicates")
--     , ("Prefer", "resolution=merge-duplicates")
--     ]
-- :}
-- Just IgnoreDuplicates
--
-- Preferences not recognized by the application are ignored:
--
-- >>> preferResolution $ fromHeaders [("Prefer", "resolution=foo")]
-- Nothing
--
-- Preferences can be separated by arbitrary amounts of space, lower-case header is also recognized:
--
-- >>> pPrint $ fromHeaders [("prefer", "count=exact,    tx=commit   ,return=minimal")]
-- Preferences
--     { preferResolution = Nothing
--     , preferRepresentation = Just None
--     , preferParameters = Nothing
--     , preferCount = Just ExactCount
--     , preferTransaction = Just Commit
--     }
--
fromHeaders :: [HTTP.Header] -> Preferences
fromHeaders :: [Header] -> Preferences
fromHeaders [Header]
headers =
  Preferences :: Maybe PreferResolution
-> Maybe PreferRepresentation
-> Maybe PreferParameters
-> Maybe PreferCount
-> Maybe PreferTransaction
-> Preferences
Preferences
    { preferResolution :: Maybe PreferResolution
preferResolution = [PreferResolution] -> Maybe PreferResolution
forall a. ToHeaderValue a => [a] -> Maybe a
parsePrefs [PreferResolution
MergeDuplicates, PreferResolution
IgnoreDuplicates]
    , preferRepresentation :: Maybe PreferRepresentation
preferRepresentation = [PreferRepresentation] -> Maybe PreferRepresentation
forall a. ToHeaderValue a => [a] -> Maybe a
parsePrefs [PreferRepresentation
Full, PreferRepresentation
None, PreferRepresentation
HeadersOnly]
    , preferParameters :: Maybe PreferParameters
preferParameters = [PreferParameters] -> Maybe PreferParameters
forall a. ToHeaderValue a => [a] -> Maybe a
parsePrefs [PreferParameters
SingleObject, PreferParameters
MultipleObjects]
    , preferCount :: Maybe PreferCount
preferCount = [PreferCount] -> Maybe PreferCount
forall a. ToHeaderValue a => [a] -> Maybe a
parsePrefs [PreferCount
ExactCount, PreferCount
PlannedCount, PreferCount
EstimatedCount]
    , preferTransaction :: Maybe PreferTransaction
preferTransaction = [PreferTransaction] -> Maybe PreferTransaction
forall a. ToHeaderValue a => [a] -> Maybe a
parsePrefs [PreferTransaction
Commit, PreferTransaction
Rollback]
    }
  where
    prefHeaders :: [Header]
prefHeaders = (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) HeaderName
HTTP.hPrefer (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst) [Header]
headers
    prefs :: [ByteString]
prefs = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BS.strip ([ByteString] -> [ByteString])
-> ([Header] -> [ByteString]) -> [Header] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> [ByteString]) -> [Header] -> [ByteString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Char -> ByteString -> [ByteString]
BS.split Char
',' (ByteString -> [ByteString])
-> (Header -> ByteString) -> Header -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> ByteString
forall a b. (a, b) -> b
snd) ([Header] -> [ByteString]) -> [Header] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ [Header]
prefHeaders

    parsePrefs :: ToHeaderValue a => [a] -> Maybe a
    parsePrefs :: [a] -> Maybe a
parsePrefs [a]
vals =
      [a] -> Maybe a
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head ([a] -> Maybe a) -> [a] -> Maybe a
forall a b. (a -> b) -> a -> b
$ (ByteString -> Maybe a) -> [ByteString] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((ByteString -> Map ByteString a -> Maybe a)
-> Map ByteString a -> ByteString -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Map ByteString a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Map ByteString a -> ByteString -> Maybe a)
-> Map ByteString a -> ByteString -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> Map ByteString a
forall a. ToHeaderValue a => [a] -> Map ByteString a
prefMap [a]
vals) [ByteString]
prefs

    prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a
    prefMap :: [a] -> Map ByteString a
prefMap = [(ByteString, a)] -> Map ByteString a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ByteString, a)] -> Map ByteString a)
-> ([a] -> [(ByteString, a)]) -> [a] -> Map ByteString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (ByteString, a)) -> [a] -> [(ByteString, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
pref -> (a -> ByteString
forall a. ToHeaderValue a => a -> ByteString
toHeaderValue a
pref, a
pref))

-- |
-- Convert a preference into the value that we look for in the 'Prefer' headers.
--
-- >>> toHeaderValue MergeDuplicates
-- "resolution=merge-duplicates"
--
class ToHeaderValue a where
  toHeaderValue :: a -> ByteString

-- |
-- Header to indicate that a preference has been applied.
--
-- >>> toAppliedHeader MergeDuplicates
-- ("Preference-Applied","resolution=merge-duplicates")
--
class ToHeaderValue a => ToAppliedHeader a where
  toAppliedHeader :: a -> HTTP.Header
  toAppliedHeader a
x = (HeaderName
HTTP.hPreferenceApplied, a -> ByteString
forall a. ToHeaderValue a => a -> ByteString
toHeaderValue a
x)

-- | How to handle duplicate values.
data PreferResolution
  = MergeDuplicates
  | IgnoreDuplicates

instance ToHeaderValue PreferResolution where
  toHeaderValue :: PreferResolution -> ByteString
toHeaderValue PreferResolution
MergeDuplicates  = ByteString
"resolution=merge-duplicates"
  toHeaderValue PreferResolution
IgnoreDuplicates = ByteString
"resolution=ignore-duplicates"

instance ToAppliedHeader PreferResolution

-- |
-- How to return the mutated data.
--
-- From https://tools.ietf.org/html/rfc7240#section-4.2
data PreferRepresentation
  = Full        -- ^ Return the body plus the Location header(in case of POST).
  | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
  | None        -- ^ Return nothing from the mutated data.
  deriving PreferRepresentation -> PreferRepresentation -> Bool
(PreferRepresentation -> PreferRepresentation -> Bool)
-> (PreferRepresentation -> PreferRepresentation -> Bool)
-> Eq PreferRepresentation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreferRepresentation -> PreferRepresentation -> Bool
$c/= :: PreferRepresentation -> PreferRepresentation -> Bool
== :: PreferRepresentation -> PreferRepresentation -> Bool
$c== :: PreferRepresentation -> PreferRepresentation -> Bool
Eq

instance ToHeaderValue PreferRepresentation where
  toHeaderValue :: PreferRepresentation -> ByteString
toHeaderValue PreferRepresentation
Full        = ByteString
"return=representation"
  toHeaderValue PreferRepresentation
None        = ByteString
"return=minimal"
  toHeaderValue PreferRepresentation
HeadersOnly = ByteString
"return=headers-only"

-- | How to pass parameters to stored procedures.
data PreferParameters
  = SingleObject    -- ^ Pass all parameters as a single json object to a stored procedure.
  | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure.
  deriving PreferParameters -> PreferParameters -> Bool
(PreferParameters -> PreferParameters -> Bool)
-> (PreferParameters -> PreferParameters -> Bool)
-> Eq PreferParameters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreferParameters -> PreferParameters -> Bool
$c/= :: PreferParameters -> PreferParameters -> Bool
== :: PreferParameters -> PreferParameters -> Bool
$c== :: PreferParameters -> PreferParameters -> Bool
Eq

instance ToHeaderValue PreferParameters where
  toHeaderValue :: PreferParameters -> ByteString
toHeaderValue PreferParameters
SingleObject    = ByteString
"params=single-object"
  toHeaderValue PreferParameters
MultipleObjects = ByteString
"params=multiple-objects"

-- | How to determine the count of (expected) results
data PreferCount
  = ExactCount     -- ^ Exact count (slower).
  | PlannedCount   -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
  | EstimatedCount -- ^ Use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
  deriving PreferCount -> PreferCount -> Bool
(PreferCount -> PreferCount -> Bool)
-> (PreferCount -> PreferCount -> Bool) -> Eq PreferCount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreferCount -> PreferCount -> Bool
$c/= :: PreferCount -> PreferCount -> Bool
== :: PreferCount -> PreferCount -> Bool
$c== :: PreferCount -> PreferCount -> Bool
Eq

instance ToHeaderValue PreferCount where
  toHeaderValue :: PreferCount -> ByteString
toHeaderValue PreferCount
ExactCount     = ByteString
"count=exact"
  toHeaderValue PreferCount
PlannedCount   = ByteString
"count=planned"
  toHeaderValue PreferCount
EstimatedCount = ByteString
"count=estimated"

-- | Whether to commit or roll back transactions.
data PreferTransaction
  = Commit   -- ^ Commit transaction - the default.
  | Rollback -- ^ Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
  deriving PreferTransaction -> PreferTransaction -> Bool
(PreferTransaction -> PreferTransaction -> Bool)
-> (PreferTransaction -> PreferTransaction -> Bool)
-> Eq PreferTransaction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PreferTransaction -> PreferTransaction -> Bool
$c/= :: PreferTransaction -> PreferTransaction -> Bool
== :: PreferTransaction -> PreferTransaction -> Bool
$c== :: PreferTransaction -> PreferTransaction -> Bool
Eq

instance ToHeaderValue PreferTransaction where
  toHeaderValue :: PreferTransaction -> ByteString
toHeaderValue PreferTransaction
Commit   = ByteString
"tx=commit"
  toHeaderValue PreferTransaction
Rollback = ByteString
"tx=rollback"

instance ToAppliedHeader PreferTransaction