diff --git a/postgrest.cabal b/postgrest.cabal index f0f0bede0..b006bb98b 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 @@ -30,13 +30,13 @@ 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 , regex-tdfa-text , Ranged-sets - , transformers + , transformers, MissingH , bcrypt, base64-string , network-uri >= 2.6 , resource-pool @@ -48,7 +48,6 @@ executable postgrest , Config , PgStructure , PgQuery - , PgError , RangeQuery , Middleware hs-source-dirs: src @@ -56,7 +55,7 @@ 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 @@ -64,8 +63,8 @@ Test-Suite spec 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 @@ Test-Suite spec , 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 index 19c3e4122..2d350cd6a 100644 --- a/src/App.hs +++ b/src/App.hs @@ -25,17 +25,17 @@ import Network.Wai 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 @@ 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 = B.Stmt "select " V.empty True <> parentheticT ( whereT qq $ countRows qt ) <> commaq <> ( @@ -65,7 +64,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 +101,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 +132,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 +145,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 +173,12 @@ app reqBody req = schema = requestedSchema hdrs range = rangeRequested hdrs allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - coerce (q, args, All b) = (q, args, b) +sqlError :: t +sqlError = undefined -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) - +isSqlError :: t +isSqlError = undefined rangeStatus :: Int -> Int -> Int -> Status rangeStatus from to total @@ -238,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 @@ -255,6 +226,7 @@ handleJsonObj reqBody handler = do jErr = encode . object $ [("message", String "Expecting a JSON object")] + data TableOptions = TableOptions { tblOptcolumns :: [Column] , tblOptpkey :: [Text] diff --git a/src/Auth.hs b/src/Auth.hs index da315403f..e8f0f5be2 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -7,8 +7,10 @@ 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.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 @@ data LoginAttempt = 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/Error.hs b/src/Error.hs new file mode 100644 index 000000000..e8f8a9910 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +module Error (PgError, errResponse) where + +import qualified Hasql 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 +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) + [(hContentType, "application/json")] (JSON.encode e) + +instance JSON.ToJSON PgError where + 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 (P.NoResult d)) = JSON.object [ + "message" .= ("No response from server"::T.Text), + "details" .= (fmap cs d::Maybe T.Text)] + 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 (P.CantConnect d)) = JSON.object [ + "message" .= ("Can't connect to the database"::T.Text), + "details" .= (fmap cs d::Maybe T.Text)] + 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 (P.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 (P.NoResult _)) = HT.status503 +httpStatus _ = HT.status500 diff --git a/src/Main.hs b/src/Main.hs index 224ccf008..7f58e0cf9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,10 +4,10 @@ import Paths_postgrest (version) 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 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) @@ -32,16 +32,12 @@ 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) (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 @@ 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 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 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/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..663053770 100644 --- 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.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 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 @@ data OrderTerm = OrderTerm { 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 :: Net.Query -> StatementT 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 :: [OrderTerm] -> StatementT 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 @@ orderParseTerm s = 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 @@ 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 +205,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..560f9c576 100644 --- 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 Data.Maybe (fromMaybe) +import Control.Applicative ( (<$>) ) -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 @@ 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 = - 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 @@ 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") @@ -132,37 +132,21 @@ 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 +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 + + where + parseEnum :: Maybe Text -> [Text] + parseEnum str = fromMaybe [] $ split (==',') <$> str -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/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..4c50c023d 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -16,10 +16,8 @@ import Control.Monad (replicateM_) 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" diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index dfe9bc20b..1de74ea76 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -7,13 +7,14 @@ 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 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 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) -- import Auth (addUser) isLeft :: Either a b -> Bool @@ -37,35 +39,41 @@ 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 +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 :: 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 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 () 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 - ]