jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

WIP: Upgrade to hasql 7

Browse Source 
Still fails handling query errors
This commit is contained in:
Joe Nelson
2015-01-25 18:33:50 -08:00
parent 8073c84809
commit b504473790
9 changed files with 204 additions and 358 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+7 -8
View File
@@ -17,11 +17,11 @@ executable postgrest
main-is: Main.hs
ghc-options: -Wall -W -O2
default-language: Haskell2010
default-extensions: OverloadedStrings
default-extensions: OverloadedStrings, ScopedTypeVariables
other-extensions: QuasiQuotes
build-depends: base >=4.6 && <5
, hasql == 0.4.*, hasql-backend
, hasql-postgres == 0.8.*
, hasql == 0.7.*, hasql-backend
, hasql-postgres == 0.10.*
, warp >= 3.0.2, wai >= 3.0.1
, wai-extra, wai-cors
, wai-middleware-static >= 0.6.0
@@ -48,7 +48,6 @@ executable postgrest
, Config
, PgStructure
, PgQuery
, PgError
, RangeQuery
, Middleware
hs-source-dirs: src
@@ -56,16 +55,16 @@ executable postgrest
Test-Suite spec
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
default-extensions: OverloadedStrings
default-extensions: OverloadedStrings, ScopedTypeVariables
other-extensions: QuasiQuotes
Hs-Source-Dirs: test, src
ghc-options: -Wall -W -Werror
ghc-options: -Wall -W
Main-Is: Main.hs
Other-Modules: App, Auth, Config, Spec, SpecHelper
Build-Depends: base, hspec >= 2.1.2, QuickCheck
, hspec-wai >= 0.5.0, hspec-wai-json
, hasql == 0.4.*, hasql-backend
, hasql-postgres == 0.8.*
, hasql == 0.7.*, hasql-backend
, hasql-postgres == 0.10.*
, warp >= 3.0.2, wai >= 3.0.1
, HTTP, convertible
, case-insensitive
src/App.hs
+48 -43
View File
@@ -25,14 +25,15 @@ import Network.Wai
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 Auth
import PgQuery
import RangeQuery
import PgStructure
import PgError
import Text.Parsec hiding (Column)
app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response
@@ -54,8 +55,7 @@ app reqBody req =
then return $ responseLBS status416 [] "HTTP Range error"
else do
let qt = QualifiedTable schema (cs table)
let select = coerce $
("select ",[],mempty) <>
let select = (H.Stmt "select " V.empty True) <>
parentheticT (
whereT qq $ countRows qt
) <> commaq <> (
@@ -65,7 +65,7 @@ app reqBody req =
. whereT qq
$ selectStar qt
)
row <- H.single select
row <- H.maybeEx select
let (tableTotal, queryTotal, body) =
fromMaybe (0, 0, Just "" :: Maybe Text) row
from = fromMaybe 0 $ rangeOffset <$> range
@@ -102,9 +102,8 @@ app reqBody req =
([table], "POST") ->
handleJsonObj reqBody $ \obj -> do
let qt = QualifiedTable schema (cs table)
query = coerce $
insertInto qt (map cs $ keys obj) (elems obj)
row <- H.single query
query = insertInto qt (map cs $ keys obj) (elems obj)
row <- H.maybeEx query
let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row
Just inserted = decode (cs insertedJson) :: Maybe Object
@@ -134,7 +133,7 @@ app reqBody req =
if S.fromList tableCols == S.fromList cols
then do
let vals = elems obj
H.unit . coerce $ iffNotT
H.unitEx $ iffNotT
(whereT qq $ update qt cols vals)
(insertSelect qt cols vals)
return $ responseLBS status204 [ jsonH ] ""
@@ -147,19 +146,18 @@ app reqBody req =
([table], "PATCH") ->
handleJsonObj reqBody $ \obj -> do
let qt = QualifiedTable schema (cs table)
H.unit
$ coerce
H.unitEx
$ whereT qq
$ update qt (map cs $ keys obj) (elems obj)
return $ responseLBS status204 [ jsonH ] ""
([table], "DELETE") -> do
let qt = QualifiedTable schema (cs table)
let del = coerce $ countT
let del = countT
. returningStarT
. whereT qq
$ deleteFrom qt
row <- H.single del
row <- H.maybeEx del
let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
return $ if deletedCount == 0
then responseLBS status404 [] ""
@@ -176,38 +174,9 @@ app reqBody req =
schema = requestedSchema hdrs
range = rangeRequested hdrs
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
coerce (q, args, All b) = (q, args, b)
isSqlError :: H.Error -> Maybe H.Error
isSqlError = Just
sqlError :: H.Error -> Response
sqlError err =
let inside = case err of
H.CantConnect _ ->
"Message: \"Cannot connect to postgres server\""
H.ConnectionLost t -> t
H.ErroneousResult t -> t
H.UnexpectedResult t -> t
H.UnparsableTemplate t -> t
H.UnparsableRow t -> t
H.NotInTransaction -> "An operation which requires a"
<> "database transaction was executed without one" in
either
(\hint ->
responseLBS status500
[(hContentType, "application/json")]
(cs . encode . object $ [
("message", String $
"Failed to parse exception:" <> inside)
, ("hint", String . cs . show $ hint)]))
(\msg ->
responseLBS (httpStatus msg)
[(hContentType, "application/json")]
(encode msg))
(parse message "" inside)
sqlError = undefined
isSqlError = undefined
rangeStatus :: Int -> Int -> Int -> Status
rangeStatus from to total
@@ -255,6 +224,42 @@ handleJsonObj reqBody handler = do
jErr = encode . object $
[("message", String "Expecting a JSON object")]
-- httpStatus :: H.TxError H.Postgres -> Status
-- httpStatus (H.ErroneousResult codeBS _ _ _) =
-- let code = cs codeBS in
-- case code of
-- '0' : '8' : _ -> status503 -- pg connection err
-- '0' : '9' : _ -> status500 -- triggered action exception
-- '0' : 'L' : _ -> status403 -- invalid grantor
-- '0' : 'P' : _ -> status403 -- invalid role specification
-- '2' : '5' : _ -> status500 -- invalid tx state
-- '2' : '8' : _ -> status403 -- invalid auth specification
-- '2' : 'D' : _ -> status500 -- invalid tx termination
-- '3' : '8' : _ -> status500 -- external routine exception
-- '3' : '9' : _ -> status500 -- external routine invocation
-- '3' : 'B' : _ -> status500 -- savepoint exception
-- '4' : '0' : _ -> status500 -- tx rollback
-- '5' : '3' : _ -> status503 -- insufficient resources
-- '5' : '4' : _ -> status413 -- too complex
-- '5' : '5' : _ -> status500 -- obj not on prereq state
-- '5' : '7' : _ -> status500 -- operator intervention
-- '5' : '8' : _ -> status500 -- system error
-- 'F' : '0' : _ -> status500 -- conf file error
-- 'H' : 'V' : _ -> status500 -- foreign data wrapper error
-- 'P' : '0' : _ -> status500 -- PL/pgSQL Error
-- 'X' : 'X' : _ -> status500 -- internal Error
-- "42P01" -> status404 -- undefined table
-- "42501" -> status404 -- insufficient privilege
-- _ -> status400
-- httpStatus (H.NoResult _) = status503 -- Received no response from the database.
-- -- (Maybe ByteString argument)
-- httpStatus (H.UnexpectedResult _) = status500 -- The database returned an unexpected result.
-- -- Indicates an improper statement or a schema mismatch.
-- -- (Text argument)
-- httpStatus H.NotInTransaction = status500
data TableOptions = TableOptions {
tblOptcolumns :: [Column]
, tblOptpkey :: [Text]
src/Auth.hs
+7 -5
View File
@@ -7,7 +7,9 @@ import Control.Applicative ( (<*>), (<$>) )
import Crypto.BCrypt
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 Data.String.Conversions (cs)
import PgQuery (pgFmtLit)
@@ -46,21 +48,21 @@ checkPass :: Text -> Text -> Bool
checkPass = (. cs) . validatePassword . cs
setRole :: Text -> H.Tx H.Postgres s ()
setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True)
setRole role = H.unitEx $ H.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
resetRole :: H.Tx H.Postgres s ()
resetRole = H.unit [H.q|reset role|]
resetRole = H.unitEx [H.stmt|reset role|]
addUser :: Text -> Text -> Text -> H.Tx H.Postgres s ()
addUser identity pass role = do
let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
H.unit $
[H.q|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
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 user pass = do
u <- H.single $ [H.q|select pass, rolname from postgrest.auth where id = ?|] user
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
src/Main.hs
+12 -12
View File
@@ -37,11 +37,7 @@ main = do
(cs $ configDbUser conf)
(cs $ configDbPass conf)
(cs $ configDbName conf)
sessSettings <- maybe (fail "Improper session settings") return $
H.sessionSettings (fromIntegral $ configPool conf) 30
let appSettings = setPort port
appSettings = setPort port
. setServerName (cs $ "postgrest/" <> prettyVersion)
$ defaultSettings
middle =
@@ -51,13 +47,17 @@ main = do
anonRole = cs $ configAnonRole conf
currRole = cs $ configDbUser conf
H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift ->
liftIO $ runSettings appSettings $ middle $ \req respond -> do
body <- strictRequestBody req
respond =<< catchJust isSqlError
(unlift $ H.tx Nothing
$ authenticated currRole anonRole (app body) req)
(return . sqlError)
poolSettings <- maybe (fail "Improper session settings") return $
H.poolSettings (fromIntegral $ configPool conf) 30
pool :: H.Pool H.Postgres
<- H.acquirePool pgSettings poolSettings
runSettings appSettings $ middle $ \req respond -> do
body <- strictRequestBody req
thing <- liftIO $ H.session pool $ H.tx Nothing $ authenticated currRole anonRole (app body) req
case thing of
Right r -> respond r
Left _ -> undefined
where
describe = progDesc "create a REST API to an existing Postgres database"
src/PgError.hs
-86
View File
@@ -1,86 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module PgError (Message(..), message, httpStatus) where
import Text.Parsec
import Text.Parsec.Text
import qualified Data.Map as M
import Text.Regex.TDFA.Text ()
import Data.Text hiding (drop, concat, head)
import Data.Aeson
import Data.Maybe
import Control.Monad (void)
import Data.String.Conversions (cs)
import Data.CaseInsensitive (CI, mk)
import Network.HTTP.Types.Status
data Message = Message {
msgStatus :: Maybe Text
, msgCode :: Text
, msgText :: Maybe Text
, msgHint :: Maybe Text
} deriving (Show, Eq)
message :: Parser Message
message = do
ps <- sepBy valPair (char ';')
let m = M.fromList ps
return $ Message
(M.lookup "status" m)
(fromMaybe "" $ M.lookup "code" m)
(M.lookup "message" m)
(M.lookup "hint" m)
valPair :: Parser (CI Text, Text)
valPair = do
_ <- spaces
name <- many1 letter
_ <- char ':'
spaces
_ <- many $ char '"'
val <- manyTill anyChar $
try
(void $ many (char '"') >> (
(void . lookAhead $ (char ';'))
<|> ((optional $ char '.') >> eof)
))
return (mk (cs name), cs val)
instance ToJSON Message where
toJSON t = object [
"message" .= msgText t
, "code" .= msgCode t
, "status" .= msgStatus t
, "hint" .= msgHint t
]
httpStatus :: Message -> Status
httpStatus m =
let code = cs $ msgCode m :: String in
case code of
'0' : '8' : _ -> status503 -- pg connection err
'0' : '9' : _ -> status500 -- triggered action exception
'0' : 'L' : _ -> status403 -- invalid grantor
'0' : 'P' : _ -> status403 -- invalid role specification
'2' : '5' : _ -> status500 -- invalid tx state
'2' : '8' : _ -> status403 -- invalid auth specification
'2' : 'D' : _ -> status500 -- invalid tx termination
'3' : '8' : _ -> status500 -- external routine exception
'3' : '9' : _ -> status500 -- external routine invocation
'3' : 'B' : _ -> status500 -- savepoint exception
'4' : '0' : _ -> status500 -- tx rollback
'5' : '3' : _ -> status503 -- insufficient resources
'5' : '4' : _ -> status413 -- too complex
'5' : '5' : _ -> status500 -- obj not on prereq state
'5' : '7' : _ -> status500 -- operator intervention
'5' : '8' : _ -> status500 -- system error
'F' : '0' : _ -> status500 -- conf file error
'H' : 'V' : _ -> status500 -- foreign data wrapper error
'P' : '0' : _ -> status500 -- PL/pgSQL Error
'X' : 'X' : _ -> status500 -- internal Error
"42P01" -> status404 -- undefined table
"42501" -> status404 -- insufficient privilege
_ -> status400
src/PgQuery.hs
+76 -104
View File
@@ -1,4 +1,6 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module PgQuery where
import RangeQuery
@@ -6,12 +8,13 @@ import RangeQuery
import qualified Hasql.Postgres as H
import qualified Hasql.Backend as H
import Data.Text hiding (map)
import Data.Text hiding (map, empty)
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)
@@ -20,9 +23,12 @@ import qualified Data.Aeson as JSON
import qualified Data.List as L
import Data.Scientific (isInteger, formatScientific, FPFormat(..))
type DynamicSQL = (BS.ByteString, [H.StatementArgument H.Postgres], All)
type StatementT = DynamicSQL -> DynamicSQL
type PStmt = H.Stmt H.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
type StatementT = PStmt -> PStmt
data QualifiedTable = QualifiedTable {
qtSchema :: Text
@@ -36,7 +42,7 @@ data OrderTerm = OrderTerm {
limitT :: Maybe NonnegRange -> StatementT
limitT r q =
q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty)
q <> H.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
where
limit = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
@@ -45,7 +51,7 @@ whereT :: Net.Query -> StatementT
whereT params q =
if L.null cols
then q
else q <> (" where ",[],mempty) <> conjunction
else q <> H.Stmt " where " empty True <> conjunction
where
cols = [ col | col <- params, fst col `notElem` ["order"] ]
conjunction = mconcat $ L.intersperse andq (map wherePred cols)
@@ -54,108 +60,85 @@ orderT :: [OrderTerm] -> StatementT
orderT ts q =
if L.null ts
then q
else q <> (" order by ",[],mempty) <> clause
else q <> H.Stmt " order by " empty True <> clause
where
clause = mconcat $ L.intersperse commaq (map queryTerm ts)
queryTerm :: OrderTerm -> DynamicSQL
queryTerm t = (" " <> cs (pgFmtIdent $ otTerm t) <> " "
<> otDirection t <> " "
, [], mempty)
queryTerm :: OrderTerm -> PStmt
queryTerm t = H.Stmt
(" " <> cs (pgFmtIdent $ otTerm t) <> " "
<> cs (otDirection t) <> " ")
empty True
parentheticT :: StatementT
parentheticT (sql, params, pre) =
(" (" <> sql <> ") ", params, pre)
parentheticT s =
s { H.stmtTemplate = " (" <> H.stmtTemplate s <> ") " }
iffNotT :: DynamicSQL -> StatementT
iffNotT (aq, ap, apre) (bq, bp, bpre) =
("WITH aaa AS (" <> aq <> " returning *) " <>
bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)"
, ap ++ bp
, All $ getAll apre && getAll bpre
)
iffNotT :: PStmt -> StatementT
iffNotT (H.Stmt aq ap apre) (H.Stmt bq bp bpre) =
H.Stmt
("WITH aaa AS (" <> aq <> " returning *) " <>
bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
(ap <> bp)
(apre && bpre)
countT :: StatementT
countT (sql, params, pre) =
("WITH qqq AS (" <> sql <> ") SELECT count(1) FROM qqq"
, params
, pre)
countT s =
s { H.stmtTemplate = "WITH qqq AS (" <> H.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
countRows :: QualifiedTable -> DynamicSQL
countRows t =
("select count(1) from " <> fromQt t, [], mempty)
countRows :: QualifiedTable -> PStmt
countRows t = H.Stmt ("select count(1) from " <> fromQt t) empty True
asJsonWithCount :: StatementT
asJsonWithCount (sql, params, pre) = (
"count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" <> sql <> ") t"
, params, pre
)
asJsonWithCount s = s { H.stmtTemplate =
"count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("
<> H.stmtTemplate s <> ") t" }
asJsonRow :: StatementT
asJsonRow (sql, params, pre) = (
"row_to_json(t) from (" <> sql <> ") t", params, pre
)
asJsonRow s = s { H.stmtTemplate = "row_to_json(t) from (" <> H.stmtTemplate s <> ") t" }
selectStar :: QualifiedTable -> DynamicSQL
selectStar t =
("select * from " <> fromQt t, [], mempty)
selectStar :: QualifiedTable -> PStmt
selectStar t = H.Stmt ("select * from " <> fromQt t) empty True
returningStarT :: StatementT
returningStarT (sql, params, pre) =
(sql <> " RETURNING *", params, pre)
returningStarT s = s { H.stmtTemplate = H.stmtTemplate s <> " RETURNING *" }
deleteFrom :: QualifiedTable -> DynamicSQL
deleteFrom t =
("delete from " <> fromQt t, [], mempty)
deleteFrom :: QualifiedTable -> PStmt
deleteFrom t = H.Stmt ("delete from " <> fromQt t) empty True
insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
insertInto t [] _ =
("insert into " <> fromQt t <> " default values returning *", [], mempty)
insertInto t cols vals =
insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
insertInto t [] _ = H.Stmt
("insert into " <> fromQt t <> " default values returning *") empty True
insertInto t cols vals = H.Stmt
("insert into " <> fromQt t <> " (" <>
cs (intercalate ", " (map pgFmtIdent cols)) <>
") values (" <>
cs (
intercalate ", " (map
((<> "::unknown") . pgFmtLit . unquoted)
vals)
) <> ") returning row_to_json(" <> fromQt t <> ".*)"
, []
, mempty
)
intercalate ", " (map pgFmtIdent cols) <>
") values ("
<> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
<> ") returning row_to_json(" <> fromQt t <> ".*)")
empty True
insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
insertSelect t [] _ =
("insert into " <> fromQt t <> " default values returning *", [], mempty)
insertSelect t cols vals =
("insert into " <> fromQt t <> " (" <>
cs (intercalate ", " (map pgFmtIdent cols)) <>
") select " <>
cs (
intercalate ", " (map
((<> "::unknown") . pgFmtLit . unquoted)
vals)
)
, []
, mempty
)
insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
insertSelect t [] _ = H.Stmt
("insert into " <> fromQt t <> " default values returning *") empty True
insertSelect t cols vals = H.Stmt
("insert into " <> fromQt t <> " ("
<> intercalate ", " (map pgFmtIdent cols)
<> ") select "
<> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals))
empty True
update :: QualifiedTable -> [Text] -> [JSON.Value] -> DynamicSQL
update t cols vals =
("update " <> fromQt t <> " set (" <>
cs (intercalate ", " (map pgFmtIdent cols)) <>
") = (" <>
cs (
intercalate ", " (map
((<> "::unknown") . pgFmtLit . unquoted)
vals)
) <> ")"
, []
, mempty
)
update :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
update t cols vals = H.Stmt
("update " <> fromQt t <> " set ("
<> intercalate ", " (map pgFmtIdent cols)
<> ") = ("
<> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
<> ")")
empty True
wherePred :: Net.QueryItem -> DynamicSQL
wherePred (col, predicate) =
(" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ", [], mempty)
wherePred :: Net.QueryItem -> PStmt
wherePred (col, predicate) = H.Stmt
(" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ")
empty True
where
opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate
@@ -185,11 +168,11 @@ orderParseTerm s =
else Nothing
_ -> Nothing
commaq :: DynamicSQL
commaq = (", ", [], mempty)
commaq :: PStmt
commaq = H.Stmt ", " empty True
andq :: DynamicSQL
andq = (" and ", [], mempty)
andq :: PStmt
andq = H.Stmt " and " empty True
pgFmtIdent :: Text -> Text
pgFmtIdent x =
@@ -212,8 +195,8 @@ pgFmtLit x =
trimNullChars :: Text -> Text
trimNullChars = Data.Text.takeWhile (/= '\x0')
fromQt :: QualifiedTable -> BS.ByteString
fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
fromQt :: QualifiedTable -> Text
fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
unquoted :: JSON.Value -> Text
unquoted (JSON.String t) = t
@@ -221,14 +204,3 @@ unquoted (JSON.Number n) =
cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
unquoted (JSON.Bool b) = cs . show $ b
unquoted _ = ""
pgParam :: JSON.Value -> H.StatementArgument H.Postgres
pgParam (JSON.Number n) = H.renderValue
(cs $ formatScientific Fixed
(if isInteger n then Just 0 else Nothing) n :: Text)
pgParam (JSON.String s) = H.renderValue s
pgParam (JSON.Bool b) = H.renderValue $
if b then "t" else "f" :: Text
pgParam JSON.Null = H.renderValue (Nothing :: Maybe Text)
pgParam (JSON.Object o) = H.renderValue $ JSON.encode o
pgParam (JSON.Array a) = H.renderValue $ JSON.encode a
src/PgStructure.hs
+17 -36
View File
@@ -16,12 +16,12 @@ import qualified Data.List as L
import qualified Data.Map as Map
import qualified Hasql as H
import qualified Hasql.Backend as H
import qualified Hasql.Backend as H hiding (Tx)
import qualified Hasql.Postgres as H
foreignKeys :: QualifiedTable -> H.Tx H.Postgres s (Map.Map Text ForeignKey)
foreignKeys table = do
r :: [(Text, Text, Text)] <- H.list $ [H.q|
r :: [(Text, Text, Text)] <- 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
@@ -41,18 +41,18 @@ foreignKeys table = do
tables :: Text -> H.Tx H.Postgres s [Table]
tables schema =
H.list $ [H.q|
map table <$> (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)
columns :: QualifiedTable -> H.Tx H.Postgres s [Column]
columns table = do
cols <- H.list $ [H.q|
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,
@@ -82,12 +82,15 @@ columns table = do
order by position |] (qtSchema table) (qtName table)
fks <- foreignKeys table
return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) cols
return $ map ((addFK fks) . column) cols
where
addFK fks = (\col -> col { colFK = Map.lookup (cs . colName $ col) fks })
primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text]
primaryKeyColumns table = do
r :: [Identity Text] <- H.list $ [H.q|
r :: [Identity Text] <- H.listEx $ [H.stmt|
select kc.column_name
from
information_schema.table_constraints tc,
@@ -132,37 +135,15 @@ data Column = Column {
, colFK :: Maybe ForeignKey
} deriving (Show)
instance H.RowParser H.Postgres Column where
parseRow r =
let schema = H.parseResult $ r V.! 0
table = H.parseResult $ r V.! 1
name = H.parseResult $ r V.! 2
position = H.parseResult $ r V.! 3
nullable = toBool <$> (H.parseResult $ r V.! 4 :: Either Text Text)
typ = H.parseResult $ r V.! 5
updatable = toBool <$> (H.parseResult $ r V.! 6 :: Either Text Text)
maxLen = H.parseResult $ r V.! 7
precision = H.parseResult $ r V.! 8
defValue = H.parseResult $ r V.! 9
enum = either (const $ Right []) (Right . split (==','))
(H.parseResult $ r V.! 10 :: Either Text Text)
in
if V.length r /= 11
then Left "Wrong number of fields in Column"
else Column <$> schema <*> table <*> name <*> position <*> nullable
<*> typ <*> updatable <*> maxLen <*> precision
<*> defValue <*> enum
<*> return Nothing
table :: (Text, Text, Bool) -> Table
table (s, n, i) = Table s n i
column :: (Text, Text, Text, Int, Text, Text, Text,
Maybe Int, Maybe Int, Maybe Text, Text)
-> Column
column (a, b, c, d, e, f, g, h, i, j, k) =
Column a b c d (toBool e) f (toBool g) h i j (split (==',') k) Nothing
instance H.RowParser H.Postgres Table where
parseRow r =
let schema = H.parseResult $ r V.! 0
name = H.parseResult $ r V.! 1
insertable = toBool <$> (H.parseResult $ r V.! 2 :: Either Text Text) in
if V.length r /= 3
then Left "Wrong number of fields in Table"
else Table <$> schema <*> name <*> insertable
instance ToJSON Column where
toJSON c = object [
test/SpecHelper.hs
+37 -23
View File
@@ -7,10 +7,13 @@ import Test.Hspec
import Test.Hspec.Wai
import Hasql as H
import Hasql.Backend as H
import Hasql.Postgres as H
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
@@ -37,35 +40,40 @@ isLeft _ = False
cfg :: AppConfig
cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10
testSettings :: SessionSettings
testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30
testSettings :: PoolSettings
testSettings = fromMaybe (error "bad settings") $ H.poolSettings 1 30
pgSettings :: Postgres
pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test"
withApp :: ActionWith Application -> IO ()
withApp perform =
withApp perform = do
let anonRole = cs $ configAnonRole cfg
currRole = cs $ configDbUser cfg in
perform $ middle $ \req resp ->
H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift ->
liftIO $ do
body <- strictRequestBody req
resp =<< catchJust isSqlError
(unlift $ H.tx Nothing
$ authenticated currRole anonRole (app body) req)
(return . sqlError)
currRole = cs $ configDbUser cfg
pool :: H.Pool H.Postgres
<- H.acquirePool pgSettings testSettings
perform $ middle $ \req resp -> do
body <- strictRequestBody req
result <- liftIO
$ H.session pool
$ H.tx Nothing
$ authenticated currRole anonRole (app body) req
resp $ case result of
Right r -> r
Left _ -> error "hahahaha"
where middle = cors corsPolicy
resetDb :: IO ()
resetDb = do
H.session pgSettings testSettings $
pool :: H.Pool H.Postgres
<- H.acquirePool pgSettings testSettings
void . liftIO $ H.session pool $
H.tx Nothing $ do
H.unit [H.q| drop schema if exists "1" cascade |]
H.unit [H.q| drop schema if exists private cascade |]
H.unit [H.q| drop schema if exists postgrest cascade |]
H.unitEx [H.stmt| drop schema if exists "1" cascade |]
H.unitEx [H.stmt| drop schema if exists private cascade |]
H.unitEx [H.stmt| drop schema if exists postgrest cascade |]
loadFixture "roles"
loadFixture "schema"
@@ -90,15 +98,21 @@ authHeader :: String -> String -> Header
authHeader u p =
(hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
clearTable :: BS.ByteString -> IO ()
clearTable table = H.session pgSettings testSettings $ H.tx Nothing $
H.unit ("delete from \"1\"."<>table, [], True)
clearTable :: Text -> IO ()
clearTable table = do
pool :: H.Pool H.Postgres
<- H.acquirePool pgSettings testSettings
void . liftIO $ H.session pool $ H.tx Nothing $
H.unitEx $ H.Stmt ("delete from \"1\"."<>table) V.empty True
createItems :: Int -> IO ()
createItems n = H.session pgSettings testSettings $ H.tx Nothing txn
createItems n = do
pool :: H.Pool H.Postgres
<- H.acquirePool pgSettings testSettings
void . liftIO $ H.session pool $ H.tx Nothing txn
where
txn = sequence_ $ map H.unit stmts
stmts = map [H.q|insert into "1".items (id) values (?)|] [1..n]
txn = sequence_ $ map H.unitEx stmts
stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n]
-- for hspec-wai
pending_ :: WaiSession ()
test/Unit/ErrorsSpec.hs
-41
View File
@@ -1,41 +0,0 @@
module Unit.ErrorsSpec where
import Test.Hspec
import Text.Parsec
import PgError
import Data.Either (rights)
spec :: Spec
spec =
describe "Parsing Hasql errors" $ do
it "can handle status and code" $
let p = parse message "" "Status: \"foo\"; Code: \"abc\"." in
rights [p] `shouldBe` [
Message (Just "foo") "abc" Nothing Nothing
]
it "can handle weird redundant quotes in status" $
let p = parse message "" "Status: \"\"foo\"\"; Code: \"abc\"." in
rights [p] `shouldBe` [
Message (Just "foo") "abc" Nothing Nothing
]
it "can handle text and code" $
let p = parse message "" "Message: \"foo\"; Code: \"abc\"." in
rights [p] `shouldBe` [
Message Nothing "abc" (Just "foo") Nothing
]
it "can handle status, text and code" $
let p = parse message "" "Status: \"hi\"; Message: \"foo\"; Code: \"abc\"." in
rights [p] `shouldBe` [
Message (Just "hi") "abc" (Just "foo") Nothing
]
it "can handle unescaped quotes in message" $
let p = parse message "" "Status: \"hi\"; Message: \"unknown \"foo\"!\"; Code: \"abc\"." in
rights [p] `shouldBe` [
Message (Just "hi") "abc" (Just "unknown \"foo\"!") Nothing
]
it "can handle periods in message" $
let p = parse message "" "Message: \"unknown \"foo\".bar\"; Code: \"42P01\"." in
rights [p] `shouldBe` [
Message Nothing "42P01" (Just "unknown \"foo\".bar") Nothing
]