{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module PostgREST.ApiRequest (
ApiRequest(..)
, InvokeMethod(..)
, ContentType(..)
, Action(..)
, Target(..)
, 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.List.NonEmpty (head)
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 hiding (head, toS)
import Protolude.Conv (toS)
type RequestBody = BL.ByteString
data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
data Action = ActionCreate | ActionRead{isHead :: Bool}
| ActionUpdate | ActionDelete
| ActionSingleUpsert | ActionInvoke InvokeMethod
| ActionInfo | ActionInspect{isHead :: Bool}
deriving Eq
data Target = TargetIdent QualifiedIdentifier
| TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool}
| TargetDefaultSpec{tdsSchema :: Schema}
| TargetUnknown [Text]
deriving Eq
data ApiRequest = ApiRequest {
iAction :: Action
, iRange :: M.HashMap ByteString NonnegRange
, iTopLevelRange :: NonnegRange
, iTarget :: Target
, iAccepts :: [ContentType]
, iPayload :: Maybe PayloadJSON
, iPreferRepresentation :: PreferRepresentation
, iPreferParameters :: Maybe PreferParameters
, iPreferCount :: Maybe PreferCount
, iPreferResolution :: Maybe PreferResolution
, iFilters :: [(Text, Text)]
, iLogic :: [(Text, Text)]
, iSelect :: Maybe Text
, iOnConflict :: Maybe Text
, iColumns :: Maybe Text
, iOrder :: [(Text, Text)]
, iCanonicalQS :: ByteString
, iJWT :: Text
, iHeaders :: [(Text, Text)]
, iCookies :: [(Text, Text)]
, iPath :: ByteString
, iMethod :: ByteString
, iProfile :: Maybe Schema
, iSchema :: Schema
}
userApiRequest :: NonEmpty Schema -> Maybe Text -> Request -> RequestBody -> Either ApiRequestError ApiRequest
userApiRequest confSchemas rootSpec req reqBody
| isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas
| isTargetingProc && method `notElem` ["HEAD", "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
, iTopLevelRange = topLevelRange
, iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept"
, iPayload = relevantPayload
, iPreferRepresentation = representation
, iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject
| hasPrefer (show MultipleObjects) -> Just MultipleObjects
| otherwise -> Nothing
, iPreferCount = if | hasPrefer (show ExactCount) -> Just ExactCount
| hasPrefer (show PlannedCount) -> Just PlannedCount
| hasPrefer (show EstimatedCount) -> Just EstimatedCount
| otherwise -> Nothing
, iPreferResolution = if | hasPrefer (show MergeDuplicates) -> Just MergeDuplicates
| hasPrefer (show IgnoreDuplicates) -> Just IgnoreDuplicates
| otherwise -> Nothing
, iFilters = filters
, iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
, iSelect = toS <$> join (lookup "select" qParams)
, iOnConflict = toS <$> join (lookup "on_conflict" 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))
$ qString
, iJWT = tokenStr
, iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hCookie]
, iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie"
, iPath = rawPathInfo req
, iMethod = method
, iProfile = profile
, iSchema = schema
}
where
qString = parseQueryReplacePlus True $ rawQueryString req
(filters, rpcQParams) =
case action of
ActionInvoke InvGet -> partitionFlts
ActionInvoke InvHead -> partitionFlts
_ -> (flts, [])
partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) 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
isTargetingDefaultSpec = case target of
TargetDefaultSpec _ -> True
_ -> False
contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
columns
| action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
| otherwise = Nothing
payload =
case (contentType, action) of
(_, ActionInvoke InvGet) -> Right rpcPrmsToJson
(_, ActionInvoke InvHead) -> Right rpcPrmsToJson
(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) keys
(ct, _) ->
Left $ toS $ "Content-Type not acceptable: " <> toMime ct
rpcPrmsToJson = ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) (S.fromList $ fst <$> rpcQParams)
topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges
action =
case method of
"HEAD" | isTargetingDefaultSpec -> ActionInspect{isHead=True}
| isTargetingProc -> ActionInvoke InvHead
| otherwise -> ActionRead{isHead=True}
"GET" | isTargetingDefaultSpec -> ActionInspect{isHead=False}
| isTargetingProc -> ActionInvoke InvGet
| otherwise -> ActionRead{isHead=False}
"POST" -> if isTargetingProc
then ActionInvoke InvPost
else ActionCreate
"PATCH" -> ActionUpdate
"PUT" -> ActionSingleUpsert
"DELETE" -> ActionDelete
"OPTIONS" -> ActionInfo
_ -> ActionInspect{isHead=False}
defaultSchema = head confSchemas
profile
| length confSchemas <= 1
= Nothing
| action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionDelete, ActionInvoke InvPost]
= Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile"
| action `elem` [ActionRead True, ActionRead False, ActionInvoke InvGet, ActionInvoke InvHead,
ActionInspect False, ActionInspect True, ActionInfo]
= Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile"
| otherwise = Nothing
schema = fromMaybe defaultSchema profile
target = case path of
[] -> case rootSpec of
Just pName -> TargetProc (QualifiedIdentifier schema pName) True
Nothing -> TargetDefaultSpec schema
[table] -> TargetIdent $ QualifiedIdentifier schema table
["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False
other -> TargetUnknown other
shouldParsePayload =
action `elem`
[ActionCreate, ActionUpdate, ActionSingleUpsert,
ActionInvoke InvPost,
ActionInvoke InvGet,
ActionInvoke InvHead]
relevantPayload | shouldParsePayload = rightToMaybe payload
| otherwise = Nothing
path = pathInfo req
method = requestMethod req
hdrs = requestHeaders req
qParams = [(toS k, v)|(k,v) <- qString]
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
representation
| hasPrefer (show Full) = Full
| hasPrefer (show None) = None
| otherwise = if action == ActionCreate
then HeadersOnly
else None
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 canonicalKeys
else Nothing
Just _ -> Nothing
Nothing -> Just emptyPJArray
JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ M.keys o)
_ -> Just emptyPJArray
where
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty