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
data Action = ActionCreate | ActionRead
| ActionUpdate | ActionDelete
| ActionInfo | ActionInvoke
| ActionInappropriate
deriving Eq
data Target = TargetIdent QualifiedIdentifier
| TargetProc QualifiedIdentifier
| TargetRoot
| TargetUnknown [T.Text]
data PreferRepresentation = Full | HeadersOnly | None deriving Eq
data ContentType = ApplicationJSON | TextCSV deriving Eq
instance Show ContentType where
show ApplicationJSON = "application/json; charset=utf-8"
show TextCSV = "text/csv; charset=utf-8"
data ApiRequest = ApiRequest {
iAction :: Action
, iRange :: M.HashMap String NonnegRange
, iTarget :: Target
, iAccepts :: Either BS.ByteString ContentType
, iPayload :: Maybe Payload
, iPreferRepresentation :: PreferRepresentation
, iPreferSingular :: Bool
, iPreferCount :: Bool
, iFilters :: [(String, String)]
, iSelect :: String
, iOrder :: [(String,String)]
, iCanonicalQS :: String
, iJWT :: T.Text
}
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)
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
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)
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
)
pluralize :: JSON.Value -> JSON.Array
pluralize obj@(JSON.Object _) = V.singleton obj
pluralize (JSON.Array arr) = arr
pluralize _ = V.empty
ensureUniform :: JSON.Array -> Maybe UniformObjects
ensureUniform arr =
let objs :: V.Vector JSON.Object
objs = foldr
(\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