From 9712549d6472ed7c0c4a8f61501c249192ff3ec1 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 12 Dec 2014 17:13:27 -0800 Subject: [PATCH] Use "::unknown" type casts to overcome binary protocol restrictions Fixes #112 --- postgrest.cabal | 6 ++++-- src/App.hs | 8 ------- src/Main.hs | 12 +++++++---- src/PgQuery.hs | 44 ++++++++++++++++++++++++++++---------- src/PgStructure.hs | 2 +- test/Feature/InsertSpec.hs | 4 ++-- test/SpecHelper.hs | 2 +- 7 files changed, 49 insertions(+), 29 deletions(-) diff --git a/postgrest.cabal b/postgrest.cabal index 2de6598d9..a78458fe9 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -16,7 +16,8 @@ executable postgrest default-extensions: OverloadedStrings other-extensions: QuasiQuotes build-depends: base >=4.6 && <5 - , hasql >= 0.4.0, hasql-backend, hasql-postgres + , hasql == 0.4.*, hasql-backend + , hasql-postgres == 0.8.* , warp >= 3.0.2, wai >= 3.0.1 , wai-extra, wai-cors , wai-middleware-static >= 0.6.0 @@ -58,7 +59,8 @@ Test-Suite spec Other-Modules: App, Auth, Config, Spec, SpecHelper Build-Depends: base, hspec >= 2.0, QuickCheck , hspec-wai >= 0.5.0, hspec-wai-json - , hasql >= 0.4.0, hasql-backend, hasql-postgres + , hasql == 0.4.*, hasql-backend + , hasql-postgres == 0.8.* , warp >= 3.0.2, wai >= 3.0.1 , HTTP, convertible , case-insensitive diff --git a/src/App.hs b/src/App.hs index 783658da9..603bd969f 100644 --- a/src/App.hs +++ b/src/App.hs @@ -14,7 +14,6 @@ import Data.HashMap.Strict (keys, elems, filterWithKey, toList) import Data.String.Conversions (cs) import Data.List (sortBy) import Data.Functor.Identity -import Data.Scientific (isInteger, formatScientific, FPFormat(..)) import qualified Data.Set as S import qualified Data.ByteString.Lazy as BL @@ -223,13 +222,6 @@ handleJsonObj reqBody handler = do jErr = encode . object $ [("error", String "Expecting a JSON object")] -unquoted :: Value -> Text -unquoted (String t) = t -unquoted (Number n) = - cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n -unquoted (Bool b) = cs . show $ b -unquoted _ = "" - data TableOptions = TableOptions { tblOptcolumns :: [Column] , tblOptpkey :: [Text] diff --git a/src/Main.hs b/src/Main.hs index abf796d85..2fb2894c9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,6 @@ module Main where -import Paths_dbapi (version) +import Paths_postgrest (version) import App import Middleware @@ -29,10 +29,14 @@ main = do unless (configSecure conf) $ putStrLn "WARNING, running in insecure mode, auth will be in plaintext" - Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) + Prelude.putStrLn $ "Listening on port " ++ + (show $ configPort conf :: String) - let pgSettings = H.Postgres (cs $ configDbHost conf) (fromIntegral $ configDbPort conf) - (cs $ configDbUser conf) (cs $ configDbPass conf) (cs $ configDbName conf) + let pgSettings = H.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 diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 0651029ac..7bad71e7f 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -18,6 +18,7 @@ import Control.Monad (join) import Data.String.Conversions (cs) 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) @@ -99,9 +100,12 @@ insertInto t cols vals = ("insert into " <> fromQt t <> " (" <> cs (intercalate ", " (map pgFmtIdent cols)) <> ") values (" <> - cs (intercalate ", " (map (const "?") vals)) <> - ") returning row_to_json(" <> fromQt t <> ".*)" - , map pgParam vals + cs ( + intercalate ", " (map + ((<> "::unknown") . pgFmtLit . unquoted) + vals) + ) <> ") returning row_to_json(" <> fromQt t <> ".*)" + , [] , mempty ) @@ -112,8 +116,12 @@ insertSelect t cols vals = ("insert into " <> fromQt t <> " (" <> cs (intercalate ", " (map pgFmtIdent cols)) <> ") select " <> - cs (intercalate ", " (map (const "?") vals)) - , map pgParam vals + cs ( + intercalate ", " (map + ((<> "::unknown") . pgFmtLit . unquoted) + vals) + ) + , [] , mempty ) @@ -122,14 +130,18 @@ update t cols vals = ("update " <> fromQt t <> " set (" <> cs (intercalate ", " (map pgFmtIdent cols)) <> ") = (" <> - cs (intercalate ", " (map (const "?") vals)) <> ")" - , map pgParam vals + cs ( + intercalate ", " (map + ((<> "::unknown") . pgFmtLit . unquoted) + vals) + ) <> ")" + , [] , mempty ) wherePred :: Net.QueryItem -> DynamicSQL wherePred (col, predicate) = - (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> " ", [], mempty) + (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ", [], mempty) where opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate @@ -189,10 +201,20 @@ trimNullChars = Data.Text.takeWhile (/= '\x0') fromQt :: QualifiedTable -> BS.ByteString fromQt t = cs $ pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t) +unquoted :: JSON.Value -> Text +unquoted (JSON.String t) = t +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 n +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 b -pgParam JSON.Null = H.renderValue (Nothing :: Maybe String) +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 cff646428..8c151936f 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, +{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses, ScopedTypeVariables #-} module PgStructure where diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index f27223779..d767d40df 100644 --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -25,7 +25,7 @@ spec = before resetDb $ around withApp $ do p <- post "/menagerie" [json| { "integer": 13, "double": 3.14159, "varchar": "testing!" - , "boolean": false, "date": "01/01/1900", "money": "$3.99" + , "boolean": false, "date": "1900-01-01", "money": "$3.99" , "enum": "foo" } |] liftIO $ do @@ -139,7 +139,7 @@ spec = before resetDb $ around withApp $ do "id":1, "nullable_string":"hi", "non_nullable_string":"bye", - "inserted_at": "now()" + "inserted_at": "2020-11-11" } |] `shouldRespondWith` ResponseMatcher { matchBody = Nothing, diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 1139657f8..0e30644c8 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -40,7 +40,7 @@ testSettings :: SessionSettings testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30 pgSettings :: Postgres -pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test" +pgSettings = H.ParamSettings "localhost" 5432 "dbapi_test" "" "dbapi_test" withApp :: ActionWith Application -> IO () withApp perform =