Make postgrest usable as a library
This commit is contained in:
Sridhar Ratnakumar
@@ -0,0 +1,315 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module PostgREST.App (app, sqlError, isSqlError) where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Control.Arrow ((***), second)
|
||||
import Control.Applicative
|
||||
|
||||
import Data.Text hiding (map)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Text.Regex.TDFA ((=~))
|
||||
import Data.Ord (comparing)
|
||||
import Data.Ranged.Ranges (emptyRange)
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.CaseInsensitive (original)
|
||||
import Data.List (sortBy)
|
||||
import Data.Functor.Identity
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Blaze.ByteString.Builder as BB
|
||||
import qualified Data.Csv as CSV
|
||||
|
||||
import Network.HTTP.Types.Status
|
||||
import Network.HTTP.Types.Header
|
||||
import Network.HTTP.Types.URI (parseSimpleQuery)
|
||||
import Network.HTTP.Base (urlEncodeVars)
|
||||
import Network.Wai
|
||||
import Network.Wai.Internal (Response(..))
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Monoid
|
||||
import qualified Data.Vector as V
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Backend as B
|
||||
import qualified Hasql.Postgres as P
|
||||
|
||||
import PostgREST.Config (AppConfig(..))
|
||||
import PostgREST.Auth
|
||||
import PostgREST.PgQuery
|
||||
import PostgREST.RangeQuery
|
||||
import PostgREST.PgStructure
|
||||
|
||||
import Prelude
|
||||
|
||||
app :: AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
|
||||
app conf reqBody req =
|
||||
case (path, verb) of
|
||||
([], _) -> do
|
||||
body <- encode <$> tables (cs schema)
|
||||
return $ responseLBS status200 [jsonH] $ cs body
|
||||
|
||||
([table], "OPTIONS") -> do
|
||||
let t = QualifiedTable schema (cs table)
|
||||
cols <- columns t
|
||||
pkey <- map cs <$> primaryKeyColumns t
|
||||
return $ responseLBS status200 [jsonH, allOrigins]
|
||||
$ encode (TableOptions cols pkey)
|
||||
|
||||
([table], "GET") ->
|
||||
if range == Just emptyRange
|
||||
then return $ responseLBS status416 [] "HTTP Range error"
|
||||
else do
|
||||
let qt = QualifiedTable schema (cs table)
|
||||
let select = B.Stmt "select " V.empty True <>
|
||||
parentheticT (
|
||||
whereT qq $ countRows qt
|
||||
) <> commaq <> (
|
||||
asJsonWithCount
|
||||
. limitT range
|
||||
. orderT (orderParse qq)
|
||||
. whereT qq
|
||||
$ selectStar qt
|
||||
)
|
||||
row <- H.maybeEx select
|
||||
let (tableTotal, queryTotal, body) =
|
||||
fromMaybe (0, 0, Just "" :: Maybe Text) row
|
||||
from = fromMaybe 0 $ rangeOffset <$> range
|
||||
to = from+queryTotal-1
|
||||
contentRange = contentRangeH from to tableTotal
|
||||
status = rangeStatus from to tableTotal
|
||||
canonical = urlEncodeVars
|
||||
. sortBy (comparing fst)
|
||||
. map (join (***) cs)
|
||||
. parseSimpleQuery
|
||||
$ rawQueryString req
|
||||
return $ responseLBS status
|
||||
[jsonH, contentRange,
|
||||
("Content-Location",
|
||||
"/" <> cs table <>
|
||||
if Prelude.null canonical then "" else "?" <> cs canonical
|
||||
)
|
||||
] (cs $ fromMaybe "[]" body)
|
||||
|
||||
(["postgrest", "users"], "POST") -> do
|
||||
let user = decode reqBody :: Maybe AuthUser
|
||||
|
||||
case user of
|
||||
Nothing -> return $ responseLBS status400 [jsonH] $
|
||||
encode . object $ [("message", String "Failed to parse user.")]
|
||||
Just u -> do
|
||||
_ <- addUser (cs $ userId u)
|
||||
(cs $ userPass u) (cs $ userRole u)
|
||||
return $ responseLBS status201
|
||||
[ jsonH
|
||||
, (hLocation, "/postgrest/users?id=eq." <> cs (userId u))
|
||||
] ""
|
||||
|
||||
(["postgrest", "tokens"], "POST") ->
|
||||
case jwtSecret of
|
||||
"secret" -> return $ responseLBS status500 [jsonH] $
|
||||
encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")]
|
||||
_ -> do
|
||||
let user = decode reqBody :: Maybe AuthUser
|
||||
|
||||
case user of
|
||||
Nothing -> return $ responseLBS status400 [jsonH] $
|
||||
encode . object $ [("message", String "Failed to parse user.")]
|
||||
Just u -> do
|
||||
setRole authenticator
|
||||
login <- signInRole (cs $ userId u)
|
||||
(cs $ userPass u)
|
||||
case login of
|
||||
LoginSuccess role ->
|
||||
return $ responseLBS status201 [ jsonH ] $
|
||||
encode . object $ [("token", String $ tokenJWT jwtSecret (cs $ userId u) role)]
|
||||
_ -> return $ responseLBS status401 [jsonH] $
|
||||
encode . object $ [("message", String "Failed authentication.")]
|
||||
|
||||
([table], "POST") -> do
|
||||
let qt = QualifiedTable schema (cs table)
|
||||
echoRequested = lookup "Prefer" hdrs == Just "return=representation"
|
||||
parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
|
||||
parsed = if lookup "Content-Type" hdrs == Just "text/csv"
|
||||
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
|
||||
primaryKeys <- primaryKeyColumns qt
|
||||
let responses = flip map inserted $ \obj -> do
|
||||
let primaries =
|
||||
if Prelude.null primaryKeys
|
||||
then obj
|
||||
else M.filterWithKey (const . (`elem` primaryKeys)) 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
|
||||
|
||||
([table], "PUT") ->
|
||||
handleJsonObj reqBody $ \obj -> do
|
||||
let qt = QualifiedTable schema (cs table)
|
||||
primaryKeys <- primaryKeyColumns qt
|
||||
let specifiedKeys = map (cs . fst) qq
|
||||
if S.fromList primaryKeys /= S.fromList specifiedKeys
|
||||
then return $ responseLBS status405 []
|
||||
"You must speficy all and only primary keys as params"
|
||||
else do
|
||||
tableCols <- map (cs . colName) <$> columns qt
|
||||
let cols = map cs $ M.keys obj
|
||||
if S.fromList tableCols == S.fromList cols
|
||||
then do
|
||||
let vals = M.elems obj
|
||||
H.unitEx $ iffNotT
|
||||
(whereT qq $ update qt cols vals)
|
||||
(insertSelect qt cols vals)
|
||||
return $ responseLBS status204 [ jsonH ] ""
|
||||
|
||||
else return $ if Prelude.null tableCols
|
||||
then responseLBS status404 [] ""
|
||||
else responseLBS status400 []
|
||||
"You must specify all columns in PUT request"
|
||||
|
||||
([table], "PATCH") ->
|
||||
handleJsonObj reqBody $ \obj -> do
|
||||
let qt = QualifiedTable schema (cs table)
|
||||
up = returningStarT
|
||||
. whereT 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) queryTotal
|
||||
echoRequested = lookup "Prefer" hdrs == Just "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 = QualifiedTable schema (cs table)
|
||||
let del = countT
|
||||
. returningStarT
|
||||
. whereT qq
|
||||
$ deleteFrom qt
|
||||
row <- H.maybeEx del
|
||||
let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
|
||||
return $ if deletedCount == 0
|
||||
then responseLBS status404 [] ""
|
||||
else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""
|
||||
|
||||
(_, _) ->
|
||||
return $ responseLBS status404 [] ""
|
||||
|
||||
where
|
||||
path = pathInfo req
|
||||
verb = requestMethod req
|
||||
qq = queryString req
|
||||
hdrs = requestHeaders req
|
||||
schema = requestedSchema (cs $ configV1Schema conf) hdrs
|
||||
authenticator = cs $ configDbUser conf
|
||||
jwtSecret = cs $ configJwtSecret conf
|
||||
range = rangeRequested hdrs
|
||||
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
|
||||
|
||||
sqlError :: t
|
||||
sqlError = undefined
|
||||
|
||||
isSqlError :: t
|
||||
isSqlError = undefined
|
||||
|
||||
rangeStatus :: Int -> Int -> Int -> Status
|
||||
rangeStatus from to total
|
||||
| from > total = status416
|
||||
| (1 + to - from) < total = status206
|
||||
| otherwise = status200
|
||||
|
||||
contentRangeH :: Int -> Int -> Int -> Header
|
||||
contentRangeH from to total =
|
||||
("Content-Range",
|
||||
if total == 0 || from > total
|
||||
then "*/" <> cs (show total)
|
||||
else cs (show from) <> "-"
|
||||
<> cs (show to) <> "/"
|
||||
<> cs (show total)
|
||||
)
|
||||
|
||||
requestedSchema :: Text -> RequestHeaders -> Text
|
||||
requestedSchema v1schema hdrs =
|
||||
case verStr of
|
||||
Just [[_, ver]] -> if ver == "1" then v1schema else ver
|
||||
_ -> v1schema
|
||||
|
||||
where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
|
||||
accept = cs <$> lookup hAccept hdrs :: Maybe Text
|
||||
verStr = (=~ verRegex) <$> accept :: Maybe [[Text]]
|
||||
|
||||
jsonH :: Header
|
||||
jsonH = (hContentType, "application/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)
|
||||
|
||||
where
|
||||
renderHeader :: Header -> BL.ByteString
|
||||
renderHeader (k, v) = cs (original k) <> ": " <> cs v
|
||||
|
||||
renderResponseBody :: Response -> BL.ByteString
|
||||
renderResponseBody (ResponseBuilder _ headers b) =
|
||||
BL.intercalate "\n" (map renderHeader headers)
|
||||
<> "\n\n" <> BB.toLazyByteString b
|
||||
renderResponseBody _ = error
|
||||
"Unable to create multipart response from non-ResponseBuilder"
|
||||
|
||||
data TableOptions = TableOptions {
|
||||
tblOptcolumns :: [Column]
|
||||
, tblOptpkey :: [Text]
|
||||
}
|
||||
|
||||
instance ToJSON TableOptions where
|
||||
toJSON t = object [
|
||||
"columns" .= tblOptcolumns t
|
||||
, "pkey" .= tblOptpkey t ]
|
||||
@@ -0,0 +1,91 @@
|
||||
{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
|
||||
module PostgREST.Auth where
|
||||
|
||||
import Data.Aeson
|
||||
import Control.Monad (mzero)
|
||||
import Control.Applicative
|
||||
import Crypto.BCrypt
|
||||
import Data.Text
|
||||
import Data.Monoid
|
||||
import Data.Map
|
||||
import qualified Data.Vector as V
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Backend as B
|
||||
import qualified Hasql.Postgres as P
|
||||
import qualified Web.JWT as JWT
|
||||
import Data.String.Conversions (cs)
|
||||
import PostgREST.PgQuery (pgFmtLit)
|
||||
|
||||
import Prelude
|
||||
|
||||
import System.IO.Unsafe
|
||||
|
||||
data AuthUser = AuthUser {
|
||||
userId :: String
|
||||
, userPass :: String
|
||||
, userRole :: 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
|
||||
|
||||
data LoginAttempt =
|
||||
NoCredentials
|
||||
| MalformedAuth
|
||||
| LoginFailed
|
||||
| LoginSuccess DbRole
|
||||
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 role " <> cs (pgFmtLit role)) V.empty True
|
||||
|
||||
resetRole :: H.Tx P.Postgres s ()
|
||||
resetRole = H.unitEx [H.stmt|reset role|]
|
||||
|
||||
addUser :: Text -> Text -> Text -> H.Tx P.Postgres s ()
|
||||
addUser identity pass role = do
|
||||
let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
|
||||
H.unitEx $
|
||||
[H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
|
||||
identity (cs hashed :: Text) role
|
||||
|
||||
signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt
|
||||
signInRole user pass = do
|
||||
u <- H.maybeEx $ [H.stmt|select pass, rolname from postgrest.auth where id = ?|] user
|
||||
return $ maybe LoginFailed (\r ->
|
||||
let (hashed, role) = r in
|
||||
if checkPass hashed pass
|
||||
then LoginSuccess role
|
||||
else LoginFailed
|
||||
) u
|
||||
|
||||
signInWithJWT :: Text -> Text -> LoginAttempt
|
||||
signInWithJWT secret input = case maybeRole of
|
||||
Just (Just (String role)) -> LoginSuccess $ cs role
|
||||
_ -> LoginFailed
|
||||
where
|
||||
maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value)
|
||||
claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded
|
||||
decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input
|
||||
|
||||
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)]
|
||||
}
|
||||
@@ -0,0 +1,64 @@
|
||||
module PostgREST.Config where
|
||||
|
||||
import Network.Wai
|
||||
import Control.Applicative
|
||||
import Data.Text (strip)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.String.Conversions (cs)
|
||||
import Options.Applicative hiding (columns)
|
||||
import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
|
||||
import Prelude
|
||||
|
||||
data AppConfig = AppConfig {
|
||||
configDbName :: String
|
||||
, configDbPort :: Int
|
||||
, configDbUser :: String
|
||||
, configDbPass :: String
|
||||
, configDbHost :: String
|
||||
|
||||
, configPort :: Int
|
||||
, configAnonRole :: String
|
||||
, configSecure :: Bool
|
||||
, configPool :: Int
|
||||
, configV1Schema :: String
|
||||
|
||||
, configJwtSecret :: String
|
||||
}
|
||||
|
||||
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)
|
||||
|
||||
<*> 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)
|
||||
|
||||
defaultCorsPolicy :: CorsResourcePolicy
|
||||
defaultCorsPolicy = CorsResourcePolicy Nothing
|
||||
["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
|
||||
(Just $ 60*60*24) False False True
|
||||
|
||||
corsPolicy :: Request -> Maybe CorsResourcePolicy
|
||||
corsPolicy req = case lookup "origin" headers of
|
||||
Just origin -> Just defaultCorsPolicy {
|
||||
corsOrigins = Just ([origin], True)
|
||||
, corsRequestHeaders = "Authentication":accHeaders
|
||||
, corsExposedHeaders = Just [
|
||||
"Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
|
||||
, "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
|
||||
]
|
||||
}
|
||||
Nothing -> Nothing
|
||||
where
|
||||
headers = requestHeaders req
|
||||
accHeaders = case lookup "access-control-request-headers" headers of
|
||||
Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
|
||||
Nothing -> []
|
||||
@@ -0,0 +1,71 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
|
||||
|
||||
module PostgREST.Error (PgError, errResponse) where
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import qualified Network.HTTP.Types.Status as HT
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Text as T
|
||||
import Data.Aeson ((.=))
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.String.Utils(replace)
|
||||
import Network.Wai(Response, responseLBS)
|
||||
import Network.HTTP.Types.Header
|
||||
|
||||
type PgError = H.SessionError P.Postgres
|
||||
|
||||
errResponse :: PgError -> Response
|
||||
errResponse e = responseLBS (httpStatus e)
|
||||
[(hContentType, "application/json")] (JSON.encode e)
|
||||
|
||||
instance JSON.ToJSON PgError where
|
||||
toJSON (H.TxError (P.ErroneousResult c m d h)) = JSON.object [
|
||||
"code" .= (cs c::T.Text),
|
||||
"message" .= (cs m::T.Text),
|
||||
"details" .= (fmap cs d::Maybe T.Text),
|
||||
"hint" .= (fmap cs h::Maybe T.Text)]
|
||||
toJSON (H.TxError (P.NoResult d)) = JSON.object [
|
||||
"message" .= ("No response from server"::T.Text),
|
||||
"details" .= (fmap cs d::Maybe T.Text)]
|
||||
toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m]
|
||||
toJSON (H.TxError P.NotInTransaction) = JSON.object [
|
||||
"message" .= ("Not in transaction"::T.Text)]
|
||||
toJSON (H.CxError (P.CantConnect d)) = JSON.object [
|
||||
"message" .= ("Can't connect to the database"::T.Text),
|
||||
"details" .= (fmap cs d::Maybe T.Text)]
|
||||
toJSON (H.CxError (P.UnsupportedVersion v)) = JSON.object [
|
||||
"message" .= ("Postgres version "++version++" is not supported") ]
|
||||
where version = replace "0" "." (show v)
|
||||
toJSON (H.ResultError m) = JSON.object ["message" .= m]
|
||||
|
||||
httpStatus :: PgError -> HT.Status
|
||||
httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =
|
||||
let code = cs codeBS in
|
||||
case code of
|
||||
'0':'8':_ -> HT.status503 -- pg connection err
|
||||
'0':'9':_ -> HT.status500 -- triggered action exception
|
||||
'0':'L':_ -> HT.status403 -- invalid grantor
|
||||
'0':'P':_ -> HT.status403 -- invalid role specification
|
||||
'2':'5':_ -> HT.status500 -- invalid tx state
|
||||
'2':'8':_ -> HT.status403 -- invalid auth specification
|
||||
'2':'D':_ -> HT.status500 -- invalid tx termination
|
||||
'3':'8':_ -> HT.status500 -- external routine exception
|
||||
'3':'9':_ -> HT.status500 -- external routine invocation
|
||||
'3':'B':_ -> HT.status500 -- savepoint exception
|
||||
'4':'0':_ -> HT.status500 -- tx rollback
|
||||
'5':'3':_ -> HT.status503 -- insufficient resources
|
||||
'5':'4':_ -> HT.status413 -- too complex
|
||||
'5':'5':_ -> HT.status500 -- obj not on prereq state
|
||||
'5':'7':_ -> HT.status500 -- operator intervention
|
||||
'5':'8':_ -> HT.status500 -- system error
|
||||
'F':'0':_ -> HT.status500 -- conf file error
|
||||
'H':'V':_ -> HT.status500 -- foreign data wrapper error
|
||||
'P':'0':_ -> HT.status500 -- PL/pgSQL Error
|
||||
'X':'X':_ -> HT.status500 -- internal Error
|
||||
"42P01" -> HT.status404 -- undefined table
|
||||
"42501" -> HT.status404 -- insufficient privilege
|
||||
_ -> HT.status400
|
||||
httpStatus (H.TxError (P.NoResult _)) = HT.status503
|
||||
httpStatus _ = HT.status500
|
||||
@@ -0,0 +1,71 @@
|
||||
module Main where
|
||||
|
||||
import Paths_postgrest (version)
|
||||
|
||||
import PostgREST.App
|
||||
import PostgREST.Middleware
|
||||
import PostgREST.Error(errResponse)
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Wai (strictRequestBody)
|
||||
import Network.Wai.Middleware.Cors (cors)
|
||||
import Network.Wai.Handler.Warp hiding (Connection)
|
||||
import Network.Wai.Middleware.Gzip (gzip, def)
|
||||
import Network.Wai.Middleware.Static (staticPolicy, only)
|
||||
import Network.Wai.Middleware.RequestLogger (logStdout)
|
||||
import Data.List (intercalate)
|
||||
import Data.Version (versionBranch)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import Options.Applicative hiding (columns)
|
||||
|
||||
import PostgREST.Config (AppConfig(..), argParser, corsPolicy)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let opts = info (helper <*> argParser) $
|
||||
fullDesc
|
||||
<> progDesc (
|
||||
"PostgREST "
|
||||
<> prettyVersion
|
||||
<> " / create a REST API to an existing Postgres database"
|
||||
)
|
||||
parserPrefs = prefs showHelpOnError
|
||||
conf <- customExecParser parserPrefs opts
|
||||
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)
|
||||
appSettings = setPort port
|
||||
. setServerName (cs $ "postgrest/" <> prettyVersion)
|
||||
$ defaultSettings
|
||||
middle = logStdout
|
||||
. (if configSecure conf then redirectInsecure else id)
|
||||
. gzip def . cors corsPolicy
|
||||
. staticPolicy (only [("favicon.ico", "static/favicon.ico")])
|
||||
|
||||
poolSettings <- maybe (fail "Improper session settings") return $
|
||||
H.poolSettings (fromIntegral $ configPool conf) 30
|
||||
pool :: H.Pool P.Postgres
|
||||
<- H.acquirePool pgSettings poolSettings
|
||||
|
||||
runSettings appSettings $ middle $ \req respond -> do
|
||||
body <- strictRequestBody req
|
||||
resOrError <- liftIO $ H.session pool $ H.tx Nothing $
|
||||
authenticated conf (app conf body) req
|
||||
either (respond . errResponse) respond resOrError
|
||||
|
||||
where
|
||||
prettyVersion = intercalate "." $ map show $ versionBranch version
|
||||
@@ -0,0 +1,84 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module PostgREST.Middleware where
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid
|
||||
import Data.Text
|
||||
-- import Data.Pool(withResource, Pool)
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import Data.String.Conversions(cs)
|
||||
|
||||
import Network.HTTP.Types.Header (hLocation, hAuthorization)
|
||||
import Network.HTTP.Types (RequestHeaders)
|
||||
import Network.HTTP.Types.Status (status400, status401, status301)
|
||||
import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
|
||||
rawQueryString, isSecure, Request(..), Response)
|
||||
import Network.URI (URI(..), parseURI)
|
||||
|
||||
import PostgREST.Config (AppConfig(..))
|
||||
import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, resetRole)
|
||||
import Codec.Binary.Base64.String (decode)
|
||||
|
||||
import Prelude
|
||||
|
||||
authenticated :: 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 -> if role /= currentRole then runInRole role else app req
|
||||
NoCredentials -> if anon /= currentRole then runInRole anon else app 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 -> H.Tx P.Postgres s Response
|
||||
runInRole r = do
|
||||
setRole r
|
||||
res <- app req
|
||||
resetRole
|
||||
return res
|
||||
|
||||
|
||||
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
|
||||
@@ -0,0 +1,290 @@
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module PostgREST.PgQuery where
|
||||
|
||||
import PostgREST.RangeQuery
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import qualified Hasql.Backend as B
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Text.Regex.TDFA ( (=~) )
|
||||
import Text.Regex.TDFA.Text ()
|
||||
import qualified Network.HTTP.Types.URI as Net
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Monoid
|
||||
import Data.Vector (empty)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Functor
|
||||
import Control.Monad (join)
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Vector as V
|
||||
import Data.Scientific (isInteger, formatScientific, FPFormat(..))
|
||||
|
||||
import Prelude
|
||||
|
||||
type PStmt = H.Stmt P.Postgres
|
||||
instance Monoid PStmt where
|
||||
mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =
|
||||
B.Stmt (query <> query') (params <> params') (prep && prep')
|
||||
mempty = B.Stmt "" empty True
|
||||
type StatementT = PStmt -> PStmt
|
||||
|
||||
data QualifiedTable = QualifiedTable {
|
||||
qtSchema :: T.Text
|
||||
, qtName :: T.Text
|
||||
} deriving (Show)
|
||||
|
||||
data OrderTerm = OrderTerm {
|
||||
otTerm :: T.Text
|
||||
, otDirection :: BS.ByteString
|
||||
, otNullOrder :: Maybe BS.ByteString
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
whereT :: Net.Query -> StatementT
|
||||
whereT 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"] ]
|
||||
conjunction = mconcat $ L.intersperse andq (map wherePred 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 count(1) FROM qqq" }
|
||||
|
||||
countRows :: QualifiedTable -> PStmt
|
||||
countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True
|
||||
|
||||
asJsonWithCount :: StatementT
|
||||
asJsonWithCount s = s { B.stmtTemplate =
|
||||
"count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("
|
||||
<> B.stmtTemplate s <> ") t" }
|
||||
|
||||
asJsonRow :: StatementT
|
||||
asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
|
||||
|
||||
selectStar :: QualifiedTable -> PStmt
|
||||
selectStar t = B.Stmt ("select * from " <> fromQt t) empty True
|
||||
|
||||
returningStarT :: StatementT
|
||||
returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
|
||||
|
||||
deleteFrom :: QualifiedTable -> PStmt
|
||||
deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
|
||||
|
||||
insertInto :: QualifiedTable
|
||||
-> V.Vector T.Text
|
||||
-> V.Vector (V.Vector JSON.Value)
|
||||
-> PStmt
|
||||
insertInto t cols vals
|
||||
| V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True
|
||||
| otherwise = B.Stmt
|
||||
("insert into " <> fromQt 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(" <> fromQt t <> ".*)")
|
||||
empty True
|
||||
|
||||
insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
insertSelect t [] _ = B.Stmt
|
||||
("insert into " <> fromQt t <> " default values returning *") empty True
|
||||
insertSelect t cols vals = B.Stmt
|
||||
("insert into " <> fromQt t <> " ("
|
||||
<> T.intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") select "
|
||||
<> T.intercalate ", " (map insertableValue vals))
|
||||
empty True
|
||||
|
||||
update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
|
||||
update t cols vals = B.Stmt
|
||||
("update " <> fromQt t <> " set ("
|
||||
<> T.intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") = ("
|
||||
<> T.intercalate ", " (map insertableValue vals)
|
||||
<> ")")
|
||||
empty True
|
||||
|
||||
wherePred :: Net.QueryItem -> PStmt
|
||||
wherePred (col, predicate) =
|
||||
B.Stmt (" " <> pgFmtJsonbPath (cs col) <> " " <> op <> " " <>
|
||||
if opCode `elem` ["is","isnot"] then whiteList value
|
||||
else cs sqlValue)
|
||||
empty True
|
||||
|
||||
where
|
||||
opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
|
||||
value = T.intercalate "." rest
|
||||
whiteList val = fromMaybe (cs (pgFmtLit val) <> "::unknown ")
|
||||
(L.find ((==) . T.toLower $ val)
|
||||
["null","true","false"])
|
||||
star c = if c == '*' then '%' else c
|
||||
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
||||
|
||||
sqlValue = case opCode of
|
||||
"like" -> unknownLiteral $ T.map star value
|
||||
"ilike" -> unknownLiteral $ T.map star value
|
||||
"in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
||||
_ -> unknownLiteral value
|
||||
|
||||
op = case opCode of
|
||||
"eq" -> "="
|
||||
"gt" -> ">"
|
||||
"lt" -> "<"
|
||||
"gte" -> ">="
|
||||
"lte" -> "<="
|
||||
"neq" -> "<>"
|
||||
"like"-> "like"
|
||||
"ilike"-> "ilike"
|
||||
"in" -> "in"
|
||||
"is" -> "is"
|
||||
"isnot" -> "is not"
|
||||
_ -> "="
|
||||
|
||||
orderParse :: Net.Query -> [OrderTerm]
|
||||
orderParse q =
|
||||
mapMaybe orderParseTerm . T.split (==',') $ cs order
|
||||
where
|
||||
order = fromMaybe "" $ join (lookup "order" q)
|
||||
|
||||
orderParseTerm :: T.Text -> Maybe OrderTerm
|
||||
orderParseTerm s =
|
||||
case T.split (=='.') s of
|
||||
(c:d:nls) ->
|
||||
if d `elem` ["asc", "desc"]
|
||||
then Just $ OrderTerm c
|
||||
( if d == "asc" then "asc" else "desc" )
|
||||
( case nls of
|
||||
[n] -> if | n == "nullsfirst" -> Just "nulls first"
|
||||
| n == "nullslast" -> Just "nulls last"
|
||||
| otherwise -> Nothing
|
||||
_ -> Nothing
|
||||
)
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
|
||||
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 :: T.Text -> T.Text
|
||||
pgFmtJsonbPath p =
|
||||
pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)
|
||||
where
|
||||
pgFmtJsonbPath' (ColIdentifier i) = 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 escaped =~ danger
|
||||
then "\"" <> escaped <> "\""
|
||||
else escaped
|
||||
|
||||
where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: T.Text
|
||||
|
||||
pgFmtLit :: T.Text -> T.Text
|
||||
pgFmtLit x =
|
||||
let trimmed = trimNullChars x
|
||||
escaped = "'" <> T.replace "'" "''" trimmed <> "'"
|
||||
slashed = T.replace "\\" "\\\\" escaped in
|
||||
cs $ if escaped =~ ("\\\\" :: T.Text)
|
||||
then "E" <> slashed
|
||||
else slashed
|
||||
|
||||
trimNullChars :: T.Text -> T.Text
|
||||
trimNullChars = T.takeWhile (/= '\x0')
|
||||
|
||||
fromQt :: QualifiedTable -> T.Text
|
||||
fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
|
||||
|
||||
unquoted :: JSON.Value -> T.Text
|
||||
unquoted (JSON.String t) = t
|
||||
unquoted (JSON.Number n) =
|
||||
cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
|
||||
unquoted (JSON.Bool b) = cs . show $ b
|
||||
unquoted v = cs $ JSON.encode v
|
||||
|
||||
insertableText :: T.Text -> T.Text
|
||||
insertableText = (<> "::unknown") . pgFmtLit
|
||||
|
||||
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
|
||||
@@ -0,0 +1,175 @@
|
||||
{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,
|
||||
MultiParamTypeClasses, ScopedTypeVariables,
|
||||
FlexibleContexts #-}
|
||||
module PostgREST.PgStructure where
|
||||
|
||||
import PostgREST.PgQuery (QualifiedTable(..))
|
||||
import Data.Text hiding (foldl, map, zipWith, concat)
|
||||
import Data.Aeson
|
||||
import Data.Functor.Identity
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Control.Applicative
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
|
||||
import Prelude
|
||||
|
||||
foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
|
||||
foreignKeys table = do
|
||||
r <- H.listEx $ [H.stmt|
|
||||
select kcu.column_name, ccu.table_name AS foreign_table_name,
|
||||
ccu.column_name AS foreign_column_name
|
||||
from information_schema.table_constraints AS tc
|
||||
join information_schema.key_column_usage AS kcu
|
||||
on tc.constraint_name = kcu.constraint_name
|
||||
join information_schema.constraint_column_usage AS ccu
|
||||
on ccu.constraint_name = tc.constraint_name
|
||||
where constraint_type = 'FOREIGN KEY'
|
||||
and tc.table_name=? and tc.table_schema = ?
|
||||
order by kcu.column_name
|
||||
|] (qtName table) (qtSchema table)
|
||||
|
||||
return $ foldl addKey Map.empty r
|
||||
where
|
||||
addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey
|
||||
addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m
|
||||
|
||||
|
||||
tables :: Text -> H.Tx P.Postgres s [Table]
|
||||
tables schema = do
|
||||
rows <- H.listEx $
|
||||
[H.stmt|
|
||||
select table_schema, table_name,
|
||||
is_insertable_into
|
||||
from information_schema.tables
|
||||
where table_schema = ?
|
||||
order by table_name
|
||||
|] schema
|
||||
return $ map tableFromRow rows
|
||||
|
||||
|
||||
columns :: QualifiedTable -> H.Tx P.Postgres s [Column]
|
||||
columns table = 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 as nullable, info.data_type as col_type,
|
||||
info.is_updatable 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 = ? and table_name = ?
|
||||
) 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 position |]
|
||||
(qtSchema table) (qtName table)
|
||||
|
||||
fks <- foreignKeys table
|
||||
return $ map (addFK fks . columnFromRow) cols
|
||||
|
||||
where
|
||||
addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }
|
||||
|
||||
|
||||
primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]
|
||||
primaryKeyColumns table = do
|
||||
r <- H.listEx $ [H.stmt|
|
||||
select 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 = ?
|
||||
and kc.table_name = ? |] (qtSchema table) (qtName table)
|
||||
return $ map runIdentity r
|
||||
|
||||
|
||||
toBool :: Text -> Bool
|
||||
toBool = (== "YES")
|
||||
|
||||
data Table = Table {
|
||||
tableSchema :: Text
|
||||
, tableName :: Text
|
||||
, tableInsertable :: Bool
|
||||
} deriving (Show)
|
||||
|
||||
data ForeignKey = ForeignKey {
|
||||
fkTable::Text, fkCol::Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
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
|
||||
} deriving (Show)
|
||||
|
||||
tableFromRow :: (Text, Text, Text) -> Table
|
||||
tableFromRow (s, n, i) = Table s n (toBool i)
|
||||
|
||||
columnFromRow :: (Text, Text, Text,
|
||||
Int, Text, Text,
|
||||
Text, 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 (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing
|
||||
|
||||
where
|
||||
parseEnum :: Maybe Text -> [Text]
|
||||
parseEnum str = fromMaybe [] $ split (==',') <$> str
|
||||
|
||||
|
||||
instance ToJSON Column where
|
||||
toJSON c = object [
|
||||
"schema" .= colSchema c
|
||||
, "name" .= colName c
|
||||
, "position" .= colPosition c
|
||||
, "nullable" .= colNullable c
|
||||
, "type" .= colType c
|
||||
, "updatable" .= colUpdatable c
|
||||
, "maxLen" .= colMaxLen c
|
||||
, "precision" .= colPrecision c
|
||||
, "references".= colFK c
|
||||
, "default" .= colDefault c
|
||||
, "enum" .= colEnum c ]
|
||||
|
||||
instance ToJSON ForeignKey where
|
||||
toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
|
||||
|
||||
instance ToJSON Table where
|
||||
toJSON v = object [
|
||||
"schema" .= tableSchema v
|
||||
, "name" .= tableName v
|
||||
, "insertable" .= tableInsertable v ]
|
||||
@@ -0,0 +1,60 @@
|
||||
module PostgREST.RangeQuery (
|
||||
rangeParse
|
||||
, rangeRequested
|
||||
, rangeLimit
|
||||
, rangeOffset
|
||||
, NonnegRange
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Network.HTTP.Types.Header
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
|
||||
import Data.Ranged.Boundaries
|
||||
import Data.Ranged.Ranges
|
||||
|
||||
import Data.String.Conversions (cs)
|
||||
import Text.Regex.TDFA ((=~))
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
|
||||
import Prelude
|
||||
|
||||
type NonnegRange = Range Int
|
||||
|
||||
rangeParse :: BS.ByteString -> Maybe NonnegRange
|
||||
rangeParse range = do
|
||||
let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString
|
||||
|
||||
parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]])
|
||||
|
||||
let [_, from, to] = readMaybe . cs <$> parsedRange
|
||||
let lower = fromMaybe emptyRange (rangeGeq <$> from)
|
||||
let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)
|
||||
|
||||
return $ rangeIntersection lower upper
|
||||
|
||||
rangeRequested :: RequestHeaders -> Maybe NonnegRange
|
||||
rangeRequested = (rangeParse =<<) . lookup hRange
|
||||
|
||||
rangeLimit :: NonnegRange -> Maybe Int
|
||||
rangeLimit range =
|
||||
case [rangeLower range, rangeUpper range]
|
||||
of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
|
||||
_ -> Nothing
|
||||
|
||||
rangeOffset :: NonnegRange -> Int
|
||||
rangeOffset range =
|
||||
case rangeLower range
|
||||
of BoundaryBelow from -> from
|
||||
_ -> error "range without lower bound" -- should never happen
|
||||
|
||||
rangeGeq :: Int -> NonnegRange
|
||||
rangeGeq n =
|
||||
Range (BoundaryBelow n) BoundaryAboveAll
|
||||
|
||||
rangeLeq :: Int -> NonnegRange
|
||||
rangeLeq n =
|
||||
Range BoundaryBelowAll (BoundaryAbove n)
|
||||
Reference in New Issue
Block a user