diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits. -version: 0.2.5.0 +version: 0.2.5.1 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE @@ -17,11 +17,11 @@ 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 @@ -30,13 +30,13 @@ , 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 , regex-tdfa-text , Ranged-sets - , transformers + , transformers, MissingH , bcrypt, base64-string , network-uri >= 2.6 , resource-pool @@ -48,7 +48,6 @@ , Config , PgStructure , PgQuery - , PgError , RangeQuery , Middleware hs-source-dirs: src @@ -56,7 +55,7 @@ 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 @@ -64,8 +63,8 @@ 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 @@ -74,17 +73,15 @@ , http-types, scientific, time , bytestring, aeson, network >= 2.6 , text, optparse-applicative - , stringsearch, parsec + , stringsearch , unordered-containers , regex-base , string-conversions , 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/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -25,17 +25,17 @@ import Data.Aeson import Data.Monoid +import qualified Data.Vector as V import qualified Hasql as H -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 PgError -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 @@ -54,8 +54,7 @@ then return $ responseLBS status416 [] "HTTP Range error" else do let qt = QualifiedTable schema (cs table) - let select = coerce $ - ("select ",[],mempty) <> + let select = B.Stmt "select " V.empty True <> parentheticT ( whereT qq $ countRows qt ) <> commaq <> ( @@ -65,7 +64,7 @@ . 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 +101,8 @@ ([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 +132,7 @@ 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 +145,18 @@ ([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 +173,12 @@ 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 :: t +sqlError = undefined +isSqlError :: t +isSqlError = undefined rangeStatus :: Int -> Int -> Int -> Status rangeStatus from to total @@ -238,8 +209,8 @@ 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 @@ -254,6 +225,7 @@ where jErr = encode . object $ [("message", String "Expecting a JSON object")] + data TableOptions = TableOptions { tblOptcolumns :: [Column] diff --git a/src/Auth.hs b/src/Auth.hs --- a/src/Auth.hs +++ b/src/Auth.hs @@ -7,8 +7,10 @@ import Crypto.BCrypt import Data.Text import Data.Monoid +import qualified Data.Vector as V import qualified Hasql as H -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) @@ -45,22 +47,22 @@ 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 :: 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.unit [H.q|reset role|] +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.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 :: Text -> Text -> H.Tx P.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 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,10 +4,10 @@ import App import Middleware +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) @@ -17,7 +17,7 @@ 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) @@ -32,16 +32,12 @@ 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) (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,16 @@ 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 P.Postgres + <- H.acquirePool pgSettings poolSettings + + runSettings appSettings $ middle $ \req respond -> do + body <- strictRequestBody req + resOrError <- liftIO $ H.session pool $ H.tx Nothing $ + authenticated currRole anonRole (app body) req + either (respond . errResponse) respond resOrError where describe = progDesc "create a REST API to an existing Postgres database" diff --git a/src/Middleware.hs b/src/Middleware.hs --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -9,7 +9,7 @@ -- 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 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 @@ 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 @@ _ -> 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/PgError.hs b/src/PgError.hs deleted file mode 100644 --- 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 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,17 +1,21 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + 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) +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 +24,12 @@ 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 P.Postgres +instance Monoid PStmt where + mappend (B.Stmt query params prep) (B.Stmt query' params' prep') = + B.Stmt (query <> query') (params <> params') (prep && prep') + mempty = B.Stmt "" empty True +type StatementT = PStmt -> PStmt data QualifiedTable = QualifiedTable { qtSchema :: Text @@ -36,7 +43,7 @@ limitT :: Maybe NonnegRange -> StatementT limitT r q = - q <> (" LIMIT " <> limit <> " OFFSET " <> offset <> " ", [], mempty) + 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 @@ -45,7 +52,7 @@ whereT params q = if L.null cols then q - else q <> (" where ",[],mempty) <> 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) @@ -54,108 +61,85 @@ orderT ts q = if L.null ts then q - else q <> (" order by ",[],mempty) <> clause + else q <> B.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 = B.Stmt + (" " <> cs (pgFmtIdent $ otTerm t) <> " " + <> cs (otDirection t) <> " ") + empty True parentheticT :: StatementT -parentheticT (sql, params, pre) = - (" (" <> sql <> ") ", params, pre) +parentheticT s = + s { B.stmtTemplate = " (" <> B.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 (B.Stmt aq ap apre) (B.Stmt bq bp bpre) = + B.Stmt + ("WITH aaa AS (" <> aq <> " returning *) " <> + bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)") + (ap <> bp) + (apre && bpre) countT :: StatementT -countT (sql, params, pre) = - ("WITH qqq AS (" <> sql <> ") SELECT count(1) FROM qqq" - , params - , pre) +countT s = + s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" } -countRows :: QualifiedTable -> DynamicSQL -countRows t = - ("select count(1) from " <> fromQt t, [], mempty) +countRows :: QualifiedTable -> PStmt +countRows t = B.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 { B.stmtTemplate = + "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from (" + <> B.stmtTemplate s <> ") t" } asJsonRow :: StatementT -asJsonRow (sql, params, pre) = ( - "row_to_json(t) from (" <> sql <> ") t", params, pre - ) +asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" } -selectStar :: QualifiedTable -> DynamicSQL -selectStar t = - ("select * from " <> fromQt t, [], mempty) +selectStar :: QualifiedTable -> PStmt +selectStar t = B.Stmt ("select * from " <> fromQt t) empty True returningStarT :: StatementT -returningStarT (sql, params, pre) = - (sql <> " RETURNING *", params, pre) +returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" } -deleteFrom :: QualifiedTable -> DynamicSQL -deleteFrom t = - ("delete from " <> fromQt t, [], mempty) +deleteFrom :: QualifiedTable -> PStmt +deleteFrom t = B.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 [] _ = B.Stmt + ("insert into " <> fromQt t <> " default values returning *") empty True +insertInto t cols vals = B.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 [] _ = B.Stmt + ("insert into " <> fromQt t <> " default values returning *") empty True +insertSelect t cols vals = B.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 = B.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) = B.Stmt + (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ") + empty True where opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate @@ -185,11 +169,11 @@ else Nothing _ -> Nothing -commaq :: DynamicSQL -commaq = (", ", [], mempty) +commaq :: PStmt +commaq = B.Stmt ", " empty True -andq :: DynamicSQL -andq = (" and ", [], mempty) +andq :: PStmt +andq = B.Stmt " and " empty True pgFmtIdent :: Text -> Text pgFmtIdent x = @@ -212,8 +196,8 @@ 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 +205,3 @@ 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 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -3,25 +3,21 @@ 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 Data.Maybe (fromMaybe) +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 -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.list $ [H.q| + 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,58 +32,65 @@ 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 = - H.list $ [H.q| +tables :: Text -> H.Tx P.Postgres s [Table] +tables schema = do + rows <- H.listEx $ + [H.stmt| select table_schema, table_name, is_insertable_into from information_schema.tables where table_schema = ? order by table_name |] schema + return $ map tableFromRow rows -columns :: QualifiedTable -> H.Tx H.Postgres s [Column] +columns :: QualifiedTable -> H.Tx P.Postgres s [Column] columns table = do - cols <- H.list $ [H.q| - 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) + cols <- H.listEx $ [H.stmt| + select info.table_schema as schema, info.table_name as table_name, + info.column_name as name, info.ordinal_position as position, + info.is_nullable as nullable, info.data_type as col_type, + info.is_updatable as updatable, + info.character_maximum_length as max_len, + info.numeric_precision as precision, + info.column_default as default_value, + array_to_string(enum_info.vals, ',') as enum + from ( + select table_schema, table_name, column_name, ordinal_position, + is_nullable, data_type, is_updatable, + character_maximum_length, numeric_precision, + column_default, udt_name + from information_schema.columns + where table_schema = ? and table_name = ? + ) as info + left outer join ( + select n.nspname as s, + t.typname as n, + array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals + from pg_type t + join pg_enum e on t.oid = e.enumtypid + join pg_catalog.pg_namespace n ON n.oid = t.typnamespace + group by s, n + ) as enum_info + on (info.udt_name = enum_info.n) + order by position |] + (qtSchema table) (qtName table) fks <- foreignKeys table - return $ map (\col -> col { colFK = Map.lookup (cs . colName $ col) fks }) 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.list $ [H.q| + r <- H.listEx $ [H.stmt| select kc.column_name from information_schema.table_constraints tc, @@ -101,9 +104,6 @@ return $ map runIdentity r -vanishNull :: [a] -> Maybe [a] -vanishNull xs = if L.null xs then Nothing else Just xs - toBool :: Text -> Bool toBool = (== "YES") @@ -132,37 +132,21 @@ , 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 +tableFromRow :: (Text, Text, Text) -> Table +tableFromRow (s, n, i) = Table s n (toBool i) +columnFromRow :: (Text, Text, Text, + Int, Text, Text, + Text, Maybe Int, Maybe Int, + Maybe Text, Maybe Text) + -> Column +columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) = + Column s t n pos (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing -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 + where + parseEnum :: Maybe Text -> [Text] + parseEnum str = fromMaybe [] $ split (==',') <$> str + instance ToJSON Column where toJSON c = object [ diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -7,13 +7,14 @@ 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 Control.Exception.Base (bracket, finally) +import Data.Text hiding (map) +import qualified Data.Vector as V import Control.Monad (void) -import Control.Exception import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange, hRange, hAuthorization) @@ -25,9 +26,10 @@ 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) -- import Auth (addUser) isLeft :: Either a b -> Bool @@ -37,35 +39,41 @@ 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 +testPoolOpts :: PoolSettings +testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30 -pgSettings :: Postgres -pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test" +pgSettings :: H.Settings +pgSettings = H.ParamSettings (cs $ configDbHost cfg) + (fromIntegral $ configDbPort cfg) + (cs $ configDbUser cfg) + (cs $ configDbPass cfg) + (cs $ configDbName cfg) 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 testPoolOpts + perform $ middle $ \req resp -> do + body <- strictRequestBody req + result <- liftIO $ H.session pool $ H.tx Nothing + $ authenticated currRole anonRole (app body) req + either (resp . errResponse) resp result + where middle = cors corsPolicy resetDb :: IO () resetDb = do - H.session pgSettings testSettings $ + pool :: H.Pool H.Postgres + <- H.acquirePool pgSettings testPoolOpts + 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 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 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 = H.session pgSettings testSettings $ H.tx Nothing txn +createItems n = do + pool :: H.Pool H.Postgres + <- H.acquirePool pgSettings testPoolOpts + 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 ()