{-# LANGUAGE LambdaCase #-}
module PostgREST.ApiRequest ( ApiRequest(..)
, ContentType(..)
, Action(..)
, Target(..)
, PreferRepresentation (..)
, mutuallyAgreeable
, userApiRequest
) where
import Protolude
import qualified Data.Aeson as JSON
import Data.Aeson.Types (emptyObject, emptyArray)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (c2w)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Csv as CSV
import qualified Data.List as L
import Data.List (lookup, last, partition)
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import Data.Maybe (fromJust)
import Control.Arrow ((***))
import qualified Data.Text as T
import qualified Data.Vector as V
import Network.HTTP.Base (urlEncodeVars)
import Network.HTTP.Types.Header (hAuthorization, hCookie)
import Network.HTTP.Types.URI (parseSimpleQuery)
import Network.Wai (Request (..))
import Network.Wai.Parse (parseHttpAccept)
import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
import Data.Ranged.Boundaries
import PostgREST.Types
import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange)
import qualified Data.CaseInsensitive as CI
import Web.Cookie (parseCookiesText)
type RequestBody = BL.ByteString
data Action = ActionCreate | ActionRead
| ActionUpdate | ActionDelete
| ActionInfo | ActionInvoke{isReadOnly :: Bool}
| ActionInspect | ActionSingleUpsert
deriving Eq
data Target = TargetIdent QualifiedIdentifier
| TargetProc QualifiedIdentifier
| TargetRoot
| TargetUnknown [Text]
deriving Eq
data PreferRepresentation = Full | HeadersOnly | None deriving Eq
data ApiRequest = ApiRequest {
iAction :: Action
, iRange :: M.HashMap ByteString NonnegRange
, iTarget :: Target
, iAccepts :: [ContentType]
, iPayload :: Maybe PayloadJSON
, iPreferRepresentation :: PreferRepresentation
, iPreferSingleObjectParameter :: Bool
, iPreferCount :: Bool
, iPreferResolution :: Maybe PreferResolution
, iFilters :: [(Text, Text)]
, iLogic :: [(Text, Text)]
, iSelect :: Text
, iOrder :: [(Text, Text)]
, iCanonicalQS :: ByteString
, iJWT :: Text
, iHeaders :: [(Text, Text)]
, iCookies :: [(Text, Text)]
}
userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
userApiRequest schema req reqBody
| isTargetingProc && method `notElem` ["GET", "POST"] = Left ActionInappropriate
| topLevelRange == emptyRange = Left InvalidRange
| shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload
| otherwise = Right ApiRequest {
iAction = action
, iTarget = target
, iRange = ranges
, iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept"
, iPayload = relevantPayload
, iPreferRepresentation = representation
, iPreferSingleObjectParameter = singleObject
, iPreferCount = hasPrefer "count=exact"
, iPreferResolution = if hasPrefer (show MergeDuplicates) then Just MergeDuplicates
else if hasPrefer (show IgnoreDuplicates) then Just IgnoreDuplicates
else Nothing
, iFilters = filters
, iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
, iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
, iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
, iCanonicalQS = toS $ urlEncodeVars
. L.sortBy (comparing fst)
. map (join (***) toS)
. parseSimpleQuery
$ rawQueryString req
, iJWT = tokenStr
, iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hAuthorization, k /= hCookie]
, iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie"
}
where
(filters, rpcQParams) =
case action of
ActionInvoke{isReadOnly=True} -> partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
_ -> (flts, [])
flts = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
hasOperator val = any (`T.isPrefixOf` val) $
((<> ".") <$> "not":M.keys operators) ++
((<> "(") <$> M.keys ftsOperators)
isEmbedPath = T.isInfixOf "."
isTargetingProc = (== Just "rpc") $ listToMaybe path
payload =
case (decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type", action) of
(_, ActionInvoke{isReadOnly=True}) ->
Right $ PayloadJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)
(CTApplicationJSON, _) ->
note "All object keys must match" . payloadAttributes reqBody
=<< if BL.null reqBody && isTargetingProc
then Right emptyObject
else JSON.eitherDecode reqBody
(CTTextCSV, _) -> do
json <- csvToJson <$> CSV.decodeByName reqBody
note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
(CTOther "application/x-www-form-urlencoded", _) ->
let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody
keys = S.fromList $ M.keys json in
Right $ PayloadJSON (JSON.encode json) PJObject keys
(ct, _) ->
Left $ toS $ "Content-Type not acceptable: " <> toMime ct
topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges
action =
case method of
"GET" | target == TargetRoot -> ActionInspect
| isTargetingProc -> ActionInvoke{isReadOnly=True}
| otherwise -> ActionRead
"POST" -> if isTargetingProc
then ActionInvoke{isReadOnly=False}
else ActionCreate
"PATCH" -> ActionUpdate
"PUT" -> ActionSingleUpsert
"DELETE" -> ActionDelete
"OPTIONS" -> ActionInfo
_ -> ActionInspect
target = case path of
[] -> TargetRoot
[table] -> TargetIdent
$ QualifiedIdentifier schema table
["rpc", proc] -> TargetProc
$ QualifiedIdentifier schema proc
other -> TargetUnknown other
shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}]
relevantPayload | shouldParsePayload = rightToMaybe payload
| otherwise = Nothing
path = pathInfo req
method = requestMethod req
hdrs = requestHeaders req
qParams = [(toS k, v)|(k,v) <- queryString req]
lookupHeader = flip lookup hdrs
hasPrefer :: Text -> Bool
hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs
where
split :: BS.ByteString -> [Text]
split = map T.strip . T.split (==',') . toS
singleObject = hasPrefer "params=single-object"
representation
| hasPrefer "return=representation" = Full
| hasPrefer "return=minimal" = None
| otherwise = HeadersOnly
auth = fromMaybe "" $ lookupHeader hAuthorization
tokenStr = case T.split (== ' ') (toS auth) of
("Bearer" : t : _) -> t
_ -> ""
endingIn:: [Text] -> Text -> Bool
endingIn xx key = lastWord `elem` xx
where lastWord = last $ T.split (=='.') key
headerRange = rangeRequested hdrs
replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]
limitParams :: M.HashMap ByteString NonnegRange
limitParams = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]
offsetParams :: M.HashMap ByteString NonnegRange
offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe =<< (toS <$> v))) | (k,v) <- qParams, isJust v, endingIn ["offset"] k]
urlRange = M.unionWith f limitParams offsetParams
where
f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)
where
l = fromMaybe 0 $ rangeLimit rl
o = rangeOffset ro
ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange
mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType
mutuallyAgreeable sProduces cAccepts =
let exact = listToMaybe $ L.intersect cAccepts sProduces in
if isNothing exact && CTAny `elem` cAccepts
then listToMaybe sProduces
else exact
decodeContentType :: BS.ByteString -> ContentType
decodeContentType ct =
case BS.takeWhile (/= BS.c2w ';') ct of
"application/json" -> CTApplicationJSON
"text/csv" -> CTTextCSV
"application/openapi+json" -> CTOpenAPI
"application/vnd.pgrst.object+json" -> CTSingularJSON
"application/vnd.pgrst.object" -> CTSingularJSON
"application/octet-stream" -> CTOctetStream
"*/*" -> CTAny
ct' -> CTOther ct'
type CsvData = V.Vector (M.HashMap Text BL.ByteString)
csvToJson :: (CSV.Header, CsvData) -> JSON.Value
csvToJson (_, vals) =
JSON.Array $ V.map rowToJsonObj vals
where
rowToJsonObj = JSON.Object .
M.map (\str ->
if str == "NULL"
then JSON.Null
else JSON.String $ toS str
)
payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON
payloadAttributes raw json =
case json of
JSON.Array arr ->
case arr V.!? 0 of
Just (JSON.Object o) ->
let canonicalKeys = S.fromList $ M.keys o
areKeysUniform = all (\case
JSON.Object x -> S.fromList (M.keys x) == canonicalKeys
_ -> False) arr in
if areKeysUniform
then Just $ PayloadJSON raw (PJArray $ V.length arr) canonicalKeys
else Nothing
Just _ -> Nothing
Nothing -> Just emptyPJArray
JSON.Object o -> Just $ PayloadJSON raw PJObject (S.fromList $ M.keys o)
_ -> Just emptyPJArray
where
emptyPJArray = PayloadJSON (JSON.encode emptyArray) (PJArray 0) S.empty