Fix warnings, lint, and ambiguous hasql imports
This commit is contained in:
+3
-3
@@ -30,7 +30,7 @@ executable postgrest
|
||||
, scientific, time
|
||||
, aeson, network >= 2.6
|
||||
, bytestring, text, split, string-conversions
|
||||
, stringsearch, parsec
|
||||
, stringsearch
|
||||
, containers, unordered-containers
|
||||
, optparse-applicative >= 0.9.1 && < 0.10
|
||||
, regex-base, regex-tdfa
|
||||
@@ -58,7 +58,7 @@ Test-Suite spec
|
||||
default-extensions: OverloadedStrings, ScopedTypeVariables
|
||||
other-extensions: QuasiQuotes
|
||||
Hs-Source-Dirs: test, src
|
||||
ghc-options: -Wall -W
|
||||
ghc-options: -Wall -W -Werror
|
||||
Main-Is: Main.hs
|
||||
Other-Modules: App, Auth, Config, Spec, SpecHelper
|
||||
Build-Depends: base, hspec >= 2.1.2, QuickCheck
|
||||
@@ -73,7 +73,7 @@ Test-Suite spec
|
||||
, http-types, scientific, time
|
||||
, bytestring, aeson, network >= 2.6
|
||||
, text, optparse-applicative
|
||||
, stringsearch, parsec
|
||||
, stringsearch
|
||||
, unordered-containers
|
||||
, regex-base
|
||||
, string-conversions
|
||||
|
||||
+9
-7
@@ -27,16 +27,15 @@ import Data.Aeson
|
||||
import Data.Monoid
|
||||
import qualified Data.Vector as V
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Backend as H hiding (Tx)
|
||||
import qualified Hasql.Postgres as H
|
||||
import qualified Hasql.Backend as B
|
||||
import qualified Hasql.Postgres as P
|
||||
|
||||
import Auth
|
||||
import PgQuery
|
||||
import RangeQuery
|
||||
import PgStructure
|
||||
import Text.Parsec hiding (Column)
|
||||
|
||||
app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response
|
||||
app :: BL.ByteString -> Request -> H.Tx P.Postgres s Response
|
||||
app reqBody req =
|
||||
case (path, verb) of
|
||||
([], _) -> do
|
||||
@@ -55,7 +54,7 @@ app reqBody req =
|
||||
then return $ responseLBS status416 [] "HTTP Range error"
|
||||
else do
|
||||
let qt = QualifiedTable schema (cs table)
|
||||
let select = (H.Stmt "select " V.empty True) <>
|
||||
let select = B.Stmt "select " V.empty True <>
|
||||
parentheticT (
|
||||
whereT qq $ countRows qt
|
||||
) <> commaq <> (
|
||||
@@ -175,7 +174,10 @@ app reqBody req =
|
||||
range = rangeRequested hdrs
|
||||
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
|
||||
|
||||
sqlError :: t
|
||||
sqlError = undefined
|
||||
|
||||
isSqlError :: t
|
||||
isSqlError = undefined
|
||||
|
||||
rangeStatus :: Int -> Int -> Int -> Status
|
||||
@@ -207,8 +209,8 @@ requestedSchema hdrs =
|
||||
jsonH :: Header
|
||||
jsonH = (hContentType, "application/json")
|
||||
|
||||
handleJsonObj :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response)
|
||||
-> H.Tx H.Postgres s Response
|
||||
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
|
||||
|
||||
+7
-7
@@ -9,8 +9,8 @@ import Data.Text
|
||||
import Data.Monoid
|
||||
import qualified Data.Vector as V
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Backend as H hiding (Tx)
|
||||
import qualified Hasql.Postgres as H
|
||||
import qualified Hasql.Backend as B
|
||||
import qualified Hasql.Postgres as P
|
||||
import Data.String.Conversions (cs)
|
||||
import PgQuery (pgFmtLit)
|
||||
|
||||
@@ -47,20 +47,20 @@ data LoginAttempt =
|
||||
checkPass :: Text -> Text -> Bool
|
||||
checkPass = (. cs) . validatePassword . cs
|
||||
|
||||
setRole :: Text -> H.Tx H.Postgres s ()
|
||||
setRole role = H.unitEx $ H.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
|
||||
setRole :: Text -> H.Tx P.Postgres s ()
|
||||
setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
|
||||
|
||||
resetRole :: H.Tx H.Postgres s ()
|
||||
resetRole :: H.Tx P.Postgres s ()
|
||||
resetRole = H.unitEx [H.stmt|reset role|]
|
||||
|
||||
addUser :: Text -> Text -> Text -> H.Tx H.Postgres s ()
|
||||
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 H.Postgres s LoginAttempt
|
||||
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 ->
|
||||
|
||||
+12
-10
@@ -1,8 +1,10 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
|
||||
|
||||
module Error (PgError, errResponse) where
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres 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
|
||||
@@ -11,33 +13,33 @@ import Data.String.Conversions (cs)
|
||||
import Data.String.Utils(replace)
|
||||
import Network.Wai(Response, responseLBS)
|
||||
|
||||
type PgError = H.SessionError H.Postgres
|
||||
type PgError = H.SessionError P.Postgres
|
||||
|
||||
errResponse :: PgError -> Response
|
||||
errResponse e = responseLBS (httpStatus e) [] (JSON.encode e)
|
||||
|
||||
instance JSON.ToJSON PgError where
|
||||
toJSON (H.TxError (H.ErroneousResult c m d h)) = JSON.object [
|
||||
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 (H.NoResult d)) = JSON.object [
|
||||
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 (H.UnexpectedResult m)) = JSON.object ["message" .= m]
|
||||
toJSON (H.TxError H.NotInTransaction) = JSON.object [
|
||||
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 (H.CantConnect d)) = JSON.object [
|
||||
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 (H.UnsupportedVersion v)) = JSON.object [
|
||||
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 (H.ErroneousResult codeBS _ _ _)) =
|
||||
httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =
|
||||
let code = cs codeBS in
|
||||
case code of
|
||||
'0':'8':_ -> HT.status503 -- pg connection err
|
||||
@@ -63,5 +65,5 @@ httpStatus (H.TxError (H.ErroneousResult codeBS _ _ _)) =
|
||||
"42P01" -> HT.status404 -- undefined table
|
||||
"42501" -> HT.status404 -- insufficient privilege
|
||||
_ -> HT.status400
|
||||
httpStatus (H.TxError (H.NoResult _)) = HT.status503
|
||||
httpStatus (H.TxError (P.NoResult _)) = HT.status503
|
||||
httpStatus _ = HT.status500
|
||||
|
||||
+3
-4
@@ -8,7 +8,6 @@ import Error(errResponse)
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Exception
|
||||
import Data.String.Conversions (cs)
|
||||
import Network.Wai (strictRequestBody)
|
||||
import Network.Wai.Middleware.Cors (cors)
|
||||
@@ -18,7 +17,7 @@ import Network.Wai.Middleware.Static (staticPolicy, only)
|
||||
import Data.List (intercalate)
|
||||
import Data.Version (versionBranch)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import Options.Applicative hiding (columns)
|
||||
|
||||
import Config (AppConfig(..), argParser, corsPolicy)
|
||||
@@ -33,7 +32,7 @@ main = do
|
||||
Prelude.putStrLn $ "Listening on port " ++
|
||||
(show $ configPort conf :: String)
|
||||
|
||||
let pgSettings = H.ParamSettings (cs $ configDbHost conf)
|
||||
let pgSettings = P.ParamSettings (cs $ configDbHost conf)
|
||||
(fromIntegral $ configDbPort conf)
|
||||
(cs $ configDbUser conf)
|
||||
(cs $ configDbPass conf)
|
||||
@@ -50,7 +49,7 @@ main = do
|
||||
|
||||
poolSettings <- maybe (fail "Improper session settings") return $
|
||||
H.poolSettings (fromIntegral $ configPool conf) 30
|
||||
pool :: H.Pool H.Postgres
|
||||
pool :: H.Pool P.Postgres
|
||||
<- H.acquirePool pgSettings poolSettings
|
||||
|
||||
runSettings appSettings $ middle $ \req respond -> do
|
||||
|
||||
+5
-5
@@ -9,7 +9,7 @@ import Data.Text
|
||||
-- import Data.Pool(withResource, Pool)
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import Data.String.Conversions(cs)
|
||||
|
||||
import Network.HTTP.Types.Header (hLocation, hAuthorization)
|
||||
@@ -23,8 +23,8 @@ import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
|
||||
import Codec.Binary.Base64.String (decode)
|
||||
|
||||
authenticated :: forall s. Text -> Text ->
|
||||
(Request -> H.Tx H.Postgres s Response) ->
|
||||
Request -> H.Tx H.Postgres s Response
|
||||
(Request -> H.Tx P.Postgres s Response) ->
|
||||
Request -> H.Tx P.Postgres s Response
|
||||
authenticated currentRole anon app req = do
|
||||
attempt <- httpRequesterRole (requestHeaders req)
|
||||
case attempt of
|
||||
@@ -36,7 +36,7 @@ authenticated currentRole anon app req = do
|
||||
NoCredentials -> if anon /= currentRole then runInRole anon else app req
|
||||
|
||||
where
|
||||
httpRequesterRole :: RequestHeaders -> H.Tx H.Postgres s LoginAttempt
|
||||
httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
|
||||
httpRequesterRole hdrs = do
|
||||
let auth = fromMaybe "" $ lookup hAuthorization hdrs
|
||||
case split (==' ') (cs auth) of
|
||||
@@ -46,7 +46,7 @@ authenticated currentRole anon app req = do
|
||||
_ -> return MalformedAuth
|
||||
_ -> return NoCredentials
|
||||
|
||||
runInRole :: Text -> H.Tx H.Postgres s Response
|
||||
runInRole :: Text -> H.Tx P.Postgres s Response
|
||||
runInRole r = do
|
||||
setRole r
|
||||
res <- app req
|
||||
|
||||
+30
-29
@@ -5,8 +5,9 @@ module PgQuery where
|
||||
|
||||
import RangeQuery
|
||||
|
||||
import qualified Hasql.Postgres as H
|
||||
import qualified Hasql.Backend as H
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import qualified Hasql.Backend as B
|
||||
|
||||
import Data.Text hiding (map, empty)
|
||||
import Text.Regex.TDFA ( (=~) )
|
||||
@@ -23,11 +24,11 @@ import qualified Data.Aeson as JSON
|
||||
import qualified Data.List as L
|
||||
import Data.Scientific (isInteger, formatScientific, FPFormat(..))
|
||||
|
||||
type PStmt = H.Stmt H.Postgres
|
||||
type PStmt = H.Stmt P.Postgres
|
||||
instance Monoid PStmt where
|
||||
mappend (H.Stmt query params prep) (H.Stmt query' params' prep') =
|
||||
H.Stmt (query <> query') (params <> params') (prep && prep')
|
||||
mempty = H.Stmt "" empty True
|
||||
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 {
|
||||
@@ -42,7 +43,7 @@ data OrderTerm = OrderTerm {
|
||||
|
||||
limitT :: Maybe NonnegRange -> StatementT
|
||||
limitT r q =
|
||||
q <> H.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
|
||||
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
|
||||
@@ -51,7 +52,7 @@ whereT :: Net.Query -> StatementT
|
||||
whereT params q =
|
||||
if L.null cols
|
||||
then q
|
||||
else q <> H.Stmt " where " empty True <> conjunction
|
||||
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)
|
||||
@@ -60,22 +61,22 @@ orderT :: [OrderTerm] -> StatementT
|
||||
orderT ts q =
|
||||
if L.null ts
|
||||
then q
|
||||
else q <> H.Stmt " order by " empty True <> clause
|
||||
else q <> B.Stmt " order by " empty True <> clause
|
||||
where
|
||||
clause = mconcat $ L.intersperse commaq (map queryTerm ts)
|
||||
queryTerm :: OrderTerm -> PStmt
|
||||
queryTerm t = H.Stmt
|
||||
queryTerm t = B.Stmt
|
||||
(" " <> cs (pgFmtIdent $ otTerm t) <> " "
|
||||
<> cs (otDirection t) <> " ")
|
||||
empty True
|
||||
|
||||
parentheticT :: StatementT
|
||||
parentheticT s =
|
||||
s { H.stmtTemplate = " (" <> H.stmtTemplate s <> ") " }
|
||||
s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
|
||||
|
||||
iffNotT :: PStmt -> StatementT
|
||||
iffNotT (H.Stmt aq ap apre) (H.Stmt bq bp bpre) =
|
||||
H.Stmt
|
||||
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)
|
||||
@@ -83,32 +84,32 @@ iffNotT (H.Stmt aq ap apre) (H.Stmt bq bp bpre) =
|
||||
|
||||
countT :: StatementT
|
||||
countT s =
|
||||
s { H.stmtTemplate = "WITH qqq AS (" <> H.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
|
||||
s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
|
||||
|
||||
countRows :: QualifiedTable -> PStmt
|
||||
countRows t = H.Stmt ("select count(1) from " <> fromQt t) empty True
|
||||
countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True
|
||||
|
||||
asJsonWithCount :: StatementT
|
||||
asJsonWithCount s = s { H.stmtTemplate =
|
||||
asJsonWithCount s = s { B.stmtTemplate =
|
||||
"count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("
|
||||
<> H.stmtTemplate s <> ") t" }
|
||||
<> B.stmtTemplate s <> ") t" }
|
||||
|
||||
asJsonRow :: StatementT
|
||||
asJsonRow s = s { H.stmtTemplate = "row_to_json(t) from (" <> H.stmtTemplate s <> ") t" }
|
||||
asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
|
||||
|
||||
selectStar :: QualifiedTable -> PStmt
|
||||
selectStar t = H.Stmt ("select * from " <> fromQt t) empty True
|
||||
selectStar t = B.Stmt ("select * from " <> fromQt t) empty True
|
||||
|
||||
returningStarT :: StatementT
|
||||
returningStarT s = s { H.stmtTemplate = H.stmtTemplate s <> " RETURNING *" }
|
||||
returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
|
||||
|
||||
deleteFrom :: QualifiedTable -> PStmt
|
||||
deleteFrom t = H.Stmt ("delete from " <> fromQt t) empty True
|
||||
deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
|
||||
|
||||
insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
|
||||
insertInto t [] _ = H.Stmt
|
||||
insertInto t [] _ = B.Stmt
|
||||
("insert into " <> fromQt t <> " default values returning *") empty True
|
||||
insertInto t cols vals = H.Stmt
|
||||
insertInto t cols vals = B.Stmt
|
||||
("insert into " <> fromQt t <> " (" <>
|
||||
intercalate ", " (map pgFmtIdent cols) <>
|
||||
") values ("
|
||||
@@ -117,9 +118,9 @@ insertInto t cols vals = H.Stmt
|
||||
empty True
|
||||
|
||||
insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
|
||||
insertSelect t [] _ = H.Stmt
|
||||
insertSelect t [] _ = B.Stmt
|
||||
("insert into " <> fromQt t <> " default values returning *") empty True
|
||||
insertSelect t cols vals = H.Stmt
|
||||
insertSelect t cols vals = B.Stmt
|
||||
("insert into " <> fromQt t <> " ("
|
||||
<> intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") select "
|
||||
@@ -127,7 +128,7 @@ insertSelect t cols vals = H.Stmt
|
||||
empty True
|
||||
|
||||
update :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
|
||||
update t cols vals = H.Stmt
|
||||
update t cols vals = B.Stmt
|
||||
("update " <> fromQt t <> " set ("
|
||||
<> intercalate ", " (map pgFmtIdent cols)
|
||||
<> ") = ("
|
||||
@@ -136,7 +137,7 @@ update t cols vals = H.Stmt
|
||||
empty True
|
||||
|
||||
wherePred :: Net.QueryItem -> PStmt
|
||||
wherePred (col, predicate) = H.Stmt
|
||||
wherePred (col, predicate) = B.Stmt
|
||||
(" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ")
|
||||
empty True
|
||||
|
||||
@@ -169,10 +170,10 @@ orderParseTerm s =
|
||||
_ -> Nothing
|
||||
|
||||
commaq :: PStmt
|
||||
commaq = H.Stmt ", " empty True
|
||||
commaq = B.Stmt ", " empty True
|
||||
|
||||
andq :: PStmt
|
||||
andq = H.Stmt " and " empty True
|
||||
andq = B.Stmt " and " empty True
|
||||
|
||||
pgFmtIdent :: Text -> Text
|
||||
pgFmtIdent x =
|
||||
|
||||
+47
-48
@@ -3,25 +3,20 @@
|
||||
module PgStructure where
|
||||
|
||||
import PgQuery (QualifiedTable(..))
|
||||
import Data.Functor ( (<$>) )
|
||||
import Data.Text hiding (foldl, map, zipWith, concat)
|
||||
import Data.Aeson
|
||||
import Data.Functor.Identity
|
||||
import qualified Data.Vector as V
|
||||
import Data.String.Conversions (cs)
|
||||
|
||||
import Control.Applicative ( (<*>) )
|
||||
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Backend as H hiding (Tx)
|
||||
import qualified Hasql.Postgres as H
|
||||
import qualified Hasql.Postgres as P
|
||||
|
||||
foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey)
|
||||
foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
|
||||
foreignKeys table = do
|
||||
r :: [(Text, Text, Text)] <- H.listEx $ [H.stmt|
|
||||
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
|
||||
@@ -36,61 +31,65 @@ foreignKeys table = do
|
||||
|
||||
return $ foldl addKey Map.empty r
|
||||
where
|
||||
addKey m (col, ftab, fcol) = Map.insert col (ForeignKey (cs ftab) (cs fcol)) m
|
||||
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 H.Postgres s [Table]
|
||||
tables schema =
|
||||
map table <$> (H.listEx $ [H.stmt|
|
||||
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)
|
||||
|] schema
|
||||
return $ map tableFromRow rows
|
||||
|
||||
|
||||
columns :: QualifiedTable -> H.Tx H.Postgres s [Column]
|
||||
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)
|
||||
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) . column) cols
|
||||
return $ map (addFK fks . columnFromRow) cols
|
||||
|
||||
where
|
||||
addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }
|
||||
|
||||
|
||||
primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text]
|
||||
primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]
|
||||
primaryKeyColumns table = do
|
||||
r :: [Identity Text] <- H.listEx $ [H.stmt|
|
||||
r <- H.listEx $ [H.stmt|
|
||||
select kc.column_name
|
||||
from
|
||||
information_schema.table_constraints tc,
|
||||
@@ -135,13 +134,13 @@ data Column = Column {
|
||||
, colFK :: Maybe ForeignKey
|
||||
} deriving (Show)
|
||||
|
||||
table :: (Text, Text, Text) -> Table
|
||||
table (s, n, i) = Table s n (toBool i)
|
||||
tableFromRow :: (Text, Text, Text) -> Table
|
||||
tableFromRow (s, n, i) = Table s n (toBool i)
|
||||
|
||||
column :: (Text, Text, Text, Int, Text, Text, Text,
|
||||
columnFromRow :: (Text, Text, Text, Int, Text, Text, Text,
|
||||
Maybe Int, Maybe Int, Maybe Text, Text)
|
||||
-> Column
|
||||
column (s, t, n, pos, nul, typ, u, l, p, d, e) =
|
||||
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 (split (==',') e) Nothing
|
||||
|
||||
|
||||
|
||||
+2
-3
@@ -14,9 +14,7 @@ import Data.String.Conversions (cs)
|
||||
import Data.Monoid
|
||||
import Data.Text hiding (map)
|
||||
import qualified Data.Vector as V
|
||||
-- import Control.Exception.Base (bracket, finally)
|
||||
import Control.Monad (void)
|
||||
import Control.Exception
|
||||
|
||||
import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
|
||||
hRange, hAuthorization)
|
||||
@@ -28,7 +26,7 @@ import qualified Data.ByteString.Char8 as BS
|
||||
import Network.Wai.Middleware.Cors (cors)
|
||||
import System.Process (readProcess)
|
||||
|
||||
import App (app, sqlError, isSqlError)
|
||||
import App (app)
|
||||
import Config (AppConfig(..), corsPolicy)
|
||||
import Middleware
|
||||
import Error(errResponse)
|
||||
@@ -44,6 +42,7 @@ cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "post
|
||||
testSettings :: PoolSettings
|
||||
testSettings = fromMaybe (error "bad settings") $ H.poolSettings 1 30
|
||||
|
||||
pgSettings :: H.Settings
|
||||
pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test"
|
||||
|
||||
withApp :: ActionWith Application -> IO ()
|
||||
|
||||
Reference in New Issue
Block a user