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

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

import qualified Data.Aeson           as JSON
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as BL
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.Set             as S
import qualified Data.Text            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.List.NonEmpty        (head)
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        (PgArg (..),
                                          ProcDescription (..),
                                          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 Protolude      hiding (head, toS)
import Protolude.Conv (toS)


type RequestBody = BL.ByteString

data PayloadJSON
  = ProcessedJSON -- ^ Cached attributes of a JSON payload
      { PayloadJSON -> ByteString
pjRaw  :: BL.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
      , PayloadJSON -> Set Text
pjKeys :: 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 { pjRaw  :: BL.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
argIsVariadic Text
k = (Text
k, [Text] -> RpcParamValue
Variadic [Text
v])
                            | Bool
otherwise       = (Text
k, Text -> RpcParamValue
Fixed Text
v)
  where
    argIsVariadic :: Text -> Bool
argIsVariadic Text
arg = Maybe PgArg -> Bool
forall a. Maybe a -> Bool
isJust (Maybe PgArg -> Bool) -> Maybe PgArg -> Bool
forall a b. (a -> b) -> a -> b
$ (PgArg -> Bool) -> [PgArg] -> Maybe PgArg
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\PgArg{Text
pgaName :: PgArg -> Text
pgaName :: Text
pgaName, Bool
pgaVar :: PgArg -> Bool
pgaVar :: Bool
pgaVar} -> Text
pgaName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
arg Bool -> Bool -> Bool
&& Bool
pgaVar) ([PgArg] -> Maybe PgArg) -> [PgArg] -> Maybe PgArg
forall a b. (a -> b) -> a -> b
$ ProcDescription -> [PgArg]
pdArgs ProcDescription
proc

-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"}
jsonRpcParams :: ProcDescription -> [(Text, Text)] -> PayloadJSON
jsonRpcParams :: ProcDescription -> [(Text, Text)] -> PayloadJSON
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 arg, save steps and directly convert to json
    ByteString -> Set Text -> PayloadJSON
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 -> PayloadJSON
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 arguments are not merged

targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe PayloadJSON
targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe PayloadJSON
targetToJsonRpcParams Maybe Target
target [(Text, Text)]
params =
  case Maybe Target
target of
    Just TargetProc{ProcDescription
tProc :: ProcDescription
tProc :: Target -> ProcDescription
tProc} -> PayloadJSON -> Maybe PayloadJSON
forall a. a -> Maybe a
Just (PayloadJSON -> Maybe PayloadJSON)
-> PayloadJSON -> Maybe PayloadJSON
forall a b. (a -> b) -> a -> b
$ ProcDescription -> [(Text, Text)] -> PayloadJSON
jsonRpcParams ProcDescription
tProc [(Text, Text)]
params
    Maybe Target
_                      -> Maybe PayloadJSON
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 ByteString NonnegRange
iRange                :: M.HashMap ByteString 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 PayloadJSON
iPayload              :: Maybe PayloadJSON                -- ^ 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
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
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 FilePath PayloadJSON -> Bool
forall a b. Either a b -> Bool
isLeft Either FilePath PayloadJSON
payload = (FilePath -> Either ApiRequestError ApiRequest)
-> (PayloadJSON -> Either ApiRequestError ApiRequest)
-> Either FilePath PayloadJSON
-> 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)
-> (FilePath -> ApiRequestError)
-> FilePath
-> Either ApiRequestError ApiRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ApiRequestError
InvalidBody (ByteString -> ApiRequestError)
-> (FilePath -> ByteString) -> FilePath -> ApiRequestError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
forall a b. StringConv a b => a -> b
toS) PayloadJSON -> Either ApiRequestError ApiRequest
forall a. a
witness Either FilePath PayloadJSON
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 ByteString NonnegRange
-> NonnegRange
-> Target
-> Maybe PayloadJSON
-> 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 ByteString NonnegRange
iRange = HashMap ByteString NonnegRange
ranges
      , iTopLevelRange :: NonnegRange
iTopLevelRange = NonnegRange
topLevelRange
      , iPayload :: Maybe PayloadJSON
iPayload = Maybe PayloadJSON
relevantPayload
      , iPreferRepresentation :: PreferRepresentation
iPreferRepresentation = PreferRepresentation
representation
      , iPreferParameters :: Maybe PreferParameters
iPreferParameters  = if | Text -> Bool
hasPrefer (PreferParameters -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferParameters
SingleObject)     -> PreferParameters -> Maybe PreferParameters
forall a. a -> Maybe a
Just PreferParameters
SingleObject
                                | Text -> Bool
hasPrefer (PreferParameters -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferParameters
MultipleObjects)  -> PreferParameters -> Maybe PreferParameters
forall a. a -> Maybe a
Just PreferParameters
MultipleObjects
                                | Bool
otherwise                         -> Maybe PreferParameters
forall a. Maybe a
Nothing
      , iPreferCount :: Maybe PreferCount
iPreferCount       = if | Text -> Bool
hasPrefer (PreferCount -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferCount
ExactCount)       -> PreferCount -> Maybe PreferCount
forall a. a -> Maybe a
Just PreferCount
ExactCount
                                | Text -> Bool
hasPrefer (PreferCount -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferCount
PlannedCount)     -> PreferCount -> Maybe PreferCount
forall a. a -> Maybe a
Just PreferCount
PlannedCount
                                | Text -> Bool
hasPrefer (PreferCount -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferCount
EstimatedCount)   -> PreferCount -> Maybe PreferCount
forall a. a -> Maybe a
Just PreferCount
EstimatedCount
                                | Bool
otherwise                         -> Maybe PreferCount
forall a. Maybe a
Nothing
      , iPreferResolution :: Maybe PreferResolution
iPreferResolution  = if | Text -> Bool
hasPrefer (PreferResolution -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferResolution
MergeDuplicates)  -> PreferResolution -> Maybe PreferResolution
forall a. a -> Maybe a
Just PreferResolution
MergeDuplicates
                                | Text -> Bool
hasPrefer (PreferResolution -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferResolution
IgnoreDuplicates) -> PreferResolution -> Maybe PreferResolution
forall a. a -> Maybe a
Just PreferResolution
IgnoreDuplicates
                                | Bool
otherwise                         -> Maybe PreferResolution
forall a. Maybe a
Nothing
      , iPreferTransaction :: Maybe PreferTransaction
iPreferTransaction = if | Text -> Bool
hasPrefer (PreferTransaction -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferTransaction
Commit)           -> PreferTransaction -> Maybe PreferTransaction
forall a. a -> Maybe a
Just PreferTransaction
Commit
                                | Text -> Bool
hasPrefer (PreferTransaction -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferTransaction
Rollback)         -> PreferTransaction -> Maybe PreferTransaction
forall a. a -> Maybe a
Just PreferTransaction
Rollback
                                | Bool
otherwise                         -> Maybe PreferTransaction
forall a. Maybe a
Nothing
      , iFilters :: [(Text, Text)]
iFilters = [(Text, Text)]
filters
      , iLogic :: [(Text, Text)]
iLogic = [(Text -> Text
forall a b. StringConv a b => a -> b
toS Text
k, ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
v) | (Text
k,Maybe ByteString
v) <- [(Text, Maybe ByteString)]
qParams, Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
v, [Text] -> Text -> Bool
endingIn [Text
"and", Text
"or"] Text
k ]
      , iSelect :: Maybe Text
iSelect = ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"select" [(Text, Maybe ByteString)]
qParams)
      , iOnConflict :: Maybe Text
iOnConflict = ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"on_conflict" [(Text, Maybe ByteString)]
qParams)
      , iColumns :: Set Text
iColumns = Set Text
payloadColumns
      , iOrder :: [(Text, Text)]
iOrder = [(Text -> Text
forall a b. StringConv a b => a -> b
toS Text
k, ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
v) | (Text
k,Maybe ByteString
v) <- [(Text, Maybe ByteString)]
qParams, Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
v, [Text] -> Text -> Bool
endingIn [Text
"order"] Text
k ]
      , iCanonicalQS :: ByteString
iCanonicalQS = FilePath -> ByteString
forall a b. StringConv a b => a -> b
toS (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
forall a b. StringConv a b => a -> b
toS ((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
BS.empty))
        ([(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. StringConv a b => a -> b
toS Text
k, ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> ByteString
forall a. HasCallStack => Maybe a -> a
fromJust Maybe ByteString
v) |
      (Text
k,Maybe ByteString
v) <- [(Text, Maybe ByteString)]
qParams, Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
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 = ByteString -> ContentType
ContentType.decodeContentType (ByteString -> ContentType)
-> (Maybe ByteString -> ByteString)
-> Maybe ByteString
-> ContentType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/json" (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] = ByteString -> Text
forall a b. StringConv a b => a -> b
toS (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"columns" [(Text, Maybe ByteString)]
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
forall a b. StringConv a b => a -> b
toS (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
forall a b. StringConv a b => a -> b
toS ByteString
reqBody
      (ContentType, Action)
_ -> case (Maybe PayloadJSON
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
pjKeys :: Set Text
pjKeys :: PayloadJSON -> Set Text
pjKeys}, Maybe (Set Text)
_) -> Set Text
pjKeys
        (Just RawJSON{}, Just Set Text
cls)      -> Set Text
cls
        (Maybe PayloadJSON, Maybe (Set Text))
_                               -> Set Text
forall a. Set a
S.empty
  payload :: Either FilePath PayloadJSON
payload = case ContentType
contentType of
    ContentType
CTApplicationJSON ->
      if Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
columns
        then PayloadJSON -> Either FilePath PayloadJSON
forall a b. b -> Either a b
Right (PayloadJSON -> Either FilePath PayloadJSON)
-> PayloadJSON -> Either FilePath PayloadJSON
forall a b. (a -> b) -> a -> b
$ ByteString -> PayloadJSON
RawJSON ByteString
reqBody
        else FilePath -> Maybe PayloadJSON -> Either FilePath PayloadJSON
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note FilePath
"All object keys must match" (Maybe PayloadJSON -> Either FilePath PayloadJSON)
-> (Value -> Maybe PayloadJSON)
-> Value
-> Either FilePath PayloadJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Value -> Maybe PayloadJSON
payloadAttributes ByteString
reqBody
               (Value -> Either FilePath PayloadJSON)
-> Either FilePath Value -> Either FilePath PayloadJSON
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if ByteString -> Bool
BL.null ByteString
reqBody Bool -> Bool -> Bool
&& Bool
isTargetingProc
                     then Value -> Either FilePath Value
forall a b. b -> Either a b
Right Value
emptyObject
                     else 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 FilePath (Header, CsvData) -> Either FilePath Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either FilePath (Header, CsvData)
forall a.
FromNamedRecord a =>
ByteString -> Either FilePath (Header, Vector a)
CSV.decodeByName ByteString
reqBody
      FilePath -> Maybe PayloadJSON -> Either FilePath PayloadJSON
forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note FilePath
"All lines must have same number of fields" (Maybe PayloadJSON -> Either FilePath PayloadJSON)
-> Maybe PayloadJSON -> Either FilePath PayloadJSON
forall a b. (a -> b) -> a -> b
$ ByteString -> Value -> Maybe PayloadJSON
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
forall a b. StringConv a b => a -> b
toS (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
forall a b. StringConv a b => a -> b
toS) ((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
forall a b. StringConv a b => a -> b
toS ByteString
reqBody) in
      PayloadJSON -> Either FilePath PayloadJSON
forall a b. b -> Either a b
Right (PayloadJSON -> Either FilePath PayloadJSON)
-> PayloadJSON -> Either FilePath PayloadJSON
forall a b. (a -> b) -> a -> b
$ ByteString -> Set Text -> PayloadJSON
ProcessedJSON (HashMap Text Value -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode HashMap Text Value
paramsMap) (Set Text -> PayloadJSON) -> Set Text -> PayloadJSON
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 ->
      FilePath -> Either FilePath PayloadJSON
forall a b. a -> Either a b
Left (FilePath -> Either FilePath PayloadJSON)
-> FilePath -> Either FilePath PayloadJSON
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
forall a b. StringConv a b => a -> b
toS (ByteString -> FilePath) -> ByteString -> FilePath
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
$ ByteString -> HashMap ByteString NonnegRange -> Maybe NonnegRange
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup ByteString
"limit" HashMap ByteString 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
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
forall a b. StringConv a b => a -> b
toS (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
forall a b. StringConv a b => a -> b
toS (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
-> Either ApiRequestError ProcDescription
findProc (Text -> Text -> QualifiedIdentifier
QualifiedIdentifier Text
procSch Text
procNam) Set Text
payloadColumns (Text -> Bool
hasPrefer (PreferParameters -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferParameters
SingleObject)) (ProcsMap -> Either ApiRequestError ProcDescription)
-> ProcsMap -> Either ApiRequestError ProcDescription
forall a b. (a -> b) -> a -> b
$ DbStructure -> ProcsMap
dbProcs DbStructure
dbStructure
    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 PayloadJSON
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 PayloadJSON
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 PayloadJSON
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 PayloadJSON
targetToJsonRpcParams (Either ApiRequestError Target -> Maybe Target
forall l r. Either l r -> Maybe r
rightToMaybe Either ApiRequestError Target
target) ([(Text, Text)] -> Maybe PayloadJSON)
-> [(Text, Text)] -> Maybe PayloadJSON
forall a b. (a -> b) -> a -> b
$ (ByteString -> Text
forall a b. StringConv a b => a -> b
toS (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
forall a b. StringConv a b => a -> b
toS) ((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
forall a b. StringConv a b => a -> b
toS ByteString
reqBody)
    (ContentType, Action)
_ | Bool
shouldParsePayload               -> Either FilePath PayloadJSON -> Maybe PayloadJSON
forall l r. Either l r -> Maybe r
rightToMaybe Either FilePath PayloadJSON
payload
      | Bool
otherwise                        -> Maybe PayloadJSON
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 ByteString)]
qParams         = [(ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
k, 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
  hasPrefer :: Text -> Bool
  hasPrefer :: Text -> Bool
hasPrefer Text
val   = ((CI ByteString, ByteString) -> Bool) -> RequestHeaders -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(CI ByteString
h,ByteString
v) -> CI ByteString
h CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
"Prefer" Bool -> Bool -> Bool
&& Text
val Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ByteString -> [Text]
split ByteString
v) RequestHeaders
hdrs
    where
        split :: BS.ByteString -> [Text]
        split :: ByteString -> [Text]
split = (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
T.strip ([Text] -> [Text])
-> (ByteString -> [Text]) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',') (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. StringConv a b => a -> b
toS
  representation :: PreferRepresentation
representation
    | Text -> Bool
hasPrefer (PreferRepresentation -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferRepresentation
Full)        = PreferRepresentation
Full
    | Text -> Bool
hasPrefer (PreferRepresentation -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferRepresentation
None)        = PreferRepresentation
None
    | Text -> Bool
hasPrefer (PreferRepresentation -> Text
forall a b. (Show a, ConvertText FilePath b) => a -> b
show PreferRepresentation
HeadersOnly) = PreferRepresentation
HeadersOnly
    | Bool
otherwise                    = PreferRepresentation
None
  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
forall a b. StringConv a b => a -> b
toS 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 ByteString NonnegRange
  limitParams :: HashMap ByteString NonnegRange
limitParams  = [(ByteString, NonnegRange)] -> HashMap ByteString NonnegRange
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text -> ByteString
forall a b. StringConv 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)
-> (ByteString -> FilePath) -> ByteString -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
forall a b. StringConv a b => a -> b
toS (ByteString -> Maybe Integer) -> Maybe ByteString -> Maybe Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
v) NonnegRange
allRange) | (Text
k,Maybe ByteString
v) <- [(Text, Maybe ByteString)]
qParams, Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
v, [Text] -> Text -> Bool
endingIn [Text
"limit"] Text
k]
  offsetParams :: M.HashMap ByteString NonnegRange
  offsetParams :: HashMap ByteString NonnegRange
offsetParams = [(ByteString, NonnegRange)] -> HashMap ByteString NonnegRange
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text -> ByteString
forall a b. StringConv 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)
-> (ByteString -> FilePath) -> ByteString -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
forall a b. StringConv a b => a -> b
toS (ByteString -> Maybe Integer) -> Maybe ByteString -> Maybe Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
v)) | (Text
k,Maybe ByteString
v) <- [(Text, Maybe ByteString)]
qParams, Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
v, [Text] -> Text -> Bool
endingIn [Text
"offset"] Text
k]

  urlRange :: HashMap ByteString NonnegRange
urlRange = (NonnegRange -> NonnegRange -> NonnegRange)
-> HashMap ByteString NonnegRange
-> HashMap ByteString NonnegRange
-> HashMap ByteString 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 ByteString NonnegRange
limitParams HashMap ByteString 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 ByteString NonnegRange
ranges = ByteString
-> NonnegRange
-> HashMap ByteString NonnegRange
-> HashMap ByteString NonnegRange
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert ByteString
"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 (ByteString -> HashMap ByteString NonnegRange -> Maybe NonnegRange
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup ByteString
"limit" HashMap ByteString NonnegRange
urlRange))) HashMap ByteString 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 BL.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) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
str
      )

payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON
payloadAttributes :: ByteString -> Value -> Maybe PayloadJSON
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 PayloadJSON -> Maybe PayloadJSON
forall a. a -> Maybe a
Just (PayloadJSON -> Maybe PayloadJSON)
-> PayloadJSON -> Maybe PayloadJSON
forall a b. (a -> b) -> a -> b
$ ByteString -> Set Text -> PayloadJSON
ProcessedJSON ByteString
raw Set Text
canonicalKeys
            else Maybe PayloadJSON
forall a. Maybe a
Nothing
        Just Value
_ -> Maybe PayloadJSON
forall a. Maybe a
Nothing
        Maybe Value
Nothing -> PayloadJSON -> Maybe PayloadJSON
forall a. a -> Maybe a
Just PayloadJSON
emptyPJArray

    JSON.Object HashMap Text Value
o -> PayloadJSON -> Maybe PayloadJSON
forall a. a -> Maybe a
Just (PayloadJSON -> Maybe PayloadJSON)
-> PayloadJSON -> Maybe PayloadJSON
forall a b. (a -> b) -> a -> b
$ ByteString -> Set Text -> PayloadJSON
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
_ -> PayloadJSON -> Maybe PayloadJSON
forall a. a -> Maybe a
Just PayloadJSON
emptyPJArray
  where
    emptyPJArray :: PayloadJSON
emptyPJArray = ByteString -> Set Text -> PayloadJSON
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
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
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 procedure by its 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 -> Either ApiRequestError ProcDescription
findProc :: QualifiedIdentifier
-> Set Text
-> Bool
-> ProcsMap
-> Either ApiRequestError ProcDescription
findProc QualifiedIdentifier
qi Set Text
payloadKeys Bool
paramsAsSingleObject ProcsMap
allProcs =
  case [ProcDescription]
bestMatch 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 -> ApiRequestError
NoRpc (QualifiedIdentifier -> Text
qiSchema QualifiedIdentifier
qi) (QualifiedIdentifier -> Text
qiName QualifiedIdentifier
qi) (Set Text -> [Text]
forall a. Set a -> [a]
S.toList Set Text
payloadKeys) Bool
paramsAsSingleObject
    [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)
  where
    bestMatch :: [ProcDescription]
bestMatch =
      case QualifiedIdentifier -> ProcsMap -> Maybe [ProcDescription]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup QualifiedIdentifier
qi ProcsMap
allProcs of
        Maybe [ProcDescription]
Nothing     -> []
        Just [ProcDescription
proc] -> [ProcDescription
proc | ProcDescription -> Bool
matches ProcDescription
proc]
        Just [ProcDescription]
procs  -> (ProcDescription -> Bool) -> [ProcDescription] -> [ProcDescription]
forall a. (a -> Bool) -> [a] -> [a]
filter ProcDescription -> Bool
matches [ProcDescription]
procs
    -- Find the exact arguments match
    matches :: ProcDescription -> Bool
matches ProcDescription
proc
      | Bool
paramsAsSingleObject = case ProcDescription -> [PgArg]
pdArgs ProcDescription
proc of
                               [PgArg
arg] -> PgArg -> Text
pgaType PgArg
arg Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"json", Text
"jsonb"]
                               [PgArg]
_     -> Bool
False
      | Bool
otherwise            = case ProcDescription -> [PgArg]
pdArgs ProcDescription
proc of
                               []   -> Set Text -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Text
payloadKeys
                               [PgArg]
args -> [PgArg] -> Bool
matchesArg [PgArg]
args
    matchesArg :: [PgArg] -> Bool
matchesArg [PgArg]
args =
      -- The function's required arguments are separated from the ones with a default value assigned.
      -- The set of names of those arguments is compared to the set of keys supplied by the client
      -- 1. If only required arguments are found, the keys must be exactly the same as those arguments
      -- 2. If only optional arguments are found, the keys must be a subset of those arguments
      -- 3. If both required and optional arguments are found, the result of taking away the optional arguments
      --    from the keys must be exactly the same as the required arguments
      case (PgArg -> Bool) -> [PgArg] -> ([PgArg], [PgArg])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition PgArg -> Bool
pgaReq [PgArg]
args of
        ([PgArg]
reqArgs, [])      -> Set Text
payloadKeys Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (PgArg -> Text
pgaName (PgArg -> Text) -> [PgArg] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgArg]
reqArgs)
        ([], [PgArg]
defArgs)      -> Set Text
payloadKeys 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 (PgArg -> Text
pgaName (PgArg -> Text) -> [PgArg] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgArg]
defArgs)
        ([PgArg]
reqArgs, [PgArg]
defArgs) -> Set Text
payloadKeys 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 (PgArg -> Text
pgaName (PgArg -> Text) -> [PgArg] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgArg]
defArgs) Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList (PgArg -> Text
pgaName (PgArg -> Text) -> [PgArg] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PgArg]
reqArgs)