{-|
Module      : PostgREST.Request.ApiRequest
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}

module PostgREST.Request.ApiRequest
  ( ApiRequest(..)
  , InvokeMethod(..)
  , ContentType(..)
  , Action(..)
  , Target(..)
  , Payload(..)
  , userApiRequest
  ) where

import qualified Data.Aeson            as JSON
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy  as LBS
import qualified Data.CaseInsensitive  as CI
import qualified Data.Csv              as CSV
import qualified Data.HashMap.Strict   as M
import qualified Data.List             as L
import qualified Data.List.NonEmpty    as NonEmptyList
import qualified Data.Set              as S
import qualified Data.Text             as T
import qualified Data.Text.Encoding    as T
import qualified Data.Vector           as V

import Control.Arrow             ((***))
import Data.Aeson.Types          (emptyArray, emptyObject)
import Data.List                 (last, lookup, partition, union)
import Data.Maybe                (fromJust)
import Data.Ranged.Boundaries    (Boundary (..))
import Data.Ranged.Ranges        (Range (..), emptyRange,
                                  rangeIntersection)
import Network.HTTP.Base         (urlEncodeVars)
import Network.HTTP.Types.Header (hAuthorization, hCookie)
import Network.HTTP.Types.URI    (parseQueryReplacePlus,
                                  parseSimpleQuery)
import Network.Wai               (Request (..))
import Network.Wai.Parse         (parseHttpAccept)
import Web.Cookie                (parseCookies)

import PostgREST.Config                  (AppConfig (..),
                                          OpenAPIMode (..))
import PostgREST.ContentType             (ContentType (..))
import PostgREST.DbStructure             (DbStructure (..))
import PostgREST.DbStructure.Identifiers (FieldName,
                                          QualifiedIdentifier (..),
                                          Schema)
import PostgREST.DbStructure.Proc        (ProcDescription (..),
                                          ProcParam (..), ProcsMap)
import PostgREST.Error                   (ApiRequestError (..))
import PostgREST.Query.SqlFragment       (ftsOperators, operators)
import PostgREST.RangeQuery              (NonnegRange, allRange,
                                          rangeGeq, rangeLimit,
                                          rangeOffset, rangeRequested,
                                          restrictRange)
import PostgREST.Request.Parsers         (pRequestColumns)
import PostgREST.Request.Preferences     (PreferCount (..),
                                          PreferParameters (..),
                                          PreferRepresentation (..),
                                          PreferResolution (..),
                                          PreferTransaction (..))

import qualified PostgREST.ContentType         as ContentType
import qualified PostgREST.Request.Preferences as Preferences

import Protolude


type RequestBody = LBS.ByteString

data Payload
  = ProcessedJSON -- ^ Cached attributes of a JSON payload
      { Payload -> ByteString
payRaw  :: LBS.ByteString
      -- ^ This is the raw ByteString that comes from the request body.  We
      -- cache this instead of an Aeson Value because it was detected that for
      -- large payloads the encoding had high memory usage, see
      -- https://github.com/PostgREST/postgrest/pull/1005 for more details
      , Payload -> Set Text
payKeys :: S.Set Text
      -- ^ Keys of the object or if it's an array these keys are guaranteed to
      -- be the same across all its objects
      }
  | RawJSON { payRaw  :: LBS.ByteString }
  | RawPay  { payRaw  :: LBS.ByteString }

data InvokeMethod = InvHead | InvGet | InvPost deriving InvokeMethod -> InvokeMethod -> Bool
(InvokeMethod -> InvokeMethod -> Bool)
-> (InvokeMethod -> InvokeMethod -> Bool) -> Eq InvokeMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InvokeMethod -> InvokeMethod -> Bool
$c/= :: InvokeMethod -> InvokeMethod -> Bool
== :: InvokeMethod -> InvokeMethod -> Bool
$c== :: InvokeMethod -> InvokeMethod -> Bool
Eq
-- | Types of things a user wants to do to tables/views/procs
data Action = ActionCreate       | ActionRead{Action -> Bool
isHead :: Bool}
            | ActionUpdate       | ActionDelete
            | ActionSingleUpsert | ActionInvoke InvokeMethod
            | ActionInfo         | ActionInspect{isHead :: Bool}
            deriving Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c== :: Action -> Action -> Bool
Eq
-- | The path info that will be mapped to a target (used to handle validations and errors before defining the Target)
data Path
  = PathInfo
      { Path -> Text
pSchema        :: Schema,
        Path -> Text
pName          :: Text,
        Path -> Bool
pHasRpc        :: Bool,
        Path -> Bool
pIsDefaultSpec :: Bool,
        Path -> Bool
pIsRootSpec    :: Bool
      }
  | PathUnknown
-- | The target db object of a user action
data Target = TargetIdent QualifiedIdentifier
            | TargetProc{Target -> ProcDescription
tProc :: ProcDescription, Target -> Bool
tpIsRootSpec :: Bool}
            | TargetDefaultSpec{Target -> Text
tdsSchema :: Schema} -- The default spec offered at root "/"
            | TargetUnknown

-- | RPC query param value `/rpc/func?v=<value>`, used for VARIADIC functions on form-urlencoded POST and GETs
-- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3.
data RpcParamValue = Fixed Text | Variadic [Text]
instance JSON.ToJSON RpcParamValue where
  toJSON :: RpcParamValue -> Value
toJSON (Fixed    Text
v) = Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
v
  toJSON (Variadic [Text]
v) = [Text] -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON [Text]
v

toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue)
toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue)
toRpcParamValue ProcDescription
proc (Text
k, Text
v) | Text -> Bool
prmIsVariadic Text
k = (Text
k, [Text] -> RpcParamValue
Variadic [Text
v])
                            | Bool
otherwise       = (Text
k, Text -> RpcParamValue
Fixed Text
v)
  where
    prmIsVariadic :: Text -> Bool
prmIsVariadic Text
prm = Maybe ProcParam -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ProcParam -> Bool) -> Maybe ProcParam -> Bool
forall a b. (a -> b) -> a -> b
$ (ProcParam -> Bool) -> [ProcParam] -> Maybe ProcParam
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ProcParam{Text
ppName :: ProcParam -> Text
ppName :: Text
ppName, Bool
ppVar :: ProcParam -> Bool
ppVar :: Bool
ppVar} -> Text
ppName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
prm Bool -> Bool -> Bool
&& Bool
ppVar) ([ProcParam] -> Maybe ProcParam) -> [ProcParam] -> Maybe ProcParam
forall a b. (a -> b) -> a -> b
$ ProcDescription -> [ProcParam]
pdParams ProcDescription
proc

-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"}
jsonRpcParams :: ProcDescription -> [(Text, Text)] -> Payload
jsonRpcParams :: ProcDescription -> [(Text, Text)] -> Payload
jsonRpcParams ProcDescription
proc [(Text, Text)]
prms =
  if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ProcDescription -> Bool
pdHasVariadic ProcDescription
proc then -- if proc has no variadic param, save steps and directly convert to json
    ByteString -> Set Text -> Payload
ProcessedJSON (HashMap Text Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode (HashMap Text Value -> ByteString)
-> HashMap Text Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, Value)] -> HashMap Text Value)
-> [(Text, Value)] -> HashMap Text Value
forall a b. (a -> b) -> a -> b
$ (Text -> Value) -> (Text, Text) -> (Text, Value)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON ((Text, Text) -> (Text, Value))
-> [(Text, Text)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
prms) ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
prms)
  else
    let paramsMap :: HashMap Text RpcParamValue
paramsMap = (RpcParamValue -> RpcParamValue -> RpcParamValue)
-> [(Text, RpcParamValue)] -> HashMap Text RpcParamValue
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
M.fromListWith RpcParamValue -> RpcParamValue -> RpcParamValue
mergeParams ([(Text, RpcParamValue)] -> HashMap Text RpcParamValue)
-> [(Text, RpcParamValue)] -> HashMap Text RpcParamValue
forall a b. (a -> b) -> a -> b
$ ProcDescription -> (Text, Text) -> (Text, RpcParamValue)
toRpcParamValue ProcDescription
proc ((Text, Text) -> (Text, RpcParamValue))
-> [(Text, Text)] -> [(Text, RpcParamValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
prms in
    ByteString -> Set Text -> Payload
ProcessedJSON (HashMap Text RpcParamValue -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode HashMap Text RpcParamValue
paramsMap) ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ HashMap Text RpcParamValue -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text RpcParamValue
paramsMap)
  where
    mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue
    mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue
mergeParams (Variadic [Text]
a) (Variadic [Text]
b) = [Text] -> RpcParamValue
Variadic ([Text] -> RpcParamValue) -> [Text] -> RpcParamValue
forall a b. (a -> b) -> a -> b
$ [Text]
b [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
a
    mergeParams RpcParamValue
v RpcParamValue
_                       = RpcParamValue
v -- repeated params for non-variadic parameters are not merged

targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe Payload
targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe Payload
targetToJsonRpcParams Maybe Target
target [(Text, Text)]
params =
  case Maybe Target
target of
    Just TargetProc{ProcDescription
tProc :: ProcDescription
tProc :: Target -> ProcDescription
tProc} -> Payload -> Maybe Payload
forall a. a -> Maybe a
Just (Payload -> Maybe Payload) -> Payload -> Maybe Payload
forall a b. (a -> b) -> a -> b
$ ProcDescription -> [(Text, Text)] -> Payload
jsonRpcParams ProcDescription
tProc [(Text, Text)]
params
    Maybe Target
_                      -> Maybe Payload
forall a. Maybe a
Nothing

{-|
  Describes what the user wants to do. This data type is a
  translation of the raw elements of an HTTP request into domain
  specific language.  There is no guarantee that the intent is
  sensible, it is up to a later stage of processing to determine
  if it is an action we are able to perform.
-}
data ApiRequest = ApiRequest {
    ApiRequest -> Action
iAction               :: Action                           -- ^ Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
  , ApiRequest -> HashMap Text NonnegRange
iRange                :: M.HashMap Text NonnegRange -- ^ Requested range of rows within response
  , ApiRequest -> NonnegRange
iTopLevelRange        :: NonnegRange                      -- ^ Requested range of rows from the top level
  , ApiRequest -> Target
iTarget               :: Target                           -- ^ The target, be it calling a proc or accessing a table
  , ApiRequest -> Maybe Payload
iPayload              :: Maybe Payload                    -- ^ Data sent by client and used for mutation actions
  , ApiRequest -> PreferRepresentation
iPreferRepresentation :: PreferRepresentation             -- ^ If client wants created items echoed back
  , ApiRequest -> Maybe PreferParameters
iPreferParameters     :: Maybe PreferParameters           -- ^ How to pass parameters to a stored procedure
  , ApiRequest -> Maybe PreferCount
iPreferCount          :: Maybe PreferCount                -- ^ Whether the client wants a result count
  , ApiRequest -> Maybe PreferResolution
iPreferResolution     :: Maybe PreferResolution           -- ^ Whether the client wants to UPSERT or ignore records on PK conflict
  , ApiRequest -> Maybe PreferTransaction
iPreferTransaction    :: Maybe PreferTransaction          -- ^ Whether the clients wants to commit or rollback the transaction
  , ApiRequest -> [(Text, Text)]
iFilters              :: [(Text, Text)]                   -- ^ Filters on the result ("id", "eq.10")
  , ApiRequest -> [(Text, Text)]
iLogic                :: [(Text, Text)]                   -- ^ &and and &or parameters used for complex boolean logic
  , ApiRequest -> Maybe Text
iSelect               :: Maybe Text                       -- ^ &select parameter used to shape the response
  , ApiRequest -> Maybe Text
iOnConflict           :: Maybe Text                       -- ^ &on_conflict parameter used to upsert on specific unique keys
  , ApiRequest -> Set Text
iColumns              :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
  , ApiRequest -> [(Text, Text)]
iOrder                :: [(Text, Text)]                   -- ^ &order parameters for each level
  , ApiRequest -> ByteString
iCanonicalQS          :: ByteString                       -- ^ Alphabetized (canonical) request query string for response URLs
  , ApiRequest -> Text
iJWT                  :: Text                             -- ^ JSON Web Token
  , ApiRequest -> [(ByteString, ByteString)]
iHeaders              :: [(ByteString, ByteString)]       -- ^ HTTP request headers
  , ApiRequest -> [(ByteString, ByteString)]
iCookies              :: [(ByteString, ByteString)]       -- ^ Request Cookies
  , ApiRequest -> ByteString
iPath                 :: ByteString                       -- ^ Raw request path
  , ApiRequest -> ByteString
iMethod               :: ByteString                       -- ^ Raw request method
  , ApiRequest -> Maybe Text
iProfile              :: Maybe Schema                     -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.
  , ApiRequest -> Text
iSchema               :: Schema                           -- ^ The request schema. Can vary depending on iProfile.
  , ApiRequest -> ContentType
iAcceptContentType    :: ContentType
  }

-- | Examines HTTP request and translates it into user intent.
userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest
userApiRequest :: AppConfig
-> DbStructure
-> Request
-> ByteString
-> Either ApiRequestError ApiRequest
userApiRequest conf :: AppConfig
conf@AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
configServerPort :: AppConfig -> Int
configServerHost :: AppConfig -> Text
configRawMediaTypes :: AppConfig -> [ByteString]
configOpenApiServerProxyUri :: AppConfig -> Maybe Text
configOpenApiMode :: AppConfig -> OpenAPIMode
configLogLevel :: AppConfig -> LogLevel
configJwtSecretIsBase64 :: AppConfig -> Bool
configJwtSecret :: AppConfig -> Maybe ByteString
configJwtRoleClaimKey :: AppConfig -> JSPath
configJwtAudience :: AppConfig -> Maybe StringOrURI
configJWKS :: AppConfig -> Maybe JWKSet
configFilePath :: AppConfig -> Maybe FilePath
configDbUseLegacyGucs :: AppConfig -> Bool
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
configServerPort :: Int
configServerHost :: Text
configRawMediaTypes :: [ByteString]
configOpenApiServerProxyUri :: Maybe Text
configOpenApiMode :: OpenAPIMode
configLogLevel :: LogLevel
configJwtSecretIsBase64 :: Bool
configJwtSecret :: Maybe ByteString
configJwtRoleClaimKey :: JSPath
configJwtAudience :: Maybe StringOrURI
configJWKS :: Maybe JWKSet
configFilePath :: Maybe FilePath
configDbUseLegacyGucs :: Bool
configDbUri :: Text
configDbTxRollbackAll :: Bool
configDbTxAllowOverride :: Bool
configDbConfig :: Bool
configDbSchemas :: NonEmpty Text
configDbRootSpec :: Maybe QualifiedIdentifier
configDbPreparedStatements :: Bool
configDbPreRequest :: Maybe QualifiedIdentifier
configDbPoolTimeout :: NominalDiffTime
configDbPoolSize :: Int
configDbMaxRows :: Maybe Integer
configDbExtraSearchPath :: [Text]
configDbChannelEnabled :: Bool
configDbChannel :: Text
configDbAnonRole :: Text
configAppSettings :: [(Text, Text)]
..} DbStructure
dbStructure Request
req ByteString
reqBody
  | Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
profile Bool -> Bool -> Bool
&& Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
profile Text -> NonEmpty Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` NonEmpty Text
configDbSchemas = ApiRequestError -> Either ApiRequestError ApiRequest
forall a b. a -> Either a b
Left (ApiRequestError -> Either ApiRequestError ApiRequest)
-> ApiRequestError -> Either ApiRequestError ApiRequest
forall a b. (a -> b) -> a -> b
$ [Text] -> ApiRequestError
UnacceptableSchema ([Text] -> ApiRequestError) -> [Text] -> ApiRequestError
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Text
configDbSchemas
  | Bool
isTargetingProc Bool -> Bool -> Bool
&& ByteString
method ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ByteString
"HEAD", ByteString
"GET", ByteString
"POST"] = ApiRequestError -> Either ApiRequestError ApiRequest
forall a b. a -> Either a b
Left ApiRequestError
ActionInappropriate
  | NonnegRange
topLevelRange NonnegRange -> NonnegRange -> Bool
forall a. Eq a => a -> a -> Bool
== NonnegRange
forall v. DiscreteOrdered v => Range v
emptyRange = ApiRequestError -> Either ApiRequestError ApiRequest
forall a b. a -> Either a b
Left ApiRequestError
InvalidRange
  | Bool
shouldParsePayload Bool -> Bool -> Bool
&& Either ByteString Payload -> Bool
forall a b. Either a b -> Bool
isLeft Either ByteString Payload
payload = (ByteString -> Either ApiRequestError ApiRequest)
-> (Payload -> Either ApiRequestError ApiRequest)
-> Either ByteString Payload
-> Either ApiRequestError ApiRequest
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ApiRequestError -> Either ApiRequestError ApiRequest
forall a b. a -> Either a b
Left (ApiRequestError -> Either ApiRequestError ApiRequest)
-> (ByteString -> ApiRequestError)
-> ByteString
-> Either ApiRequestError ApiRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ApiRequestError
InvalidBody) Payload -> Either ApiRequestError ApiRequest
forall a. a
witness Either ByteString Payload
payload
  | Either ApiRequestError (Maybe (Set Text)) -> Bool
forall a b. Either a b -> Bool
isLeft Either ApiRequestError (Maybe (Set Text))
parsedColumns = (ApiRequestError -> Either ApiRequestError ApiRequest)
-> (Maybe (Set Text) -> Either ApiRequestError ApiRequest)
-> Either ApiRequestError (Maybe (Set Text))
-> Either ApiRequestError ApiRequest
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ApiRequestError -> Either ApiRequestError ApiRequest
forall a b. a -> Either a b
Left Maybe (Set Text) -> Either ApiRequestError ApiRequest
forall a. a
witness Either ApiRequestError (Maybe (Set Text))
parsedColumns
  | Bool
otherwise = do
     ContentType
acceptContentType <- AppConfig
-> Action
-> Path
-> [ContentType]
-> Either ApiRequestError ContentType
findAcceptContentType AppConfig
conf Action
action Path
path [ContentType]
accepts
     Target
checkedTarget <- Either ApiRequestError Target
target
     ApiRequest -> Either ApiRequestError ApiRequest
forall (m :: * -> *) a. Monad m => a -> m a
return ApiRequest :: Action
-> HashMap Text NonnegRange
-> NonnegRange
-> Target
-> Maybe Payload
-> PreferRepresentation
-> Maybe PreferParameters
-> Maybe PreferCount
-> Maybe PreferResolution
-> Maybe PreferTransaction
-> [(Text, Text)]
-> [(Text, Text)]
-> Maybe Text
-> Maybe Text
-> Set Text
-> [(Text, Text)]
-> ByteString
-> Text
-> [(ByteString, ByteString)]
-> [(ByteString, ByteString)]
-> ByteString
-> ByteString
-> Maybe Text
-> Text
-> ContentType
-> ApiRequest
ApiRequest {
      iAction :: Action
iAction = Action
action
      , iTarget :: Target
iTarget = Target
checkedTarget
      , iRange :: HashMap Text NonnegRange
iRange = HashMap Text NonnegRange
ranges
      , iTopLevelRange :: NonnegRange
iTopLevelRange = NonnegRange
topLevelRange
      , iPayload :: Maybe Payload
iPayload = Maybe Payload
relevantPayload
      , iPreferRepresentation :: PreferRepresentation
iPreferRepresentation = PreferRepresentation
-> Maybe PreferRepresentation -> PreferRepresentation
forall a. a -> Maybe a -> a
fromMaybe PreferRepresentation
None Maybe PreferRepresentation
preferRepresentation
      , iPreferParameters :: Maybe PreferParameters
iPreferParameters = Maybe PreferParameters
preferParameters
      , iPreferCount :: Maybe PreferCount
iPreferCount = Maybe PreferCount
preferCount
      , iPreferResolution :: Maybe PreferResolution
iPreferResolution = Maybe PreferResolution
preferResolution
      , iPreferTransaction :: Maybe PreferTransaction
iPreferTransaction = Maybe PreferTransaction
preferTransaction
      , iFilters :: [(Text, Text)]
iFilters = [(Text, Text)]
filters
      , iLogic :: [(Text, Text)]
iLogic = [(Text -> Text
forall a b. ConvertText a b => a -> b
toS Text
k, Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
v) | (Text
k,Maybe Text
v) <- [(Text, Maybe Text)]
qParams, Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
v, [Text] -> Text -> Bool
endingIn [Text
"and", Text
"or"] Text
k ]
      , iSelect :: Maybe Text
iSelect = Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe Text)] -> Maybe (Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"select" [(Text, Maybe Text)]
qParams)
      , iOnConflict :: Maybe Text
iOnConflict = Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe Text)] -> Maybe (Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"on_conflict" [(Text, Maybe Text)]
qParams)
      , iColumns :: Set Text
iColumns = Set Text
payloadColumns
      , iOrder :: [(Text, Text)]
iOrder = [(Text -> Text
forall a b. ConvertText a b => a -> b
toS Text
k, Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
v) | (Text
k,Maybe Text
v) <- [(Text, Maybe Text)]
qParams, Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
v, [Text] -> Text -> Bool
endingIn [Text
"order"] Text
k ]
      , iCanonicalQS :: ByteString
iCanonicalQS = FilePath -> ByteString
BS.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> FilePath
urlEncodeVars
        ([(FilePath, FilePath)] -> FilePath)
-> ([(ByteString, Maybe ByteString)] -> [(FilePath, FilePath)])
-> [(ByteString, Maybe ByteString)]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst
        ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> ([(ByteString, Maybe ByteString)] -> [(FilePath, FilePath)])
-> [(ByteString, Maybe ByteString)]
-> [(FilePath, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Maybe ByteString) -> (FilePath, FilePath))
-> [(ByteString, Maybe ByteString)] -> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (((ByteString -> FilePath)
 -> (ByteString -> FilePath)
 -> (ByteString, ByteString)
 -> (FilePath, FilePath))
-> (ByteString -> FilePath)
-> (ByteString, ByteString)
-> (FilePath, FilePath)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (ByteString -> FilePath)
-> (ByteString -> FilePath)
-> (ByteString, ByteString)
-> (FilePath, FilePath)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) ByteString -> FilePath
BS.unpack ((ByteString, ByteString) -> (FilePath, FilePath))
-> ((ByteString, Maybe ByteString) -> (ByteString, ByteString))
-> (ByteString, Maybe ByteString)
-> (FilePath, FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ByteString -> ByteString)
-> (ByteString, Maybe ByteString) -> (ByteString, ByteString)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty))
        ([(ByteString, Maybe ByteString)] -> FilePath)
-> [(ByteString, Maybe ByteString)] -> FilePath
forall a b. (a -> b) -> a -> b
$ [(ByteString, Maybe ByteString)]
qString
      , iJWT :: Text
iJWT = Text
tokenStr
      , iHeaders :: [(ByteString, ByteString)]
iHeaders = [ (CI ByteString -> ByteString
forall s. CI s -> s
CI.foldedCase CI ByteString
k, ByteString
v) | (CI ByteString
k,ByteString
v) <- RequestHeaders
hdrs, CI ByteString
k CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= CI ByteString
hCookie]
      , iCookies :: [(ByteString, ByteString)]
iCookies = [(ByteString, ByteString)]
-> (ByteString -> [(ByteString, ByteString)])
-> Maybe ByteString
-> [(ByteString, ByteString)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [(ByteString, ByteString)]
parseCookies (Maybe ByteString -> [(ByteString, ByteString)])
-> Maybe ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Maybe ByteString
lookupHeader CI ByteString
"Cookie"
      , iPath :: ByteString
iPath = Request -> ByteString
rawPathInfo Request
req
      , iMethod :: ByteString
iMethod = ByteString
method
      , iProfile :: Maybe Text
iProfile = Maybe Text
profile
      , iSchema :: Text
iSchema = Text
schema
      , iAcceptContentType :: ContentType
iAcceptContentType = ContentType
acceptContentType
      }
 where
  accepts :: [ContentType]
accepts = [ContentType]
-> (ByteString -> [ContentType])
-> Maybe ByteString
-> [ContentType]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [ContentType
CTAny] ((ByteString -> ContentType) -> [ByteString] -> [ContentType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ByteString -> ContentType
ContentType.decodeContentType ([ByteString] -> [ContentType])
-> (ByteString -> [ByteString]) -> ByteString -> [ContentType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
parseHttpAccept) (Maybe ByteString -> [ContentType])
-> Maybe ByteString -> [ContentType]
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Maybe ByteString
lookupHeader CI ByteString
"accept"
  -- queryString with '+' converted to ' '(space)
  qString :: [(ByteString, Maybe ByteString)]
qString = Bool -> ByteString -> [(ByteString, Maybe ByteString)]
parseQueryReplacePlus Bool
True (ByteString -> [(ByteString, Maybe ByteString)])
-> ByteString -> [(ByteString, Maybe ByteString)]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawQueryString Request
req
  -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)
  ([(Text, Text)]
filters, [(Text, Text)]
rpcQParams) =
    case Action
action of
      ActionInvoke InvokeMethod
InvGet  -> ([(Text, Text)], [(Text, Text)])
partitionFlts
      ActionInvoke InvokeMethod
InvHead -> ([(Text, Text)], [(Text, Text)])
partitionFlts
      Action
_                    -> ([(Text, Text)]
flts, [])
  partitionFlts :: ([(Text, Text)], [(Text, Text)])
partitionFlts = ((Text, Text) -> Bool)
-> [(Text, Text)] -> ([(Text, Text)], [(Text, Text)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Bool -> Bool -> Bool)
-> ((Text, Text) -> Bool)
-> ((Text, Text) -> Bool)
-> (Text, Text)
-> Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(||) (Text -> Bool
isEmbedPath (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) (Text -> Bool
hasOperator (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd)) [(Text, Text)]
flts
  flts :: [(Text, Text)]
flts =
    [ (Text -> Text
forall a b. ConvertText a b => a -> b
toS Text
k, Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
v) |
      (Text
k,Maybe Text
v) <- [(Text, Maybe Text)]
qParams, Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
v,
      Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"select", Text
"columns"],
      Bool -> Bool
not ([Text] -> Text -> Bool
endingIn [Text
"order", Text
"limit", Text
"offset", Text
"and", Text
"or"] Text
k) ]
  hasOperator :: Text -> Bool
hasOperator Text
val = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
val) ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$
                      ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".") (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
"not"Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:HashMap Text ByteString -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text ByteString
operators) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
                      ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(") (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text ByteString -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text ByteString
ftsOperators)
  isEmbedPath :: Text -> Bool
isEmbedPath = Text -> Text -> Bool
T.isInfixOf Text
"."
  isTargetingProc :: Bool
isTargetingProc = case Path
path of
    PathInfo{Bool
pHasRpc :: Bool
pHasRpc :: Path -> Bool
pHasRpc, Bool
pIsRootSpec :: Bool
pIsRootSpec :: Path -> Bool
pIsRootSpec} -> Bool
pHasRpc Bool -> Bool -> Bool
|| Bool
pIsRootSpec
    Path
_                              -> Bool
False
  isTargetingDefaultSpec :: Bool
isTargetingDefaultSpec = case Path
path of
    PathInfo{pIsDefaultSpec :: Path -> Bool
pIsDefaultSpec=Bool
True} -> Bool
True
    Path
_                             -> Bool
False
  contentType :: ContentType
contentType = ContentType
-> (ByteString -> ContentType) -> Maybe ByteString -> ContentType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ContentType
CTApplicationJSON ByteString -> ContentType
ContentType.decodeContentType (Maybe ByteString -> ContentType)
-> Maybe ByteString -> ContentType
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Maybe ByteString
lookupHeader CI ByteString
"content-type"
  columns :: Maybe Text
columns
    | Action
action Action -> [Action] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Action
ActionCreate, Action
ActionUpdate, InvokeMethod -> Action
ActionInvoke InvokeMethod
InvPost] = Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe Text)] -> Maybe (Maybe Text)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"columns" [(Text, Maybe Text)]
qParams)
    | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
  parsedColumns :: Either ApiRequestError (Maybe (Set Text))
parsedColumns = Maybe Text -> Either ApiRequestError (Maybe (Set Text))
pRequestColumns Maybe Text
columns
  payloadColumns :: Set Text
payloadColumns =
    case (ContentType
contentType, Action
action) of
      (ContentType
_, ActionInvoke InvokeMethod
InvGet)  -> [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
rpcQParams
      (ContentType
_, ActionInvoke InvokeMethod
InvHead) -> [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
rpcQParams
      (ContentType
CTUrlEncoded, Action
_)         -> [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> Text)
-> [(ByteString, ByteString)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) ([(ByteString, ByteString)] -> [Text])
-> [(ByteString, ByteString)] -> [Text]
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
parseSimpleQuery (ByteString -> [(ByteString, ByteString)])
-> ByteString -> [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
reqBody
      (ContentType, Action)
_ -> case (Maybe Payload
relevantPayload, Maybe (Set Text)
-> Either ApiRequestError (Maybe (Set Text)) -> Maybe (Set Text)
forall b a. b -> Either a b -> b
fromRight Maybe (Set Text)
forall a. Maybe a
Nothing Either ApiRequestError (Maybe (Set Text))
parsedColumns) of
        (Just ProcessedJSON{Set Text
payKeys :: Set Text
payKeys :: Payload -> Set Text
payKeys}, Maybe (Set Text)
_) -> Set Text
payKeys
        (Just RawJSON{}, Just Set Text
cls)       -> Set Text
cls
        (Maybe Payload, Maybe (Set Text))
_                                -> Set Text
forall a. Set a
S.empty
  payload :: Either ByteString Payload
  payload :: Either ByteString Payload
payload = case ContentType
contentType of
    ContentType
CTApplicationJSON ->
      if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
columns
        then Payload -> Either ByteString Payload
forall a b. b -> Either a b
Right (Payload -> Either ByteString Payload)
-> Payload -> Either ByteString Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Payload
RawJSON ByteString
reqBody
        else ByteString -> Maybe Payload -> Either ByteString Payload
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note ByteString
"All object keys must match" (Maybe Payload -> Either ByteString Payload)
-> (Value -> Maybe Payload) -> Value -> Either ByteString Payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Value -> Maybe Payload
payloadAttributes ByteString
reqBody
               (Value -> Either ByteString Payload)
-> Either ByteString Value -> Either ByteString Payload
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if ByteString -> Bool
LBS.null ByteString
reqBody Bool -> Bool -> Bool
&& Bool
isTargetingProc
                     then Value -> Either ByteString Value
forall a b. b -> Either a b
Right Value
emptyObject
                     else (FilePath -> ByteString)
-> Either FilePath Value -> Either ByteString Value
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FilePath -> ByteString
BS.pack (Either FilePath Value -> Either ByteString Value)
-> Either FilePath Value -> Either ByteString Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
JSON.eitherDecode ByteString
reqBody
    ContentType
CTTextCSV -> do
      Value
json <- (Header, CsvData) -> Value
csvToJson ((Header, CsvData) -> Value)
-> Either ByteString (Header, CsvData) -> Either ByteString Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> ByteString)
-> Either FilePath (Header, CsvData)
-> Either ByteString (Header, CsvData)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FilePath -> ByteString
BS.pack (ByteString -> Either FilePath (Header, CsvData)
forall a.
FromNamedRecord a =>
ByteString -> Either FilePath (Header, Vector a)
CSV.decodeByName ByteString
reqBody)
      ByteString -> Maybe Payload -> Either ByteString Payload
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note ByteString
"All lines must have same number of fields" (Maybe Payload -> Either ByteString Payload)
-> Maybe Payload -> Either ByteString Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Value -> Maybe Payload
payloadAttributes (Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode Value
json) Value
json
    ContentType
CTUrlEncoded ->
      let paramsMap :: HashMap Text Value
paramsMap = [(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, Value)] -> HashMap Text Value)
-> [(Text, Value)] -> HashMap Text Value
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> Value)
-> (ByteString, ByteString)
-> (Text, Value)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> Value
JSON.String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) ((ByteString, ByteString) -> (Text, Value))
-> [(ByteString, ByteString)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [(ByteString, ByteString)]
parseSimpleQuery (ByteString -> ByteString
LBS.toStrict ByteString
reqBody) in
      Payload -> Either ByteString Payload
forall a b. b -> Either a b
Right (Payload -> Either ByteString Payload)
-> Payload -> Either ByteString Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Set Text -> Payload
ProcessedJSON (HashMap Text Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode HashMap Text Value
paramsMap) (Set Text -> Payload) -> Set Text -> Payload
forall a b. (a -> b) -> a -> b
$ [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (HashMap Text Value -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text Value
paramsMap)
    ContentType
ct ->
      if Bool
isTargetingProc Bool -> Bool -> Bool
&& ContentType
ct ContentType -> [ContentType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ContentType
CTTextPlain, ContentType
CTOctetStream]
        then Payload -> Either ByteString Payload
forall a b. b -> Either a b
Right (Payload -> Either ByteString Payload)
-> Payload -> Either ByteString Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Payload
RawPay ByteString
reqBody
        else ByteString -> Either ByteString Payload
forall a b. a -> Either a b
Left (ByteString -> Either ByteString Payload)
-> ByteString -> Either ByteString Payload
forall a b. (a -> b) -> a -> b
$ ByteString
"Content-Type not acceptable: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ContentType -> ByteString
ContentType.toMime ContentType
ct
  topLevelRange :: NonnegRange
topLevelRange = NonnegRange -> Maybe NonnegRange -> NonnegRange
forall a. a -> Maybe a -> a
fromMaybe NonnegRange
allRange (Maybe NonnegRange -> NonnegRange)
-> Maybe NonnegRange -> NonnegRange
forall a b. (a -> b) -> a -> b
$ Text -> HashMap Text NonnegRange -> Maybe NonnegRange
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
"limit" HashMap Text NonnegRange
ranges -- if no limit is specified, get all the request rows
  action :: Action
action =
    case ByteString
method of
      -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response
      -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4
      ByteString
"HEAD"     | Bool
isTargetingDefaultSpec -> ActionInspect :: Bool -> Action
ActionInspect{isHead :: Bool
isHead=Bool
True}
                 | Bool
isTargetingProc        -> InvokeMethod -> Action
ActionInvoke InvokeMethod
InvHead
                 | Bool
otherwise              -> ActionRead :: Bool -> Action
ActionRead{isHead :: Bool
isHead=Bool
True}
      ByteString
"GET"      | Bool
isTargetingDefaultSpec -> ActionInspect :: Bool -> Action
ActionInspect{isHead :: Bool
isHead=Bool
False}
                 | Bool
isTargetingProc        -> InvokeMethod -> Action
ActionInvoke InvokeMethod
InvGet
                 | Bool
otherwise              -> ActionRead :: Bool -> Action
ActionRead{isHead :: Bool
isHead=Bool
False}
      ByteString
"POST"    -> if Bool
isTargetingProc
                    then InvokeMethod -> Action
ActionInvoke InvokeMethod
InvPost
                    else Action
ActionCreate
      ByteString
"PATCH"   -> Action
ActionUpdate
      ByteString
"PUT"     -> Action
ActionSingleUpsert
      ByteString
"DELETE"  -> Action
ActionDelete
      ByteString
"OPTIONS" -> Action
ActionInfo
      ByteString
_         -> ActionInspect :: Bool -> Action
ActionInspect{isHead :: Bool
isHead=Bool
False}

  defaultSchema :: Text
defaultSchema = NonEmpty Text -> Text
forall a. NonEmpty a -> a
NonEmptyList.head NonEmpty Text
configDbSchemas
  profile :: Maybe Text
profile
    | NonEmpty Text -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Text
configDbSchemas Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 -- only enable content negotiation by profile when there are multiple schemas specified in the config
      = Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise = case Action
action of
        -- POST/PATCH/PUT/DELETE don't use the same header as per the spec
        Action
ActionCreate         -> Maybe Text
contentProfile
        Action
ActionUpdate         -> Maybe Text
contentProfile
        Action
ActionSingleUpsert   -> Maybe Text
contentProfile
        Action
ActionDelete         -> Maybe Text
contentProfile
        ActionInvoke InvokeMethod
InvPost -> Maybe Text
contentProfile
        Action
_                    -> Maybe Text
acceptProfile
    where
      contentProfile :: Maybe Text
contentProfile = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> (ByteString -> Text) -> Maybe ByteString -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
defaultSchema ByteString -> Text
T.decodeUtf8 (Maybe ByteString -> Text) -> Maybe ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Maybe ByteString
lookupHeader CI ByteString
"Content-Profile"
      acceptProfile :: Maybe Text
acceptProfile = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> (ByteString -> Text) -> Maybe ByteString -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
defaultSchema ByteString -> Text
T.decodeUtf8 (Maybe ByteString -> Text) -> Maybe ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Maybe ByteString
lookupHeader CI ByteString
"Accept-Profile"
  schema :: Text
schema = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
defaultSchema Maybe Text
profile
  target :: Either ApiRequestError Target
target =
    let
      callFindProc :: Text -> Text -> Either ApiRequestError ProcDescription
callFindProc Text
procSch Text
procNam = QualifiedIdentifier
-> Set Text
-> Bool
-> ProcsMap
-> ContentType
-> Bool
-> Either ApiRequestError ProcDescription
findProc
        (Text -> Text -> QualifiedIdentifier
QualifiedIdentifier Text
procSch Text
procNam) Set Text
payloadColumns (Maybe PreferParameters
preferParameters Maybe PreferParameters -> Maybe PreferParameters -> Bool
forall a. Eq a => a -> a -> Bool
== PreferParameters -> Maybe PreferParameters
forall a. a -> Maybe a
Just PreferParameters
SingleObject) (DbStructure -> ProcsMap
dbProcs DbStructure
dbStructure)
        ContentType
contentType (Action
action Action -> Action -> Bool
forall a. Eq a => a -> a -> Bool
== InvokeMethod -> Action
ActionInvoke InvokeMethod
InvPost)
    in
    case Path
path of
      PathInfo{Text
pSchema :: Text
pSchema :: Path -> Text
pSchema, Text
pName :: Text
pName :: Path -> Text
pName, Bool
pHasRpc :: Bool
pHasRpc :: Path -> Bool
pHasRpc, Bool
pIsRootSpec :: Bool
pIsRootSpec :: Path -> Bool
pIsRootSpec, Bool
pIsDefaultSpec :: Bool
pIsDefaultSpec :: Path -> Bool
pIsDefaultSpec}
        | Bool
pHasRpc Bool -> Bool -> Bool
|| Bool
pIsRootSpec -> (ProcDescription -> Bool -> Target
`TargetProc` Bool
pIsRootSpec) (ProcDescription -> Target)
-> Either ApiRequestError ProcDescription
-> Either ApiRequestError Target
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Either ApiRequestError ProcDescription
callFindProc Text
pSchema Text
pName
        | Bool
pIsDefaultSpec         -> Target -> Either ApiRequestError Target
forall a b. b -> Either a b
Right (Target -> Either ApiRequestError Target)
-> Target -> Either ApiRequestError Target
forall a b. (a -> b) -> a -> b
$ Text -> Target
TargetDefaultSpec Text
pSchema
        | Bool
otherwise              -> Target -> Either ApiRequestError Target
forall a b. b -> Either a b
Right (Target -> Either ApiRequestError Target)
-> Target -> Either ApiRequestError Target
forall a b. (a -> b) -> a -> b
$ QualifiedIdentifier -> Target
TargetIdent (QualifiedIdentifier -> Target) -> QualifiedIdentifier -> Target
forall a b. (a -> b) -> a -> b
$ Text -> Text -> QualifiedIdentifier
QualifiedIdentifier Text
pSchema Text
pName
      Path
PathUnknown -> Target -> Either ApiRequestError Target
forall a b. b -> Either a b
Right Target
TargetUnknown

  shouldParsePayload :: Bool
shouldParsePayload = case (ContentType
contentType, Action
action) of
    (ContentType
CTUrlEncoded, ActionInvoke InvokeMethod
InvPost) -> Bool
False
    (ContentType
_, Action
act)                             -> Action
act Action -> [Action] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Action
ActionCreate, Action
ActionUpdate, Action
ActionSingleUpsert, InvokeMethod -> Action
ActionInvoke InvokeMethod
InvPost]
  relevantPayload :: Maybe Payload
relevantPayload = case (ContentType
contentType, Action
action) of
    -- Though ActionInvoke GET/HEAD doesn't really have a payload, we use the payload variable as a way
    -- to store the query string arguments to the function.
    (ContentType
_, ActionInvoke InvokeMethod
InvGet)             -> Maybe Target -> [(Text, Text)] -> Maybe Payload
targetToJsonRpcParams (Either ApiRequestError Target -> Maybe Target
forall l r. Either l r -> Maybe r
rightToMaybe Either ApiRequestError Target
target) [(Text, Text)]
rpcQParams
    (ContentType
_, ActionInvoke InvokeMethod
InvHead)            -> Maybe Target -> [(Text, Text)] -> Maybe Payload
targetToJsonRpcParams (Either ApiRequestError Target -> Maybe Target
forall l r. Either l r -> Maybe r
rightToMaybe Either ApiRequestError Target
target) [(Text, Text)]
rpcQParams
    (ContentType
CTUrlEncoded, ActionInvoke InvokeMethod
InvPost) -> Maybe Target -> [(Text, Text)] -> Maybe Payload
targetToJsonRpcParams (Either ApiRequestError Target -> Maybe Target
forall l r. Either l r -> Maybe r
rightToMaybe Either ApiRequestError Target
target) ([(Text, Text)] -> Maybe Payload)
-> [(Text, Text)] -> Maybe Payload
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> Text) -> (ByteString, ByteString) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
T.decodeUtf8) ((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [(ByteString, ByteString)]
parseSimpleQuery (ByteString -> ByteString
LBS.toStrict ByteString
reqBody)
    (ContentType, Action)
_ | Bool
shouldParsePayload               -> Either ByteString Payload -> Maybe Payload
forall l r. Either l r -> Maybe r
rightToMaybe Either ByteString Payload
payload
      | Bool
otherwise                        -> Maybe Payload
forall a. Maybe a
Nothing
  path :: Path
path =
    case Request -> [Text]
pathInfo Request
req of
      []             -> case Maybe QualifiedIdentifier
configDbRootSpec of
                          Just (QualifiedIdentifier Text
pSch Text
pName)     -> Text -> Text -> Bool -> Bool -> Bool -> Path
PathInfo (if Text
pSch Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty then Text
schema else Text
pSch) Text
pName Bool
False Bool
False Bool
True
                          Maybe QualifiedIdentifier
Nothing | OpenAPIMode
configOpenApiMode OpenAPIMode -> OpenAPIMode -> Bool
forall a. Eq a => a -> a -> Bool
== OpenAPIMode
OADisabled -> Path
PathUnknown
                                  | Bool
otherwise                       -> Text -> Text -> Bool -> Bool -> Bool -> Path
PathInfo Text
schema Text
"" Bool
False Bool
True Bool
False
      [Text
table]        -> Text -> Text -> Bool -> Bool -> Bool -> Path
PathInfo Text
schema Text
table Bool
False Bool
False Bool
False
      [Text
"rpc", Text
pName] -> Text -> Text -> Bool -> Bool -> Bool -> Path
PathInfo Text
schema Text
pName Bool
True Bool
False Bool
False
      [Text]
_              -> Path
PathUnknown
  method :: ByteString
method          = Request -> ByteString
requestMethod Request
req
  hdrs :: RequestHeaders
hdrs            = Request -> RequestHeaders
requestHeaders Request
req
  qParams :: [(Text, Maybe Text)]
qParams         = [(ByteString -> Text
T.decodeUtf8 ByteString
k, ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
v)|(ByteString
k,Maybe ByteString
v) <- [(ByteString, Maybe ByteString)]
qString]
  lookupHeader :: CI ByteString -> Maybe ByteString
lookupHeader    = (CI ByteString -> RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> CI ByteString -> Maybe ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RequestHeaders
hdrs
  Preferences.Preferences{Maybe PreferTransaction
Maybe PreferCount
Maybe PreferParameters
Maybe PreferRepresentation
Maybe PreferResolution
preferTransaction :: Preferences -> Maybe PreferTransaction
preferCount :: Preferences -> Maybe PreferCount
preferParameters :: Preferences -> Maybe PreferParameters
preferRepresentation :: Preferences -> Maybe PreferRepresentation
preferResolution :: Preferences -> Maybe PreferResolution
preferTransaction :: Maybe PreferTransaction
preferResolution :: Maybe PreferResolution
preferCount :: Maybe PreferCount
preferParameters :: Maybe PreferParameters
preferRepresentation :: Maybe PreferRepresentation
..} = RequestHeaders -> Preferences
Preferences.fromHeaders RequestHeaders
hdrs
  auth :: ByteString
auth = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Maybe ByteString
lookupHeader CI ByteString
hAuthorization
  tokenStr :: Text
tokenStr = case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (ByteString -> Text
T.decodeUtf8 ByteString
auth) of
    (Text
"Bearer" : Text
t : [Text]
_) -> Text
t
    (Text
"bearer" : Text
t : [Text]
_) -> Text
t
    [Text]
_                  -> Text
""
  endingIn:: [Text] -> Text -> Bool
  endingIn :: [Text] -> Text -> Bool
endingIn [Text]
xx Text
key = Text
lastWord Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
xx
    where lastWord :: Text
lastWord = [Text] -> Text
forall a. [a] -> a
last ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') Text
key

  headerRange :: NonnegRange
headerRange = RequestHeaders -> NonnegRange
rangeRequested RequestHeaders
hdrs
  replaceLast :: Text -> Text -> Text
replaceLast Text
x Text
s = Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
L.init ((Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.') Text
s) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
x]
  limitParams :: M.HashMap Text NonnegRange
  limitParams :: HashMap Text NonnegRange
limitParams  = [(Text, NonnegRange)] -> HashMap Text NonnegRange
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text -> Text
replaceLast Text
"limit" Text
k), Maybe Integer -> NonnegRange -> NonnegRange
restrictRange (FilePath -> Maybe Integer
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe Integer)
-> (Text -> FilePath) -> Text -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a b. ConvertText a b => a -> b
toS (Text -> Maybe Integer) -> Maybe Text -> Maybe Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
v) NonnegRange
allRange) | (Text
k,Maybe Text
v) <- [(Text, Maybe Text)]
qParams, Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
v, [Text] -> Text -> Bool
endingIn [Text
"limit"] Text
k]
  offsetParams :: M.HashMap Text NonnegRange
  offsetParams :: HashMap Text NonnegRange
offsetParams = [(Text, NonnegRange)] -> HashMap Text NonnegRange
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text -> Text
replaceLast Text
"limit" Text
k), NonnegRange
-> (Integer -> NonnegRange) -> Maybe Integer -> NonnegRange
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NonnegRange
allRange Integer -> NonnegRange
rangeGeq (FilePath -> Maybe Integer
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe Integer)
-> (Text -> FilePath) -> Text -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a b. ConvertText a b => a -> b
toS (Text -> Maybe Integer) -> Maybe Text -> Maybe Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
v)) | (Text
k,Maybe Text
v) <- [(Text, Maybe Text)]
qParams, Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
v, [Text] -> Text -> Bool
endingIn [Text
"offset"] Text
k]

  urlRange :: HashMap Text NonnegRange
urlRange = (NonnegRange -> NonnegRange -> NonnegRange)
-> HashMap Text NonnegRange
-> HashMap Text NonnegRange
-> HashMap Text NonnegRange
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
M.unionWith NonnegRange -> NonnegRange -> NonnegRange
f HashMap Text NonnegRange
limitParams HashMap Text NonnegRange
offsetParams
    where
      f :: NonnegRange -> NonnegRange -> NonnegRange
f NonnegRange
rl NonnegRange
ro = Boundary Integer -> Boundary Integer -> NonnegRange
forall v. Boundary v -> Boundary v -> Range v
Range (Integer -> Boundary Integer
forall a. a -> Boundary a
BoundaryBelow Integer
o) (Integer -> Boundary Integer
forall a. a -> Boundary a
BoundaryAbove (Integer -> Boundary Integer) -> Integer -> Boundary Integer
forall a b. (a -> b) -> a -> b
$ Integer
o Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
        where
          l :: Integer
l = Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (Maybe Integer -> Integer) -> Maybe Integer -> Integer
forall a b. (a -> b) -> a -> b
$ NonnegRange -> Maybe Integer
rangeLimit NonnegRange
rl
          o :: Integer
o = NonnegRange -> Integer
rangeOffset NonnegRange
ro
  ranges :: HashMap Text NonnegRange
ranges = Text
-> NonnegRange
-> HashMap Text NonnegRange
-> HashMap Text NonnegRange
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Text
"limit" (NonnegRange -> NonnegRange -> NonnegRange
forall v. DiscreteOrdered v => Range v -> Range v -> Range v
rangeIntersection NonnegRange
headerRange (NonnegRange -> Maybe NonnegRange -> NonnegRange
forall a. a -> Maybe a -> a
fromMaybe NonnegRange
allRange (Text -> HashMap Text NonnegRange -> Maybe NonnegRange
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup Text
"limit" HashMap Text NonnegRange
urlRange))) HashMap Text NonnegRange
urlRange

{-|
  Find the best match from a list of content types accepted by the
  client in order of decreasing preference and a list of types
  producible by the server.  If there is no match but the client
  accepts */* then return the top server pick.
-}
mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType
mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType
mutuallyAgreeable [ContentType]
sProduces [ContentType]
cAccepts =
  let exact :: Maybe ContentType
exact = [ContentType] -> Maybe ContentType
forall a. [a] -> Maybe a
listToMaybe ([ContentType] -> Maybe ContentType)
-> [ContentType] -> Maybe ContentType
forall a b. (a -> b) -> a -> b
$ [ContentType] -> [ContentType] -> [ContentType]
forall a. Eq a => [a] -> [a] -> [a]
L.intersect [ContentType]
cAccepts [ContentType]
sProduces in
  if Maybe ContentType -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ContentType
exact Bool -> Bool -> Bool
&& ContentType
CTAny ContentType -> [ContentType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ContentType]
cAccepts
     then [ContentType] -> Maybe ContentType
forall a. [a] -> Maybe a
listToMaybe [ContentType]
sProduces
     else Maybe ContentType
exact

type CsvData = V.Vector (M.HashMap Text LBS.ByteString)

{-|
  Converts CSV like
  a,b
  1,hi
  2,bye

  into a JSON array like
  [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]

  The reason for its odd signature is so that it can compose
  directly with CSV.decodeByName
-}
csvToJson :: (CSV.Header, CsvData) -> JSON.Value
csvToJson :: (Header, CsvData) -> Value
csvToJson (Header
_, CsvData
vals) =
  Array -> Value
JSON.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (HashMap Text ByteString -> Value) -> CsvData -> Array
forall a b. (a -> b) -> Vector a -> Vector b
V.map HashMap Text ByteString -> Value
rowToJsonObj CsvData
vals
 where
  rowToJsonObj :: HashMap Text ByteString -> Value
rowToJsonObj = HashMap Text Value -> Value
JSON.Object (HashMap Text Value -> Value)
-> (HashMap Text ByteString -> HashMap Text Value)
-> HashMap Text ByteString
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (ByteString -> Value)
-> HashMap Text ByteString -> HashMap Text Value
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
M.map (\ByteString
str ->
        if ByteString
str ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"NULL"
          then Value
JSON.Null
          else Text -> Value
JSON.String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Value) -> ByteString -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict ByteString
str
      )

payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
payloadAttributes :: ByteString -> Value -> Maybe Payload
payloadAttributes ByteString
raw Value
json =
  -- Test that Array contains only Objects having the same keys
  case Value
json of
    JSON.Array Array
arr ->
      case Array
arr Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
V.!? Int
0 of
        Just (JSON.Object HashMap Text Value
o) ->
          let canonicalKeys :: Set Text
canonicalKeys = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text Value
o
              areKeysUniform :: Bool
areKeysUniform = (Value -> Bool) -> Array -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\case
                JSON.Object HashMap Text Value
x -> [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (HashMap Text Value -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text Value
x) Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== Set Text
canonicalKeys
                Value
_ -> Bool
False) Array
arr in
          if Bool
areKeysUniform
            then Payload -> Maybe Payload
forall a. a -> Maybe a
Just (Payload -> Maybe Payload) -> Payload -> Maybe Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Set Text -> Payload
ProcessedJSON ByteString
raw Set Text
canonicalKeys
            else Maybe Payload
forall a. Maybe a
Nothing
        Just Value
_ -> Maybe Payload
forall a. Maybe a
Nothing
        Maybe Value
Nothing -> Payload -> Maybe Payload
forall a. a -> Maybe a
Just Payload
emptyPJArray

    JSON.Object HashMap Text Value
o -> Payload -> Maybe Payload
forall a. a -> Maybe a
Just (Payload -> Maybe Payload) -> Payload -> Maybe Payload
forall a b. (a -> b) -> a -> b
$ ByteString -> Set Text -> Payload
ProcessedJSON ByteString
raw ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> [Text] -> Set Text
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> [Text]
forall k v. HashMap k v -> [k]
M.keys HashMap Text Value
o)

    -- truncate everything else to an empty array.
    Value
_ -> Payload -> Maybe Payload
forall a. a -> Maybe a
Just Payload
emptyPJArray
  where
    emptyPJArray :: Payload
emptyPJArray = ByteString -> Set Text -> Payload
ProcessedJSON (Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode Value
emptyArray) Set Text
forall a. Set a
S.empty

findAcceptContentType :: AppConfig -> Action -> Path -> [ContentType] -> Either ApiRequestError ContentType
findAcceptContentType :: AppConfig
-> Action
-> Path
-> [ContentType]
-> Either ApiRequestError ContentType
findAcceptContentType AppConfig
conf Action
action Path
path [ContentType]
accepts =
  case [ContentType] -> [ContentType] -> Maybe ContentType
mutuallyAgreeable (AppConfig -> Action -> Path -> [ContentType]
requestContentTypes AppConfig
conf Action
action Path
path) [ContentType]
accepts of
    Just ContentType
ct ->
      ContentType -> Either ApiRequestError ContentType
forall a b. b -> Either a b
Right ContentType
ct
    Maybe ContentType
Nothing ->
      ApiRequestError -> Either ApiRequestError ContentType
forall a b. a -> Either a b
Left (ApiRequestError -> Either ApiRequestError ContentType)
-> ([ByteString] -> ApiRequestError)
-> [ByteString]
-> Either ApiRequestError ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ApiRequestError
ContentTypeError ([ByteString] -> Either ApiRequestError ContentType)
-> [ByteString] -> Either ApiRequestError ContentType
forall a b. (a -> b) -> a -> b
$ (ContentType -> ByteString) -> [ContentType] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ContentType -> ByteString
ContentType.toMime [ContentType]
accepts

requestContentTypes :: AppConfig -> Action -> Path -> [ContentType]
requestContentTypes :: AppConfig -> Action -> Path -> [ContentType]
requestContentTypes AppConfig
conf Action
action Path
path =
  case Action
action of
    ActionRead Bool
_    -> [ContentType]
defaultContentTypes [ContentType] -> [ContentType] -> [ContentType]
forall a. [a] -> [a] -> [a]
++ AppConfig -> [ContentType]
rawContentTypes AppConfig
conf
    ActionInvoke InvokeMethod
_  -> [ContentType]
invokeContentTypes
    ActionInspect Bool
_ -> [ContentType
CTOpenAPI, ContentType
CTApplicationJSON]
    Action
ActionInfo      -> [ContentType
CTTextCSV]
    Action
_               -> [ContentType]
defaultContentTypes
  where
    invokeContentTypes :: [ContentType]
invokeContentTypes =
      [ContentType]
defaultContentTypes
        [ContentType] -> [ContentType] -> [ContentType]
forall a. [a] -> [a] -> [a]
++ AppConfig -> [ContentType]
rawContentTypes AppConfig
conf
        [ContentType] -> [ContentType] -> [ContentType]
forall a. [a] -> [a] -> [a]
++ [ContentType
CTOpenAPI | Path -> Bool
pIsRootSpec Path
path]
    defaultContentTypes :: [ContentType]
defaultContentTypes =
      [ContentType
CTApplicationJSON, ContentType
CTSingularJSON, ContentType
CTTextCSV]

rawContentTypes :: AppConfig -> [ContentType]
rawContentTypes :: AppConfig -> [ContentType]
rawContentTypes AppConfig{Bool
Int
[(Text, Text)]
[ByteString]
[Text]
JSPath
Maybe Integer
Maybe FilePath
Maybe ByteString
Maybe Text
Maybe StringOrURI
Maybe JWKSet
Maybe QualifiedIdentifier
Text
FileMode
NonEmpty Text
NominalDiffTime
OpenAPIMode
LogLevel
configServerUnixSocketMode :: FileMode
configServerUnixSocket :: Maybe FilePath
configServerPort :: Int
configServerHost :: Text
configRawMediaTypes :: [ByteString]
configOpenApiServerProxyUri :: Maybe Text
configOpenApiMode :: OpenAPIMode
configLogLevel :: LogLevel
configJwtSecretIsBase64 :: Bool
configJwtSecret :: Maybe ByteString
configJwtRoleClaimKey :: JSPath
configJwtAudience :: Maybe StringOrURI
configJWKS :: Maybe JWKSet
configFilePath :: Maybe FilePath
configDbUseLegacyGucs :: Bool
configDbUri :: Text
configDbTxRollbackAll :: Bool
configDbTxAllowOverride :: Bool
configDbConfig :: Bool
configDbSchemas :: NonEmpty Text
configDbRootSpec :: Maybe QualifiedIdentifier
configDbPreparedStatements :: Bool
configDbPreRequest :: Maybe QualifiedIdentifier
configDbPoolTimeout :: NominalDiffTime
configDbPoolSize :: Int
configDbMaxRows :: Maybe Integer
configDbExtraSearchPath :: [Text]
configDbChannelEnabled :: Bool
configDbChannel :: Text
configDbAnonRole :: Text
configAppSettings :: [(Text, Text)]
configServerUnixSocketMode :: AppConfig -> FileMode
configServerUnixSocket :: AppConfig -> Maybe FilePath
configServerPort :: AppConfig -> Int
configServerHost :: AppConfig -> Text
configRawMediaTypes :: AppConfig -> [ByteString]
configOpenApiServerProxyUri :: AppConfig -> Maybe Text
configOpenApiMode :: AppConfig -> OpenAPIMode
configLogLevel :: AppConfig -> LogLevel
configJwtSecretIsBase64 :: AppConfig -> Bool
configJwtSecret :: AppConfig -> Maybe ByteString
configJwtRoleClaimKey :: AppConfig -> JSPath
configJwtAudience :: AppConfig -> Maybe StringOrURI
configJWKS :: AppConfig -> Maybe JWKSet
configFilePath :: AppConfig -> Maybe FilePath
configDbUseLegacyGucs :: AppConfig -> Bool
configDbUri :: AppConfig -> Text
configDbTxRollbackAll :: AppConfig -> Bool
configDbTxAllowOverride :: AppConfig -> Bool
configDbConfig :: AppConfig -> Bool
configDbSchemas :: AppConfig -> NonEmpty Text
configDbRootSpec :: AppConfig -> Maybe QualifiedIdentifier
configDbPreparedStatements :: AppConfig -> Bool
configDbPreRequest :: AppConfig -> Maybe QualifiedIdentifier
configDbPoolTimeout :: AppConfig -> NominalDiffTime
configDbPoolSize :: AppConfig -> Int
configDbMaxRows :: AppConfig -> Maybe Integer
configDbExtraSearchPath :: AppConfig -> [Text]
configDbChannelEnabled :: AppConfig -> Bool
configDbChannel :: AppConfig -> Text
configDbAnonRole :: AppConfig -> Text
configAppSettings :: AppConfig -> [(Text, Text)]
..} =
  (ByteString -> ContentType
ContentType.decodeContentType (ByteString -> ContentType) -> [ByteString] -> [ContentType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
configRawMediaTypes) [ContentType] -> [ContentType] -> [ContentType]
forall a. Eq a => [a] -> [a] -> [a]
`union` [ContentType
CTOctetStream, ContentType
CTTextPlain]

{-|
  Search a pg proc by matching name and arguments keys to parameters. Since a function can be overloaded,
  the name is not enough to find it. An overloaded function can have a different volatility or even a different return type.
-}
findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> ContentType -> Bool -> Either ApiRequestError ProcDescription
findProc :: QualifiedIdentifier
-> Set Text
-> Bool
-> ProcsMap
-> ContentType
-> Bool
-> Either ApiRequestError ProcDescription
findProc QualifiedIdentifier
qi Set Text
argumentsKeys Bool
paramsAsSingleObject ProcsMap
allProcs ContentType
contentType Bool
isInvPost =
  case ([ProcDescription], [ProcDescription])
matchProc of
    ([], [])     -> ApiRequestError -> Either ApiRequestError ProcDescription
forall a b. a -> Either a b
Left (ApiRequestError -> Either ApiRequestError ProcDescription)
-> ApiRequestError -> Either ApiRequestError ProcDescription
forall a b. (a -> b) -> a -> b
$ Text
-> Text -> [Text] -> Bool -> ContentType -> Bool -> ApiRequestError
NoRpc (QualifiedIdentifier -> Text
qiSchema QualifiedIdentifier
qi) (QualifiedIdentifier -> Text
qiName QualifiedIdentifier
qi) (Set Text -> [Text]
forall a. Set a -> [a]
S.toList Set Text
argumentsKeys) Bool
paramsAsSingleObject ContentType
contentType Bool
isInvPost
    -- If there are no functions with named arguments, fallback to the single unnamed argument function
    ([], [ProcDescription
proc]) -> ProcDescription -> Either ApiRequestError ProcDescription
forall a b. b -> Either a b
Right ProcDescription
proc
    ([], [ProcDescription]
procs)  -> ApiRequestError -> Either ApiRequestError ProcDescription
forall a b. a -> Either a b
Left (ApiRequestError -> Either ApiRequestError ProcDescription)
-> ApiRequestError -> Either ApiRequestError ProcDescription
forall a b. (a -> b) -> a -> b
$ [ProcDescription] -> ApiRequestError
AmbiguousRpc ([ProcDescription] -> [ProcDescription]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ProcDescription]
procs)
    -- Matches the functions with named arguments
    ([ProcDescription
proc], [ProcDescription]
_)  -> ProcDescription -> Either ApiRequestError ProcDescription
forall a b. b -> Either a b
Right ProcDescription
proc
    ([ProcDescription]
procs, [ProcDescription]
_)   -> ApiRequestError -> Either ApiRequestError ProcDescription
forall a b. a -> Either a b
Left (ApiRequestError -> Either ApiRequestError ProcDescription)
-> ApiRequestError -> Either ApiRequestError ProcDescription
forall a b. (a -> b) -> a -> b
$ [ProcDescription] -> ApiRequestError
AmbiguousRpc ([ProcDescription] -> [ProcDescription]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ProcDescription]
procs)
  where
    matchProc :: ([ProcDescription], [ProcDescription])
matchProc = [ProcDescription] -> ([ProcDescription], [ProcDescription])
forall (t :: * -> *).
Foldable t =>
t ProcDescription -> ([ProcDescription], [ProcDescription])
overloadedProcPartition ([ProcDescription] -> ([ProcDescription], [ProcDescription]))
-> [ProcDescription] -> ([ProcDescription], [ProcDescription])
forall a b. (a -> b) -> a -> b
$ [ProcDescription]
-> QualifiedIdentifier -> ProcsMap -> [ProcDescription]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
M.lookupDefault [ProcDescription]
forall a. Monoid a => a
mempty QualifiedIdentifier
qi ProcsMap
allProcs -- first find the proc by name
    -- The partition obtained has the form (overloadedProcs,fallbackProcs)
    -- where fallbackProcs are functions with a single unnamed parameter
    overloadedProcPartition :: t ProcDescription -> ([ProcDescription], [ProcDescription])
overloadedProcPartition t ProcDescription
procs = (ProcDescription
 -> ([ProcDescription], [ProcDescription])
 -> ([ProcDescription], [ProcDescription]))
-> ([ProcDescription], [ProcDescription])
-> t ProcDescription
-> ([ProcDescription], [ProcDescription])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ProcDescription
-> ([ProcDescription], [ProcDescription])
-> ([ProcDescription], [ProcDescription])
select ([],[]) t ProcDescription
procs
    select :: ProcDescription
-> ([ProcDescription], [ProcDescription])
-> ([ProcDescription], [ProcDescription])
select ProcDescription
proc ~([ProcDescription]
ts,[ProcDescription]
fs)
      | ProcDescription -> Bool
matchesParams ProcDescription
proc         = (ProcDescription
procProcDescription -> [ProcDescription] -> [ProcDescription]
forall a. a -> [a] -> [a]
:[ProcDescription]
ts,[ProcDescription]
fs)
      | ProcDescription -> Bool
hasSingleUnnamedParam ProcDescription
proc = ([ProcDescription]
ts,ProcDescription
procProcDescription -> [ProcDescription] -> [ProcDescription]
forall a. a -> [a] -> [a]
:[ProcDescription]
fs)
      | Bool
otherwise                  = ([ProcDescription]
ts,[ProcDescription]
fs)
    -- If the function is called with post and has a single unnamed parameter
    -- it can be called depending on content type and the parameter type
    hasSingleUnnamedParam :: ProcDescription -> Bool
hasSingleUnnamedParam ProcDescription
proc = Bool
isInvPost Bool -> Bool -> Bool
&& case ProcDescription -> [ProcParam]
pdParams ProcDescription
proc of
      [ProcParam Text
"" Text
ppType Bool
_ Bool
_]
        | ContentType
contentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTApplicationJSON -> Text
ppType Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"json", Text
"jsonb"]
        | ContentType
contentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTTextPlain       -> Text
ppType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"text"
        | ContentType
contentType ContentType -> ContentType -> Bool
forall a. Eq a => a -> a -> Bool
== ContentType
CTOctetStream     -> Text
ppType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"bytea"
        | Bool
otherwise                        -> Bool
False
      [ProcParam]
_ -> Bool
False
    matchesParams :: ProcDescription -> Bool
matchesParams ProcDescription
proc =
      let params :: [ProcParam]
params = ProcDescription -> [ProcParam]
pdParams ProcDescription
proc in
      -- exceptional case for Prefer: params=single-object
      if Bool
paramsAsSingleObject
        then [ProcParam] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProcParam]
params Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& (ProcParam -> Text
ppType (ProcParam -> Text) -> Maybe ProcParam -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcParam] -> Maybe ProcParam
forall a. [a] -> Maybe a
headMay [ProcParam]
params) Maybe Text -> [Maybe Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"json", Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"jsonb"]
      -- If the function has no parameters, the arguments keys must be empty as well
      else if [ProcParam] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProcParam]
params
        then Set Text -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Text
argumentsKeys Bool -> Bool -> Bool
&& ContentType
contentType ContentType -> [ContentType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ContentType
CTTextPlain, ContentType
CTOctetStream]
      -- A function has optional and required parameters. Optional parameters have a default value and
      -- don't require arguments for the function to be executed, required parameters must have an argument present.
      else case (ProcParam -> Bool) -> [ProcParam] -> ([ProcParam], [ProcParam])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition ProcParam -> Bool
ppReq [ProcParam]
params of
      -- If the function only has required parameters, the arguments keys must match those parameters
        ([ProcParam]
reqParams, [])        -> Set Text
argumentsKeys Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (ProcParam -> Text
ppName (ProcParam -> Text) -> [ProcParam] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcParam]
reqParams)
      -- If the function only has optional parameters, the arguments keys can match none or any of them(a subset)
        ([], [ProcParam]
optParams)        -> Set Text
argumentsKeys Set Text -> Set Text -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`S.isSubsetOf` [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (ProcParam -> Text
ppName (ProcParam -> Text) -> [ProcParam] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcParam]
optParams)
      -- If the function has required and optional parameters, the arguments keys have to match the required parameters
      -- and can match any or none of the default parameters.
        ([ProcParam]
reqParams, [ProcParam]
optParams) -> Set Text
argumentsKeys Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (ProcParam -> Text
ppName (ProcParam -> Text) -> [ProcParam] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcParam]
optParams) Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (ProcParam -> Text
ppName (ProcParam -> Text) -> [ProcParam] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ProcParam]
reqParams)