nri-postgresql (empty) → 0.1.0.0
raw patch · 17 files changed
+1609/−0 lines, 17 filesdep +aesondep +attoparsecdep +base
Dependencies added: aeson, attoparsec, base, bytestring, filepath, network, nri-env-parser, nri-observability, nri-prelude, postgresql-typed, resource-pool, resourcet, safe-exceptions, template-haskell, text, time
Files
- CHANGELOG.md +3/−0
- LICENSE +29/−0
- README.md +3/−0
- nri-postgresql.cabal +131/−0
- src/Postgres.hs +251/−0
- src/Postgres/Connection.hs +137/−0
- src/Postgres/Error.hs +22/−0
- src/Postgres/Query.hs +115/−0
- src/Postgres/QueryParser.hs +122/−0
- src/Postgres/Settings.hs +330/−0
- src/Postgres/Test.hs +89/−0
- src/Postgres/Time.hs +37/−0
- test/Main.hs +32/−0
- test/ObservabilitySpec.hs +96/−0
- test/PostgresSettingsSpec.hs +23/−0
- test/QueryParserSpec.hs +152/−0
- test/TimeSpec.hs +37/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++- Initial release.
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2021, NoRedInk+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+# nri-postgresql++A library for querying postgresql. Wrapper around `postgresql-typed`.
+ nri-postgresql.cabal view
@@ -0,0 +1,131 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: nri-postgresql+version: 0.1.0.0+synopsis: Make queries against Postgresql.+description: Please see the README at <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-postgresql#readme>.+category: Web+homepage: https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-postgresql#readme+bug-reports: https://github.com/NoRedInk/haskell-libraries/issues+author: NoRedInk+maintainer: haskell-open-source@noredink.com+copyright: 2021 NoRedInk Corp.+license: BSD3+license-file: LICENSE+build-type: Simple+extra-doc-files:+ README.md+ LICENSE+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NoRedInk/haskell-libraries+ subdir: postgresql++library+ exposed-modules:+ Postgres+ Postgres.Test+ other-modules:+ Postgres.Connection+ Postgres.Error+ Postgres.Query+ Postgres.QueryParser+ Postgres.Settings+ Postgres.Time+ Paths_nri_postgresql+ hs-source-dirs:+ src+ default-extensions:+ DataKinds+ DeriveGeneric+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ PartialTypeSignatures+ ScopedTypeVariables+ Strict+ TypeOperators+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin+ build-depends:+ aeson >=1.4.6.0 && <1.6+ , attoparsec >=0.13.0.0 && <0.15+ , base >=4.12.0.0 && <4.16+ , bytestring >=0.10.8.2 && <0.12+ , filepath >=1.4.2.1 && <1.5+ , network >=3.1.0.0 && <3.2+ , nri-env-parser >=0.1.0.0 && <0.2+ , nri-observability >=0.1.0.0 && <0.2+ , nri-prelude >=0.1.0.0 && <0.7+ , postgresql-typed ==0.6.*+ , resource-pool >=0.2.0.0 && <0.3+ , resourcet >=1.2.0 && <1.3+ , safe-exceptions >=0.1.7.0 && <1.3+ , template-haskell >=2.15.0.0 && <2.17+ , text >=1.2.3.1 && <1.3+ , time >=1.8.0.2 && <1.13+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Postgres+ Postgres.Connection+ Postgres.Error+ Postgres.Query+ Postgres.QueryParser+ Postgres.Settings+ Postgres.Test+ Postgres.Time+ ObservabilitySpec+ PostgresSettingsSpec+ QueryParserSpec+ TimeSpec+ Paths_nri_postgresql+ hs-source-dirs:+ src+ test+ default-extensions:+ DataKinds+ DeriveGeneric+ FlexibleContexts+ FlexibleInstances+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ NamedFieldPuns+ NoImplicitPrelude+ OverloadedStrings+ PartialTypeSignatures+ ScopedTypeVariables+ Strict+ TypeOperators+ ExtendedDefaultRules+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -fplugin=NriPrelude.Plugin -threaded -rtsopts "-with-rtsopts=-N -T" -fno-warn-type-defaults+ build-depends:+ aeson >=1.4.6.0 && <1.6+ , attoparsec >=0.13.0.0 && <0.15+ , base >=4.12.0.0 && <4.16+ , bytestring >=0.10.8.2 && <0.12+ , filepath >=1.4.2.1 && <1.5+ , network >=3.1.0.0 && <3.2+ , nri-env-parser >=0.1.0.0 && <0.2+ , nri-observability >=0.1.0.0 && <0.2+ , nri-prelude >=0.1.0.0 && <0.7+ , postgresql-typed ==0.6.*+ , resource-pool >=0.2.0.0 && <0.3+ , resourcet >=1.2.0 && <1.3+ , safe-exceptions >=0.1.7.0 && <1.3+ , template-haskell >=2.15.0.0 && <2.17+ , text >=1.2.3.1 && <1.3+ , time >=1.8.0.2 && <1.13+ default-language: Haskell2010
+ src/Postgres.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Functions for running Postgres queries.+module Postgres+ ( -- Connection+ Connection.Connection,+ Connection.connection,+ -- Settings+ Settings.Settings,+ Settings.decoder,+ -- Querying+ Query.Query,+ Query.Error (..),+ Query.sql,+ doQuery,+ -- Handling transactions+ transaction,+ inTestTransaction,+ -- Reexposing useful postgresql-typed types+ PGTypes.PGColumn (pgDecode),+ PGTypes.PGParameter (pgEncode),+ )+where++import qualified Control.Exception.Safe as Exception+import qualified Data.Pool+import Database.PostgreSQL.Typed (PGConnection)+import qualified Database.PostgreSQL.Typed.Array as PGArray+import Database.PostgreSQL.Typed.Protocol+ ( PGError,+ pgBegin,+ pgCommit,+ pgErrorCode,+ pgRollback,+ pgRollbackAll,+ )+import qualified Database.PostgreSQL.Typed.Types as PGTypes+import GHC.Stack (HasCallStack, withFrozenCallStack)+import qualified List+import qualified Log+import qualified Log.SqlQuery as SqlQuery+import qualified Platform+import Postgres.Connection (Connection)+import qualified Postgres.Connection as Connection+import qualified Postgres.Query as Query+import qualified Postgres.Settings as Settings+import qualified Postgres.Time as Time+import qualified Task+import qualified Tuple+import qualified Prelude++-- |+-- Perform a database transaction.+transaction :: Connection -> (Connection -> Task e a) -> Task e a+transaction conn func =+ let start :: PGConnection -> Task x PGConnection+ start c =+ doIO conn <| do+ pgBegin c+ Prelude.pure c+ --+ end :: Platform.Succeeded -> PGConnection -> Task x ()+ end succeeded c =+ doIO conn+ <| case succeeded of+ Platform.Succeeded -> pgCommit c+ Platform.Failed -> pgRollback c+ Platform.FailedWith _ -> pgRollback c+ --+ setSingle :: PGConnection -> Connection+ setSingle c =+ -- All queries in a transactions must run on the same thread.+ conn {Connection.singleOrPool = Connection.Single c}+ in withConnection conn <| \c ->+ Platform.bracketWithError (start c) end (setSingle >> func)++-- | Run code in a transaction, then roll that transaction back.+-- Useful in tests that shouldn't leave anything behind in the DB.+inTestTransaction :: Connection -> (Connection -> Task x a) -> Task x a+inTestTransaction conn func =+ let start :: PGConnection -> Task x PGConnection+ start c = do+ rollbackAllSafe conn c+ doIO conn <| pgBegin c+ Prelude.pure c+ --+ end :: Platform.Succeeded -> PGConnection -> Task x ()+ end _ c =+ rollbackAllSafe conn c+ --+ setSingle :: PGConnection -> Connection+ setSingle c =+ -- All queries in a transactions must run on the same thread.+ conn {Connection.singleOrPool = Connection.Single c}+ in --+ withConnection conn <| \c ->+ Platform.bracketWithError (start c) end (setSingle >> func)++rollbackAllSafe :: Connection -> PGConnection -> Task x ()+rollbackAllSafe conn c =+ doIO conn <| do+ -- Because calling `rollbackAllTransactions` when no transactions are+ -- running will result in a warning message in the log (even if tests+ -- pass), let's start by beginning a transaction, so that we alwas have+ -- at least one to kill.+ pgBegin c+ pgRollbackAll c++-- | Run a query against MySql. This will return a list of rows, where the @row@+-- type is a tuple containing the queried columns.+--+-- > doQuery+-- > connection+-- > [sql| SELECT name, breed FROM doggos |]+-- > (\result ->+-- > case result of+-- > Ok rows -> Task.succeed rows+-- > Err err -> Task.fail err+-- > )+doQuery ::+ HasCallStack =>+ Connection ->+ Query.Query row ->+ (Result Query.Error [row] -> Task e a) ->+ Task e a+doQuery conn query handleResponse =+ runQuery conn query+ -- Handle the response before wrapping the operation in a context. This way,+ -- if the response handling logic creates errors, those errors can inherit+ -- context values like the query string.+ |> ( \task ->+ withFrozenCallStack Platform.tracingSpan "Postgresql Query" <| do+ res <-+ Platform.finally+ task+ ( do+ Platform.setTracingSpanDetails queryInfo+ Platform.setTracingSpanSummary+ ( (SqlQuery.sqlOperation queryInfo |> Maybe.withDefault "?")+ ++ " "+ ++ (SqlQuery.queriedRelation queryInfo |> Maybe.withDefault "?")+ )+ )+ -- If we end up here it means the query succeeded. Overwrite the tracing+ -- details to contain the amount of selected rows. This information can be+ -- useful when debugging slow queries.+ Platform.setTracingSpanDetails+ queryInfo {SqlQuery.rowsReturned = Just (List.length res)}+ Prelude.pure res+ )+ |> map Ok+ |> Task.onError (Task.succeed << Err)+ |> andThen handleResponse+ where+ queryInfo = Query.details query (Connection.connDetails conn)++fromPGError :: Connection -> PGError -> Query.Error+fromPGError c pgError =+ -- There's a lot of errors Postgres might throw. For a couple we have custom+ -- `Error` constructors defined, because we've seen a couple of them and would+ -- like to handle them in special ways or define custom error messages for+ -- them. If a Postgres error starts showing up in our log, please feel free+ -- to add a special case for it to this list!+ case pgErrorCode pgError of+ "23505" ->+ Exception.displayException pgError+ |> Text.fromList+ |> Query.UniqueViolation+ "57014" ->+ Query.Timeout (Time.milliseconds (Connection.timeout c))+ _ ->+ Exception.displayException pgError+ |> Text.fromList+ -- We add the full error in the context array rather than the+ -- message string, to help errors being grouped correctly in a+ -- bug tracker. Errors might contain unique bits of data like+ -- generated id's or timestamps which when included in the main+ -- error message would result in each error being grouped by+ -- itself.+ |> (\err -> Query.Other "Postgres query failed with unexpected error" [Log.context "error" err])++--+-- CONNECTION HELPERS+--++runQuery :: Connection -> Query.Query row -> Task Query.Error [row]+runQuery conn query =+ withConnection conn <| \c ->+ Query.runQuery query c+ |> Exception.try+ |> map+ ( \res -> case res of+ Prelude.Right x -> Ok x+ Prelude.Left err -> Err (fromPGError conn err)+ )+ |> Platform.doAnything (Connection.doAnything conn)+ |> withTimeout conn++withTimeout :: Connection -> Task Query.Error a -> Task Query.Error a+withTimeout conn task =+ if Time.microseconds (Connection.timeout conn) > 0+ then+ Task.timeout+ (Time.milliseconds (Connection.timeout conn))+ (Query.Timeout (Time.milliseconds (Connection.timeout conn)))+ task+ else task++-- | by default, queries pull a connection from the connection pool.+-- For SQL transactions, we want all queries within the transaction to run+-- on the same connection. withConnection lets transaction bundle+-- queries on the same connection.+withConnection :: Connection -> (PGConnection -> Task e a) -> Task e a+withConnection conn func =+ let acquire :: Data.Pool.Pool conn -> Task x (conn, Data.Pool.LocalPool conn)+ acquire pool =+ Log.withContext "acquiring Postgres connection from pool" []+ <| doIO conn+ <| Data.Pool.takeResource pool+ --+ release :: Data.Pool.Pool conn -> Platform.Succeeded -> (conn, Data.Pool.LocalPool conn) -> Task y ()+ release pool succeeded (c, localPool) =+ doIO conn+ <| case succeeded of+ Platform.Succeeded ->+ Data.Pool.putResource localPool c+ Platform.Failed ->+ Data.Pool.destroyResource pool localPool c+ Platform.FailedWith _ ->+ Data.Pool.destroyResource pool localPool c+ in --+ case Connection.singleOrPool conn of+ (Connection.Single c) ->+ func c+ --+ (Connection.Pool pool) ->+ Platform.bracketWithError (acquire pool) (release pool) (Tuple.first >> func)++doIO :: Connection -> Prelude.IO a -> Task x a+doIO conn io =+ Platform.doAnything (Connection.doAnything conn) (io |> map Ok)++-- useful typeclass instances+instance PGTypes.PGType "jsonb" => PGTypes.PGType "jsonb[]" where+ type PGVal "jsonb[]" = PGArray.PGArray (PGTypes.PGVal "jsonb")++instance PGTypes.PGType "jsonb" => PGArray.PGArrayType "jsonb[]" where+ type PGElemType "jsonb[]" = "jsonb"
+ src/Postgres/Connection.hs view
@@ -0,0 +1,137 @@+module Postgres.Connection (connection, connectionIO, SingleOrPool (..), Connection (..)) where++import qualified Control.Exception.Safe as Exception+import qualified Data.Acquire+import qualified Data.Pool+import qualified Data.Text.Encoding+import Database.PostgreSQL.Typed+ ( PGConnection,+ PGDatabase (PGDatabase),+ pgConnect,+ pgDBAddr,+ pgDBName,+ pgDBUser,+ pgDisconnect,+ )+import qualified Log.SqlQuery as SqlQuery+import qualified Network.Socket as Socket+import qualified Postgres.Settings as Settings+import qualified Postgres.Time as Time+import qualified System.Exit+import qualified Prelude++-- | A connection to Postgres. You need this for making Postgres queries.+data Connection = Connection+ { doAnything :: Platform.DoAnythingHandler,+ singleOrPool :: SingleOrPool PGConnection,+ connDetails :: SqlQuery.Details,+ timeout :: Time.Interval+ }++-- | A database connection type.+-- Defining our own type makes it easier to change it in the future, without+-- having to fix compilation errors all over the codebase.+data SingleOrPool c+ = -- | By default a connection pool is passed around. It will:+ -- - Create new connections in the pool up to a certain limit.+ -- - Remove connections from the pool after a query in a connection errored.+ Pool (Data.Pool.Pool c)+ | -- | A single connection is only used in the context of a transaction, where+ -- we need to insure several SQL statements happen on the same connection.+ Single c++connectionIO :: Settings.Settings -> Prelude.IO Connection+connectionIO settings = do+ let database = Settings.toPGDatabase settings+ let stripes =+ Settings.unPgPoolStripes (Settings.pgPoolStripes (Settings.pgPool settings))+ |> Prelude.fromIntegral+ let maxIdleTime = Settings.unPgPoolMaxIdleTime (Settings.pgPoolMaxIdleTime (Settings.pgPool settings))+ let size =+ Settings.unPgPoolSize (Settings.pgPoolSize (Settings.pgPool settings))+ |> Prelude.fromIntegral+ doAnything <- Platform.doAnythingHandler+ pool <-+ map Pool+ <| Data.Pool.createPool+ (pgConnect database `Exception.catch` handleError (toConnectionString database))+ pgDisconnect+ stripes+ maxIdleTime+ size+ Prelude.pure+ ( Connection+ doAnything+ pool+ (connectionDetails database)+ (Settings.pgQueryTimeout settings)+ )++-- | Create a 'Connection'.+connection :: Settings.Settings -> Data.Acquire.Acquire Connection+connection settings =+ Data.Acquire.mkAcquire (connectionIO settings) release+ where+ release Connection {singleOrPool} =+ case singleOrPool of+ Pool pool -> Data.Pool.destroyAllResources pool+ Single single -> pgDisconnect single++handleError :: Text -> Exception.IOException -> Prelude.IO a+handleError connectionString err = do+ Prelude.putStrLn "I couldn't connect to Postgres"+ Prelude.putStrLn ""+ Prelude.putStrLn "Is the database running?"+ Prelude.putStrLn ("I tried to connect to: " ++ Text.toList connectionString)+ System.Exit.die (Exception.displayException err)++toConnectionString :: PGDatabase -> Text+toConnectionString PGDatabase {pgDBUser, pgDBAddr, pgDBName} =+ Text.join+ ""+ [ Data.Text.Encoding.decodeUtf8 pgDBUser,+ ":*****@",+ case pgDBAddr of+ Prelude.Right sockAddr ->+ Text.fromList (Prelude.show sockAddr)+ Prelude.Left (hostName, serviceName) ->+ Text.fromList hostName+ ++ ":"+ ++ Text.fromList serviceName,+ "/",+ Data.Text.Encoding.decodeUtf8 pgDBName+ ]++connectionDetails :: PGDatabase -> SqlQuery.Details+connectionDetails db =+ case pgDBAddr db of+ Prelude.Left (hostName, serviceName) ->+ SqlQuery.emptyDetails+ { SqlQuery.databaseType = Just SqlQuery.postgresql,+ SqlQuery.host = Just (Text.fromList hostName),+ SqlQuery.port = Text.toInt (Text.fromList serviceName),+ SqlQuery.database = Just databaseName+ }+ Prelude.Right (Socket.SockAddrInet portNum hostAddr) ->+ SqlQuery.emptyDetails+ { SqlQuery.databaseType = Just SqlQuery.postgresql,+ SqlQuery.host = Just (Text.fromList (Prelude.show hostAddr)),+ SqlQuery.port = Just (Prelude.fromIntegral portNum),+ SqlQuery.database = Just databaseName+ }+ Prelude.Right (Socket.SockAddrInet6 portNum _flowInfo hostAddr _scopeId) ->+ SqlQuery.emptyDetails+ { SqlQuery.databaseType = Just SqlQuery.postgresql,+ SqlQuery.host = Just (Text.fromList (Prelude.show hostAddr)),+ SqlQuery.port = Just (Prelude.fromIntegral portNum),+ SqlQuery.database = Just databaseName+ }+ Prelude.Right (Socket.SockAddrUnix sockPath) ->+ SqlQuery.emptyDetails+ { SqlQuery.databaseType = Just SqlQuery.postgresql,+ SqlQuery.host = Just (Text.fromList sockPath),+ SqlQuery.port = Nothing,+ SqlQuery.database = Just databaseName+ }+ where+ databaseName = pgDBName db |> Data.Text.Encoding.decodeUtf8
+ src/Postgres/Error.hs view
@@ -0,0 +1,22 @@+module Postgres.Error+ ( Error (..),+ )+where++import qualified Control.Exception.Safe as Exception+import qualified Log+import qualified Text+import Prelude (Show (show))++-- | A postgres query might fail with one of these errors.+data Error+ = Timeout Float+ | UniqueViolation Text+ | Other Text [Log.Context]++instance Show Error where+ show (Timeout interval) = "Query timed out after " ++ Text.toList (Text.fromFloat interval) ++ " milliseconds"+ show (UniqueViolation err) = "Query violated uniqueness constraint: " ++ Text.toList err+ show (Other msg _) = "Query failed with unexpected error: " ++ Text.toList msg++instance Exception.Exception Error
+ src/Postgres/Query.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Description : Helpers for running queries.+--+-- This module expose some helpers for running postgresql-typed queries. They+-- return the correct amount of results in a Servant handler, or throw a+-- Rollbarred error.+module Postgres.Query+ ( sql,+ Query (..),+ Error (..),+ format,+ details,+ )+where++import Control.Monad (void)+import Data.String (String)+import qualified Data.Text.Encoding+import Database.PostgreSQL.Typed (PGConnection, pgSQL, useTPGDatabase)+import Database.PostgreSQL.Typed.Array ()+import Database.PostgreSQL.Typed.Query (getQueryString, pgQuery)+import qualified Database.PostgreSQL.Typed.Types as PGTypes+import qualified Environment+import Language.Haskell.TH (ExpQ)+import Language.Haskell.TH.Quote+ ( QuasiQuoter (QuasiQuoter, quoteDec, quoteExp, quotePat, quoteType),+ )+import Language.Haskell.TH.Syntax (runIO)+import qualified List+import qualified Log+import qualified Log.SqlQuery as SqlQuery+import Postgres.Error (Error (..))+import qualified Postgres.QueryParser as Parser+import qualified Postgres.Settings+import qualified Text+import Prelude (IO)+import qualified Prelude++-- | A Postgres query. Create one of these using the `sql` quasiquoter.+data Query row = Query+ { -- | Run a query against Postgres+ runQuery :: PGConnection -> IO [row],+ -- | The raw SQL string+ sqlString :: Text,+ -- | The query string as extracted from an `sql` quasi quote.+ quasiQuotedString :: Text,+ -- | SELECT / INSERT / UPDATE / INSERT ON DUPLICATE KEY UPDATE ...+ sqlOperation :: Text,+ -- | The main table/view/.. queried.+ queriedRelation :: Text+ }++qqSQL :: String -> ExpQ+qqSQL query = do+ let db =+ Environment.decode Postgres.Settings.decoder+ |> map Postgres.Settings.toPGDatabase+ db' <- runIO db+ void (useTPGDatabase db')+ let meta = Parser.parse (Text.fromList query)+ let op = Text.toList (Parser.sqlOperation meta)+ let rel = Text.toList (Parser.queriedRelation meta)+ [e|+ let q = $(quoteExp pgSQL query)+ in Query+ { runQuery = \c -> pgQuery c q,+ sqlString = Data.Text.Encoding.decodeUtf8 (getQueryString PGTypes.unknownPGTypeEnv q),+ quasiQuotedString = Text.fromList query,+ sqlOperation = op,+ queriedRelation = rel+ }+ |]++-- | Quasi-quoter that allows you to write plain SQL in your code. The query is+-- checked at compile-time using the 'postgresql-typed' library.+--+-- Requires the QuasiQuotes language extension to be enabled.+--+-- > [sql| SELECT name, breed FROM doggos |]+sql :: QuasiQuoter+sql =+ QuasiQuoter+ { quoteExp = qqSQL,+ quoteType = Prelude.error "sql not supported in types",+ quotePat = Prelude.error "sql not supported in patterns",+ quoteDec = Prelude.error "sql not supported in declarations"+ }++format :: Query row -> Text.Text+format query =+ let fixBang query_ =+ case Text.uncons query_ of+ Just ('!', rest) -> "! " ++ Text.trim rest+ Just _ -> query_+ Nothing -> query_+ indent string =+ " " ++ string+ in quasiQuotedString query+ |> Text.split "\n"+ |> List.map Text.trim+ |> Text.join "\n "+ |> fixBang+ |> indent++details :: Query row -> SqlQuery.Details -> SqlQuery.Details+details query connectionDetails =+ connectionDetails+ { SqlQuery.query = Just (Log.mkSecret (sqlString query)),+ SqlQuery.queryTemplate = Just (quasiQuotedString query),+ SqlQuery.sqlOperation = Just (sqlOperation query),+ SqlQuery.queriedRelation = Just (queriedRelation query)+ }
+ src/Postgres/QueryParser.hs view
@@ -0,0 +1,122 @@+-- |+-- Parse some high-level information out of a query, for use in tracing.+-- We try to find the query method (SELECT / INSERT / ...) and queried table+-- in the root SQL query. We assume the root query to be the first query not+-- in a sub query. We assume everything between parens `( ... )` to be a+-- sub query.+module Postgres.QueryParser+ ( parse,+ QueryMeta (..),+ )+where++import Control.Applicative+import Control.Monad (void)+import Data.Attoparsec.Text (Parser, anyChar, asciiCI, char, inClass, manyTill, skipSpace, space, takeWhile)+import qualified Data.Attoparsec.Text as Attoparsec+import Data.Foldable (asum)+import qualified List+import qualified Maybe+import qualified Text+import Prelude (Either (Left, Right))++parse :: Text -> QueryMeta+parse query =+ case Attoparsec.parseOnly parser query of+ Left _ ->+ QueryMeta+ { queriedRelation =+ Text.lines query+ |> List.head+ |> Maybe.withDefault "",+ sqlOperation = "UNKNOWN"+ }+ Right result -> result++data QueryMeta = QueryMeta+ { queriedRelation :: Text,+ sqlOperation :: Text+ }+ deriving (Eq, Show)++parser :: Parser QueryMeta+parser =+ keepLooking+ <| asum+ [ delete,+ insert,+ select,+ truncate',+ update+ ]++keepLooking :: Parser a -> Parser a+keepLooking p = do+ skipSpace+ asum+ [ -- 1. If we encounter sub queries (bounded in parens), skip them first.+ do+ void <| some skipSubExpression+ keepLooking p,+ -- 2. Try to run the target parser.+ p,+ -- 3. Failing all else, move forward a word and try again.+ do+ void <| manyTill anyChar (space <|> char '(')+ keepLooking p+ ]++skipSubExpression :: Parser ()+skipSubExpression = do+ void <| char '('+ void <| keepLooking (char ')')++delete :: Parser QueryMeta+delete = do+ void <| asciiCI "DELETE"+ skipSpace+ void <| asciiCI "FROM"+ skipSpace+ queriedRelation <- tableName+ pure QueryMeta {queriedRelation, sqlOperation = "DELETE"}++insert :: Parser QueryMeta+insert = do+ void <| asciiCI "INSERT"+ skipSpace+ void <| asciiCI "INTO"+ skipSpace+ queriedRelation <- tableName+ pure QueryMeta {queriedRelation, sqlOperation = "INSERT"}++select :: Parser QueryMeta+select = do+ void <| asciiCI "SELECT"+ keepLooking <| do+ void <| asciiCI "FROM"+ keepLooking <| do+ queriedRelation <- tableName+ pure QueryMeta {queriedRelation, sqlOperation = "SELECT"}++tableName :: Parser Text+tableName =+ takeWhile (inClass "a-zA-Z0-9._")++truncate' :: Parser QueryMeta+truncate' = do+ void <| asciiCI "UPDATE"+ skipSpace+ (asciiCI "ONLY" |> void) <|> pure ()+ skipSpace+ queriedRelation <- tableName+ pure QueryMeta {queriedRelation, sqlOperation = "UPDATE"}++update :: Parser QueryMeta+update = do+ void <| asciiCI "TRUNCATE"+ skipSpace+ (asciiCI "TABLE" |> void) <|> pure ()+ (asciiCI "ONLY" |> void) <|> pure ()+ skipSpace+ queriedRelation <- tableName+ pure QueryMeta {queriedRelation, sqlOperation = "TRUNCATE"}
+ src/Postgres/Settings.hs view
@@ -0,0 +1,330 @@+module Postgres.Settings+ ( Settings+ ( Settings,+ pgConnection,+ pgPool,+ pgQueryTimeout+ ),+ ConnectionSettings+ ( ConnectionSettings,+ pgDatabase,+ pgUser,+ pgHost,+ pgPassword,+ pgPort+ ),+ PoolSettings+ ( PoolSettings,+ pgPoolStripes,+ pgPoolMaxIdleTime,+ pgPoolSize+ ),+ decoder,+ decoderWithPrefix,+ PgDatabase (PgDatabase, unPgDatabase),+ PgUser (PgUser, unPgUser),+ PgHost (PgHost, unPgHost),+ PgPassword (PgPassword, unPgPassword),+ PgPort (PgPort, unPgPort),+ PgPoolStripes (PgPoolStripes, unPgPoolStripes),+ PgPoolMaxIdleTime (PgPoolMaxIdleTime, unPgPoolMaxIdleTime),+ PgPoolSize (PgPoolSize, unPgPoolSize),+ defaultSettings,+ toPGDatabase,+ )+where++import qualified Data.ByteString.Char8+import qualified Data.Text.Encoding+import qualified Data.Time+import Database.PostgreSQL.Typed+ ( PGDatabase,+ defaultPGDatabase,+ pgDBAddr,+ pgDBName,+ pgDBParams,+ pgDBPass,+ pgDBUser,+ )+import qualified Environment+import qualified Log+import Network.Socket (SockAddr (SockAddrUnix))+import qualified Postgres.Time as Time+import System.FilePath ((</>))+import Prelude (Either (Left, Right), pure, realToFrac, round, show)++-- | Postgres connection details. You can use 'decoder' to create one of these.+data Settings = Settings+ { pgConnection :: ConnectionSettings,+ pgPool :: PoolSettings,+ pgQueryTimeout :: Time.Interval+ }+ deriving (Eq, Show)++defaultSettings :: Settings+defaultSettings =+ Settings+ { pgConnection =+ ConnectionSettings+ { pgDatabase = PgDatabase "postgres",+ pgUser = PgUser "postgres",+ pgHost = PgHost "localhost",+ pgPassword = PgPassword (Log.mkSecret ""),+ pgPort = PgPort 5432+ },+ pgPool =+ PoolSettings+ { pgPoolSize =+ -- Connections in the pool are allocated on demand, so we won't+ -- create all these connections unless the application can make use+ -- of them.+ PgPoolSize 500,+ pgPoolMaxIdleTime = PgPoolMaxIdleTime (toNominalDiffTime 3600),+ pgPoolStripes = PgPoolStripes 1+ },+ pgQueryTimeout = Time.fromSeconds 5+ }++data ConnectionSettings = ConnectionSettings+ { pgDatabase :: PgDatabase,+ pgUser :: PgUser,+ pgHost :: PgHost,+ pgPassword :: PgPassword,+ pgPort :: PgPort+ }+ deriving (Eq, Show)++data PoolSettings = PoolSettings+ { pgPoolSize :: PgPoolSize,+ pgPoolMaxIdleTime :: PgPoolMaxIdleTime,+ pgPoolStripes :: PgPoolStripes+ }+ deriving (Eq, Show)++-- | Create a 'Settings' value by reading settings from environment values.+--+-- [@environment variable@] PGHOST+-- [@default value@] localhost+--+-- [@environment variable@] PGPORT+-- [@default value@] 5432+--+-- [@environment variable@] PGDATABASE+-- [@default value@] postgresql+--+-- [@environment variable@] PGUSER+-- [@default value@] postgresql+--+-- [@environment variable@] PGPASSWORD+-- [@default value@]+--+-- [@environment variable@] PG_POOL_SIZE+-- [@default value@] 500+--+-- [@environment variable@] PG_POOL_STRIPES+-- [@default value@] 1+--+-- [@environment variable@] PG_POOL_MAX_IDLE_TIME+-- [@default value@] 3600+--+-- [@environment variable@] PG_QUERY_TIMEOUT_SECONDS+-- [@default value@] 5+decoder :: Environment.Decoder Settings+decoder = decoderWithPrefix ""++decoderWithPrefix :: Text -> Environment.Decoder Settings+decoderWithPrefix prefix =+ pure Settings+ |> andMap (connectionDecoder prefix)+ |> andMap poolDecoder+ |> andMap queryTimeoutDecoder++connectionDecoder :: Text -> Environment.Decoder ConnectionSettings+connectionDecoder prefix =+ pure ConnectionSettings+ |> andMap (pgDatabaseDecoder prefix)+ |> andMap (pgUserDecoder prefix)+ |> andMap (pgHostDecoder prefix)+ |> andMap (pgPasswordDecoder prefix)+ |> andMap (pgPortDecoder prefix)++poolDecoder :: Environment.Decoder PoolSettings+poolDecoder =+ pure PoolSettings+ |> andMap pgPoolSizeDecoder+ |> andMap pgPoolMaxIdleTimeDecoder+ |> andMap pgPoolStripesDecoder++newtype PgPort = PgPort {unPgPort :: Int}+ deriving (Eq, Show)++pgPortDecoder :: Text -> Environment.Decoder PgPort+pgPortDecoder prefix =+ Environment.variable+ Environment.Variable+ { Environment.name = prefix ++ "PGPORT",+ Environment.description = "The port postgres is running on.",+ Environment.defaultValue =+ defaultSettings |> pgConnection |> pgPort |> unPgPort |> show |> Text.fromList+ }+ (Environment.int |> map PgPort)++newtype PgPassword = PgPassword {unPgPassword :: Log.Secret Text}+ deriving (Eq, Show)++pgPasswordDecoder :: Text -> Environment.Decoder PgPassword+pgPasswordDecoder prefix =+ Environment.variable+ Environment.Variable+ { Environment.name = prefix ++ "PGPASSWORD",+ Environment.description = "The postgres user password.",+ Environment.defaultValue =+ defaultSettings |> pgConnection |> pgPassword |> unPgPassword |> Log.unSecret+ }+ (Environment.secret Environment.text |> map PgPassword)++newtype PgHost = PgHost {unPgHost :: Text}+ deriving (Eq, Show)++pgHostDecoder :: Text -> Environment.Decoder PgHost+pgHostDecoder prefix =+ Environment.variable+ Environment.Variable+ { Environment.name = prefix ++ "PGHOST",+ Environment.description = "The hostname of the postgres server to connect to.",+ Environment.defaultValue =+ defaultSettings |> pgConnection |> pgHost |> unPgHost+ }+ (Environment.text |> map PgHost)++newtype PgUser = PgUser {unPgUser :: Text}+ deriving (Eq, Show)++pgUserDecoder :: Text -> Environment.Decoder PgUser+pgUserDecoder prefix =+ Environment.variable+ Environment.Variable+ { Environment.name = prefix ++ "PGUSER",+ Environment.description = "The postgres user to connect with.",+ Environment.defaultValue =+ defaultSettings |> pgConnection |> pgUser |> unPgUser+ }+ (Environment.text |> map PgUser)++newtype PgDatabase = PgDatabase {unPgDatabase :: Text}+ deriving (Eq, Show)++pgDatabaseDecoder :: Text -> Environment.Decoder PgDatabase+pgDatabaseDecoder prefix =+ Environment.variable+ Environment.Variable+ { Environment.name = prefix ++ "PGDATABASE",+ Environment.description = "The postgres database to connect to.",+ Environment.defaultValue =+ defaultSettings |> pgConnection |> pgDatabase |> unPgDatabase+ }+ (map PgDatabase Environment.text)++newtype PgPoolStripes = PgPoolStripes {unPgPoolStripes :: Int}+ deriving (Eq, Show)++pgPoolStripesDecoder :: Environment.Decoder PgPoolStripes+pgPoolStripesDecoder =+ Environment.variable+ Environment.Variable+ { Environment.name = "PG_POOL_STRIPES",+ Environment.description = "The amount of sub-connection pools to create. Best refer to the resource-pool package for more info on this one. 1 is a good value for most applications.",+ Environment.defaultValue =+ defaultSettings |> pgPool |> pgPoolStripes |> unPgPoolStripes |> show |> Text.fromList+ }+ (Environment.int |> map PgPoolStripes)++newtype PgPoolMaxIdleTime = PgPoolMaxIdleTime {unPgPoolMaxIdleTime :: Data.Time.NominalDiffTime}+ deriving (Eq, Show)++pgPoolMaxIdleTimeDecoder :: Environment.Decoder PgPoolMaxIdleTime+pgPoolMaxIdleTimeDecoder =+ Environment.variable+ Environment.Variable+ { Environment.name = "PG_POOL_MAX_IDLE_TIME",+ Environment.description = "The maximum time a database connection will be able remain idle until it is closed.",+ Environment.defaultValue =+ defaultSettings |> pgPool |> pgPoolMaxIdleTime |> unPgPoolMaxIdleTime |> fromNominalDiffTime |> show |> Text.fromList+ }+ (Environment.int |> map (PgPoolMaxIdleTime << toNominalDiffTime))++toNominalDiffTime :: Int -> Data.Time.NominalDiffTime+toNominalDiffTime = realToFrac++fromNominalDiffTime :: Data.Time.NominalDiffTime -> Int+fromNominalDiffTime = Prelude.round++newtype PgPoolSize = PgPoolSize {unPgPoolSize :: Int}+ deriving (Eq, Show)++pgPoolSizeDecoder :: Environment.Decoder PgPoolSize+pgPoolSizeDecoder =+ Environment.variable+ Environment.Variable+ { Environment.name = "PG_POOL_SIZE",+ Environment.description = "The size of the postgres connection pool. This is the maximum amount of parallel database connections the app will be able to use.",+ Environment.defaultValue =+ defaultSettings |> pgPool |> pgPoolSize |> unPgPoolSize |> show |> Text.fromList+ }+ (Environment.int |> map PgPoolSize)++toPGDatabase :: Settings -> PGDatabase+toPGDatabase+ Settings+ { pgConnection =+ ConnectionSettings+ { pgDatabase,+ pgUser,+ pgHost,+ pgPassword,+ pgPort+ },+ pgQueryTimeout+ } =+ defaultPGDatabase+ { pgDBName = Data.Text.Encoding.encodeUtf8 (unPgDatabase pgDatabase),+ pgDBUser = Data.Text.Encoding.encodeUtf8 (unPgUser pgUser),+ pgDBPass = Data.Text.Encoding.encodeUtf8 <| Log.unSecret (unPgPassword pgPassword),+ pgDBParams =+ if Time.milliseconds pgQueryTimeout > 0+ then+ [ -- We configure Postgres to automatically kill queries when they run+ -- too long. That should offer some protection against queries+ -- locking up the database.+ -- https://www.postgresql.org/docs/9.4/runtime-config-client.html+ ("statement_timeout", pgQueryTimeout |> Time.milliseconds |> floor |> show |> Data.ByteString.Char8.pack)+ ]+ else [],+ pgDBAddr =+ -- The rule that PostgreSQL/libpq applies to `host`:+ --+ -- If this begins with a slash, it specifies Unix-domain+ -- communication rather than TCP/IP communication; the value is the+ -- name of the directory in which the socket file is stored+ --+ -- https://www.postgresql.org/docs/9.6/libpq-connect.html#LIBPQ-CONNECT-HOST+ if Text.startsWith "/" host+ then+ Text.toList host </> ".s.PGSQL." ++ show port+ |> SockAddrUnix+ |> Right+ else Left (Text.toList host, show port)+ }+ where+ host = unPgHost pgHost+ port = unPgPort pgPort++queryTimeoutDecoder :: Environment.Decoder Time.Interval+queryTimeoutDecoder =+ Environment.variable+ Environment.Variable+ { Environment.name = "PG_QUERY_TIMEOUT_SECONDS",+ Environment.description = "The maximum time a query can run before it is cancelled.",+ Environment.defaultValue = defaultSettings |> pgQueryTimeout |> Time.seconds |> show |> Text.fromList+ }+ (Environment.float |> map Time.fromSeconds)
+ src/Postgres/Test.hs view
@@ -0,0 +1,89 @@+{-# OPTIONS_GHC -fno-cse #-}++-- | Write tests that require a Postgres connection.+module Postgres.Test (test) where++import qualified Control.Concurrent.MVar as MVar+import qualified Environment+import qualified Expect+import qualified GHC.Stack as Stack+import qualified Platform+import qualified Postgres+import qualified Postgres.Connection as Connection+import qualified Postgres.Settings as Settings+import qualified System.IO.Unsafe+import qualified Test+import qualified Prelude++-- | A variant of `Test.test` that is passed a Postgres connection, for doing tests+-- that require access to Postgres. The test body is run within a transaction that+-- gets rolled back after the test completes.+--+-- Usage:+--+-- Postgres.Test.test "My Postgres test" <| \Postgres -> do+-- -- test stuff!+test ::+ Stack.HasCallStack =>+ Text ->+ (Postgres.Connection -> Expect.Expectation) ->+ Test.Test+test description body =+ Stack.withFrozenCallStack Test.test description <| \_ ->+ Expect.around+ ( \task' -> do+ conn <- getTestConnection+ Postgres.inTestTransaction conn task'+ )+ body++-- Obtain a Postgres connection for use in tests.+getTestConnection :: Task e Postgres.Connection+getTestConnection =+ -- The MVar exists to allow this function to be called by multiple tests+ -- running in parallel, and only the first test calling it will create a+ -- connection pool. The other tests will block until the pool is created, then+ -- share it.+ --+ -- This works because `MVar.modifyMVar` ensures the function we pass it is+ -- not called concurrently.+ MVar.modifyMVar+ testConnectionVar+ ( \maybeConn -> do+ conn <-+ case maybeConn of+ Just conn -> Prelude.pure conn+ Nothing -> do+ testSettings <- Environment.decode (Settings.decoderWithPrefix "TEST_")+ settings <-+ if Settings.pgConnection Settings.defaultSettings == Settings.pgConnection testSettings+ then Environment.decode Settings.decoder+ else Prelude.pure testSettings+ Connection.connectionIO settings+ Prelude.pure (Just conn, conn)+ )+ |> map Ok+ |> Platform.doAnything testDoAnything++-- | Create a 'global' variable containing the connection we want to use in+-- tests.+--+-- It's not truly global, only functions in this module can access it (because+-- we do not expose it). But it is a bit global in the sense that they'll be+-- able to access this variable without needing to be passed a reference to it+-- from outside.+--+-- The `NOINLINE` is instruction to Haskell not to try be efficient and inline+-- this function in where it's called. If Haskell did that it would result+-- in a new `MVar` being created every time we use `testConnectionVar`, instead+-- of a single `MVar` being shared between all these calls.+{-# NOINLINE testConnectionVar #-}+testConnectionVar :: MVar.MVar (Maybe Postgres.Connection)+testConnectionVar = System.IO.Unsafe.unsafePerformIO (MVar.newMVar Nothing)++-- | Creates a unpacked `DoAnythingHandler`, allowing us to use it without+-- to turn `IO` into `Task` types without needing to pass it in as an argument,+-- in the context of this test helper.+{-# NOINLINE testDoAnything #-}+testDoAnything :: Platform.DoAnythingHandler+testDoAnything = System.IO.Unsafe.unsafePerformIO Platform.doAnythingHandler
+ src/Postgres/Time.hs view
@@ -0,0 +1,37 @@+module Postgres.Time+ ( Interval,+ fromMicroseconds,+ fromMilliseconds,+ fromSeconds,+ microseconds,+ milliseconds,+ seconds,+ )+where++-- | A type representing a time interval.+newtype Interval = Interval+ { -- | Get the duration of an interval in microseconds.+ microseconds :: Int+ }+ deriving (Eq, Show)++-- | Create an `Interval` lasting a certain number of microseconds.+fromMicroseconds :: Int -> Interval+fromMicroseconds = Interval++-- | Get the duration of an interval in seconds.+seconds :: Interval -> Float+seconds interval = 1e-6 * toFloat (microseconds interval)++-- | Create an `Interval` lasting a certain number of seconds.+fromSeconds :: Float -> Interval+fromSeconds duration = fromMicroseconds (round (1e6 * duration))++-- | Get the duration of an interval in milliseconds.+milliseconds :: Interval -> Float+milliseconds interval = 1e-3 * toFloat (microseconds interval)++-- | Create an `Interval` lasting a certain number of milliseconds.+fromMilliseconds :: Float -> Interval+fromMilliseconds duration = fromMicroseconds (round (1e3 * duration))
+ test/Main.hs view
@@ -0,0 +1,32 @@+module Main+ ( main,+ )+where++import qualified Data.Acquire as Acquire+import qualified Environment+import qualified ObservabilitySpec+import qualified Postgres+import qualified PostgresSettingsSpec+import qualified QueryParserSpec+import Test (Test, describe, run)+import qualified TimeSpec+import qualified Prelude++-- `Test.run` exits after finishing, so run other tests first.+main :: Prelude.IO ()+main = do+ postgresSettings <- Environment.decode Postgres.decoder+ Acquire.withAcquire+ (Postgres.connection postgresSettings)+ (run << tests)++tests :: Postgres.Connection -> Test+tests postgres =+ describe+ "lib/database"+ [ PostgresSettingsSpec.tests,+ QueryParserSpec.tests,+ TimeSpec.tests,+ ObservabilitySpec.tests postgres+ ]
+ test/ObservabilitySpec.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE QuasiQuotes #-}++module ObservabilitySpec+ ( tests,+ )+where++import qualified Control.Concurrent.MVar as MVar+import qualified Debug+import qualified Expect+import qualified Log.SqlQuery as SqlQuery+import qualified Maybe+import qualified Platform+import qualified Postgres+import qualified Task+import Test (Test, describe)+import qualified Test+import qualified Prelude++-- | Note: the tests below pretty easily break because of code movemenents in+-- this file. The test logs they expect contain stack traces to function calls+-- in this module, so if everything shifts down a line because we add an extra+-- import or something these tests break.+--+-- Easiest thing to do is to remove the whole golden-results directory and run+-- the tests again. That will regenerate the expectation files. Then check the+-- diff of the new file to make sure it's only line numbers that changed, not+-- something more significant such as the module name of the stack trace.+tests :: Postgres.Connection -> Test+tests postgres =+ describe+ "ObservabilitySpec"+ [ Test.test "Postgres queries report the span data we expect" <| \_ -> do+ span <-+ Postgres.doQuery+ postgres+ [Postgres.sql|!SELECT 1::bigint|]+ ( \res ->+ case res of+ Err err -> Task.fail err+ Ok (_ :: [Int]) -> Task.succeed ()+ )+ |> spanForTask+ Debug.toString span+ |> Expect.equalToContentsOf "test/golden-results/observability-spec-postgres-reporting"+ ]++spanForTask :: Show e => Task e () -> Expect.Expectation' Platform.TracingSpan+spanForTask task =+ Expect.fromIO <| do+ spanVar <- MVar.newEmptyMVar+ res <-+ Platform.rootTracingSpanIO+ "test-request"+ (MVar.putMVar spanVar)+ "test-root"+ (\log -> Task.attempt log task)+ case res of+ Err err -> Prelude.fail <| Text.toList (Debug.toString err)+ Ok _ ->+ MVar.takeMVar spanVar+ |> map constantValuesForVariableFields++-- | Timestamps recorded in spans would make each test result different from the+-- last. This helper sets all timestamps to zero to prevent this.+--+-- Similarly the db URI changes in each test, because we create temporary test+-- database. To prevent this from failing tests we set the URI to a standard+-- value.+constantValuesForVariableFields :: Platform.TracingSpan -> Platform.TracingSpan+constantValuesForVariableFields span =+ span+ { Platform.started = 0,+ Platform.finished = 0,+ Platform.details =+ Platform.details span+ |> andThen+ ( \details ->+ details+ |> Platform.renderTracingSpanDetails+ [ Platform.Renderer+ ( \info ->+ Platform.toTracingSpanDetails+ info+ { SqlQuery.host = Just "/mock/db/path.sock",+ SqlQuery.port = Nothing,+ SqlQuery.database = Just "mock-db-name"+ }+ )+ ]+ |> Maybe.withDefault details+ |> Just+ ),+ Platform.allocated = 0,+ Platform.children = map constantValuesForVariableFields (Platform.children span)+ }
+ test/PostgresSettingsSpec.hs view
@@ -0,0 +1,23 @@+module PostgresSettingsSpec (tests) where++import qualified Environment (decodeDefaults)+import qualified Expect+import qualified Postgres.Settings+import Test (Test, describe, test)++tests :: Test+tests =+ describe+ "Postgres.Settings"+ [ decodingTests+ ]++decodingTests :: Test+decodingTests =+ describe+ "decoding"+ [ test "default connection settings are decoded" <| \() ->+ Expect.equal+ (Ok Postgres.Settings.defaultSettings :: Result Text Postgres.Settings.Settings) -- expected+ (Environment.decodeDefaults Postgres.Settings.decoder) -- observed+ ]
+ test/QueryParserSpec.hs view
@@ -0,0 +1,152 @@+module QueryParserSpec (tests) where++import qualified Expect+import qualified Postgres.QueryParser as Parser+import Test (Test, describe, test)+import qualified Text++-- The tests below pull from real queries used in this repo. If a particular+-- query not listed here doesn't show up correctly in traces please add it as+-- test case.+tests :: Test+tests =+ describe+ "Postgres.QueryParser"+ [ describe+ "parse SQL"+ [ test "simple select" <| \_ ->+ parseTest+ [ "SELECT hat FROM royalty",+ "WHERE hat IN (\"crown\", \"fedora\", \"cap\")"+ ]+ |> Expect.equal (Parser.QueryMeta "royalty" "SELECT"),+ test "subquery in FROM" <| \_ ->+ parseTest+ [ "SELECT draft_id, title, updated_at, created_at",+ "FROM (SELECT (drafts.get_draft(id)).*",+ " FROM drafts.deltas",+ " WHERE id = ANY (${draftIds}::uuid[])",+ " ) draft_data;"+ ]+ |> Expect.equal (Parser.QueryMeta "draft_data" "SELECT"),+ test "unparseable string" <| \_ ->+ parseTest+ [ "Hello,",+ "World!"+ ]+ |> Expect.equal (Parser.QueryMeta "Hello," "UNKNOWN"),+ test "preceded by WITH statement" <| \_ ->+ parseTest+ [ "WITH answers AS (",+ " SELECT",+ " correctness,",+ " index,",+ " message::text,",+ " multiple_dropzone_index",+ " FROM content_creation.multiple_dropzone_answers",+ " WHERE template_id = ${templateId}",+ "),",+ "draggables AS (",+ " SELECT",+ " answer_index,",+ " array_agg(draggable_index ORDER BY answer_draggable_index ASC) as draggable_indices",+ " FROM content_creation.multiple_dropzone_answer_draggables",+ " WHERE template_id = ${templateId}",+ " GROUP BY answer_index",+ ")",+ "SELECT",+ " answers.multiple_dropzone_index,",+ " answers.index,",+ " answers.correctness,",+ " draggables.draggable_indices,",+ " answers.message",+ "FROM answers",+ "LEFT JOIN draggables",+ " ON answers.index = draggables.answer_index",+ "ORDER BY answers.index ASC"+ ]+ |> Expect.equal (Parser.QueryMeta "answers" "SELECT"),+ test "simple insert" <| \_ ->+ parseTest+ [ "INSERT INTO drafts.deltas (",+ " title,",+ " content,",+ " parent_id",+ ")",+ "VALUES (",+ " ${Draft.titleDelta delta},",+ " ${Draft.contentDelta delta},",+ " ${maybeParentId}",+ ")",+ "RETURNING id, created_at;"+ ]+ |> Expect.equal (Parser.QueryMeta "drafts.deltas" "INSERT"),+ test "insert preceded by WITH statement" <| \_ ->+ parseTest+ [ "WITH insert_text_blocks AS (",+ " INSERT INTO tutorials.text_blocks (",+ " tutorial_id,",+ " id,",+ " section_id,",+ " text",+ " )",+ " SELECT",+ " ${tutorialId},",+ " unnest(${map textBlockId textBlocks}::bigint[]),",+ " unnest(${map textBlockSectionId textBlocks}::bigint[]),",+ " unnest(${map textBlockText textBlocks}::text[])",+ "),",+ "insert_tip_blocks AS (",+ " INSERT INTO tutorials.tip_blocks (",+ " tutorial_id,",+ " id,",+ " section_id,",+ " tip",+ " )",+ " SELECT",+ " ${tutorialId},",+ " unnest(${map tipBlockId tipBlocks}::bigint[]),",+ " unnest(${map tipBlockSectionId tipBlocks}::bigint[]),",+ " unnest(${map tipBlockTip tipBlocks}::text[])",+ ")",+ "INSERT INTO tutorials.sections (",+ " tutorial_id,",+ " id,",+ " block_type,",+ " image,",+ " next_caption",+ ")",+ "SELECT",+ " ${tutorialId},",+ " unnest(${map sectionId sections}::bigint[]),",+ " unnest(${map sectionBlockType sections}::text[]),",+ " unnest(${map sectionImage sections}::text[]),",+ " unnest(${map sectionNextCaption sections}::text[])"+ ]+ |> Expect.equal (Parser.QueryMeta "tutorials.sections" "INSERT"),+ test "simple delete" <| \_ ->+ parseTest+ [ "DELETE FROM todo.todos",+ "WHERE user_id = ${userId}",+ "AND id = ${todoId}"+ ]+ |> Expect.equal (Parser.QueryMeta "todo.todos" "DELETE"),+ test "simple update" <| \_ ->+ parseTest+ [ "UPDATE tutorials.tutorials",+ " SET archived = true",+ " WHERE public_id = ${toDBPublicId publicId}"+ ]+ |> Expect.equal (Parser.QueryMeta "tutorials.tutorials" "UPDATE"),+ test "simple truncate" <| \_ ->+ parseTest+ [ "TRUNCATE ONLY roses"+ ]+ |> Expect.equal (Parser.QueryMeta "roses" "TRUNCATE")+ ]+ ]++parseTest :: [Text] -> Parser.QueryMeta+parseTest queryLines =+ Text.join "\n" queryLines+ |> Parser.parse
+ test/TimeSpec.hs view
@@ -0,0 +1,37 @@+module TimeSpec (tests) where++import qualified Expect+import qualified Postgres.Time as Time+import Test (Test, describe, test)++tests :: Test+tests =+ describe+ "Postgres.Time"+ [ test "fromSeconds" <| \_ ->+ Time.fromSeconds 2.5+ |> Time.microseconds+ |> Expect.equal 2500000,+ test "seconds" <| \_ ->+ Time.fromMicroseconds 2000000+ |> Time.seconds+ |> round+ |> Expect.equal 2,+ test "fromMilliseconds" <| \_ ->+ Time.fromMilliseconds 2.5+ |> Time.microseconds+ |> Expect.equal 2500,+ test "milliseconds" <| \_ ->+ Time.fromMicroseconds 2000+ |> Time.milliseconds+ |> round+ |> Expect.equal 2,+ test "fromMicroseconds" <| \_ ->+ Time.fromMicroseconds 2+ |> Time.microseconds+ |> Expect.equal 2,+ test "microseconds" <| \_ ->+ Time.fromMicroseconds 2+ |> Time.microseconds+ |> Expect.equal 2+ ]