postgrest 0.2.5.0 → 0.2.5.1
raw patch · 9 files changed
+243/−388 lines, 9 filesdep +MissingHdep −parsecdep ~hasqldep ~hasql-postgres
Dependencies added: MissingH
Dependencies removed: parsec
Dependency ranges changed: hasql, hasql-postgres
Files
- postgrest.cabal +12/−15
- src/App.hs +19/−47
- src/Auth.hs +12/−10
- src/Main.hs +14/−15
- src/Middleware.hs +5/−5
- src/PgError.hs +0/−86
- src/PgQuery.hs +79/−106
- src/PgStructure.hs +61/−77
- test/SpecHelper.hs +41/−27
postgrest.cabal view
@@ -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
src/App.hs view
@@ -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]
src/Auth.hs view
@@ -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
src/Main.hs view
@@ -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"
src/Middleware.hs view
@@ -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
− src/PgError.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module PgError (Message(..), message, httpStatus) where--import Text.Parsec-import Text.Parsec.Text-import qualified Data.Map as M-import Text.Regex.TDFA.Text ()-import Data.Text hiding (drop, concat, head)-import Data.Aeson-import Data.Maybe-import Control.Monad (void)--import Data.String.Conversions (cs)-import Data.CaseInsensitive (CI, mk)--import Network.HTTP.Types.Status--data Message = Message {- msgStatus :: Maybe Text- , msgCode :: Text- , msgText :: Maybe Text- , msgHint :: Maybe Text-} deriving (Show, Eq)--message :: Parser Message-message = do- ps <- sepBy valPair (char ';')- let m = M.fromList ps- return $ Message- (M.lookup "status" m)- (fromMaybe "" $ M.lookup "code" m)- (M.lookup "message" m)- (M.lookup "hint" m)--valPair :: Parser (CI Text, Text)-valPair = do- _ <- spaces- name <- many1 letter- _ <- char ':'- spaces- _ <- many $ char '"'- val <- manyTill anyChar $- try- (void $ many (char '"') >> (- (void . lookAhead $ (char ';'))- <|> ((optional $ char '.') >> eof)- ))- return (mk (cs name), cs val)---instance ToJSON Message where- toJSON t = object [- "message" .= msgText t- , "code" .= msgCode t- , "status" .= msgStatus t- , "hint" .= msgHint t- ]--httpStatus :: Message -> Status-httpStatus m =- let code = cs $ msgCode m :: String in- case code of- '0' : '8' : _ -> status503 -- pg connection err- '0' : '9' : _ -> status500 -- triggered action exception- '0' : 'L' : _ -> status403 -- invalid grantor- '0' : 'P' : _ -> status403 -- invalid role specification- '2' : '5' : _ -> status500 -- invalid tx state- '2' : '8' : _ -> status403 -- invalid auth specification- '2' : 'D' : _ -> status500 -- invalid tx termination- '3' : '8' : _ -> status500 -- external routine exception- '3' : '9' : _ -> status500 -- external routine invocation- '3' : 'B' : _ -> status500 -- savepoint exception- '4' : '0' : _ -> status500 -- tx rollback- '5' : '3' : _ -> status503 -- insufficient resources- '5' : '4' : _ -> status413 -- too complex- '5' : '5' : _ -> status500 -- obj not on prereq state- '5' : '7' : _ -> status500 -- operator intervention- '5' : '8' : _ -> status500 -- system error- 'F' : '0' : _ -> status500 -- conf file error- 'H' : 'V' : _ -> status500 -- foreign data wrapper error- 'P' : '0' : _ -> status500 -- PL/pgSQL Error- 'X' : 'X' : _ -> status500 -- internal Error- "42P01" -> status404 -- undefined table- "42501" -> status404 -- insufficient privilege- _ -> status400
src/PgQuery.hs view
@@ -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
src/PgStructure.hs view
@@ -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 [
test/SpecHelper.hs view
@@ -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 ()