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/src/IW/Db/Issue.hs b/src/IW/Db/Issue.hs index 59668e7..908619f 100644 --- a/src/IW/Db/Issue.hs +++ b/src/IW/Db/Issue.hs @@ -8,14 +8,15 @@ 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 @@ -23,13 +24,13 @@ getIssues = queryRaw [sql| |] -- | 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 () diff --git a/src/IW/Db/Repo.hs b/src/IW/Db/Repo.hs index 6462208..6e11715 100644 --- a/src/IW/Db/Repo.hs +++ b/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 + ] diff --git a/src/IW/Server/Issue.hs b/src/IW/Server/Issue.hs index ff6e3a3..393f5f3 100644 --- a/src/IW/Server/Issue.hs +++ b/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] diff --git a/src/Prelude.hs b/src/Prelude.hs index 78d55b3..054a64f 100644 --- a/src/Prelude.hs +++ b/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) 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