From b5044737901f1a6a539e8b01340be91510c1e1c8 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sun, 25 Jan 2015 18:33:50 -0800 Subject: [PATCH 1/9] WIP: Upgrade to hasql 7 Still fails handling query errors --- postgrest.cabal | 15 ++-- src/App.hs | 91 ++++++++++---------- src/Auth.hs | 12 +-- src/Main.hs | 24 +++--- src/PgError.hs | 86 ------------------- src/PgQuery.hs | 180 +++++++++++++++++----------------------- src/PgStructure.hs | 53 ++++-------- test/SpecHelper.hs | 60 +++++++++----- test/Unit/ErrorsSpec.hs | 41 --------- 9 files changed, 204 insertions(+), 358 deletions(-) delete mode 100644 src/PgError.hs delete mode 100644 test/Unit/ErrorsSpec.hs 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 - ] From ead346816b24b0589de94dd50e5c1e32d02bace2 Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Mon, 26 Jan 2015 17:31:59 -0800 Subject: [PATCH 2/9] reporting errors, but not passing tests. --- postgrest.cabal | 8 +++--- src/Error.hs | 67 ++++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 7 +++-- test/SpecHelper.hs | 9 +++---- 4 files changed, 76 insertions(+), 15 deletions(-) create mode 100644 src/Error.hs diff --git a/postgrest.cabal b/postgrest.cabal index 20fb5f932..97bd66fec 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -36,7 +36,7 @@ executable postgrest , regex-base, regex-tdfa , regex-tdfa-text , Ranged-sets - , transformers + , transformers, MissingH , bcrypt, base64-string , network-uri >= 2.6 , resource-pool @@ -80,10 +80,8 @@ Test-Suite spec , http-media, regex-tdfa , regex-tdfa-text , Ranged-sets - , transformers - , bcrypt - , base64-string - , split + , transformers, MissingH, split + , bcrypt, base64-string , network-uri >= 2.6 , resource-pool , blaze-builder diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 index 000000000..f837b27c5 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module Error (PgError, errResponse) where + +import qualified Hasql as H +import qualified Hasql.Postgres as H +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) + +type PgError = H.SessionError H.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 [ + "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 [ + "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 [ + "message" .= ("Not in transaction"::T.Text)] + toJSON (H.CxError (H.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 [ + "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 _ _ _)) = + 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 (H.NoResult _)) = HT.status503 +httpStatus _ = HT.status500 diff --git a/src/Main.hs b/src/Main.hs index 79c1ea3a0..7dc81bc62 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -54,10 +54,9 @@ main = do 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 + resOrError <- liftIO $ H.session pool $ H.tx Nothing $ + authenticated currRole anonRole (app body) req + either (undefined) respond resOrError where describe = progDesc "create a REST API to an existing Postgres database" diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 5ab2b3a21..e29baa44e 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -31,6 +31,7 @@ import System.Process (readProcess) import App (app, sqlError, isSqlError) import Config (AppConfig(..), corsPolicy) import Middleware +import Error(errResponse) -- import Auth (addUser) isLeft :: Either a b -> Bool @@ -54,13 +55,9 @@ withApp perform = do perform $ middle $ \req resp -> do body <- strictRequestBody req - result <- liftIO - $ H.session pool - $ H.tx Nothing + result <- liftIO $ H.session pool $ H.tx Nothing $ authenticated currRole anonRole (app body) req - resp $ case result of - Right r -> r - Left _ -> error "hahahaha" + either (resp . errResponse) resp result where middle = cors corsPolicy From e1ad5cb1aea761bbb219de5878f7e3e69bed2754 Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Mon, 26 Jan 2015 18:07:38 -0800 Subject: [PATCH 3/9] handle errors in the app too --- src/App.hs | 35 ----------------------------------- src/Main.hs | 3 ++- 2 files changed, 2 insertions(+), 36 deletions(-) diff --git a/src/App.hs b/src/App.hs index 927ba2427..0cf77de09 100644 --- a/src/App.hs +++ b/src/App.hs @@ -225,41 +225,6 @@ handleJsonObj reqBody handler = do [("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/Main.hs b/src/Main.hs index 7dc81bc62..2ac10b4cf 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,6 +4,7 @@ import Paths_postgrest (version) import App import Middleware +import Error(errResponse) import Control.Monad (unless) import Control.Monad.IO.Class (liftIO) @@ -56,7 +57,7 @@ main = do body <- strictRequestBody req resOrError <- liftIO $ H.session pool $ H.tx Nothing $ authenticated currRole anonRole (app body) req - either (undefined) respond resOrError + either (respond . errResponse) respond resOrError where describe = progDesc "create a REST API to an existing Postgres database" From 3151aa2ebcc564b65a384edcde38debab29c26c1 Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Mon, 26 Jan 2015 18:42:46 -0800 Subject: [PATCH 4/9] fix table parsing --- src/PgStructure.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/PgStructure.hs b/src/PgStructure.hs index de6fff76c..11b8c9154 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -85,7 +85,7 @@ columns table = do return $ map ((addFK fks) . column) cols where - addFK fks = (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) + addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks } primaryKeyColumns :: QualifiedTable -> H.Tx H.Postgres s [Text] @@ -135,14 +135,14 @@ data Column = Column { , colFK :: Maybe ForeignKey } deriving (Show) -table :: (Text, Text, Bool) -> Table -table (s, n, i) = Table s n i +table :: (Text, Text, Text) -> Table +table (s, n, i) = Table s n (toBool 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 +column (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 instance ToJSON Column where From da6318f5a26719262afd209723fe46a53a169587 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 28 Jan 2015 11:06:49 -0800 Subject: [PATCH 5/9] Fix warnings, lint, and ambiguous hasql imports --- postgrest.cabal | 6 +-- src/App.hs | 16 ++++---- src/Auth.hs | 14 +++---- src/Error.hs | 22 ++++++----- src/Main.hs | 7 ++-- src/Middleware.hs | 10 ++--- src/PgQuery.hs | 59 ++++++++++++++-------------- src/PgStructure.hs | 95 +++++++++++++++++++++++----------------------- test/SpecHelper.hs | 5 +-- 9 files changed, 118 insertions(+), 116 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 97bd66fec..b006bb98b 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs index 0cf77de09..2d350cd6a 100644 --- a/src/App.hs +++ b/src/App.hs @@ -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 diff --git a/src/Auth.hs b/src/Auth.hs index 14dc23b11..e8f0f5be2 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -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 -> diff --git a/src/Error.hs b/src/Error.hs index f837b27c5..63d1e089b 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 2ac10b4cf..7f58e0cf9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Middleware.hs b/src/Middleware.hs index 2d0310e91..429a6f6e5 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -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 diff --git a/src/PgQuery.hs b/src/PgQuery.hs index ee6bbdbc4..663053770 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -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 = diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 11b8c9154..42f517070 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index e29baa44e..d0d47f0c1 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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 () From 27450fae66e367773fe541d17063fff893010ac9 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 28 Jan 2015 23:52:34 -0800 Subject: [PATCH 6/9] Fix NULL input problem Relates to #127 Still auth problems though --- src/PgStructure.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/PgStructure.hs b/src/PgStructure.hs index 42f517070..560f9c576 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -7,8 +7,9 @@ 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.List as L import qualified Data.Map as Map import qualified Hasql as H @@ -103,9 +104,6 @@ primaryKeyColumns table = do return $ map runIdentity r -vanishNull :: [a] -> Maybe [a] -vanishNull xs = if L.null xs then Nothing else Just xs - toBool :: Text -> Bool toBool = (== "YES") @@ -137,11 +135,17 @@ data Column = Column { 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, Text) - -> Column +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 (split (==',') e) Nothing + 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 From 88af46fbe39c7cead80b62f146fe263c34a70029 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 31 Jan 2015 11:31:05 -0800 Subject: [PATCH 7/9] Reduce test settings duplication and better variable name --- test/SpecHelper.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index d0d47f0c1..1de74ea76 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -39,18 +39,22 @@ isLeft _ = False cfg :: AppConfig cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 -testSettings :: PoolSettings -testSettings = fromMaybe (error "bad settings") $ H.poolSettings 1 30 +testPoolOpts :: PoolSettings +testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 pgSettings :: H.Settings -pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test" +pgSettings = H.ParamSettings (cs $ configDbHost cfg) + (fromIntegral $ configDbPort cfg) + (cs $ configDbUser cfg) + (cs $ configDbPass cfg) + (cs $ configDbName cfg) withApp :: ActionWith Application -> IO () withApp perform = do let anonRole = cs $ configAnonRole cfg currRole = cs $ configDbUser cfg pool :: H.Pool H.Postgres - <- H.acquirePool pgSettings testSettings + <- H.acquirePool pgSettings testPoolOpts perform $ middle $ \req resp -> do body <- strictRequestBody req @@ -64,7 +68,7 @@ withApp perform = do resetDb :: IO () resetDb = do pool :: H.Pool H.Postgres - <- H.acquirePool pgSettings testSettings + <- H.acquirePool pgSettings testPoolOpts void . liftIO $ H.session pool $ H.tx Nothing $ do H.unitEx [H.stmt| drop schema if exists "1" cascade |] @@ -97,14 +101,14 @@ authHeader u p = clearTable :: Text -> IO () clearTable table = do pool :: H.Pool H.Postgres - <- H.acquirePool pgSettings testSettings + <- H.acquirePool pgSettings testPoolOpts void . liftIO $ H.session pool $ H.tx Nothing $ H.unitEx $ H.Stmt ("delete from \"1\"."<>table) V.empty True createItems :: Int -> IO () createItems n = do pool :: H.Pool H.Postgres - <- H.acquirePool pgSettings testSettings + <- H.acquirePool pgSettings testPoolOpts void . liftIO $ H.session pool $ H.tx Nothing txn where txn = sequence_ $ map H.unitEx stmts From f06f3e33949784ee1c3b14a4612dd6335dd5e643 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 31 Jan 2015 11:32:08 -0800 Subject: [PATCH 8/9] Isolate tests Credentials from AuthSpec were interfering with StructureSpec --- test/Feature/AuthSpec.hs | 30 ++++++++++++++++++------------ test/Feature/InsertSpec.hs | 2 +- 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index b2228faa4..4c5f208a0 100644 --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -11,15 +11,21 @@ import SpecHelper -- }}} spec :: Spec -spec = around withApp $ describe "authorization" $ do - it "hides tables that anonymous does not own" $ - get "/authors_only" `shouldRespondWith` 404 - it "indicates login failure" $ do - let auth = authHeader "postgrest_test_author" "fakefake" - request methodGet "/authors_only" [auth] "" - `shouldRespondWith` 401 - it "allows users with permissions to see their tables" $ do - _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |] - let auth = authHeader "jdoe" "1234" - request methodGet "/authors_only" [auth] "" - `shouldRespondWith` 200 +spec = beforeAll + (clearTable "postgrest.auth") . afterAll_ (clearTable "postgrest.auth") + $ around withApp + $ describe "authorization" $ do + + it "hides tables that anonymous does not own" $ + get "/authors_only" `shouldRespondWith` 404 + + it "indicates login failure" $ do + let auth = authHeader "postgrest_test_author" "fakefake" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 401 + + it "allows users with permissions to see their tables" $ do + _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |] + let auth = authHeader "jdoe" "1234" + request methodGet "/authors_only" [auth] "" + `shouldRespondWith` 200 diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 3e75e8657..2aaf3f856 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -19,7 +19,7 @@ import TestTypes(IncPK(..), CompoundPK(..)) --import Debug.Trace spec :: Spec -spec = around withApp $ do +spec = afterAll_ resetDb $ around withApp $ do describe "Posting new record" $ do after_ (clearTable "menagerie") . it "accepts disparate json types" $ do p <- post "/menagerie" From 90f9b00e5e2dd54c9454eed442d86912e02e7aaf Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Sat, 31 Jan 2015 12:33:44 -0800 Subject: [PATCH 9/9] Include JSON content type for errors --- src/Error.hs | 4 +++- test/Feature/InsertSpec.hs | 2 -- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Error.hs b/src/Error.hs index 63d1e089b..e8f8a9910 100644 --- a/src/Error.hs +++ b/src/Error.hs @@ -12,11 +12,13 @@ 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) [] (JSON.encode e) +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 [ diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 2aaf3f856..4c50c023d 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -16,8 +16,6 @@ import Control.Monad (replicateM_) import TestTypes(IncPK(..), CompoundPK(..)) ---import Debug.Trace - spec :: Spec spec = afterAll_ resetDb $ around withApp $ do describe "Posting new record" $ do