[#118] Use named parameters in database queries (#128)

* [#118] Introduce queryNamed and executeNamed database functions

Resolves #118

* [#118] Refactor database functions to use queryNamed and executeNamed

Resolves #118

issue-wanted.cabal

@@ -113,6 +113,7 @@ library
                      , lens ^>= 4.17
                      , mtl ^>= 2.2.2
                      , postgresql-simple ^>= 0.6.1
+                     , postgresql-simple-named ^>= 0.0.0.0
                      , random ^>= 1.1
                      , resource-pool
                      , servant ^>= 0.16

src/IW/App/Error.hs

@@ -23,6 +23,7 @@ module IW.App.Error
        , missingHeader
        , headerDecodeError
        , dbError
+       , dbNamedError
        , urlDownloadFailedError
 
          -- * Error throwing helpers
@@ -36,6 +37,7 @@ import Control.Monad.Except (MonadError)
 import Data.CaseInsensitive (foldedCase)
 import GHC.Stack (SrcLoc (SrcLoc, srcLocModule, srcLocStartLine))
 import Network.HTTP.Types.Header (HeaderName)
+import PgNamed (PgNamedError)
 import Servant.Server (err401, err404, err417, err500, errBody)
 
 import IW.Core.Url (Url (..))
@@ -121,6 +123,8 @@ data IError
     | HeaderDecodeError Text
     -- | Data base specific errors
     | DbError Text
+    -- | Data base named parameters errors.
+    | DbNamedError PgNamedError
     deriving (Show, Eq)
 
 {- | Errors from the @github@ library search functions that can be thrown.
@@ -155,6 +159,7 @@ toHttpError (AppError _callStack errorType) = case errorType of
         MissingHeader name     -> err401 { errBody = toLazy $ "Header not found: " <> foldedCase name }
         HeaderDecodeError name -> err401 { errBody = encodeUtf8 $ "Unable to decode header: " <> name }
         DbError e              -> err500 { errBody = encodeUtf8 e }
+        DbNamedError e         -> err500 { errBody = show e }
     GitHubError err -> err500 { errBody = show err }
     UrlDownloadFailed url -> err500 { errBody = encodeUtf8 $ "Couldn't download file from " <> unUrl url }
 
@@ -199,6 +204,9 @@ headerDecodeError = InternalError . HeaderDecodeError
 dbError :: Text -> AppErrorType
 dbError = InternalError . DbError
 
+dbNamedError :: PgNamedError -> AppErrorType
+dbNamedError = InternalError . DbNamedError
+
 urlDownloadFailedError :: Url -> AppErrorType
 urlDownloadFailedError = UrlDownloadFailed
 

src/IW/Db/Functions.hs

@@ -6,8 +6,10 @@ module IW.Db.Functions
 
          -- * Sql functions
        , query
+       , queryNamed
        , queryRaw
        , execute
+       , executeNamed
        , executeRaw
        , executeMany
        , returning
@@ -17,11 +19,14 @@ module IW.Db.Functions
        , singleRowError
        ) where
 
+import PgNamed (NamedParam, PgNamedError)
+
 import IW.App.Env (DbPool, Has, grab)
-import IW.App.Error (AppErrorType, WithError, dbError, throwOnNothingM)
+import IW.App.Error (AppErrorType, WithError, dbError, dbNamedError, throwError, throwOnNothingM)
 
 import qualified Data.Pool as Pool
 import qualified Database.PostgreSQL.Simple as Sql
+import qualified PgNamed as Sql
 
 
 -- | Constraint for monadic actions that wants access to database.
@@ -51,9 +56,19 @@ query
 query q args = withPool $ \conn -> Sql.query conn q args
 {-# INLINE query #-}
 
+-- | Performs a query with named parameters and returns a list of rows.
+queryNamed
+    :: (WithError m, WithDb env m, FromRow res)
+    => Sql.Query
+    -> [NamedParam]
+    -> m [res]
+queryNamed q params = withPool (\conn -> runExceptT $ Sql.queryNamed conn q params)
+    >>= liftDbError
+{-# INLINE queryNamed #-}
+
 -- | Executes a query without arguments that is not expected to return results.
 executeRaw
-    :: (WithDb env m)
+    :: WithDb env m
     => Sql.Query
     -> m ()
 executeRaw q = withPool $ \conn -> void $ Sql.execute_ conn q
@@ -78,6 +93,16 @@ executeMany
 executeMany q args = withPool $ \conn -> void $ Sql.executeMany conn q args
 {-# INLINE executeMany #-}
 
+-- | Executes a query with named parameters, returning the number of rows affected.
+executeNamed
+    :: (WithError m, WithDb env m)
+    => Sql.Query
+    -> [NamedParam]
+    -> m Int64
+executeNamed q params = withPool (\conn -> runExceptT $ Sql.executeNamed conn q params)
+    >>= liftDbError
+{-# INLINE executeNamed #-}
+
 -- | Executes a multi-row query that is expected to return results.
 -- A @RETURNING@ statement needs to be in the SQL query.
 returning
@@ -101,10 +126,15 @@ withPool f = do
 
 -- | Helper function working with results from a database when you expect
 -- only one row to be returned.
-asSingleRow :: (WithError m) => m [a] -> m a
+asSingleRow :: WithError m => m [a] -> m a
 asSingleRow res = withFrozenCallStack $ throwOnNothingM
     singleRowError
     (viaNonEmpty head <$> res)
 
+-- | Lift database named parameters errors.
+liftDbError :: WithError m => Either PgNamedError a -> m a
+liftDbError = either (throwError . dbNamedError) pure
+{-# INLINE liftDbError #-}
+
 singleRowError :: AppErrorType
 singleRowError = dbError "Expected a single row, but got none"

src/IW/Db/Issue.hs

@@ -8,28 +8,29 @@ module IW.Db.Issue
        , upsertIssues
        ) where
 
+import IW.App (WithError)
 import IW.Core.Issue (Issue (..), Label (..))
 import IW.Core.SqlArray (SqlArray (..))
 import IW.Core.WithId (WithId)
-import IW.Db.Functions (WithDb, executeMany, query, queryRaw)
+import IW.Db.Functions (WithDb, executeMany, queryNamed, queryRaw)
 
 
 -- | Returns all issues in the database.
-getIssues :: (WithDb env m) => m [WithId Issue]
+getIssues :: WithDb env m => m [WithId Issue]
 getIssues = queryRaw [sql|
     SELECT id, repo_owner, repo_name, number, title, body, labels
     FROM issues
     LIMIT 100
 |]
 
 -- | Returns all issues with at least one label in the given list.
-getIssuesByLabels :: (WithDb env m) => [Label] -> m [WithId Issue]
-getIssuesByLabels = query [sql|
+getIssuesByLabels :: (WithDb env m, WithError m) => [Label] -> m [WithId Issue]
+getIssuesByLabels labels = queryNamed [sql|
     SELECT id, repo_owner, repo_name, number, title, body, labels
     FROM issues
-    WHERE ? && labels
+    WHERE labels && ?labels
     LIMIT 100
-|] . Only . SqlArray
+|] [ "labels" =? SqlArray labels ]
 
 -- | Insert a list of issues into the database, but update on conflict.
 upsertIssues :: (WithDb env m) => [Issue] -> m ()

src/IW/Db/Repo.hs

@@ -9,10 +9,11 @@ module IW.Db.Repo
        , updateRepoCategories
        ) where
 
+import IW.App (WithError)
 import IW.Core.Repo (Repo, RepoOwner, RepoName, Category)
 import IW.Core.SqlArray (SqlArray (..))
 import IW.Core.WithId (WithId)
-import IW.Db.Functions (WithDb, executeMany, execute, query, queryRaw)
+import IW.Db.Functions (WithDb, executeMany, executeNamed, queryNamed, queryRaw)
 
 
 -- | Returns all repos in the database.
@@ -24,13 +25,13 @@ getRepos = queryRaw [sql|
 |]
 
 -- | Returns all repos with at least one category in the given list.
-getReposByCategories :: WithDb env m => [Category] -> m [WithId Repo]
-getReposByCategories = query [sql|
+getReposByCategories :: (WithDb env m, WithError m) => [Category] -> m [WithId Repo]
+getReposByCategories categories = queryNamed [sql|
     SELECT id, owner, name, descr, categories
     FROM repos
-    WHERE ? && categories
+    WHERE categories && ?categories
     LIMIT 100
-|] . Only . SqlArray
+|] [ "categories" =? SqlArray categories ]
 
 -- | Insert a list of repos into the database, but update on conflict.
 upsertRepos :: WithDb env m => [Repo] -> m ()
@@ -47,14 +48,19 @@ upsertRepos = executeMany [sql|
 
 -- | Update a repo's categories field.
 updateRepoCategories
-    :: WithDb env m
+    :: ( WithDb env m
+       , WithError m
+       )
     => RepoOwner
     -> RepoName
     -> [Category]
     -> m ()
-updateRepoCategories repoOwner repoName categories = execute [sql|
+updateRepoCategories repoOwner repoName categories = void $ executeNamed [sql|
     UPDATE repos
-    SET categories = ?
-    WHERE owner = ?
-      AND name = ?
-|] (SqlArray categories, repoOwner, repoName)
+    SET categories = ?categories
+    WHERE owner = ?owner
+      AND name = ?name
+|] [ "categories" =? SqlArray categories
+   , "owner" =? repoOwner
+   , "name" =? repoName
+   ]

src/IW/Server/Issue.hs

@@ -7,6 +7,7 @@ module IW.Server.Issue
        , issuesHandler
        ) where
 
+import IW.App (WithError)
 import IW.Core.Issue (Issue (..), Label (..))
 import IW.Core.WithId (WithId (..))
 import IW.Db (WithDb, getIssuesByLabels)
@@ -29,6 +30,7 @@ issueServer = IssueSite
 
 issuesHandler
     :: ( WithDb env m
+       , WithError m
        )
     => [Label]
     -> m [WithId Issue]

src/Prelude.hs

@@ -30,6 +30,7 @@ import Database.PostgreSQL.Simple.SqlQQ as Sql (sql)
 import Database.PostgreSQL.Simple.ToField as Sql (ToField (toField))
 import Database.PostgreSQL.Simple.ToRow as Sql (ToRow (toRow))
 import Database.PostgreSQL.Simple.Types as Sql (Only (..))
+import PgNamed as Sql ((=?))
 
 import Servant.API as Web ((:>), Capture, Get, Header, Header', JSON, NoContent (NoContent), Post,
                            QueryFlag, QueryParam, QueryParam', ReqBody)

stack.yaml

@@ -20,6 +20,7 @@ extra-deps:
   # testing
   - hedgehog-1.0
 
+  - postgresql-simple-named-0.0.0.0
   - servant-0.16.0.1
   - servant-server-0.16
   - tomland-1.0.0