refactor: Use hasql-dynamic on RPC/POST/PUT/PATCH

Change callProc/createWriteStatement to H.Snippet.

Parametrize the inputs on the same SQLFragments by taking advantage
of hasql-dynamic-statements. It's not necessary to parametrize
every input, inlining with pgFmtLit can still be used for queries
that can't be parametrized(like SET LOCALs).

Also adds hasql-dynamic-statements to Nix and stack.
This commit is contained in:
steve-chavez
2020-11-23 19:00:50 -05:00
committed by Steve Chavez
parent b13e95aefb
commit 8e58b56d5c
10 changed files with 184 additions and 135 deletions
+30 -24
View File
@@ -1,13 +1,15 @@
module Main where
import Control.Lens ((^?))
import qualified Data.Aeson.Lens as L
import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE
import qualified Hasql.Pool as P
import qualified Hasql.Statement as H
import qualified Hasql.Transaction as HT
import qualified Hasql.Transaction.Sessions as HT
import Control.Lens ((^?))
import qualified Data.Aeson.Lens as L
import qualified Hasql.Decoders as HD
import qualified Hasql.DynamicStatements.Snippet as H
import qualified Hasql.DynamicStatements.Statement as H
import qualified Hasql.Encoders as HE
import qualified Hasql.Pool as P
import qualified Hasql.Statement as H
import qualified Hasql.Transaction as HT
import qualified Hasql.Transaction.Sessions as HT
import Text.Heredoc
import Protolude hiding (get, toS)
@@ -28,49 +30,53 @@ main = do
hspec $ describe "QueryCost" $
context "call proc query" $ do
it "should not exceed cost when calling setof composite proc" $ do
cost <- exec pool [str| {"id": 3} |] $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] False Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]
(Just $ RawJSON [str| {"id": 3} |]) False Nothing []
liftIO $
cost `shouldSatisfy` (< Just 40)
it "should not exceed cost when calling setof composite proc with empty params" $ do
cost <- exec pool mempty $
requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] False Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] Nothing False Nothing []
liftIO $
cost `shouldSatisfy` (< Just 30)
it "should not exceed cost when calling scalar proc" $ do
cost <- exec pool [str| {"a": 3, "b": 4} |] $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] True Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False]
(Just $ RawJSON [str| {"a": 3, "b": 4} |]) True Nothing []
liftIO $
cost `shouldSatisfy` (< Just 10)
context "params=multiple-objects" $ do
it "should not exceed cost when calling setof composite proc" $ do
cost <- exec pool [str| [{"id": 1}, {"id": 4}] |] $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] False (Just MultipleObjects) []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]
(Just $ RawJSON [str| [{"id": 1}, {"id": 4}] |]) False (Just MultipleObjects) []
liftIO $ do
-- lower bound needed for now to make sure that cost is not Nothing
cost `shouldSatisfy` (> Just 2000)
cost `shouldSatisfy` (< Just 2100)
it "should not exceed cost when calling scalar proc" $ do
cost <- exec pool [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |] $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] True Nothing []
cost <- exec pool $
requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False]
(Just $ RawJSON [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]) True Nothing []
liftIO $
cost `shouldSatisfy` (< Just 10)
exec :: P.Pool -> ByteString -> SqlQuery -> IO (Maybe Int64)
exec pool input query =
exec :: P.Pool -> H.Snippet -> IO (Maybe Int64)
exec pool query =
join . rightToMaybe <$>
P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement input $ explainCost query)
P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement mempty $ explainCost query)
explainCost :: SqlQuery -> H.Statement ByteString (Maybe Int64)
explainCost :: H.Snippet -> H.Statement () (Maybe Int64)
explainCost query =
H.Statement sql (HE.param $ HE.nonNullable HE.unknown) decodeExplain False
H.dynamicallyParameterized snippet decodeExplain False
where
sql = "EXPLAIN (FORMAT JSON) " <> query
snippet = "EXPLAIN (FORMAT JSON) " <> query
decodeExplain :: HD.Result (Maybe Int64)
decodeExplain =
let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in