diff --git a/postgrest.cabal b/postgrest.cabal index f0f0bede0..20fb5f932 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs index 19c3e4122..927ba2427 100644 --- a/src/App.hs +++ b/src/App.hs @@ -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] diff --git a/src/Auth.hs b/src/Auth.hs index da315403f..14dc23b11 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 224ccf008..79c1ea3a0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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" diff --git a/src/PgError.hs b/src/PgError.hs deleted file mode 100644 index 3f7db9506..000000000 --- a/src/PgError.hs +++ /dev/null @@ -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 diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 2aa95071f..ee6bbdbc4 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -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 diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 8c151936f..de6fff76c 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -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 [ diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index dfe9bc20b..5ab2b3a21 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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 () diff --git a/test/Unit/ErrorsSpec.hs b/test/Unit/ErrorsSpec.hs deleted file mode 100644 index c29524848..000000000 --- a/test/Unit/ErrorsSpec.hs +++ /dev/null @@ -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 - ]