From 93b83f1448fffd055f6232cdd9502b1d68f8148f Mon Sep 17 00:00:00 2001
From: rashadg1030 <rashad.sasaki@gmail.com>
Date: Sat, 20 Jul 2019 23:21:33 -0700
Subject: [PATCH] [#118] Introduce queryNamed and executeNamed database
 functions

Resolves #118
---
 issue-wanted.cabal     |  1 +
 src/IW/App/Error.hs    |  8 ++++++++
 src/IW/Db/Functions.hs | 36 +++++++++++++++++++++++++++++++++---
 stack.yaml             |  1 +
 4 files changed, 43 insertions(+), 3 deletions(-)

diff --git a/issue-wanted.cabal b/issue-wanted.cabal
index 761e6bd..c525e8d 100644
--- a/issue-wanted.cabal
+++ b/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
diff --git a/src/IW/App/Error.hs b/src/IW/App/Error.hs
index c03a014..8c8ac84 100644
--- a/src/IW/App/Error.hs
+++ b/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
 
diff --git a/src/IW/Db/Functions.hs b/src/IW/Db/Functions.hs
index fd864ec..fcb452a 100644
--- a/src/IW/Db/Functions.hs
+++ b/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"
diff --git a/stack.yaml b/stack.yaml
index 8f6ba15..7850206 100644
--- a/stack.yaml
+++ b/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