Merge v3
This commit is contained in:
Joe Nelson
+273
-267
@@ -1,102 +1,77 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
--module PostgREST.App where
|
||||
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.Arrow ((***))
|
||||
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 qualified Data.HashMap.Strict as HM
|
||||
import Data.List (find, sortBy, delete, transpose)
|
||||
import Data.Maybe (fromMaybe, fromJust, 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 Data.Tree
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Text.Parsec.Error
|
||||
import Text.ParserCombinators.Parsec (parse)
|
||||
|
||||
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.Aeson.Types (emptyArray)
|
||||
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.DbStructure
|
||||
import PostgREST.QueryBuilder
|
||||
import PostgREST.RangeQuery
|
||||
import PostgREST.Types
|
||||
import PostgREST.Auth (tokenJWT)
|
||||
|
||||
import Prelude
|
||||
|
||||
app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response
|
||||
app dbstructure conf reqBody dbrole req =
|
||||
app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
|
||||
app dbStructure conf reqBody 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 -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
|
||||
. limitT range
|
||||
$ qs
|
||||
)
|
||||
case request of
|
||||
Left e -> return $ responseLBS status400 [jsonH] $ cs e
|
||||
Right (selectQuery, _, _) -> do
|
||||
let q = B.Stmt (createStatement selectQuery Nothing True range [] (not $ hasPrefer "count=none") isCsv) V.empty True
|
||||
row <- H.maybeEx q
|
||||
let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
|
||||
to = from+queryTotal-1
|
||||
contentRange = contentRangeH from to tableTotal
|
||||
status = rangeStatus from to tableTotal
|
||||
canonical = urlEncodeVars
|
||||
let (tableTotal, queryTotal, _ , body) = extractQueryResult row
|
||||
to = frm+queryTotal-1
|
||||
contentRange = contentRangeH frm to tableTotal
|
||||
status = rangeStatus frm to tableTotal
|
||||
canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
|
||||
. sortBy (comparing fst)
|
||||
. map (join (***) cs)
|
||||
. parseSimpleQuery
|
||||
@@ -108,99 +83,48 @@ app dbstructure conf reqBody dbrole req =
|
||||
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)
|
||||
frm = fromMaybe 0 $ rangeOffset <$> range
|
||||
|
||||
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)
|
||||
([table], "POST") ->
|
||||
case request of
|
||||
Left e -> return $ responseLBS status400 [jsonH] $ cs e
|
||||
Right (selectQuery, mutateQuery, isSingle) -> do
|
||||
let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
|
||||
q = B.Stmt (createStatement selectQuery (Just (mutateQuery, isSingle)) echoRequested Nothing pKeys False isCsv) V.empty True
|
||||
row <- H.maybeEx q
|
||||
let (_, _, location, body) = extractQueryResult row
|
||||
return $ responseLBS status201
|
||||
[ jsonH
|
||||
, (hLocation, "/postgrest/users?id=eq." <> cs (userId u))
|
||||
] ""
|
||||
[
|
||||
contentTypeH,
|
||||
(hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
|
||||
]
|
||||
$ if echoRequested then fromMaybe "[]" body else ""
|
||||
|
||||
(["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
|
||||
([_], "PATCH") ->
|
||||
case request of
|
||||
Left e -> return $ responseLBS status400 [jsonH] $ cs e
|
||||
Right (selectQuery, mutateQuery, _) -> do
|
||||
let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) echoRequested Nothing [] False isCsv) V.empty True
|
||||
row <- H.maybeEx q
|
||||
let (_, queryTotal, _, body) = extractQueryResult row
|
||||
r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
|
||||
s = case () of _ | queryTotal == 0 -> status404
|
||||
| echoRequested -> status200
|
||||
| otherwise -> status204
|
||||
return $ responseLBS s [contentTypeH, r]
|
||||
$ if echoRequested then fromMaybe "[]" body else ""
|
||||
|
||||
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
|
||||
([_], "DELETE") ->
|
||||
case request of
|
||||
Left e -> return $ responseLBS status400 [jsonH] $ cs e
|
||||
Right (selectQuery, mutateQuery, _) -> do
|
||||
let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) False Nothing [] True isCsv) V.empty True
|
||||
row <- H.maybeEx q
|
||||
let (_, queryTotal, _, _) = extractQueryResult row
|
||||
return $ if queryTotal == 0
|
||||
then responseLBS status404 [] ""
|
||||
else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
|
||||
|
||||
(["rpc", proc], "POST") -> do
|
||||
let qi = QualifiedIdentifier schema (cs proc)
|
||||
@@ -208,137 +132,75 @@ app dbstructure conf reqBody dbrole req =
|
||||
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
|
||||
asJson (callProc qi $ fromMaybe HM.empty (decode reqBody))
|
||||
bodyJson :: Maybe (Identity Value) <- H.maybeEx call
|
||||
returnJWT <- doesProcReturnJWT schema proc
|
||||
return $ responseLBS status200 [jsonH]
|
||||
(cs $ fromMaybe "[]" $ runIdentity <$> body)
|
||||
(let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
|
||||
if returnJWT
|
||||
then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
|
||||
else cs $ encode body)
|
||||
else return $ responseLBS status404 [] ""
|
||||
|
||||
-- check that proc exists
|
||||
-- check that arg names are all specified
|
||||
-- select * from "1".proc(a := "foo"::undefined) where whereT limit limitT
|
||||
-- select * from public.proc(a := "foo"::undefined) where whereT limit limitT
|
||||
|
||||
([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 ] ""
|
||||
([], _) -> do
|
||||
body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) allTabs)
|
||||
return $ responseLBS status200 [jsonH] $ cs body
|
||||
|
||||
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 (queryTotal-1) (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))] ""
|
||||
([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
|
||||
|
||||
(_, _) ->
|
||||
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
|
||||
allTabs = dbTables dbStructure
|
||||
allRels = dbRelations dbStructure
|
||||
allCols = dbColumns dbStructure
|
||||
allPrKeys = dbPrimaryKeys dbStructure
|
||||
filterCol sc table (Column{colTable=Table{tableSchema=s, tableName=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
|
||||
filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
|
||||
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
|
||||
schema = cs $ configSchema conf
|
||||
jwtSecret = (cs $ configJwtSecret conf) :: Text
|
||||
range = rangeRequested hdrs
|
||||
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
|
||||
contentType = fromMaybe "application/json" $ contentTypeForAccept accept
|
||||
isCsv = contentType == csvMT
|
||||
contentTypeH = (hContentType, contentType)
|
||||
|
||||
sqlError :: t
|
||||
sqlError = undefined
|
||||
|
||||
isSqlError :: t
|
||||
isSqlError = undefined
|
||||
echoRequested = hasPrefer "return=representation"
|
||||
request = parseRequest schema allRels (head path) req reqBody --TODO! is head safe?
|
||||
|
||||
rangeStatus :: Int -> Int -> Maybe Int -> Status
|
||||
rangeStatus _ _ Nothing = status200
|
||||
rangeStatus from to (Just total)
|
||||
| from > total = status416
|
||||
| (1 + to - from) < total = status206
|
||||
rangeStatus frm to (Just total)
|
||||
| frm > total = status416
|
||||
| (1 + to - frm) < total = status206
|
||||
| otherwise = status200
|
||||
|
||||
contentRangeH :: Int -> Int -> Maybe Int -> Header
|
||||
contentRangeH from to total =
|
||||
contentRangeH frm to total =
|
||||
("Content-Range", cs headerValue)
|
||||
where
|
||||
headerValue = rangeString <> "/" <> totalString
|
||||
rangeString
|
||||
| totalNotZero && fromInRange = show from <> "-" <> cs (show to)
|
||||
| totalNotZero && fromInRange = show frm <> "-" <> 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]]
|
||||
|
||||
fromInRange = frm <= to
|
||||
|
||||
jsonMT :: BS.ByteString
|
||||
jsonMT = "application/json"
|
||||
@@ -362,48 +224,120 @@ contentTypeForAccept 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 -- defaults to JSON
|
||||
|
||||
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)
|
||||
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
|
||||
renderHeader :: Header -> BL.ByteString
|
||||
renderHeader (k, v) = cs (original k) <> ": " <> cs v
|
||||
message = show (errorPos e)
|
||||
details = strip $ replace "\n" " " $ cs
|
||||
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
|
||||
|
||||
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"
|
||||
parseRequestBody :: Bool -> BL.ByteString -> Either Text ([Text],[[Value]])
|
||||
parseRequestBody isCsv reqBody = first cs $
|
||||
checkStructure =<<
|
||||
if isCsv
|
||||
then do
|
||||
rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody
|
||||
if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row)
|
||||
else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows))
|
||||
else eitherDecode reqBody >>= convertJson
|
||||
where
|
||||
checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]])
|
||||
checkStructure v
|
||||
| headerMatchesContent v = Right v
|
||||
| isCsv = Left "CSV header does not match rows length"
|
||||
| otherwise = Left "The number of keys in objects do not match"
|
||||
|
||||
headerMatchesContent :: ([Text], [[Value]]) -> Bool
|
||||
headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals
|
||||
where headerLength = length header
|
||||
|
||||
convertJson :: Value -> Either String ([Text],[[Value]])
|
||||
convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
|
||||
where
|
||||
invalidMsg = "Expecting single JSON object or JSON array of objects"
|
||||
normalized :: Either String [(Text, [Value])]
|
||||
normalized = groupByKey =<< normalizeValue v
|
||||
|
||||
vals :: [(Text, [Value])] -> [[Value]]
|
||||
vals = transpose . map snd
|
||||
|
||||
header :: [(Text, [Value])] -> [Text]
|
||||
header = map fst
|
||||
|
||||
groupByKey :: Value -> Either String [(Text,[Value])]
|
||||
groupByKey (Array a) = HM.toList . foldr (HM.unionWith (++)) (HM.fromList []) <$> maps
|
||||
where
|
||||
maps :: Either String [HM.HashMap Text [Value]]
|
||||
maps = mapM getElems $ V.toList a
|
||||
getElems (Object o) = Right $ HM.map (:[]) o
|
||||
getElems _ = Left invalidMsg
|
||||
groupByKey _ = Left invalidMsg
|
||||
|
||||
normalizeValue :: Value -> Either String Value
|
||||
normalizeValue val =
|
||||
case val of
|
||||
Object obj -> Right $ Array (V.fromList[Object obj])
|
||||
a@(Array _) -> Right a
|
||||
_ -> Left invalidMsg
|
||||
|
||||
augumentRequestWithJoin :: Schema -> [Relation] -> ApiRequest -> Either Text ApiRequest
|
||||
augumentRequestWithJoin schema allRels request =
|
||||
(first formatRelationError . addRelations schema allRels Nothing) request
|
||||
>>= addJoinConditions schema
|
||||
|
||||
-- we use strings here because most of this data will be sent to parsers (which need strings for now)
|
||||
queryParams :: Request -> [(String, Maybe String)]
|
||||
queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
|
||||
|
||||
selectStr :: [(String, Maybe String)] -> String
|
||||
selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
|
||||
|
||||
whereFilters :: [(String, Maybe String)] -> [(String, String)]
|
||||
whereFilters qParams = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]
|
||||
|
||||
orderStr :: [(String, Maybe String)] -> Maybe String
|
||||
orderStr qParams = join $ lookup "order" qParams
|
||||
|
||||
buildSelectApiRequest :: Text -> String -> [(String, String)] -> Maybe String -> Either Text ApiRequest
|
||||
buildSelectApiRequest rootTableName sel wher orderS =
|
||||
first formatParserError $ foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
|
||||
where
|
||||
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++sel++">>") sel
|
||||
addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
|
||||
flts = mapM pRequestFilter wher
|
||||
ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
|
||||
|
||||
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
|
||||
addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest
|
||||
addFilter (path, flt) (Node rn forest) =
|
||||
case targetNode of
|
||||
Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
|
||||
Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
|
||||
where
|
||||
targetNodeName:remainingPath = path
|
||||
(targetNode,restForest) = splitForest targetNodeName forest
|
||||
splitForest name forst =
|
||||
case maybeNode of
|
||||
Nothing -> (Nothing,forest)
|
||||
Just node -> (Just node, delete node forest)
|
||||
where maybeNode = find ((name==).fst.snd.rootLabel) forst
|
||||
|
||||
toSourceRelation :: Text -> Relation -> Maybe Relation
|
||||
toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
|
||||
| mt == tableName t = Just $ r {relTable=t {tableName=sourceSubqueryName}}
|
||||
| mt == tableName ft = Just $ r {relFTable=t {tableName=sourceSubqueryName}}
|
||||
| Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceSubqueryName}) <$> rt}
|
||||
| otherwise = Nothing
|
||||
|
||||
data TableOptions = TableOptions {
|
||||
tblOptcolumns :: [Column]
|
||||
@@ -414,3 +348,75 @@ instance ToJSON TableOptions where
|
||||
toJSON t = object [
|
||||
"columns" .= tblOptcolumns t
|
||||
, "pkey" .= tblOptpkey t ]
|
||||
|
||||
parseRequest :: Schema -> [Relation] -> NodeName -> Request -> BL.ByteString -> Either Text (Text, Text, Bool)
|
||||
parseRequest schema allRels rootTableName httpRequest reqBody =
|
||||
(,,) <$> selectQuery
|
||||
<*> (if method == "GET" then pure "" else mutateQuery)
|
||||
<*> (if method == "GET" then pure False else pure isSingleRecord)
|
||||
where
|
||||
hdrs = requestHeaders httpRequest
|
||||
lookupHeader = flip lookup hdrs
|
||||
isCsv = lookupHeader "Content-Type" == Just csvMT
|
||||
method = requestMethod httpRequest
|
||||
qParams = queryParams httpRequest
|
||||
parsedBody = parseRequestBody isCsv reqBody
|
||||
isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody
|
||||
parseField f = parse pField ("failed to parse field <<"++f++">>") f
|
||||
flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody)
|
||||
vals = snd <$> parsedBody
|
||||
setWith = if isSingleRecord
|
||||
then M.fromList <$> (zip <$> flds <*> (head <$> vals))
|
||||
else Left "Expecting a sigle CSV line with header or a JSON object"
|
||||
allFilters = whereFilters qParams
|
||||
mutateFilters = filter (not . ( '.' `elem` ) . fst) allFilters -- update/delete filters can be only on the root table
|
||||
cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
|
||||
fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels
|
||||
rels = case method of
|
||||
"POST" -> fakeSourceRelations ++ allRels
|
||||
"PATCH" -> fakeSourceRelations ++ allRels
|
||||
_ -> allRels
|
||||
selectApiRequest = augumentRequestWithJoin schema rels
|
||||
=<< buildSelectApiRequest rootName sel filters (orderStr qParams)
|
||||
where
|
||||
sel = if method == "DELETE"
|
||||
then "*" -- we are not returning the records so no need to consider nested items
|
||||
else selectStr qParams
|
||||
rootName = if method == "GET"
|
||||
then rootTableName
|
||||
else sourceSubqueryName
|
||||
filters = if method == "GET"
|
||||
then allFilters
|
||||
else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update
|
||||
selectQuery = requestToQuery schema <$> selectApiRequest
|
||||
mutateQuery = requestToQuery schema <$> case method of
|
||||
"POST" -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)) <*> pure []
|
||||
"PATCH" -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
|
||||
"DELETE" -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure []
|
||||
_ -> undefined
|
||||
|
||||
createStatement :: Text -> Maybe (Text, Bool) -> Bool -> Maybe NonnegRange -> [Text] -> Bool -> Bool -> Text
|
||||
createStatement selectQuery Nothing _ range _ countTable asCsv =
|
||||
wrapQuery selectQuery [
|
||||
if countTable then countAllF else countNoneF,
|
||||
countF,
|
||||
"null", -- location header can not be calucalted
|
||||
if asCsv then asCsvF else asJsonF
|
||||
] selectStarF range
|
||||
createStatement selectQuery (Just (changeQuery, isSingle)) echoRequested _ pKeys _ asCsv =
|
||||
wrapQuery changeQuery [
|
||||
countNoneF, -- when updateing it does not make sense
|
||||
countF,
|
||||
if isSingle then locationF pKeys else "null",
|
||||
if echoRequested
|
||||
then
|
||||
if asCsv
|
||||
then asCsvF
|
||||
else if isSingle then asJsonSingleF else asJsonF
|
||||
else "null"
|
||||
|
||||
] selectQuery Nothing
|
||||
|
||||
extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
|
||||
-> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
|
||||
extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "")
|
||||
|
||||
+77
-97
@@ -1,104 +1,84 @@
|
||||
module PostgREST.Auth where
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-|
|
||||
Module : PostgREST.Auth
|
||||
Description : PostgREST authorization functions.
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad (mzero)
|
||||
import Crypto.BCrypt
|
||||
import Data.Aeson
|
||||
import Data.Map
|
||||
import Data.Monoid
|
||||
This module provides functions to deal with the JWT authorization (http://jwt.io).
|
||||
It also can be used to define other authorization functions,
|
||||
in the future Oauth, LDAP and similar integrations can be coded here.
|
||||
|
||||
Authentication should always be implemented in an external service.
|
||||
In the test suite there is an example of simple login function that can be used for a
|
||||
very simple authentication system inside the PostgreSQL database.
|
||||
-}
|
||||
module PostgREST.Auth (
|
||||
setRole
|
||||
, claimsToSQL
|
||||
, jwtClaims
|
||||
, tokenJWT
|
||||
) where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Data.Aeson (Value (..), Object)
|
||||
import Data.Aeson.Types (emptyObject, emptyArray)
|
||||
import Data.Vector as V (null, head)
|
||||
import Data.Map as M (fromList, toList)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text
|
||||
import Data.Maybe (isNothing)
|
||||
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.PgQuery (pgFmtLit)
|
||||
import Prelude
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (NominalDiffTime)
|
||||
import PostgREST.PgQuery (pgFmtLit, pgFmtIdent, unquoted)
|
||||
import qualified Web.JWT as JWT
|
||||
import qualified Data.HashMap.Lazy as H
|
||||
|
||||
import System.IO.Unsafe
|
||||
|
||||
data AuthUser = AuthUser {
|
||||
userId :: String
|
||||
, userPass :: String
|
||||
, userRole :: Maybe String
|
||||
} deriving (Show)
|
||||
|
||||
instance FromJSON AuthUser where
|
||||
parseJSON (Object v) = AuthUser <$>
|
||||
v .: "id" <*>
|
||||
v .: "pass" <*>
|
||||
v .:? "role"
|
||||
parseJSON _ = mzero
|
||||
|
||||
instance ToJSON AuthUser where
|
||||
toJSON u = object [
|
||||
"id" .= userId u
|
||||
, "pass" .= userPass u
|
||||
, "role" .= userRole u ]
|
||||
|
||||
type DbRole = Text
|
||||
type UserId = Text
|
||||
|
||||
data LoginAttempt =
|
||||
NoCredentials
|
||||
| MalformedAuth
|
||||
| LoginFailed
|
||||
| LoginSuccess DbRole UserId
|
||||
deriving (Eq, Show)
|
||||
|
||||
checkPass :: Text -> Text -> Bool
|
||||
checkPass = (. cs) . validatePassword . cs
|
||||
|
||||
setRole :: Text -> H.Tx P.Postgres s ()
|
||||
setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True
|
||||
|
||||
setUserId :: Text -> H.Tx P.Postgres s ()
|
||||
setUserId uid =
|
||||
if uid /= ""
|
||||
then H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True
|
||||
else resetUserId
|
||||
|
||||
resetUserId :: H.Tx P.Postgres s ()
|
||||
resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|]
|
||||
|
||||
addUser :: Text -> Text -> Maybe Text -> H.Tx P.Postgres s ()
|
||||
addUser identity pass role =
|
||||
H.unitEx $
|
||||
if isNothing role
|
||||
then [H.stmt|insert into postgrest.auth (id, pass) values (?, ?)|]
|
||||
identity hashedText
|
||||
else [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
|
||||
identity hashedText role
|
||||
where Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
|
||||
hashedText = cs hashed :: Text
|
||||
|
||||
signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt
|
||||
signInRole user pass = do
|
||||
u <- H.maybeEx $ [H.stmt|select id, pass, rolname from postgrest.auth where id = ?|] user
|
||||
return $ maybe LoginFailed (\r ->
|
||||
let (uid, hashed, role) = r in
|
||||
if checkPass hashed pass
|
||||
then LoginSuccess role uid
|
||||
else LoginFailed
|
||||
) u
|
||||
|
||||
signInWithJWT :: Text -> Text -> LoginAttempt
|
||||
signInWithJWT secret input = case maybeRole of
|
||||
Just (Just (String role)) -> case maybeUserId of
|
||||
Just (Just (String uid)) -> LoginSuccess (cs role) (cs uid)
|
||||
_ -> LoginFailed
|
||||
_ -> LoginFailed
|
||||
{-|
|
||||
Receives a map of JWT claims and returns a list
|
||||
of PostgreSQL statements to set the claims as user defined GUCs.
|
||||
Except if we have a claim called role,
|
||||
this one is mapped to a SET ROLE statement.
|
||||
In case there is any problem decoding the JWT it returns Nothing.
|
||||
-}
|
||||
claimsToSQL :: JWT.ClaimsMap -> [Text]
|
||||
claimsToSQL = map setVar . toList
|
||||
where
|
||||
setVar ("role", String val) = setRole val
|
||||
setVar (k, val) = "set local postgrest.claims." <> pgFmtIdent k <>
|
||||
" = " <> valueToVariable val <> ";"
|
||||
valueToVariable = pgFmtLit . unquoted
|
||||
|
||||
{-|
|
||||
Receives the JWT secret (from config) and a JWT and
|
||||
returns a map of JWT claims
|
||||
In case there is any problem decoding the JWT it returns Nothing.
|
||||
-}
|
||||
jwtClaims :: Text -> Text -> NominalDiffTime -> Maybe JWT.ClaimsMap
|
||||
jwtClaims secret input time =
|
||||
case join $ claim JWT.exp of
|
||||
Just expires ->
|
||||
if JWT.secondsSinceEpoch expires > time
|
||||
then customClaims
|
||||
else Nothing
|
||||
_ -> customClaims
|
||||
where
|
||||
maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value)
|
||||
maybeUserId = (Data.Map.lookup "id" <$> claims) ::Maybe (Maybe Value)
|
||||
claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded
|
||||
decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input
|
||||
claim :: (JWT.JWTClaimsSet -> a) -> Maybe a
|
||||
claim prop = prop . JWT.claims <$> decoded
|
||||
customClaims = claim JWT.unregisteredClaims
|
||||
|
||||
tokenJWT :: Text -> Text -> Text -> Text
|
||||
tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet
|
||||
where
|
||||
claimsSet = JWT.def {
|
||||
JWT.unregisteredClaims = Data.Map.fromList [("id", String uid), ("role", String role)]
|
||||
}
|
||||
-- | Receives the name of a role and returns a SET ROLE statement
|
||||
setRole :: Text -> Text
|
||||
setRole role = "set local role " <> cs (pgFmtLit role) <> ";"
|
||||
|
||||
|
||||
{-|
|
||||
Receives the JWT secret (from config) and a JWT and a JSON value
|
||||
and returns a signed JWT.
|
||||
-}
|
||||
tokenJWT :: Text -> Value -> Text
|
||||
tokenJWT secret (Array a) = JWT.encodeSigned JWT.HS256 (JWT.secret secret)
|
||||
JWT.def { JWT.unregisteredClaims = fromHashMap o }
|
||||
where
|
||||
Object o = if V.null a then emptyObject else V.head a
|
||||
fromHashMap :: Object -> JWT.ClaimsMap
|
||||
fromHashMap = M.fromList . H.toList
|
||||
tokenJWT secret _ = tokenJWT secret emptyArray
|
||||
|
||||
+11
-22
@@ -28,44 +28,33 @@ import Data.Text (strip)
|
||||
import Data.Version (versionBranch)
|
||||
import Network.Wai
|
||||
import Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
|
||||
import Options.Applicative hiding (columns)
|
||||
import Options.Applicative
|
||||
import Paths_postgrest (version)
|
||||
import Prelude
|
||||
|
||||
-- | Data type to store all command line options
|
||||
data AppConfig = AppConfig {
|
||||
configDbName :: String
|
||||
, configDbPort :: Int
|
||||
, configDbUser :: String
|
||||
, configDbPass :: String
|
||||
, configDbHost :: String
|
||||
|
||||
configDatabase :: String
|
||||
, configPort :: Int
|
||||
, configAnonRole :: String
|
||||
, configSecure :: Bool
|
||||
, configPool :: Int
|
||||
, configV1Schema :: String
|
||||
, configSchema :: String
|
||||
, configJwtSecret :: String
|
||||
, configPool :: Int
|
||||
}
|
||||
|
||||
argParser :: Parser AppConfig
|
||||
argParser = AppConfig
|
||||
<$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database")
|
||||
<*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault)
|
||||
<*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role")
|
||||
<*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role")
|
||||
<*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault)
|
||||
<$> argument str (help "database connection string" <> metavar "STRING")
|
||||
|
||||
<*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault)
|
||||
<*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE" <> help "postgres role to use for non-authenticated requests")
|
||||
<*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")
|
||||
<*> option auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)
|
||||
<*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)
|
||||
<*> strOption (long "jwt-secret" <> metavar "SECRET" <> value "secret" <> help "Secret used to encrypt and decrypt JWT tokens)" <> showDefault)
|
||||
<*> option auto (long "port" <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault)
|
||||
<*> strOption (long "anonymous" <> short 'a' <> help "postgres role to use for non-authenticated requests" <> metavar "ROLE")
|
||||
<*> strOption (long "schema" <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "1" <> showDefault)
|
||||
<*> strOption (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault)
|
||||
<*> option auto (long "pool" <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault)
|
||||
|
||||
defaultCorsPolicy :: CorsResourcePolicy
|
||||
defaultCorsPolicy = CorsResourcePolicy Nothing
|
||||
["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
|
||||
["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
|
||||
(Just $ 60*60*24) False False True
|
||||
|
||||
-- | CORS policy to be used in by Wai Cors middleware
|
||||
|
||||
@@ -0,0 +1,354 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
module PostgREST.DbStructure (
|
||||
getDbStructure
|
||||
, accessibleTables
|
||||
, doesProcExist
|
||||
, doesProcReturnJWT
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad (join)
|
||||
import Data.Functor.Identity
|
||||
import Data.List (elemIndex, find, subsequences, sort, transpose)
|
||||
import Data.Maybe (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe)
|
||||
import Data.Monoid
|
||||
import Data.Text (Text, split)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import qualified Hasql.Backend as B
|
||||
import PostgREST.PgQuery ()
|
||||
import PostgREST.Types
|
||||
|
||||
import GHC.Exts (groupWith)
|
||||
import Prelude
|
||||
|
||||
getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure
|
||||
getDbStructure schema = do
|
||||
tabs <- allTables
|
||||
cols <- allColumns tabs
|
||||
syns <- allSynonyms cols
|
||||
rels <- allRelations tabs cols
|
||||
keys <- allPrimaryKeys tabs
|
||||
|
||||
let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels
|
||||
cols' = addForeignKeys rels' cols
|
||||
keys' = synonymousPrimaryKeys syns keys
|
||||
|
||||
return DbStructure {
|
||||
dbTables = tabs
|
||||
, dbColumns = cols'
|
||||
, dbRelations = rels'
|
||||
, dbPrimaryKeys = keys'
|
||||
}
|
||||
|
||||
doesProc :: forall c s. B.CxValue c Int =>
|
||||
(Text -> Text -> B.Stmt c) -> Text -> Text -> H.Tx c s Bool
|
||||
doesProc stmt schema proc = do
|
||||
row :: Maybe (Identity Int) <- H.maybeEx $ stmt schema proc
|
||||
return $ isJust row
|
||||
|
||||
doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
|
||||
doesProcExist = doesProc [H.stmt|
|
||||
SELECT 1
|
||||
FROM pg_catalog.pg_namespace n
|
||||
JOIN pg_catalog.pg_proc p
|
||||
ON pronamespace = n.oid
|
||||
WHERE nspname = ?
|
||||
AND proname = ?
|
||||
|]
|
||||
|
||||
doesProcReturnJWT :: Text -> Text -> H.Tx P.Postgres s Bool
|
||||
doesProcReturnJWT = doesProc [H.stmt|
|
||||
SELECT 1
|
||||
FROM pg_catalog.pg_namespace n
|
||||
JOIN pg_catalog.pg_proc p
|
||||
ON pronamespace = n.oid
|
||||
WHERE nspname = ?
|
||||
AND proname = ?
|
||||
AND pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims'
|
||||
|]
|
||||
|
||||
accessibleTables :: [Table] -> H.Tx P.Postgres s [Table]
|
||||
accessibleTables allTabs = do
|
||||
accessible <- H.listEx $ [H.stmt|
|
||||
SELECT
|
||||
n.nspname AS table_schema,
|
||||
c.relname AS table_name
|
||||
FROM pg_class c
|
||||
JOIN pg_namespace n ON n.oid = c.relnamespace
|
||||
WHERE
|
||||
c.relkind IN ('v','r','m') AND
|
||||
n.nspname NOT IN ('pg_catalog', 'information_schema') AND (
|
||||
pg_has_role(c.relowner, 'USAGE'::text) OR
|
||||
has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR
|
||||
has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text)
|
||||
)
|
||||
ORDER BY table_schema, table_name
|
||||
|]
|
||||
let isAccessible table = isJust $ find (\(s,n) -> tableSchema table == s && tableName table == n) accessible
|
||||
return $ filter isAccessible allTabs
|
||||
|
||||
synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]]
|
||||
synonymousColumns allSyns cols = synCols'
|
||||
where
|
||||
syns = sort $ filter ((== colTable (head cols)) . colTable . fst) allSyns
|
||||
synCols = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols
|
||||
synCols' = (filter sameTable . filter matchLength) synCols
|
||||
matchLength cs = length cols == length cs
|
||||
sameTable (c:cs) = all (\cc -> colTable c == colTable cc) (c:cs)
|
||||
sameTable [] = False
|
||||
|
||||
addForeignKeys :: [Relation] -> [Column] -> [Column]
|
||||
addForeignKeys rels = map addFk
|
||||
where
|
||||
addFk col = col { colFK = fk col }
|
||||
fk col = join $ relToFk col <$> find (lookupFn col) rels
|
||||
lookupFn :: Column -> Relation -> Bool
|
||||
lookupFn c (Relation{relColumns=cs, relType=rty}) = c `elem` cs && rty==Child
|
||||
-- lookupFn _ _ = False
|
||||
relToFk col (Relation{relColumns=cols, relFColumns=colsF}) = ForeignKey <$> colF
|
||||
where
|
||||
pos = elemIndex col cols
|
||||
colF = (colsF !!) <$> pos
|
||||
|
||||
addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]
|
||||
addSynonymousRelations _ [] = []
|
||||
addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels
|
||||
where
|
||||
synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})
|
||||
synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs})
|
||||
synRels cols mapFn = map (\cs -> mapFn (colTable $ head cs) cs) $ synonymousColumns syns cols
|
||||
|
||||
addParentRelations :: [Relation] -> [Relation]
|
||||
addParentRelations [] = []
|
||||
addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels
|
||||
|
||||
addManyToManyRelations :: [Relation] -> [Relation]
|
||||
addManyToManyRelations rels = rels ++ mapMaybe link2Relation links
|
||||
where
|
||||
links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels
|
||||
groupFn :: Relation -> Text
|
||||
groupFn (Relation{relTable=Table{tableSchema=s, tableName=t}}) = s<>"_"<>t
|
||||
combinations k ns = filter ((k==).length) (subsequences ns)
|
||||
link2Relation [
|
||||
Relation{relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},
|
||||
Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc}
|
||||
]
|
||||
| lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation t c ft fc Many (Just lt) (Just lc1) (Just lc2)
|
||||
| otherwise = Nothing
|
||||
link2Relation _ = Nothing
|
||||
|
||||
raiseRelations :: Schema -> [(Column,Column)] -> [Relation] -> [Relation]
|
||||
raiseRelations schema syns = map raiseRel
|
||||
where
|
||||
raiseRel rel
|
||||
| tableSchema table == schema = rel
|
||||
| isJust newCols = rel{relFTable=fromJust newTable,relFColumns=fromJust newCols}
|
||||
| otherwise = rel
|
||||
where
|
||||
cols = relFColumns rel
|
||||
table = relFTable rel
|
||||
newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . head) (synonymousColumns syns cols)
|
||||
newTable = (colTable . head) <$> newCols
|
||||
|
||||
synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey]
|
||||
synonymousPrimaryKeys _ [] = []
|
||||
synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys syns keys
|
||||
where
|
||||
keySyns = filter ((\c -> colTable c == pkTable key && colName c == pkName key) . fst) syns
|
||||
newKeys = map ((\c -> PrimaryKey{pkTable=colTable c,pkName=colName c}) . snd) keySyns
|
||||
|
||||
allTables :: H.Tx P.Postgres s [Table]
|
||||
allTables = do
|
||||
rows <- H.listEx $ [H.stmt|
|
||||
SELECT
|
||||
n.nspname AS table_schema,
|
||||
c.relname AS table_name,
|
||||
c.relkind = 'r' OR (c.relkind IN ('v','f'))
|
||||
AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8
|
||||
OR (EXISTS
|
||||
( SELECT 1
|
||||
FROM pg_trigger
|
||||
WHERE pg_trigger.tgrelid = c.oid
|
||||
AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable
|
||||
FROM pg_class c
|
||||
JOIN pg_namespace n ON n.oid = c.relnamespace
|
||||
WHERE c.relkind IN ('v','r','m')
|
||||
AND n.nspname NOT IN ('pg_catalog', 'information_schema')
|
||||
GROUP BY table_schema, table_name, insertable
|
||||
ORDER BY table_schema, table_name
|
||||
|]
|
||||
return $ map tableFromRow rows
|
||||
|
||||
tableFromRow :: (Text, Text, Bool) -> Table
|
||||
tableFromRow (s, n, i) = Table s n i
|
||||
|
||||
allColumns :: [Table] -> H.Tx P.Postgres s [Column]
|
||||
allColumns tabs = do
|
||||
cols <- H.listEx $ [H.stmt|
|
||||
SELECT DISTINCT
|
||||
info.table_schema AS schema,
|
||||
info.table_name AS table_name,
|
||||
info.column_name AS name,
|
||||
info.ordinal_position AS position,
|
||||
info.is_nullable::boolean AS nullable,
|
||||
info.data_type AS col_type,
|
||||
info.is_updatable::boolean AS updatable,
|
||||
info.character_maximum_length AS max_len,
|
||||
info.numeric_precision AS precision,
|
||||
info.column_default AS default_value,
|
||||
array_to_string(enum_info.vals, ',') AS enum
|
||||
FROM (
|
||||
SELECT
|
||||
table_schema,
|
||||
table_name,
|
||||
column_name,
|
||||
ordinal_position,
|
||||
is_nullable,
|
||||
data_type,
|
||||
is_updatable,
|
||||
character_maximum_length,
|
||||
numeric_precision,
|
||||
column_default,
|
||||
udt_name
|
||||
FROM information_schema.columns
|
||||
WHERE table_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
) AS info
|
||||
LEFT OUTER JOIN (
|
||||
SELECT
|
||||
n.nspname AS s,
|
||||
t.typname AS n,
|
||||
array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals
|
||||
FROM pg_type t
|
||||
JOIN pg_enum e ON t.oid = e.enumtypid
|
||||
JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace
|
||||
GROUP BY s,n
|
||||
) AS enum_info ON (info.udt_name = enum_info.n)
|
||||
ORDER BY schema, position
|
||||
|]
|
||||
return $ mapMaybe (columnFromRow tabs) cols
|
||||
|
||||
columnFromRow :: [Table] ->
|
||||
(Text, Text, Text,
|
||||
Int, Bool, Text,
|
||||
Bool, Maybe Int, Maybe Int,
|
||||
Maybe Text, Maybe Text)
|
||||
-> Maybe Column
|
||||
columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table
|
||||
where
|
||||
buildColumn tbl = Column tbl n pos nul typ u l p d (parseEnum e) Nothing
|
||||
table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
|
||||
parseEnum :: Maybe Text -> [Text]
|
||||
parseEnum str = fromMaybe [] $ split (==',') <$> str
|
||||
|
||||
allRelations :: [Table] -> [Column] -> H.Tx P.Postgres s [Relation]
|
||||
allRelations tabs cols = do
|
||||
rels <- H.listEx $ [H.stmt|
|
||||
SELECT ns1.nspname AS table_schema,
|
||||
tab.relname AS table_name,
|
||||
column_info.cols AS columns,
|
||||
ns2.nspname AS foreign_table_schema,
|
||||
other.relname AS foreign_table_name,
|
||||
column_info.refs AS foreign_columns
|
||||
FROM pg_constraint,
|
||||
LATERAL (SELECT array_agg(cols.attname) AS cols,
|
||||
array_agg(cols.attnum) AS nums,
|
||||
array_agg(refs.attname) AS refs
|
||||
FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,
|
||||
LATERAL (SELECT * FROM pg_attribute
|
||||
WHERE attrelid = conrelid AND attnum = col)
|
||||
AS cols,
|
||||
LATERAL (SELECT * FROM pg_attribute
|
||||
WHERE attrelid = confrelid AND attnum = ref)
|
||||
AS refs)
|
||||
AS column_info,
|
||||
LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1,
|
||||
LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
|
||||
LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other,
|
||||
LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2
|
||||
WHERE confrelid != 0
|
||||
ORDER BY (conrelid, column_info.nums)
|
||||
|]
|
||||
return $ mapMaybe (relationFromRow tabs cols) rels
|
||||
|
||||
relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation
|
||||
relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =
|
||||
if isJust table && isJust tableF && length cols == length rcs && length colsF == length frcs
|
||||
then Just $ Relation (fromJust table) cols (fromJust tableF) colsF Child Nothing Nothing Nothing
|
||||
else Nothing
|
||||
where
|
||||
findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs
|
||||
findCols s t cs = filter (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col `elem` cs) allCols
|
||||
table = findTable rs rt
|
||||
tableF = findTable frs frt
|
||||
cols = findCols rs rt rcs
|
||||
colsF = findCols frs frt frcs
|
||||
|
||||
allPrimaryKeys :: [Table] -> H.Tx P.Postgres s [PrimaryKey]
|
||||
allPrimaryKeys tabs = do
|
||||
pks <- H.listEx $ [H.stmt|
|
||||
SELECT
|
||||
kc.table_schema,
|
||||
kc.table_name,
|
||||
kc.column_name
|
||||
FROM
|
||||
information_schema.table_constraints tc,
|
||||
information_schema.key_column_usage kc
|
||||
WHERE
|
||||
tc.constraint_type = 'PRIMARY KEY' AND
|
||||
kc.table_name = tc.table_name AND
|
||||
kc.table_schema = tc.table_schema AND
|
||||
kc.constraint_name = tc.constraint_name AND
|
||||
kc.table_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
|]
|
||||
return $ mapMaybe (pkFromRow tabs) pks
|
||||
|
||||
pkFromRow :: [Table] -> (Schema, Text, Text) -> Maybe PrimaryKey
|
||||
pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n
|
||||
where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
|
||||
|
||||
allSynonyms :: [Column] -> H.Tx P.Postgres s [(Column,Column)]
|
||||
allSynonyms allCols = do
|
||||
syns <- H.listEx $ [H.stmt|
|
||||
WITH synonyms AS (
|
||||
SELECT
|
||||
vcu.table_schema AS src_table_schema,
|
||||
vcu.table_name AS src_table_name,
|
||||
vcu.column_name AS src_column_name,
|
||||
view.table_schema AS syn_table_schema,
|
||||
view.table_name AS syn_table_name,
|
||||
view.view_definition AS view_definition
|
||||
FROM
|
||||
information_schema.views AS view,
|
||||
information_schema.view_column_usage AS vcu
|
||||
WHERE
|
||||
view.table_schema = vcu.view_schema AND
|
||||
view.table_name = vcu.view_name AND
|
||||
view.table_schema NOT IN ('pg_catalog', 'information_schema') AND
|
||||
(SELECT COUNT(*) FROM information_schema.view_table_usage WHERE view_schema = view.table_schema AND view_name = view.table_name) = 1
|
||||
)
|
||||
SELECT
|
||||
src_table_schema, src_table_name, src_column_name,
|
||||
syn_table_schema, syn_table_name,
|
||||
(regexp_matches(view_definition, CONCAT('\.(', src_column_name, ')(?=,|$)'), 'gn'))[1]
|
||||
FROM synonyms
|
||||
UNION (
|
||||
SELECT
|
||||
src_table_schema, src_table_name, src_column_name,
|
||||
syn_table_schema, syn_table_name,
|
||||
(regexp_matches(view_definition, CONCAT('\.', src_column_name, '\sAS\s("?)(.+?)\1(,|$)'), 'gn'))[2] /* " <- for syntax highlighting */
|
||||
FROM synonyms
|
||||
)
|
||||
|]
|
||||
return $ mapMaybe (synonymFromRow allCols) syns
|
||||
|
||||
synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column)
|
||||
synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
|
||||
where
|
||||
col1 = findCol s1 t1 c1
|
||||
col2 = findCol s2 t2 c2
|
||||
findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols
|
||||
+21
-40
@@ -1,39 +1,39 @@
|
||||
module Main where
|
||||
|
||||
|
||||
import PostgREST.PgStructure
|
||||
import PostgREST.Types
|
||||
import Network.Wai
|
||||
|
||||
import PostgREST.App
|
||||
import PostgREST.Error (errResponse)
|
||||
import PostgREST.Config (AppConfig (..),
|
||||
minimumPgVersion,
|
||||
prettyVersion,
|
||||
readOptions)
|
||||
import PostgREST.Error (errResponse, PgError)
|
||||
import PostgREST.Middleware
|
||||
import PostgREST.DbStructure
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Aeson (encode)
|
||||
import Data.Functor.Identity
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp hiding (Connection)
|
||||
import Network.Wai.Middleware.RequestLogger (logStdout)
|
||||
|
||||
import System.IO (BufferMode (..),
|
||||
hSetBuffering, stderr,
|
||||
stdin, stdout)
|
||||
|
||||
import PostgREST.Config (AppConfig (..),
|
||||
prettyVersion,
|
||||
readOptions,
|
||||
minimumPgVersion)
|
||||
|
||||
isServerVersionSupported :: H.Session P.Postgres IO Bool
|
||||
isServerVersionSupported = do
|
||||
Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|]
|
||||
Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|]
|
||||
return $ read (cs row) >= minimumPgVersion
|
||||
|
||||
hasqlError :: PgError -> IO a
|
||||
hasqlError = error . cs . encode
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
hSetBuffering stdout LineBuffering
|
||||
@@ -43,55 +43,36 @@ main = do
|
||||
conf <- readOptions
|
||||
let port = configPort conf
|
||||
|
||||
unless (configSecure conf) $
|
||||
putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
|
||||
unless ("secret" /= configJwtSecret conf) $
|
||||
putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
|
||||
Prelude.putStrLn $ "Listening on port " ++
|
||||
(show $ configPort conf :: String)
|
||||
|
||||
let pgSettings = P.ParamSettings (cs $ configDbHost conf)
|
||||
(fromIntegral $ configDbPort conf)
|
||||
(cs $ configDbUser conf)
|
||||
(cs $ configDbPass conf)
|
||||
(cs $ configDbName conf)
|
||||
let pgSettings = P.StringSettings $ cs (configDatabase conf)
|
||||
appSettings = setPort port
|
||||
. setServerName (cs $ "postgrest/" <> prettyVersion)
|
||||
$ defaultSettings
|
||||
middle = logStdout . defaultMiddle (configSecure conf)
|
||||
middle = logStdout . defaultMiddle
|
||||
|
||||
poolSettings <- maybe (fail "Improper session settings") return $
|
||||
H.poolSettings (fromIntegral $ configPool conf) 30
|
||||
pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
|
||||
|
||||
supportedOrError <- H.session pool isServerVersionSupported
|
||||
either (fail . show)
|
||||
either hasqlError
|
||||
(\supported ->
|
||||
unless supported $
|
||||
fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
|
||||
error (
|
||||
"Cannot run in this PostgreSQL version, PostgREST needs at least "
|
||||
<> show minimumPgVersion)
|
||||
) supportedOrError
|
||||
|
||||
let txSettings = Just (H.ReadCommitted, Just True)
|
||||
metadata <- H.session pool $ H.tx txSettings $ do
|
||||
tabs <- allTables
|
||||
rels <- allRelations
|
||||
cols <- allColumns rels
|
||||
keys <- allPrimaryKeys
|
||||
return (tabs, rels, cols, keys)
|
||||
|
||||
dbstructure <- case metadata of
|
||||
Left e -> fail $ show e
|
||||
Right (tabs, rels, cols, keys) ->
|
||||
return DbStructure {
|
||||
tables=tabs
|
||||
, columns=cols
|
||||
, relations=rels
|
||||
, primaryKeys=keys
|
||||
}
|
||||
|
||||
dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf)
|
||||
dbStructure <- either hasqlError return dbOrError
|
||||
|
||||
runSettings appSettings $ middle $ \ req respond -> do
|
||||
body <- strictRequestBody req
|
||||
resOrError <- liftIO $ H.session pool $ H.tx txSettings $
|
||||
authenticated conf (app dbstructure conf body) req
|
||||
runWithClaims conf (app dbStructure conf body) req
|
||||
either (respond . errResponse) respond resOrError
|
||||
|
||||
+41
-74
@@ -4,91 +4,57 @@
|
||||
module PostgREST.Middleware where
|
||||
|
||||
import Data.Maybe (fromMaybe, isNothing)
|
||||
import Data.Monoid
|
||||
import Data.Text
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
|
||||
import Network.HTTP.Types (RequestHeaders)
|
||||
import Network.HTTP.Types.Header (hAccept, hAuthorization,
|
||||
hLocation)
|
||||
import Network.HTTP.Types.Status (status301, status400, status401,
|
||||
status415)
|
||||
import Network.URI (URI (..), parseURI)
|
||||
import Network.Wai (Application, Request (..),
|
||||
Response, isSecure, rawPathInfo,
|
||||
rawQueryString, requestHeaders,
|
||||
responseLBS)
|
||||
import Network.HTTP.Types.Header (hAccept, hAuthorization)
|
||||
import Network.HTTP.Types.Status (status415, status400)
|
||||
import Network.Wai (Application, Request (..), Response,
|
||||
requestHeaders, responseLBS)
|
||||
import Network.Wai.Middleware.Cors (cors)
|
||||
import Network.Wai.Middleware.Gzip (def, gzip)
|
||||
import Network.Wai.Middleware.Static (only, staticPolicy)
|
||||
|
||||
import Codec.Binary.Base64.String (decode)
|
||||
import PostgREST.App (contentTypeForAccept)
|
||||
import PostgREST.Auth (DbRole, LoginAttempt (..),
|
||||
setRole, setUserId, signInRole,
|
||||
signInWithJWT)
|
||||
import PostgREST.Auth (setRole, jwtClaims, claimsToSQL)
|
||||
import PostgREST.Config (AppConfig (..), corsPolicy)
|
||||
|
||||
import Prelude
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
authenticated :: forall s. AppConfig ->
|
||||
(DbRole -> Request -> H.Tx P.Postgres s Response) ->
|
||||
import Prelude hiding(concat)
|
||||
|
||||
import qualified Data.Vector as V
|
||||
import qualified Hasql.Backend as B
|
||||
import qualified Data.Map.Lazy as M
|
||||
|
||||
runWithClaims :: forall s. AppConfig ->
|
||||
(Request -> H.Tx P.Postgres s Response) ->
|
||||
Request -> H.Tx P.Postgres s Response
|
||||
authenticated conf app req = do
|
||||
attempt <- httpRequesterRole (requestHeaders req)
|
||||
case attempt of
|
||||
MalformedAuth ->
|
||||
return $ responseLBS status400 [] "Malformed basic auth header"
|
||||
LoginFailed ->
|
||||
return $ responseLBS status401 [] "Invalid username or password"
|
||||
LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app currentRole req
|
||||
NoCredentials -> if anon /= currentRole then runInRole anon "" else app currentRole req
|
||||
|
||||
where
|
||||
jwtSecret = cs $ configJwtSecret conf
|
||||
currentRole = cs $ configDbUser conf
|
||||
anon = cs $ configAnonRole conf
|
||||
httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
|
||||
httpRequesterRole hdrs = do
|
||||
let auth = fromMaybe "" $ lookup hAuthorization hdrs
|
||||
case split (==' ') (cs auth) of
|
||||
("Basic" : b64 : _) ->
|
||||
case split (==':') (cs . decode . cs $ b64) of
|
||||
(u:p:_) -> signInRole u p
|
||||
_ -> return MalformedAuth
|
||||
("Bearer" : jwt : _) ->
|
||||
return $ signInWithJWT jwtSecret jwt
|
||||
_ -> return NoCredentials
|
||||
|
||||
runInRole :: Text -> Text -> H.Tx P.Postgres s Response
|
||||
runInRole r uid = do
|
||||
setUserId uid
|
||||
setRole r
|
||||
app r req
|
||||
|
||||
|
||||
redirectInsecure :: Application -> Application
|
||||
redirectInsecure app req respond = do
|
||||
let hdrs = requestHeaders req
|
||||
host = lookup "host" hdrs
|
||||
uriM = parseURI . cs =<< mconcat [
|
||||
Just "https://",
|
||||
host,
|
||||
Just $ rawPathInfo req,
|
||||
Just $ rawQueryString req]
|
||||
isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
|
||||
|
||||
if not (isSecure req || isHerokuSecure)
|
||||
then case uriM of
|
||||
Just uri ->
|
||||
respond $ responseLBS status301 [
|
||||
(hLocation, cs . show $ uri { uriScheme = "https:" })
|
||||
] ""
|
||||
Nothing ->
|
||||
respond $ responseLBS status400 [] "SSL is required"
|
||||
else app req respond
|
||||
runWithClaims conf app req = do
|
||||
_ <- H.unitEx $ stmt setAnon
|
||||
let time = unsafePerformIO getPOSIXTime
|
||||
case split (== ' ') (cs auth) of
|
||||
("Bearer" : tokenStr : _) ->
|
||||
case jwtClaims jwtSecret tokenStr time of
|
||||
Just claims ->
|
||||
if M.member "role" claims
|
||||
then do
|
||||
mapM_ H.unitEx $ stmt <$> claimsToSQL claims
|
||||
app req
|
||||
else invalidJWT
|
||||
_ -> invalidJWT
|
||||
_ -> app req
|
||||
where
|
||||
stmt c = B.Stmt c V.empty True
|
||||
hdrs = requestHeaders req
|
||||
jwtSecret = (cs $ configJwtSecret conf) :: Text
|
||||
auth = fromMaybe "" $ lookup hAuthorization hdrs
|
||||
anon = cs $ configAnonRole conf
|
||||
setAnon = setRole anon
|
||||
invalidJWT = return $ responseLBS status400 [("Content-Type","application/json")] "{\"message\":\"Invalid JWT\"}"
|
||||
|
||||
unsupportedAccept :: Application -> Application
|
||||
unsupportedAccept app req respond = do
|
||||
@@ -98,8 +64,9 @@ unsupportedAccept app req respond = do
|
||||
then respond $ responseLBS status415 [] "Unsupported Accept header, try: application/json"
|
||||
else app req respond
|
||||
|
||||
defaultMiddle :: Bool -> Application -> Application
|
||||
defaultMiddle secure = (if secure then redirectInsecure else id)
|
||||
. gzip def . cors corsPolicy
|
||||
defaultMiddle :: Application -> Application
|
||||
defaultMiddle =
|
||||
gzip def
|
||||
. cors corsPolicy
|
||||
. staticPolicy (only [("favicon.ico", "static/favicon.ico")])
|
||||
. unsupportedAccept
|
||||
|
||||
+12
-64
@@ -1,48 +1,27 @@
|
||||
module PostgREST.Parsers
|
||||
( parseGetRequest
|
||||
)
|
||||
-- ( parseGetRequest
|
||||
-- )
|
||||
where
|
||||
|
||||
import Control.Applicative hiding ((<$>))
|
||||
--lines needed for ghc 7.8
|
||||
import Data.Functor ((<$>))
|
||||
import Data.Traversable (traverse)
|
||||
|
||||
import Control.Monad (join)
|
||||
import Data.List (delete, find)
|
||||
import Data.Maybe
|
||||
import Data.Monoid
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
import Data.Tree
|
||||
import Network.Wai (Request, pathInfo, queryString)
|
||||
import PostgREST.Types
|
||||
import Text.ParserCombinators.Parsec hiding (many, (<|>))
|
||||
|
||||
parseGetRequest :: Request -> Either ParseError ApiRequest
|
||||
parseGetRequest httpRequest =
|
||||
foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
|
||||
where
|
||||
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
|
||||
addOrder (Node r f) o = Node r{order=o} f
|
||||
flts = mapM pRequestFilter whereFilters
|
||||
rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
|
||||
qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
|
||||
orderStr = join $ lookup "order" qString
|
||||
ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr
|
||||
selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to *
|
||||
whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ]
|
||||
import PostgREST.PgQuery (operators)
|
||||
|
||||
pRequestSelect :: Text -> Parser ApiRequest
|
||||
pRequestSelect rootNodeName = do
|
||||
fieldTree <- pFieldForest
|
||||
return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree
|
||||
return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
|
||||
where
|
||||
treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest
|
||||
treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) =
|
||||
treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
|
||||
case fldForest of
|
||||
[] -> Node (rNode {fields=fld:fields rNode}) rForest
|
||||
_ -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest)
|
||||
[] -> Node (q {select=fld:select q}, i) rForest
|
||||
_ -> Node (q, i) (foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing)) []) fldForest:rForest)
|
||||
|
||||
pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
|
||||
pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
|
||||
@@ -54,21 +33,6 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
|
||||
op = fst <$> opVal
|
||||
val = snd <$> opVal
|
||||
|
||||
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
|
||||
addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest
|
||||
addFilter (path, flt) (Node rn forest) =
|
||||
case targetNode of
|
||||
Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
|
||||
Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
|
||||
where
|
||||
targetNodeName:remainingPath = path
|
||||
(targetNode,restForest) = splitForest targetNodeName forest
|
||||
splitForest name forst =
|
||||
case maybeNode of
|
||||
Nothing -> (Nothing,forest)
|
||||
Just node -> (Just node, delete node forest)
|
||||
where maybeNode = find ((name==).mainTable.rootLabel) forst
|
||||
|
||||
ws :: Parser Text
|
||||
ws = cs <$> many (oneOf " \t")
|
||||
|
||||
@@ -82,22 +46,20 @@ pTreePath = do
|
||||
let pp = map cs p
|
||||
jpp = map cs <$> jp
|
||||
return (init pp, (last pp, jpp))
|
||||
where
|
||||
|
||||
|
||||
pFieldForest :: Parser [Tree SelectItem]
|
||||
pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
|
||||
|
||||
pFieldTree :: Parser (Tree SelectItem)
|
||||
pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')'))
|
||||
<|> Node <$> pSelect <*> pure []
|
||||
pFieldTree = try (Node <$> pSelect <*> between (char '(') (char ')') pFieldForest)
|
||||
<|> Node <$> pSelect <*> pure []
|
||||
|
||||
pStar :: Parser Text
|
||||
pStar = cs <$> (string "*" *> pure ("*"::String))
|
||||
|
||||
pFieldName :: Parser Text
|
||||
pFieldName = cs <$> (many1 (letter <|> digit <|> oneOf "_")
|
||||
<?> "field name (* or [a..z0..9_])")
|
||||
<?> "field name (* or [a..z0..9_])")
|
||||
|
||||
pJsonPathStep :: Parser Text
|
||||
pJsonPathStep = cs <$> try (string "->" *> pFieldName)
|
||||
@@ -116,22 +78,8 @@ pSelect = lexeme $
|
||||
return ((s, Nothing), Nothing)
|
||||
|
||||
pOperator :: Parser Operator
|
||||
pOperator = cs <$> ( try (string "lte") -- has to be before lt
|
||||
<|> try (string "lt")
|
||||
<|> try (string "eq")
|
||||
<|> try (string "gte") -- has to be before gh
|
||||
<|> try (string "gt")
|
||||
<|> try (string "lt")
|
||||
<|> try (string "neq")
|
||||
<|> try (string "like")
|
||||
<|> try (string "ilike")
|
||||
<|> try (string "in")
|
||||
<|> try (string "notin")
|
||||
<|> try (string "is" )
|
||||
<|> try (string "isnot")
|
||||
<|> try (string "@@")
|
||||
<?> "operator (eq, gt, ...)"
|
||||
)
|
||||
pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")
|
||||
where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators
|
||||
|
||||
pValue :: Parser FValue
|
||||
pValue = VText <$> (cs <$> many anyChar)
|
||||
|
||||
+233
-230
@@ -3,14 +3,48 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module PostgREST.PgQuery where
|
||||
module PostgREST.PgQuery (
|
||||
fromQi
|
||||
, insertableValue
|
||||
, wrapQuery
|
||||
, asJson
|
||||
, callProc
|
||||
, unquoted
|
||||
, operators
|
||||
|
||||
-- format functions
|
||||
, pgFmtLit
|
||||
, pgFmtIdent
|
||||
, pgFmtValue
|
||||
, pgFmtCondition
|
||||
, pgFmtColumn
|
||||
, pgFmtJsonPath
|
||||
, pgFmtTable
|
||||
, pgFmtField
|
||||
, pgFmtSelectItem
|
||||
, pgFmtAsJsonPath
|
||||
|
||||
-- query fragments
|
||||
, sourceSubqueryName
|
||||
, orderF
|
||||
, countNoneF
|
||||
, countAllF
|
||||
, countF
|
||||
, locationF
|
||||
, asCsvF
|
||||
, asJsonSingleF
|
||||
, asJsonF
|
||||
, selectStarF
|
||||
|
||||
, StatementT
|
||||
) where
|
||||
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Backend as B
|
||||
import qualified Hasql.Postgres as P
|
||||
import PostgREST.RangeQuery
|
||||
import PostgREST.Types (OrderTerm (..), QualifiedIdentifier(..))
|
||||
import PostgREST.Types
|
||||
|
||||
import Control.Monad (join)
|
||||
import qualified Data.Aeson as JSON
|
||||
@@ -25,11 +59,10 @@ import Data.Scientific (FPFormat (..), formatScientific,
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as T
|
||||
import Data.Vector (empty)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Network.HTTP.Types.URI as Net
|
||||
import Text.Regex.TDFA ((=~))
|
||||
|
||||
import Prelude
|
||||
import qualified Data.Map as M
|
||||
|
||||
type PStmt = H.Stmt P.Postgres
|
||||
instance Monoid PStmt where
|
||||
@@ -37,81 +70,35 @@ instance Monoid PStmt where
|
||||
B.Stmt (query <> query') (params <> params') (prep && prep')
|
||||
mempty = B.Stmt "" empty True
|
||||
type StatementT = PStmt -> PStmt
|
||||
data JsonbPath =
|
||||
ColIdentifier T.Text
|
||||
| KeyIdentifier T.Text
|
||||
| SingleArrow JsonbPath JsonbPath
|
||||
| DoubleArrow JsonbPath JsonbPath
|
||||
deriving (Show)
|
||||
|
||||
|
||||
limitT :: Maybe NonnegRange -> StatementT
|
||||
limitT r q =
|
||||
q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
|
||||
where
|
||||
limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
|
||||
offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
|
||||
operators :: [(T.Text, T.Text)]
|
||||
operators = [
|
||||
("eq", "="),
|
||||
("gte", ">="), -- has to be before gt (parsers)
|
||||
("gt", ">"),
|
||||
("lte", "<="), -- has to be before lt (parsers)
|
||||
("lt", "<"),
|
||||
("neq", "<>"),
|
||||
("like", "like"),
|
||||
("ilike", "ilike"),
|
||||
("in", "in"),
|
||||
("notin", "not in"),
|
||||
("isnot", "is not"), -- has to be before is (parsers)
|
||||
("is", "is"),
|
||||
("@@", "@@"),
|
||||
("@>", "@>"),
|
||||
("<@", "<@")
|
||||
]
|
||||
|
||||
whereT :: QualifiedIdentifier -> Net.Query -> StatementT
|
||||
whereT table params q =
|
||||
if L.null cols
|
||||
then q
|
||||
else q <> B.Stmt " where " empty True <> conjunction
|
||||
where
|
||||
cols = [ col | col <- params, fst col `notElem` ["order","select"] ]
|
||||
wherePredTable = wherePred table
|
||||
conjunction = mconcat $ L.intersperse andq (map wherePredTable cols)
|
||||
|
||||
withT :: PStmt -> T.Text -> StatementT
|
||||
withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
|
||||
B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq <> " from " <> v)
|
||||
(ep <> wp)
|
||||
(epre && wpre)
|
||||
|
||||
orderT :: [OrderTerm] -> StatementT
|
||||
orderT ts q =
|
||||
if L.null ts
|
||||
then q
|
||||
else q <> B.Stmt " order by " empty True <> clause
|
||||
where
|
||||
clause = mconcat $ L.intersperse commaq (map queryTerm ts)
|
||||
queryTerm :: OrderTerm -> PStmt
|
||||
queryTerm t = B.Stmt
|
||||
(" " <> cs (pgFmtIdent $ otTerm t) <> " "
|
||||
<> cs (otDirection t) <> " "
|
||||
<> maybe "" cs (otNullOrder t) <> " ")
|
||||
empty True
|
||||
|
||||
parentheticT :: StatementT
|
||||
parentheticT s =
|
||||
s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
|
||||
|
||||
iffNotT :: PStmt -> StatementT
|
||||
iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
|
||||
B.Stmt
|
||||
("WITH aaa AS (" <> aq <> " returning *) " <>
|
||||
bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
|
||||
(ap <> bp)
|
||||
(apre && bpre)
|
||||
|
||||
countT :: StatementT
|
||||
countT s =
|
||||
s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT pg_catalog.count(1) FROM qqq" }
|
||||
|
||||
countRows :: QualifiedIdentifier -> PStmt
|
||||
countRows t = B.Stmt ("select pg_catalog.count(1) from " <> fromQi t) empty True
|
||||
|
||||
countNone :: PStmt
|
||||
countNone = B.Stmt "select null" empty True
|
||||
|
||||
asCsvWithCount :: QualifiedIdentifier -> StatementT
|
||||
asCsvWithCount table = withCount . asCsv table
|
||||
|
||||
asCsv :: QualifiedIdentifier -> StatementT
|
||||
asCsv table s = s {
|
||||
B.stmtTemplate =
|
||||
"(select string_agg(quote_ident(column_name::text), ',') from "
|
||||
<> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '"
|
||||
<> fromQi table <> "' order by ordinal_position) h) || '\r' || "
|
||||
<> "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '') from ("
|
||||
<> B.stmtTemplate s <> ") t" }
|
||||
|
||||
asJsonWithCount :: StatementT
|
||||
asJsonWithCount = withCount . asJson
|
||||
operatorsMap :: M.Map T.Text T.Text
|
||||
operatorsMap = M.fromList operators
|
||||
|
||||
asJson :: StatementT
|
||||
asJson s = s {
|
||||
@@ -119,56 +106,6 @@ asJson s = s {
|
||||
"array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from ("
|
||||
<> B.stmtTemplate s <> ") t" }
|
||||
|
||||
withCount :: StatementT
|
||||
withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s }
|
||||
|
||||
asJsonRow :: StatementT
|
||||
asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
|
||||
|
||||
returningStarT :: StatementT
|
||||
returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
|
||||
|
||||
deleteFrom :: QualifiedIdentifier -> PStmt
|
||||
deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True
|
||||
|
||||
insertInto :: QualifiedIdentifier
|
||||
-> V.Vector T.Text
|
||||
-> V.Vector (V.Vector JSON.Value)
|
||||
-> PStmt
|
||||
insertInto t cols vals
|
||||
| V.null cols = B.Stmt ("insert into " <> fromQi t <> " default values returning *") empty True
|
||||
| otherwise = B.Stmt
|
||||
("insert into " <> fromQi t <> " (" <>
|
||||
T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>
|
||||
") values "
|
||||
<> T.intercalate ", "
|
||||
(V.toList $ V.map (\v -> "("
|
||||
<> T.intercalate ", " (V.toList $ V.map insertableValue v)
|
||||
<> ")"
|
||||
) vals
|
||||
)
|
||||
<> " returning row_to_json(" <> fromQi t <> ".*)")
|
||||
empty True
|
||||
|
||||
insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
insertSelect t [] _ = B.Stmt
|
||||
("insert into " <> fromQi t <> " default values returning *") empty True
|
||||
insertSelect t cols vals = B.Stmt
|
||||
("insert into " <> fromQi t <> " ("
|
||||
<> T.intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") select "
|
||||
<> T.intercalate ", " (map insertableValue vals))
|
||||
empty True
|
||||
|
||||
update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
update t cols vals = B.Stmt
|
||||
("update " <> fromQi t <> " set ("
|
||||
<> T.intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") = ("
|
||||
<> T.intercalate ", " (map insertableValue vals)
|
||||
<> ")")
|
||||
empty True
|
||||
|
||||
callProc :: QualifiedIdentifier -> JSON.Object -> PStmt
|
||||
callProc qi params = do
|
||||
let args = T.intercalate "," $ map assignment (H.toList params)
|
||||
@@ -176,116 +113,19 @@ callProc qi params = do
|
||||
where
|
||||
assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
|
||||
|
||||
wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
|
||||
wherePred table (col, predicate) =
|
||||
B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
|
||||
if opCode `elem` ["is","isnot"] then whiteList value
|
||||
else cs sqlValue)
|
||||
empty True
|
||||
|
||||
where
|
||||
headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
|
||||
hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
|
||||
opCode = hasNot (head rest) headPredicate
|
||||
notOp = hasNot headPredicate ""
|
||||
value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
|
||||
sqlValue = pgFmtValue opCode value
|
||||
op = pgFmtOperator opCode
|
||||
|
||||
|
||||
whiteList :: T.Text -> T.Text
|
||||
whiteList val = fromMaybe
|
||||
(cs (pgFmtLit val) <> "::unknown ")
|
||||
(L.find ((==) . T.toLower $ val) ["null","true","false"])
|
||||
|
||||
pgFmtValue :: T.Text -> T.Text -> T.Text
|
||||
pgFmtValue opCode value =
|
||||
case opCode of
|
||||
"like" -> unknownLiteral $ T.map star value
|
||||
"ilike" -> unknownLiteral $ T.map star value
|
||||
"in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
||||
"notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
||||
"@@" -> "to_tsquery(" <> unknownLiteral value <> ") "
|
||||
_ -> unknownLiteral value
|
||||
where
|
||||
star c = if c == '*' then '%' else c
|
||||
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
||||
|
||||
pgFmtOperator :: T.Text -> T.Text
|
||||
pgFmtOperator opCode =
|
||||
case opCode of
|
||||
"eq" -> "="
|
||||
"gt" -> ">"
|
||||
"lt" -> "<"
|
||||
"gte" -> ">="
|
||||
"lte" -> "<="
|
||||
"neq" -> "<>"
|
||||
"like"-> "like"
|
||||
"ilike"-> "ilike"
|
||||
"in" -> "in"
|
||||
"notin" -> "not in"
|
||||
"is" -> "is"
|
||||
"isnot" -> "is not"
|
||||
"@@" -> "@@"
|
||||
_ -> "="
|
||||
|
||||
commaq :: PStmt
|
||||
commaq = B.Stmt ", " empty True
|
||||
|
||||
andq :: PStmt
|
||||
andq = B.Stmt " and " empty True
|
||||
|
||||
data JsonbPath =
|
||||
ColIdentifier T.Text
|
||||
| KeyIdentifier T.Text
|
||||
| SingleArrow JsonbPath JsonbPath
|
||||
| DoubleArrow JsonbPath JsonbPath
|
||||
deriving (Show)
|
||||
|
||||
parseJsonbPath :: T.Text -> Maybe JsonbPath
|
||||
parseJsonbPath p =
|
||||
case T.splitOn "->>" p of
|
||||
[a,b] ->
|
||||
let i:is = T.splitOn "->" a in
|
||||
Just $ DoubleArrow
|
||||
(foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))
|
||||
(KeyIdentifier b)
|
||||
_ -> Nothing
|
||||
|
||||
pgFmtJsonbPath :: QualifiedIdentifier -> T.Text -> T.Text
|
||||
pgFmtJsonbPath table p =
|
||||
pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)
|
||||
where
|
||||
pgFmtJsonbPath' (ColIdentifier i) = fromQi table <> "." <> pgFmtIdent i
|
||||
pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i
|
||||
pgFmtJsonbPath' (SingleArrow a b) =
|
||||
pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b
|
||||
pgFmtJsonbPath' (DoubleArrow a b) =
|
||||
pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b
|
||||
|
||||
pgFmtIdent :: T.Text -> T.Text
|
||||
pgFmtIdent x =
|
||||
let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in
|
||||
if (cs escaped :: BS.ByteString) =~ danger
|
||||
then "\"" <> escaped <> "\""
|
||||
else escaped
|
||||
|
||||
where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString
|
||||
|
||||
pgFmtLit :: T.Text -> T.Text
|
||||
pgFmtLit x =
|
||||
let trimmed = trimNullChars x
|
||||
escaped = "'" <> T.replace "'" "''" trimmed <> "'"
|
||||
slashed = T.replace "\\" "\\\\" escaped in
|
||||
if T.isInfixOf "\\\\" escaped
|
||||
then "E" <> slashed
|
||||
else slashed
|
||||
|
||||
trimNullChars :: T.Text -> T.Text
|
||||
trimNullChars = T.takeWhile (/= '\x0')
|
||||
|
||||
fromQi :: QualifiedIdentifier -> T.Text
|
||||
fromQi t = pgFmtIdent (qiSchema t) <> "." <> pgFmtIdent (qiName t)
|
||||
fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
|
||||
where
|
||||
n = qiName t
|
||||
s = qiSchema t
|
||||
|
||||
unquoted :: JSON.Value -> T.Text
|
||||
unquoted (JSON.String t) = t
|
||||
@@ -301,6 +141,169 @@ insertableValue :: JSON.Value -> T.Text
|
||||
insertableValue JSON.Null = "null"
|
||||
insertableValue v = insertableText $ unquoted v
|
||||
|
||||
paramFilter :: JSON.Value -> T.Text
|
||||
paramFilter JSON.Null = "is.null"
|
||||
paramFilter v = "eq." <> unquoted v
|
||||
wrapQuery :: T.Text -> [T.Text] -> T.Text -> Maybe NonnegRange -> T.Text
|
||||
wrapQuery source selectColumns returnSelect range =
|
||||
withSourceF source <>
|
||||
" SELECT " <>
|
||||
T.intercalate ", " selectColumns <>
|
||||
" " <>
|
||||
fromF returnSelect ( limitF range )
|
||||
|
||||
|
||||
-- query fragments
|
||||
sourceSubqueryName :: T.Text
|
||||
sourceSubqueryName = "pg_source"
|
||||
|
||||
withSourceF :: T.Text -> T.Text
|
||||
withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")"
|
||||
|
||||
countF :: T.Text
|
||||
countF = "pg_catalog.count(t)"
|
||||
|
||||
countAllF :: T.Text
|
||||
countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )"
|
||||
|
||||
countNoneF :: T.Text
|
||||
countNoneF = "null"
|
||||
|
||||
asJsonF :: T.Text
|
||||
asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying"
|
||||
|
||||
asJsonSingleF :: T.Text --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
|
||||
asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying "
|
||||
|
||||
asCsvF :: T.Text
|
||||
asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
|
||||
|
||||
asCsvHeaderF :: T.Text
|
||||
asCsvHeaderF =
|
||||
"(SELECT string_agg(a.k, ',')" <>
|
||||
" FROM (" <>
|
||||
" SELECT json_object_keys(r)::TEXT as k" <>
|
||||
" FROM ( " <>
|
||||
" SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <>
|
||||
" ) s" <>
|
||||
" ) a" <>
|
||||
")"
|
||||
|
||||
asCsvBodyF :: T.Text
|
||||
asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')"
|
||||
|
||||
selectStarF :: T.Text
|
||||
selectStarF = "SELECT * FROM " <> sourceSubqueryName
|
||||
|
||||
fromF :: T.Text -> T.Text -> T.Text
|
||||
fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t"
|
||||
|
||||
limitF :: Maybe NonnegRange -> T.Text
|
||||
limitF r = "LIMIT " <> limit <> " OFFSET " <> offset
|
||||
where
|
||||
limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
|
||||
offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
|
||||
|
||||
locationF :: [T.Text] -> T.Text
|
||||
locationF pKeys =
|
||||
"(" <>
|
||||
" WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss limit 1)" <>
|
||||
" SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <>
|
||||
" FROM s, json_each_text(s.r) AS json_data" <>
|
||||
(
|
||||
if null pKeys
|
||||
then ""
|
||||
else " WHERE json_data.key IN ('" <> T.intercalate "','" pKeys <> "')"
|
||||
) <>
|
||||
")"
|
||||
|
||||
orderF :: [OrderTerm] -> T.Text
|
||||
orderF ts =
|
||||
if L.null ts
|
||||
then ""
|
||||
else "ORDER BY " <> clause
|
||||
where
|
||||
clause = T.intercalate "," (map queryTerm ts)
|
||||
queryTerm :: OrderTerm -> T.Text
|
||||
queryTerm t = " "
|
||||
<> cs (pgFmtIdent $ otTerm t) <> " "
|
||||
<> cs (otDirection t) <> " "
|
||||
<> maybe "" cs (otNullOrder t) <> " "
|
||||
|
||||
-- formating functions
|
||||
|
||||
pgFmtValue :: T.Text -> T.Text -> T.Text
|
||||
pgFmtValue opCode val =
|
||||
case opCode of
|
||||
"like" -> unknownLiteral $ T.map star val
|
||||
"ilike" -> unknownLiteral $ T.map star val
|
||||
"in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") "
|
||||
"notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") "
|
||||
"@@" -> "to_tsquery(" <> unknownLiteral val <> ") "
|
||||
_ -> unknownLiteral val
|
||||
where
|
||||
star c = if c == '*' then '%' else c
|
||||
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
||||
|
||||
pgFmtOperator :: T.Text -> T.Text
|
||||
pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operatorsMap
|
||||
|
||||
pgFmtIdent :: T.Text -> T.Text
|
||||
pgFmtIdent x =
|
||||
let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in
|
||||
if (cs escaped :: BS.ByteString) =~ danger
|
||||
then "\"" <> escaped <> "\""
|
||||
else escaped
|
||||
|
||||
where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString
|
||||
|
||||
pgFmtLit :: T.Text -> T.Text
|
||||
pgFmtLit x =
|
||||
let trimmed = trimNullChars x
|
||||
escaped = "'" <> T.replace "'" "''" trimmed <> "'"
|
||||
slashed = T.replace "\\" "\\\\" escaped in
|
||||
if T.isInfixOf "\\\\" escaped
|
||||
then "E" <> slashed
|
||||
else slashed
|
||||
|
||||
pgFmtCondition :: QualifiedIdentifier -> Filter -> T.Text
|
||||
pgFmtCondition table (Filter (col,jp) ops val) =
|
||||
notOp <> " " <> sqlCol <> " " <> pgFmtOperator opCode <> " " <>
|
||||
if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue
|
||||
where
|
||||
headPredicate:rest = T.split (=='.') ops
|
||||
hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
|
||||
opCode = hasNot (head rest) headPredicate
|
||||
notOp = hasNot headPredicate ""
|
||||
sqlCol = case val of
|
||||
VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp
|
||||
VForeignKey qi _ -> pgFmtColumn qi col
|
||||
sqlValue = valToStr val
|
||||
getInner v = case v of
|
||||
VText s -> s
|
||||
_ -> ""
|
||||
valToStr v = case v of
|
||||
VText s -> pgFmtValue opCode s
|
||||
VForeignKey (QualifiedIdentifier s _) (ForeignKey Column{colTable=Table{tableName=ft}, colName=fc}) -> pgFmtColumn qi fc
|
||||
where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft
|
||||
_ -> ""
|
||||
|
||||
pgFmtColumn :: QualifiedIdentifier -> T.Text -> T.Text
|
||||
pgFmtColumn table "*" = fromQi table <> ".*"
|
||||
pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
|
||||
|
||||
pgFmtJsonPath :: Maybe JsonPath -> T.Text
|
||||
pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
|
||||
pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
|
||||
pgFmtJsonPath _ = ""
|
||||
|
||||
pgFmtTable :: Table -> T.Text
|
||||
pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n
|
||||
|
||||
pgFmtField :: QualifiedIdentifier -> Field -> T.Text
|
||||
pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
|
||||
|
||||
pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> T.Text
|
||||
pgFmtSelectItem table (f@(_, jp), Nothing) = pgFmtField table f <> pgFmtAsJsonPath jp
|
||||
pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp
|
||||
|
||||
pgFmtAsJsonPath :: Maybe JsonPath -> T.Text
|
||||
pgFmtAsJsonPath Nothing = ""
|
||||
pgFmtAsJsonPath (Just xx) = " AS " <> last xx
|
||||
|
||||
@@ -1,264 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
module PostgREST.PgStructure where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad (join)
|
||||
import Data.Functor.Identity
|
||||
import Data.List (elemIndex, find)
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Monoid
|
||||
import Data.Text (Text, split)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import PostgREST.PgQuery ()
|
||||
import PostgREST.Types
|
||||
|
||||
import GHC.Exts (groupWith)
|
||||
import Prelude
|
||||
|
||||
|
||||
doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
|
||||
doesProcExist schema proc = do
|
||||
row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt|
|
||||
SELECT 1
|
||||
FROM pg_catalog.pg_namespace n
|
||||
JOIN pg_catalog.pg_proc p
|
||||
ON pronamespace = n.oid
|
||||
WHERE nspname = ?
|
||||
AND proname = ?
|
||||
|] schema proc
|
||||
return $ isJust row
|
||||
|
||||
|
||||
tableFromRow :: (Text, Text, Bool, Maybe Text) -> Table
|
||||
tableFromRow (s, n, i, a) = Table s n i (parseAcl a)
|
||||
where
|
||||
parseAcl :: Maybe Text -> [Text]
|
||||
parseAcl str = fromMaybe [] $ split (==',') <$> str
|
||||
|
||||
columnFromRow :: (Text, Text, Text,
|
||||
Int, Bool, Text,
|
||||
Bool, Maybe Int, Maybe Int,
|
||||
Maybe Text, Maybe Text)
|
||||
-> Column
|
||||
columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
|
||||
Column s t n pos nul typ u l p d (parseEnum e) Nothing
|
||||
|
||||
where
|
||||
parseEnum :: Maybe Text -> [Text]
|
||||
parseEnum str = fromMaybe [] $ split (==',') <$> str
|
||||
|
||||
|
||||
relationFromRow :: (Text, Text, [Text], Text, [Text]) -> Relation
|
||||
relationFromRow (s, t, cs, ft, fcs) = Relation s t cs ft fcs Child Nothing Nothing Nothing
|
||||
|
||||
pkFromRow :: (Text, Text, Text) -> PrimaryKey
|
||||
pkFromRow (s, t, n) = PrimaryKey s t n
|
||||
|
||||
|
||||
addParentRelation :: Relation -> [Relation] -> [Relation]
|
||||
addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c Parent Nothing Nothing Nothing:rel:rels
|
||||
|
||||
allTables :: H.Tx P.Postgres s [Table]
|
||||
allTables = do
|
||||
rows <- H.listEx $ [H.stmt|
|
||||
SELECT
|
||||
n.nspname AS table_schema,
|
||||
c.relname AS table_name,
|
||||
c.relkind = 'r' OR (c.relkind IN ('v','f'))
|
||||
AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8
|
||||
OR (EXISTS
|
||||
( SELECT 1
|
||||
FROM pg_trigger
|
||||
WHERE pg_trigger.tgrelid = c.oid
|
||||
AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable,
|
||||
array_to_string(array_agg(r.rolname), ',') AS acl
|
||||
FROM pg_class c
|
||||
CROSS JOIN pg_roles r
|
||||
JOIN pg_namespace n ON n.oid = c.relnamespace
|
||||
WHERE c.relkind IN ('v','r','m')
|
||||
AND n.nspname NOT IN ('pg_catalog', 'information_schema')
|
||||
AND (
|
||||
pg_has_role(r.rolname, c.relowner, 'USAGE'::text) OR
|
||||
has_table_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR
|
||||
has_any_column_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) )
|
||||
|
||||
GROUP BY table_schema, table_name, insertable
|
||||
ORDER BY table_schema, table_name
|
||||
|]
|
||||
return $ map tableFromRow rows
|
||||
|
||||
allRelations :: H.Tx P.Postgres s [Relation]
|
||||
allRelations = do
|
||||
rels <- H.listEx $ [H.stmt|
|
||||
WITH table_fk AS (
|
||||
SELECT ns.nspname AS table_schema,
|
||||
tab.relname AS table_name,
|
||||
column_info.cols AS columns,
|
||||
other.relname AS foreign_table_name,
|
||||
column_info.refs AS foreign_columns
|
||||
FROM pg_constraint,
|
||||
LATERAL (SELECT array_agg(cols.attname) AS cols,
|
||||
array_agg(cols.attnum) AS nums,
|
||||
array_agg(refs.attname) AS refs
|
||||
FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,
|
||||
LATERAL (SELECT * FROM pg_attribute
|
||||
WHERE attrelid = conrelid AND attnum = col)
|
||||
AS cols,
|
||||
LATERAL (SELECT * FROM pg_attribute
|
||||
WHERE attrelid = confrelid AND attnum = ref)
|
||||
AS refs)
|
||||
AS column_info,
|
||||
LATERAL (SELECT * FROM pg_namespace
|
||||
WHERE pg_namespace.oid = connamespace) AS ns,
|
||||
LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
|
||||
LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other
|
||||
WHERE confrelid != 0
|
||||
ORDER BY (conrelid, column_info.nums)
|
||||
)
|
||||
|
||||
SELECT * FROM table_fk
|
||||
UNION
|
||||
(
|
||||
SELECT
|
||||
vcu.table_schema,
|
||||
vcu.view_name AS table_name,
|
||||
array_agg(vcu.column_name::text) AS columns,
|
||||
table_fk.foreign_table_name,
|
||||
table_fk.foreign_columns
|
||||
FROM information_schema.view_column_usage as vcu
|
||||
JOIN table_fk ON
|
||||
table_fk.table_schema = vcu.view_schema AND
|
||||
table_fk.table_name = vcu.table_name AND
|
||||
vcu.column_name = ANY (table_fk.columns)
|
||||
WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
AND columns = table_fk.columns
|
||||
GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_name, table_fk.foreign_columns
|
||||
)
|
||||
UNION
|
||||
(
|
||||
SELECT
|
||||
vcu.view_schema as table_schema,
|
||||
table_fk.table_name,
|
||||
table_fk.columns,
|
||||
vcu.view_name as foreign_table_name,
|
||||
array_agg(vcu.column_name::text) as foreign_columns
|
||||
FROM information_schema.view_column_usage as vcu
|
||||
JOIN table_fk ON
|
||||
table_fk.table_schema = vcu.view_schema AND
|
||||
table_fk.foreign_table_name = vcu.table_name AND
|
||||
vcu.column_name = ANY (table_fk.foreign_columns)
|
||||
WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
AND foreign_columns = table_fk.foreign_columns
|
||||
GROUP BY vcu.view_schema, table_fk.table_name, vcu.view_name, table_fk.columns
|
||||
)
|
||||
|]
|
||||
let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels
|
||||
let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations
|
||||
return $ simpleRelations ++ mapMaybe link2Relation links
|
||||
where
|
||||
groupFn :: Relation -> Text
|
||||
groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t
|
||||
link2Relation [
|
||||
Relation{relSchema=sc, relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},
|
||||
Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc}
|
||||
] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
|
||||
link2Relation _ = Nothing
|
||||
|
||||
allColumns :: [Relation] -> H.Tx P.Postgres s [Column]
|
||||
allColumns rels = do
|
||||
cols <- H.listEx $ [H.stmt|
|
||||
SELECT
|
||||
info.table_schema AS schema,
|
||||
info.table_name AS table_name,
|
||||
info.column_name AS name,
|
||||
info.ordinal_position AS position,
|
||||
info.is_nullable::boolean AS nullable,
|
||||
info.data_type AS col_type,
|
||||
info.is_updatable::boolean AS updatable,
|
||||
info.character_maximum_length AS max_len,
|
||||
info.numeric_precision AS precision,
|
||||
info.column_default AS default_value,
|
||||
array_to_string(enum_info.vals, ',') AS enum
|
||||
FROM (
|
||||
SELECT
|
||||
table_schema,
|
||||
table_name,
|
||||
column_name,
|
||||
ordinal_position,
|
||||
is_nullable,
|
||||
data_type,
|
||||
is_updatable,
|
||||
character_maximum_length,
|
||||
numeric_precision,
|
||||
column_default,
|
||||
udt_name
|
||||
FROM information_schema.columns
|
||||
WHERE table_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
) AS info
|
||||
LEFT OUTER JOIN (
|
||||
SELECT
|
||||
n.nspname AS s,
|
||||
t.typname AS n,
|
||||
array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals
|
||||
FROM pg_type t
|
||||
JOIN pg_enum e ON t.oid = e.enumtypid
|
||||
JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace
|
||||
GROUP BY s,n
|
||||
) AS enum_info ON (info.udt_name = enum_info.n)
|
||||
ORDER BY schema, position
|
||||
|]
|
||||
return $ map (addFK . columnFromRow) cols
|
||||
|
||||
where
|
||||
addFK col = col { colFK = fk col }
|
||||
fk col = join $ relToFk (colName col) <$> find (lookupFn col) rels
|
||||
lookupFn :: Column -> Relation -> Bool
|
||||
lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumns=rc, relType=rty}) =
|
||||
cs==rs && ct==rt && cn `elem` rc && rty==Child
|
||||
lookupFn _ _ = False
|
||||
relToFk cName (Relation{relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey t <$> c
|
||||
where
|
||||
pos = elemIndex cName cs
|
||||
c = (fcs !!) <$> pos
|
||||
|
||||
allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey]
|
||||
allPrimaryKeys = do
|
||||
pks <- H.listEx $ [H.stmt|
|
||||
WITH table_pk AS (
|
||||
SELECT
|
||||
kc.table_schema,
|
||||
kc.table_name,
|
||||
kc.column_name
|
||||
FROM
|
||||
information_schema.table_constraints tc,
|
||||
information_schema.key_column_usage kc
|
||||
WHERE
|
||||
tc.constraint_type = 'PRIMARY KEY' AND
|
||||
kc.table_name = tc.table_name AND
|
||||
kc.table_schema = tc.table_schema AND
|
||||
kc.constraint_name = tc.constraint_name AND
|
||||
kc.table_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
)
|
||||
SELECT table_schema,
|
||||
table_name,
|
||||
column_name
|
||||
FROM table_pk
|
||||
UNION (
|
||||
SELECT
|
||||
vcu.view_schema,
|
||||
vcu.view_name,
|
||||
vcu.column_name
|
||||
FROM information_schema.view_column_usage AS vcu
|
||||
JOIN
|
||||
table_pk ON table_pk.table_schema = vcu.view_schema AND
|
||||
table_pk.table_name = vcu.table_name AND
|
||||
table_pk.column_name = vcu.column_name
|
||||
WHERE vcu.view_schema NOT IN ('pg_catalog','information_schema')
|
||||
)
|
||||
|]
|
||||
return $ map pkFromRow pks
|
||||
+97
-108
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module PostgREST.QueryBuilder
|
||||
where
|
||||
|
||||
@@ -6,160 +7,148 @@ import Control.Error
|
||||
import Data.List (find)
|
||||
import Data.Monoid
|
||||
import Data.Text hiding (filter, find, foldr, head, last, map,
|
||||
null, zipWith)
|
||||
null, zipWith, concatMap)
|
||||
import Control.Applicative
|
||||
import Data.Tree
|
||||
import PostgREST.PgQuery (PStmt, fromQi,
|
||||
orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
|
||||
pgFmtValue, whiteList)
|
||||
import PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem,
|
||||
pgFmtIdent, pgFmtCondition,
|
||||
insertableValue, orderF, sourceSubqueryName, pgFmtJsonPath)
|
||||
import PostgREST.Types
|
||||
import qualified Data.Vector as V (empty)
|
||||
import qualified Hasql.Backend as B
|
||||
import qualified Data.Map as M
|
||||
|
||||
findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
|
||||
findRelation :: [Relation] -> Schema -> Text -> Text -> Maybe Relation
|
||||
findRelation allRelations s t1 t2 =
|
||||
find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
|
||||
find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations
|
||||
|
||||
addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
|
||||
addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) =
|
||||
addRelations :: Schema -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
|
||||
addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
|
||||
case parentNode of
|
||||
Nothing -> Node query{relation=Nothing} <$> updatedForest
|
||||
(Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
|
||||
Nothing -> Node (query, (table, Nothing)) <$> updatedForest
|
||||
(Just (Node (_, (parentTable, _)) _)) -> Node <$> (addRel n <$> rel) <*> updatedForest
|
||||
where
|
||||
rel = note ("no relation between " <> table <> " and " <> parentTable)
|
||||
$ findRelation allRelations schema table parentTable
|
||||
<|> findRelation allRelations schema parentTable table
|
||||
addRel :: Query -> Relation -> Query
|
||||
addRel q r = q{relation = Just r}
|
||||
addRel :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation))
|
||||
addRel (q, (t, _)) r = (q, (t, Just r))
|
||||
where
|
||||
updatedForest = mapM (addRelations schema allRelations (Just node)) forest
|
||||
|
||||
getJoinConditions :: Relation -> [Filter]
|
||||
getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) =
|
||||
getJoinConditions (Relation t cs ft fcs typ lt lc1 lc2) =
|
||||
case typ of
|
||||
Child -> zipWith (toFilter t ft) cs fcs
|
||||
Parent -> zipWith (toFilter t ft) cs fcs
|
||||
Many -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2)
|
||||
Child -> zipWith (toFilter tN ftN) cs fcs
|
||||
Parent -> zipWith (toFilter tN ftN) cs fcs
|
||||
Many -> zipWith (toFilter tN ltN) cs (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)
|
||||
where
|
||||
toFilter :: Text -> Text -> FieldName -> FieldName -> Filter
|
||||
toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc))
|
||||
s = tableSchema t
|
||||
tN = tableName t
|
||||
ftN = tableName ft
|
||||
ltN = fromMaybe "" (tableName <$> lt)
|
||||
toFilter :: Text -> Text -> Column -> Column -> Filter
|
||||
toFilter tb ftb c fc = Filter (colName c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}}))
|
||||
|
||||
addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
|
||||
addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
|
||||
addJoinConditions :: Text -> ApiRequest -> Either Text ApiRequest
|
||||
addJoinConditions schema (Node (query, (n, r)) forest) =
|
||||
case r of
|
||||
Nothing -> Node updatedQuery <$> updatedForest -- this is the root node
|
||||
Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
|
||||
Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest
|
||||
Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node
|
||||
Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest
|
||||
Just (Relation{relType=Parent}) -> Node (updatedQuery, (n,r)) <$> updatedForest
|
||||
Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->
|
||||
Node <$> pure qq <*> updatedForest
|
||||
Node (qq, (n, r)) <$> updatedForest
|
||||
where
|
||||
q = addCond updatedQuery (getJoinConditions rel)
|
||||
qq = q{joinTables=linkTable:joinTables q}
|
||||
_ -> Left "unknow relation"
|
||||
qq = q{from=tableName linkTable : from q}
|
||||
_ -> Left "unknown relation"
|
||||
where
|
||||
-- add parentTable and parentJoinConditions to the query
|
||||
updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions
|
||||
updatedQuery = foldr (flip addCond) (query{from = parentTables ++ from query}) parentJoinConditions
|
||||
where
|
||||
parentJoinConditions = map (getJoinConditions.snd) parents
|
||||
parentJoinConditions = map (getJoinConditions . snd) parents
|
||||
parentTables = map fst parents
|
||||
parents = mapMaybe (getParents.rootLabel) forest
|
||||
getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel)
|
||||
parents = mapMaybe (getParents . rootLabel) forest
|
||||
getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
|
||||
getParents _ = Nothing
|
||||
updatedForest = mapM (addJoinConditions schema allColumns) forest
|
||||
addCond q con = q{filters=con ++ filters q}
|
||||
updatedForest = mapM (addJoinConditions schema) forest
|
||||
addCond q con = q{where_=con ++ where_ q}
|
||||
|
||||
requestToCountQuery :: Text -> ApiRequest -> PStmt
|
||||
requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
|
||||
B.Stmt query V.empty True
|
||||
emptyOnNull :: Text -> [a] -> Text
|
||||
emptyOnNull val x = if null x then "" else val
|
||||
|
||||
requestToQuery :: Text -> ApiRequest -> Text
|
||||
requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
|
||||
query
|
||||
where
|
||||
-- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
|
||||
-- of our WITH query part
|
||||
tblSchema tbl = if tbl == sourceSubqueryName then "" else schema
|
||||
qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl
|
||||
toQi t = QualifiedIdentifier (tblSchema t) t
|
||||
query = Data.Text.unwords [
|
||||
"SELECT pg_catalog.count(1)",
|
||||
"FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
|
||||
("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions
|
||||
]
|
||||
emptyOnNull val x = if null x then "" else val
|
||||
localConditions = filter fn conditions
|
||||
where
|
||||
fn (Filter{value=VText _}) = True
|
||||
fn (Filter{value=VForeignKey _ _}) = False
|
||||
|
||||
requestToQuery :: Text -> ApiRequest -> PStmt
|
||||
requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) =
|
||||
orderT (fromMaybe [] ord) query
|
||||
where
|
||||
query = B.Stmt qStr V.empty True
|
||||
qStr = Data.Text.unwords [
|
||||
("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
|
||||
"SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
|
||||
"FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)),
|
||||
("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions
|
||||
"SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
|
||||
"FROM ", intercalate ", " (map (fromQi . toQi) tbls),
|
||||
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
|
||||
orderF (fromMaybe [] ord)
|
||||
]
|
||||
emptyOnNull val x = if null x then "" else val
|
||||
(withs, selects) = foldr getQueryParts ([],[]) forest
|
||||
getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text])
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s)
|
||||
getQueryParts :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
|
||||
getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
|
||||
where
|
||||
sel = "("
|
||||
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
|
||||
<> "FROM (" <> subquery <> ") " <> table
|
||||
<> ") AS " <> table
|
||||
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
|
||||
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s)
|
||||
where subquery = requestToQuery schema (Node n forst)
|
||||
getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
|
||||
where
|
||||
sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
|
||||
wit = table <> " AS ( " <> subquery <> " )"
|
||||
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
|
||||
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s)
|
||||
where subquery = requestToQuery schema (Node n forst)
|
||||
getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
|
||||
where
|
||||
sel = "("
|
||||
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
|
||||
<> "FROM (" <> subquery <> ") " <> table
|
||||
<> ") AS " <> table
|
||||
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
|
||||
|
||||
-- the following is just to remove the warning
|
||||
where subquery = requestToQuery schema (Node n forst)
|
||||
--the following is just to remove the warning
|
||||
--getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
|
||||
--posible relations are Child Parent Many
|
||||
getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined
|
||||
|
||||
pgFmtCondition :: QualifiedIdentifier -> Filter -> Text
|
||||
pgFmtCondition table (Filter (col,jp) ops val) =
|
||||
notOp <> " " <> sqlCol <> " " <> pgFmtOperator opCode <> " " <>
|
||||
if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue
|
||||
getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
|
||||
requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) =
|
||||
query
|
||||
where
|
||||
headPredicate:rest = split (=='.') ops
|
||||
hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
|
||||
opCode = hasNot (head rest) headPredicate
|
||||
notOp = hasNot headPredicate ""
|
||||
sqlCol = case val of
|
||||
VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp
|
||||
VForeignKey qi _ -> pgFmtColumn qi col
|
||||
sqlValue = valToStr val
|
||||
getInner v = case v of
|
||||
VText s -> s
|
||||
_ -> ""
|
||||
valToStr v = case v of
|
||||
VText s -> pgFmtValue opCode s
|
||||
VForeignKey (QualifiedIdentifier s _) (ForeignKey ft fc) -> pgFmtColumn (QualifiedIdentifier s ft) fc
|
||||
|
||||
pgFmtColumn :: QualifiedIdentifier -> Text -> Text
|
||||
pgFmtColumn table "*" = fromQi table <> ".*"
|
||||
pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
|
||||
|
||||
pgFmtJsonPath :: Maybe JsonPath -> Text
|
||||
pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
|
||||
pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
|
||||
pgFmtJsonPath _ = ""
|
||||
|
||||
pgFmtTable :: Table -> Text
|
||||
pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n
|
||||
|
||||
pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text
|
||||
pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp
|
||||
pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp
|
||||
|
||||
asJsonPath :: Maybe JsonPath -> Text
|
||||
asJsonPath Nothing = ""
|
||||
asJsonPath (Just xx) = " AS " <> last xx
|
||||
qi = QualifiedIdentifier schema mainTbl
|
||||
query = Data.Text.unwords [
|
||||
"INSERT INTO ", fromQi qi,
|
||||
" (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
|
||||
"VALUES " <> intercalate ", "
|
||||
( map (\v ->
|
||||
"(" <>
|
||||
intercalate ", " ( map insertableValue v ) <>
|
||||
")"
|
||||
) vals
|
||||
),
|
||||
"RETURNING " <> fromQi qi <> ".*"
|
||||
]
|
||||
requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
|
||||
query
|
||||
where
|
||||
qi = QualifiedIdentifier schema mainTbl
|
||||
query = Data.Text.unwords [
|
||||
"UPDATE ", fromQi qi,
|
||||
" SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
|
||||
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
|
||||
"RETURNING " <> fromQi qi <> ".*"
|
||||
]
|
||||
formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v
|
||||
requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) =
|
||||
query
|
||||
where
|
||||
qi = QualifiedIdentifier schema mainTbl
|
||||
query = Data.Text.unwords [
|
||||
"DELETE FROM ", fromQi qi,
|
||||
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
|
||||
"RETURNING " <> fromQi qi <> ".*"
|
||||
]
|
||||
|
||||
+69
-54
@@ -3,69 +3,71 @@ import Data.Text
|
||||
import Data.Tree
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Aeson
|
||||
import Data.Map
|
||||
|
||||
data DbStructure = DbStructure {
|
||||
tables :: [Table]
|
||||
, columns :: [Column]
|
||||
, relations :: [Relation]
|
||||
, primaryKeys :: [PrimaryKey]
|
||||
}
|
||||
|
||||
|
||||
data Table = Table {
|
||||
tableSchema :: Text
|
||||
, tableName :: Text
|
||||
, tableInsertable :: Bool
|
||||
, tableAcl :: [Text]
|
||||
} deriving (Show)
|
||||
|
||||
data ForeignKey = ForeignKey {
|
||||
fkTable::Text, fkCol::Text
|
||||
dbTables :: [Table]
|
||||
, dbColumns :: [Column]
|
||||
, dbRelations :: [Relation]
|
||||
, dbPrimaryKeys :: [PrimaryKey]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
type Schema = Text
|
||||
|
||||
data Column = Column {
|
||||
colSchema :: Text
|
||||
, colTable :: Text
|
||||
, colName :: Text
|
||||
, colPosition :: Int
|
||||
, colNullable :: Bool
|
||||
, colType :: Text
|
||||
, colUpdatable :: Bool
|
||||
, colMaxLen :: Maybe Int
|
||||
, colPrecision :: Maybe Int
|
||||
, colDefault :: Maybe Text
|
||||
, colEnum :: [Text]
|
||||
, colFK :: Maybe ForeignKey
|
||||
} | Star {colSchema :: Text, colTable :: Text } deriving (Show)
|
||||
data Table = Table {
|
||||
tableSchema :: Schema
|
||||
, tableName :: Text
|
||||
, tableInsertable :: Bool
|
||||
} deriving (Show, Ord)
|
||||
|
||||
data ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
|
||||
|
||||
data Column =
|
||||
Column {
|
||||
colTable :: Table
|
||||
, colName :: Text
|
||||
, colPosition :: Int
|
||||
, colNullable :: Bool
|
||||
, colType :: Text
|
||||
, colUpdatable :: Bool
|
||||
, colMaxLen :: Maybe Int
|
||||
, colPrecision :: Maybe Int
|
||||
, colDefault :: Maybe Text
|
||||
, colEnum :: [Text]
|
||||
, colFK :: Maybe ForeignKey
|
||||
}
|
||||
| Star { colTable :: Table }
|
||||
deriving (Show, Ord)
|
||||
|
||||
type Synonym = (Column,Column)
|
||||
|
||||
data PrimaryKey = PrimaryKey {
|
||||
pkSchema::Text, pkTable::Text, pkName::Text
|
||||
}
|
||||
pkTable :: Table
|
||||
, pkName :: Text
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data OrderTerm = OrderTerm {
|
||||
otTerm :: Text
|
||||
otTerm :: Text
|
||||
, otDirection :: BS.ByteString
|
||||
, otNullOrder :: Maybe BS.ByteString
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data QualifiedIdentifier = QualifiedIdentifier {
|
||||
qiSchema :: Text
|
||||
qiSchema :: Schema
|
||||
, qiName :: Text
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
data RelationType = Child | Parent | Many deriving (Show, Eq)
|
||||
data Relation = Relation {
|
||||
relSchema :: Text
|
||||
, relTable :: Text
|
||||
, relColumns :: [Text]
|
||||
, relFTable :: Text
|
||||
, relFColumns :: [Text]
|
||||
, relType :: RelationType
|
||||
, relLTable :: Maybe Text
|
||||
, relLCols1 :: Maybe [Text]
|
||||
, relLCols2 :: Maybe [Text]
|
||||
relTable :: Table
|
||||
, relColumns :: [Column]
|
||||
, relFTable :: Table
|
||||
, relFColumns :: [Column]
|
||||
, relType :: RelationType
|
||||
, relLTable :: Maybe Table
|
||||
, relLCols1 :: Maybe [Column]
|
||||
, relLCols2 :: Maybe [Column]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
@@ -75,23 +77,21 @@ type FieldName = Text
|
||||
type JsonPath = [Text]
|
||||
type Field = (FieldName, Maybe JsonPath)
|
||||
type Cast = Text
|
||||
type NodeName = Text
|
||||
type SelectItem = (Field, Maybe Cast)
|
||||
type Path = [Text]
|
||||
data Query = Select {
|
||||
mainTable::Text
|
||||
, fields::[SelectItem]
|
||||
, joinTables::[Text]
|
||||
, filters::[Filter]
|
||||
, order::Maybe [OrderTerm]
|
||||
, relation::Maybe Relation
|
||||
} deriving (Show, Eq)
|
||||
data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] }
|
||||
| Insert { into::Text, fields::[Field], values::[[Value]] }
|
||||
| Delete { from::[Text], where_::[Filter] }
|
||||
| Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq)
|
||||
data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
|
||||
type ApiRequest = Tree Query
|
||||
type ApiNode = (Query, (NodeName, Maybe Relation))
|
||||
type ApiRequest = Tree ApiNode
|
||||
|
||||
|
||||
instance ToJSON Column where
|
||||
toJSON c = object [
|
||||
"schema" .= colSchema c
|
||||
"schema" .= tableSchema t
|
||||
, "name" .= colName c
|
||||
, "position" .= colPosition c
|
||||
, "nullable" .= colNullable c
|
||||
@@ -102,12 +102,27 @@ instance ToJSON Column where
|
||||
, "references".= colFK c
|
||||
, "default" .= colDefault c
|
||||
, "enum" .= colEnum c ]
|
||||
where
|
||||
t = colTable c
|
||||
|
||||
instance ToJSON ForeignKey where
|
||||
toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
|
||||
toJSON fk = object [
|
||||
"schema" .= tableSchema t
|
||||
, "table" .= tableName t
|
||||
, "column" .= colName c ]
|
||||
where
|
||||
c = fkCol fk
|
||||
t = colTable c
|
||||
|
||||
instance ToJSON Table where
|
||||
toJSON v = object [
|
||||
"schema" .= tableSchema v
|
||||
, "name" .= tableName v
|
||||
, "insertable" .= tableInsertable v ]
|
||||
|
||||
instance Eq Table where
|
||||
Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
|
||||
|
||||
instance Eq Column where
|
||||
Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
|
||||
_ == _ = False
|
||||
|
||||
Reference in New Issue
Block a user