Use "::unknown" type casts to overcome binary protocol restrictions

Fixes #112

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

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]

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)
+  let pgSettings = H.ParamSettings (cs $ configDbHost conf)
-                     (cs $ configDbUser conf) (cs $ configDbPass conf) (cs $ configDbName 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

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)) <>
+    cs (
-    ") returning row_to_json(" <> fromQt t <> ".*)"
+      intercalate ", " (map
-  , map pgParam vals
+        ((<> "::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))
+    cs (
-  , map pgParam vals
+      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)) <> ")"
+    cs (
-  , map pgParam vals
+      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.Bool      b) = H.renderValue $
-pgParam JSON.Null       = H.renderValue (Nothing :: Maybe String)
+  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

@@ -1,4 +1,4 @@
-{-# LANGUAGE QuasiQuotes, OverloadedStrings,
+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,
              MultiParamTypeClasses, ScopedTypeVariables #-}
 module PgStructure where
 

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,

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 =