module PostgREST.App (
app
, sqlError
, isSqlError
, contentTypeForAccept
, jsonH
, requestedSchema
, TableOptions(..)
) where
import qualified Blaze.ByteString.Builder as BB
import Control.Applicative
import Control.Arrow (second, (***))
import Control.Monad (join)
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (original)
import qualified Data.Csv as CSV
import Data.Functor.Identity
import qualified Data.HashMap.Strict as M
import Data.List (find, sortBy)
import Data.Maybe (fromMaybe, isJust, isNothing,
mapMaybe)
import Data.Ord (comparing)
import Data.Ranged.Ranges (emptyRange)
import qualified Data.Set as S
import Data.String.Conversions (cs)
import Data.Text (Text, replace, strip)
import Text.Regex.TDFA ((=~))
import Text.Parsec.Error
import Network.HTTP.Base (urlEncodeVars)
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
import Network.HTTP.Types.URI (parseSimpleQuery)
import Network.Wai
import Network.Wai.Internal (Response (..))
import Network.Wai.Parse (parseHttpAccept)
import Data.Aeson
import Data.Monoid
import qualified Data.Vector as V
import qualified Hasql as H
import qualified Hasql.Backend as B
import qualified Hasql.Postgres as P
import PostgREST.Auth
import PostgREST.Config (AppConfig (..))
import PostgREST.Parsers
import PostgREST.PgQuery
import PostgREST.PgStructure
import PostgREST.QueryBuilder
import PostgREST.RangeQuery
import PostgREST.Types
import Prelude
app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response
app dbstructure conf reqBody dbrole req =
case (path, verb) of
([], _) -> do
let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs
return $ responseLBS status200 [jsonH] $ cs body
([table], "OPTIONS") -> do
let cols = filter (filterCol schema table) allCols
pkeys = map pkName $ filter (filterPk schema table) allPrKeys
body = encode (TableOptions cols pkeys)
return $ responseLBS status200 [jsonH, allOrigins] $ cs body
([table], "GET") ->
if range == Just emptyRange
then return $ responseLBS status416 [] "HTTP Range error"
else
case queries of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right (qs, cqs) -> do
let qt = qualify table
count = if hasPrefer "count=none"
then countNone
else cqs
q = B.Stmt "select " V.empty True <>
parentheticT count
<> commaq <> (
bodyForAccept contentType qt
. limitT range
$ qs
)
row <- H.maybeEx q
let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
to = from+queryTotal1
contentRange = contentRangeH from to tableTotal
status = rangeStatus from to tableTotal
canonical = urlEncodeVars
. sortBy (comparing fst)
. map (join (***) cs)
. parseSimpleQuery
$ rawQueryString req
return $ responseLBS status
[contentTypeH, contentRange,
("Content-Location",
"/" <> cs table <>
if Prelude.null canonical then "" else "?" <> cs canonical
)
] (fromMaybe "[]" body)
where
from = fromMaybe 0 $ rangeOffset <$> range
apiRequest = first formatParserError (parseGetRequest req)
>>= first formatRelationError . addRelations schema allRels Nothing
>>= addJoinConditions schema allCols
where
formatRelationError :: Text -> Text
formatRelationError e = cs $ encode $ object [
"mesage" .= ("could not find foreign keys between these entities"::String),
"details" .= e]
formatParserError :: ParseError -> Text
formatParserError e = cs $ encode $ object [
"message" .= message,
"details" .= details]
where
message = show (errorPos e)
details = strip $ replace "\n" " " $ cs
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
query = requestToQuery schema <$> apiRequest
countQuery = requestToCountQuery schema <$> apiRequest
queries = (,) <$> query <*> countQuery
(["postgrest", "users"], "POST") -> do
let user = decode reqBody :: Maybe AuthUser
case user of
Nothing -> return $ responseLBS status400 [jsonH] $
encode . object $ [("message", String "Failed to parse user.")]
Just u -> do
_ <- addUser (cs $ userId u)
(cs $ userPass u) (cs <$> userRole u)
return $ responseLBS status201
[ jsonH
, (hLocation, "/postgrest/users?id=eq." <> cs (userId u))
] ""
(["postgrest", "tokens"], "POST") ->
case jwtSecret of
"secret" -> return $ responseLBS status500 [jsonH] $
encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")]
_ -> do
let user = decode reqBody :: Maybe AuthUser
case user of
Nothing -> return $ responseLBS status400 [jsonH] $
encode . object $ [("message", String "Failed to parse user.")]
Just u -> do
setRole authenticator
login <- signInRole (cs $ userId u) (cs $ userPass u)
case login of
LoginSuccess role uid ->
return $ responseLBS status201 [ jsonH ] $
encode . object $ [("token", String $ tokenJWT jwtSecret uid role)]
_ -> return $ responseLBS status401 [jsonH] $
encode . object $ [("message", String "Failed authentication.")]
([table], "POST") -> do
let qt = qualify table
echoRequested = hasPrefer "return=representation"
parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
parsed = if lookupHeader "Content-Type" == Just csvMT
then do
rows <- CSV.decode CSV.NoHeader reqBody
if V.null rows then Left "CSV requires header"
else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
else eitherDecode reqBody >>= \val ->
case val of
Object obj -> Right . second V.singleton . V.unzip . V.fromList $
M.toList obj
_ -> Left "Expecting single JSON object or CSV rows"
case parsed of
Left err -> return $ responseLBS status400 [] $
encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
Right toBeInserted -> do
rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
responses = flip map inserted $ \obj -> do
let primaries =
if Prelude.null pKeys
then obj
else M.filterWithKey (const . (`elem` pKeys)) obj
let params = urlEncodeVars
$ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
$ sortBy (comparing fst) $ M.toList primaries
responseLBS status201
[ jsonH
, (hLocation, "/" <> cs table <> "?" <> cs params)
] $ if echoRequested then encode obj else ""
return $ multipart status201 responses
(["rpc", proc], "POST") -> do
let qi = QualifiedIdentifier schema (cs proc)
exists <- doesProcExist schema proc
if exists
then do
let call = B.Stmt "select " V.empty True <>
asJson (callProc qi $ fromMaybe M.empty (decode reqBody))
body :: Maybe (Identity Text) <- H.maybeEx call
return $ responseLBS status200 [jsonH]
(cs $ fromMaybe "[]" $ runIdentity <$> body)
else return $ responseLBS status404 [] ""
([table], "PUT") ->
handleJsonObj reqBody $ \obj -> do
let qt = qualify table
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
specifiedKeys = map (cs . fst) qq
if S.fromList pKeys /= S.fromList specifiedKeys
then return $ responseLBS status405 []
"You must speficy all and only primary keys as params"
else do
let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols
cols = map cs $ M.keys obj
if S.fromList tableCols == S.fromList cols
then do
let vals = M.elems obj
H.unitEx $ iffNotT
(whereT qt qq $ update qt cols vals)
(insertSelect qt cols vals)
return $ responseLBS status204 [ jsonH ] ""
else return $ if Prelude.null tableCols
then responseLBS status404 [] ""
else responseLBS status400 []
"You must specify all columns in PUT request"
([table], "PATCH") ->
handleJsonObj reqBody $ \obj -> do
let qt = qualify table
up = returningStarT
. whereT qt qq
$ update qt (map cs $ M.keys obj) (M.elems obj)
patch = withT up "t" $ B.Stmt
"select count(t), array_to_json(array_agg(row_to_json(t)))::character varying"
V.empty True
row <- H.maybeEx patch
let (queryTotal, body) =
fromMaybe (0 :: Int, Just "" :: Maybe Text) row
r = contentRangeH 0 (queryTotal1) (Just queryTotal)
echoRequested = hasPrefer "return=representation"
s = case () of _ | queryTotal == 0 -> status404
| echoRequested -> status200
| otherwise -> status204
return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
([table], "DELETE") -> do
let qt = qualify table
del = countT
. returningStarT
. whereT qt qq
$ deleteFrom qt
row <- H.maybeEx del
let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
return $ if deletedCount == 0
then responseLBS status404 [] ""
else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""
(_, _) ->
return $ responseLBS status404 [] ""
where
allTabs = tables dbstructure
allRels = relations dbstructure
allCols = columns dbstructure
allPrKeys = primaryKeys dbstructure
filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t
filterCol _ _ _ = False
filterPk sc table pk = sc == pkSchema pk && table == pkTable pk
filterTableAcl :: Text -> Table -> Bool
filterTableAcl r (Table{tableAcl=a}) = r `elem` a
path = pathInfo req
verb = requestMethod req
qq = queryString req
qualify = QualifiedIdentifier schema
hdrs = requestHeaders req
lookupHeader = flip lookup hdrs
hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs
accept = lookupHeader hAccept
schema = requestedSchema (cs $ configV1Schema conf) accept
authenticator = cs $ configDbUser conf
jwtSecret = cs $ configJwtSecret conf
range = rangeRequested hdrs
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
contentType = fromMaybe "application/json" $ contentTypeForAccept accept
contentTypeH = (hContentType, contentType)
sqlError :: t
sqlError = undefined
isSqlError :: t
isSqlError = undefined
rangeStatus :: Int -> Int -> Maybe Int -> Status
rangeStatus _ _ Nothing = status200
rangeStatus from to (Just total)
| from > total = status416
| (1 + to from) < total = status206
| otherwise = status200
contentRangeH :: Int -> Int -> Maybe Int -> Header
contentRangeH from to total =
("Content-Range", cs headerValue)
where
headerValue = rangeString <> "/" <> totalString
rangeString
| totalNotZero && fromInRange = show from <> "-" <> cs (show to)
| otherwise = "*"
totalString = fromMaybe "*" (show <$> total)
totalNotZero = fromMaybe True ((/=) 0 <$> total)
fromInRange = from <= to
requestedSchema :: Text -> Maybe BS.ByteString -> Text
requestedSchema v1schema accept =
case verStr of
Just [[_, ver]] -> if ver == "1" then v1schema else cs ver
_ -> v1schema
where
verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString
verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]]
jsonMT :: BS.ByteString
jsonMT = "application/json"
csvMT :: BS.ByteString
csvMT = "text/csv"
allMT :: BS.ByteString
allMT = "*/*"
jsonH :: Header
jsonH = (hContentType, jsonMT)
contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString
contentTypeForAccept accept
| isNothing accept || has allMT || has jsonMT = Just jsonMT
| has csvMT = Just csvMT
| otherwise = Nothing
where
Just acceptH = accept
findInAccept = flip find $ parseHttpAccept acceptH
has = isJust . findInAccept . BS.isPrefixOf
bodyForAccept :: BS.ByteString -> QualifiedIdentifier -> StatementT
bodyForAccept contentType table
| contentType == csvMT = asCsvWithCount table
| otherwise = asJsonWithCount
handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
-> H.Tx P.Postgres s Response
handleJsonObj reqBody handler = do
let p = eitherDecode reqBody
case p of
Left err ->
return $ responseLBS status400 [jsonH] jErr
where
jErr = encode . object $
[("message", String $ "Failed to parse JSON payload. " <> cs err)]
Right (Object o) -> handler o
Right _ ->
return $ responseLBS status400 [jsonH] jErr
where
jErr = encode . object $
[("message", String "Expecting a JSON object")]
parseCsvCell :: BL.ByteString -> Value
parseCsvCell s = if s == "NULL" then Null else String $ cs s
multipart :: Status -> [Response] -> Response
multipart _ [] = responseLBS status204 [] ""
multipart _ [r] = r
multipart s rs =
responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $
BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs)
where
renderHeader :: Header -> BL.ByteString
renderHeader (k, v) = cs (original k) <> ": " <> cs v
renderResponseBody :: Response -> BL.ByteString
renderResponseBody (ResponseBuilder _ headers b) =
BL.intercalate "\n" (map renderHeader headers)
<> "\n\n" <> BB.toLazyByteString b
renderResponseBody _ = error
"Unable to create multipart response from non-ResponseBuilder"
data TableOptions = TableOptions {
tblOptcolumns :: [Column]
, tblOptpkey :: [Text]
}
instance ToJSON TableOptions where
toJSON t = object [
"columns" .= tblOptcolumns t
, "pkey" .= tblOptpkey t ]