{-# LANGUAGE LambdaCase #-}
module PostgREST.ApiRequest (
ApiRequest(..)
, ContentType(..)
, Action(..)
, Target(..)
, PreferRepresentation (..)
, mutuallyAgreeable
, 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)
import Data.Maybe (fromJust)
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 (parseCookiesText)
import Data.Ranged.Boundaries
import PostgREST.Error (ApiRequestError (..))
import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,
rangeLimit, rangeOffset, rangeRequested,
restrictRange)
import PostgREST.Types
import Protolude
type RequestBody = BL.ByteString
data Action = ActionCreate | ActionRead
| ActionUpdate | ActionDelete
| ActionInfo | ActionInvoke{isReadOnly :: Bool}
| ActionInspect | ActionSingleUpsert
deriving Eq
data Target = TargetIdent QualifiedIdentifier
| TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool}
| TargetDefaultSpec
| 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
, iColumns :: Maybe Text
, iOrder :: [(Text, Text)]
, iCanonicalQS :: ByteString
, iJWT :: Text
, iHeaders :: [(Text, Text)]
, iCookies :: [(Text, Text)]
}
userApiRequest :: Schema -> Maybe QualifiedIdentifier -> Request -> RequestBody -> Either ApiRequestError ApiRequest
userApiRequest schema rootSpec 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 "*" $ join $ lookup "select" qParams
, iColumns = columns
, iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
, iCanonicalQS = toS $ urlEncodeVars
. L.sortOn fst
. map (join (***) toS . second (fromMaybe BS.empty))
$ queryStringWPlus
, iJWT = tokenStr
, iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hAuthorization, k /= hCookie]
, iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie"
}
where
queryStringWPlus = parseQueryReplacePlus False $ rawQueryString req
(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 `notElem` ["select", "columns"],
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 = case target of
TargetProc _ _ -> True
_ -> False
contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
columns | action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}] = toS <$> join (lookup "columns" qParams)
| otherwise = Nothing
payload =
case (contentType, action) of
(_, ActionInvoke{isReadOnly=True}) ->
Right $ ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)
(CTApplicationJSON, _) ->
if isJust columns
then Right $ RawJSON reqBody
else 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 $ ProcessedJSON (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 == TargetDefaultSpec -> 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
[] -> case rootSpec of
Just rsQi -> TargetProc rsQi True
Nothing -> TargetDefaultSpec
[table] -> TargetIdent $ QualifiedIdentifier schema table
["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False
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) <- queryStringWPlus]
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
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 $ ProcessedJSON raw (PJArray $ V.length arr) canonicalKeys
else Nothing
Just _ -> Nothing
Nothing -> Just emptyPJArray
JSON.Object o -> Just $ ProcessedJSON raw PJObject (S.fromList $ M.keys o)
_ -> Just emptyPJArray
where
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) (PJArray 0) S.empty