269 lines
10 KiB
Haskell
269 lines
10 KiB
Haskell
module PostgREST.ApiRequest where
|
|
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.Csv as CSV
|
|
import Data.List (find, sortBy)
|
|
import qualified Data.HashMap.Strict as M
|
|
import qualified Data.Set as S
|
|
import Data.Maybe (fromMaybe, isJust, isNothing,
|
|
listToMaybe, fromJust)
|
|
import Control.Arrow ((***))
|
|
import Control.Monad (join)
|
|
import Data.Monoid ((<>))
|
|
import Data.Ord (comparing)
|
|
import Data.String.Conversions (cs)
|
|
import qualified Data.Text as T
|
|
import Text.Read (readMaybe)
|
|
import qualified Data.Vector as V
|
|
import Network.HTTP.Base (urlEncodeVars)
|
|
import Network.HTTP.Types.Header (hAuthorization)
|
|
import Network.HTTP.Types.URI (parseSimpleQuery)
|
|
import Network.Wai (Request (..))
|
|
import Network.Wai.Parse (parseHttpAccept)
|
|
import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange)
|
|
import PostgREST.Types (QualifiedIdentifier (..),
|
|
Schema, Payload(..),
|
|
UniformObjects(..))
|
|
import Data.Ranged.Ranges (singletonRange, rangeIntersection)
|
|
|
|
type RequestBody = BL.ByteString
|
|
|
|
-- | Types of things a user wants to do to tables/views/procs
|
|
data Action = ActionCreate | ActionRead
|
|
| ActionUpdate | ActionDelete
|
|
| ActionInfo | ActionInvoke
|
|
| ActionInappropriate
|
|
deriving Eq
|
|
-- | The target db object of a user action
|
|
data Target = TargetIdent QualifiedIdentifier
|
|
| TargetProc QualifiedIdentifier
|
|
| TargetRoot
|
|
| TargetUnknown [T.Text]
|
|
-- | How to return the inserted data
|
|
data PreferRepresentation = Full | HeadersOnly | None deriving Eq
|
|
-- | Enumeration of currently supported content types for
|
|
-- route responses and upload payloads
|
|
data ContentType = ApplicationJSON | TextCSV deriving Eq
|
|
instance Show ContentType where
|
|
show ApplicationJSON = "application/json; charset=utf-8"
|
|
show TextCSV = "text/csv; charset=utf-8"
|
|
|
|
{-|
|
|
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 {
|
|
-- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
|
|
iAction :: Action
|
|
-- | Requested range of rows within response
|
|
, iRange :: M.HashMap String NonnegRange
|
|
-- | The target, be it calling a proc or accessing a table
|
|
, iTarget :: Target
|
|
-- | The content type the client most desires (or JSON if undecided)
|
|
, iAccepts :: Either BS.ByteString ContentType
|
|
-- | Data sent by client and used for mutation actions
|
|
, iPayload :: Maybe Payload
|
|
-- | If client wants created items echoed back
|
|
, iPreferRepresentation :: PreferRepresentation
|
|
-- | If client wants first row as raw object
|
|
, iPreferSingular :: Bool
|
|
-- | Whether the client wants a result count (slower)
|
|
, iPreferCount :: Bool
|
|
-- | Filters on the result ("id", "eq.10")
|
|
, iFilters :: [(String, String)]
|
|
-- | &select parameter used to shape the response
|
|
, iSelect :: String
|
|
-- | &order parameters for each level
|
|
, iOrder :: [(String,String)]
|
|
-- | Alphabetized (canonical) request query string for response URLs
|
|
, iCanonicalQS :: String
|
|
-- | JSON Web Token
|
|
, iJWT :: T.Text
|
|
}
|
|
|
|
-- | Examines HTTP request and translates it into user intent.
|
|
userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest
|
|
userApiRequest schema req reqBody =
|
|
let action =
|
|
if isTargetingProc
|
|
then
|
|
if method == "POST"
|
|
then ActionInvoke
|
|
else ActionInappropriate
|
|
else
|
|
case method of
|
|
"GET" -> ActionRead
|
|
"POST" -> ActionCreate
|
|
"PATCH" -> ActionUpdate
|
|
"DELETE" -> ActionDelete
|
|
"OPTIONS" -> ActionInfo
|
|
_ -> ActionInappropriate
|
|
target = case path of
|
|
[] -> TargetRoot
|
|
[table] -> TargetIdent
|
|
$ QualifiedIdentifier schema table
|
|
["rpc", proc] -> TargetProc
|
|
$ QualifiedIdentifier schema proc
|
|
other -> TargetUnknown other
|
|
payload = case pickContentType (lookupHeader "content-type") of
|
|
Right ApplicationJSON ->
|
|
either (PayloadParseError . cs)
|
|
(\val -> case ensureUniform (pluralize val) of
|
|
Nothing -> PayloadParseError "All object keys must match"
|
|
Just json -> PayloadJSON json)
|
|
(JSON.eitherDecode reqBody)
|
|
Right TextCSV ->
|
|
either (PayloadParseError . cs)
|
|
(\val -> case ensureUniform (csvToJson val) of
|
|
Nothing -> PayloadParseError "All lines must have same number of fields"
|
|
Just json -> PayloadJSON json)
|
|
(CSV.decodeByName reqBody)
|
|
-- This is a Left value because form-urlencoded is not a content
|
|
-- type which we ever use for responses, only something we handle
|
|
-- just this once for requests
|
|
Left "application/x-www-form-urlencoded" ->
|
|
PayloadJSON . UniformObjects . V.singleton . M.fromList
|
|
. map (cs *** JSON.String . cs) . parseSimpleQuery
|
|
$ cs reqBody
|
|
Left accept ->
|
|
PayloadParseError $
|
|
"Content-type not acceptable: " <> accept
|
|
relevantPayload = case action of
|
|
ActionCreate -> Just payload
|
|
ActionUpdate -> Just payload
|
|
ActionInvoke -> Just payload
|
|
_ -> Nothing in
|
|
|
|
ApiRequest {
|
|
iAction = action
|
|
, iTarget = target
|
|
, iRange = M.insert "limit" (rangeIntersection headerRange urlRange) $
|
|
M.fromList [ (cs k, restrictRange (readMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ]
|
|
, iAccepts = pickContentType $ lookupHeader "accept"
|
|
, iPayload = relevantPayload
|
|
, iPreferRepresentation = representation
|
|
, iPreferSingular = singular
|
|
, iPreferCount = not $ singular || hasPrefer "count=none"
|
|
, iFilters = [ (cs k, fromJust v) | (k,v) <- qParams, isJust v, k /= "select", k /= "offset", not (endingIn ["order", "limit"] k) ]
|
|
, iSelect = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
|
|
, iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
|
|
, iCanonicalQS = urlEncodeVars
|
|
. sortBy (comparing fst)
|
|
. map (join (***) cs)
|
|
. parseSimpleQuery
|
|
$ rawQueryString req
|
|
, iJWT = tokenStr
|
|
}
|
|
|
|
where
|
|
path = pathInfo req
|
|
method = requestMethod req
|
|
isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
|
|
hdrs = requestHeaders req
|
|
qParams = [(cs k, cs <$> v)|(k,v) <- queryString req]
|
|
lookupHeader = flip lookup hdrs
|
|
hasPrefer :: T.Text -> Bool
|
|
hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs
|
|
where
|
|
split :: BS.ByteString -> [T.Text]
|
|
split = map T.strip . T.split (==';') . cs
|
|
singular = hasPrefer "plurality=singular"
|
|
representation
|
|
| hasPrefer "return=representation" = Full
|
|
| hasPrefer "return=minimal" = None
|
|
| otherwise = HeadersOnly
|
|
auth = fromMaybe "" $ lookupHeader hAuthorization
|
|
tokenStr = case T.split (== ' ') (cs auth) of
|
|
("Bearer" : t : _) -> t
|
|
_ -> ""
|
|
endingIn:: [T.Text] -> T.Text -> Bool
|
|
endingIn xx key = lastWord `elem` xx
|
|
where lastWord = last $ T.split (=='.') key
|
|
|
|
headerRange = if singular then singletonRange 0 else rangeRequested hdrs
|
|
urlOffsetRange = rangeGeq . fromMaybe (0::Integer) $
|
|
readMaybe =<< join (lookup "offset" qParams)
|
|
urlRange = restrictRange
|
|
(readMaybe =<< join (lookup "limit" qParams))
|
|
urlOffsetRange
|
|
|
|
-- PRIVATE ---------------------------------------------------------------
|
|
|
|
{-|
|
|
Picks a preferred content type from an Accept header (or from
|
|
Content-Type as a degenerate case).
|
|
|
|
For example
|
|
text/csv -> TextCSV
|
|
*/* -> ApplicationJSON
|
|
text/csv, application/json -> TextCSV
|
|
application/json, text/csv -> ApplicationJSON
|
|
-}
|
|
pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType
|
|
pickContentType accept
|
|
| isNothing accept || has ctAll || has ctJson = Right ApplicationJSON
|
|
| has ctCsv = Right TextCSV
|
|
| otherwise = Left accept'
|
|
where
|
|
ctAll = "*/*"
|
|
ctCsv = "text/csv"
|
|
ctJson = "application/json"
|
|
Just accept' = accept
|
|
findInAccept = flip find $ parseHttpAccept accept'
|
|
has = isJust . findInAccept . BS.isPrefixOf
|
|
|
|
type CsvData = V.Vector (M.HashMap T.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.Array
|
|
csvToJson (_, vals) =
|
|
V.map rowToJsonObj vals
|
|
where
|
|
rowToJsonObj = JSON.Object .
|
|
M.map (\str ->
|
|
if str == "NULL"
|
|
then JSON.Null
|
|
else JSON.String $ cs str
|
|
)
|
|
|
|
-- | Convert {foo} to [{foo}], leave arrays unchanged
|
|
-- and truncate everything else to an empty array.
|
|
pluralize :: JSON.Value -> JSON.Array
|
|
pluralize obj@(JSON.Object _) = V.singleton obj
|
|
pluralize (JSON.Array arr) = arr
|
|
pluralize _ = V.empty
|
|
|
|
-- | Test that Array contains only Objects having the same keys
|
|
-- and if so mark it as UniformObjects
|
|
ensureUniform :: JSON.Array -> Maybe UniformObjects
|
|
ensureUniform arr =
|
|
let objs :: V.Vector JSON.Object
|
|
objs = foldr -- filter non-objects, map to raw objects
|
|
(\val result -> case val of
|
|
JSON.Object o -> V.cons o result
|
|
_ -> result)
|
|
V.empty arr
|
|
keysPerObj = V.map (S.fromList . M.keys) objs
|
|
canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0
|
|
areKeysUniform = all (==canonicalKeys) keysPerObj in
|
|
|
|
if (V.length objs == V.length arr) && areKeysUniform
|
|
then Just (UniformObjects objs)
|
|
else Nothing
|