diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for hs-opentelemetry-instrumentation-postgresql-simple + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ian Duncan (c) 2021 + +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 Ian Duncan nor the names of other + 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 +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# hs-opentelemetry-instrumentation-postgresql-simple diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hs-opentelemetry-instrumentation-postgresql-simple.cabal b/hs-opentelemetry-instrumentation-postgresql-simple.cabal new file mode 100644 --- /dev/null +++ b/hs-opentelemetry-instrumentation-postgresql-simple.cabal @@ -0,0 +1,64 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: hs-opentelemetry-instrumentation-postgresql-simple +version: 0.0.1.0 +description: Please see the README on GitHub at +homepage: https://github.com/iand675/hs-opentelemetry#readme +bug-reports: https://github.com/iand675/hs-opentelemetry/issues +author: Ian Duncan +maintainer: ian@iankduncan.com +copyright: 2021 Ian Duncan +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/iand675/hs-opentelemetry + +library + exposed-modules: + OpenTelemetry.Instrumentation.PostgresqlSimple + other-modules: + Paths_hs_opentelemetry_instrumentation_postgresql_simple + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , hs-opentelemetry-api ==0.0.3.* + , iproute + , network + , postgresql-libpq + , postgresql-simple + , text + , unliftio + default-language: Haskell2010 + +test-suite hs-opentelemetry-instrumentation-postgresql-simple-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_hs_opentelemetry_instrumentation_postgresql_simple + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , hs-opentelemetry-api ==0.0.3.* + , hs-opentelemetry-instrumentation-postgresql-simple + , iproute + , network + , postgresql-libpq + , postgresql-simple + , text + , unliftio + default-language: Haskell2010 diff --git a/src/OpenTelemetry/Instrumentation/PostgresqlSimple.hs b/src/OpenTelemetry/Instrumentation/PostgresqlSimple.hs new file mode 100644 --- /dev/null +++ b/src/OpenTelemetry/Instrumentation/PostgresqlSimple.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module OpenTelemetry.Instrumentation.PostgresqlSimple + ( staticConnectionAttributes + {- + -- * Queries that return results + query + , query_ + -- ** Queries taking parser as argument + , queryWith + , queryWith_ + -- * Queries that stream results + , fold + , foldWithOptions + , fold_ + , foldWithOptions_ + , forEach + , forEach_ + , returning + -- ** Queries that stream results taking a parser as an argument + , foldWith + , foldWithOptionsAndParser + , foldWith_ + , foldWithOptionsAndParser_ + , forEachWith + , forEachWith_ + , returningWith + -- * Statements that do not return results + , execute + , execute_ + , executeMany + -- * Reexported functions + , module X + -} + ) where + +import Control.Monad.IO.Class +import qualified Database.PostgreSQL.Simple as Simple +import Database.PostgreSQL.Simple as X hiding + ( query + , query_ + , queryWith + , queryWith_ + , fold + , foldWithOptions + , fold_ + , foldWithOptions_ + , forEach + , forEach_ + , returning + , foldWith + , foldWithOptionsAndParser + , foldWith_ + , foldWithOptionsAndParser_ + , forEachWith + , forEachWith_ + , returningWith + , execute + , execute_ + , executeMany + ) +import Database.PostgreSQL.Simple.Internal + ( Connection(Connection, connectionHandle) ) +import qualified Data.ByteString.Char8 as C +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Data.Text as T +import OpenTelemetry.Trace.Core +import OpenTelemetry.Trace.Monad +import OpenTelemetry.Resource ((.=), (.=?)) +import Data.Maybe (catMaybes) +import qualified Data.Text.Encoding as TE +import Text.Read (readMaybe) +import Data.IP +import qualified Database.PostgreSQL.Simple.FromRow as Simple +import Data.Int (Int64) +import UnliftIO +import Data.Text (Text) +import GHC.Stack + +staticConnectionAttributes :: MonadIO m => Connection -> m [(T.Text, Attribute)] +staticConnectionAttributes Connection{connectionHandle} = liftIO $ do + (mDb, mUser, mHost, mPort) <- withMVar connectionHandle $ \pqConn -> do + (,,,) + <$> LibPQ.db pqConn + <*> LibPQ.user pqConn + <*> LibPQ.host pqConn + <*> LibPQ.port pqConn + pure $ + ("db.system", toAttribute ("postgresql" :: T.Text)) : + catMaybes + [ "db.user" .=? (TE.decodeUtf8 <$> mUser) + , "db.name" .=? (TE.decodeUtf8 <$> mDb) + , "net.peer.port" .=? (do + port <- TE.decodeUtf8 <$> mPort + (readMaybe $ T.unpack port) :: Maybe Int + ) + , case (readMaybe . C.unpack) =<< mHost of + Nothing -> "net.peer.name" .=? (TE.decodeUtf8 <$> mHost) + Just (IPv4 ipv4) -> "net.peer.ip" .= T.pack (show ipv4) + Just (IPv6 ipv6) -> "net.peer.ip" .= T.pack (show ipv6) + ] + +{- +-- | Perform a @SELECT@ or other SQL query that is expected to return +-- results. All results are retrieved and converted before this +-- function returns. +-- +-- When processing large results, this function will consume a lot of +-- client-side memory. Consider using 'fold' instead. +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string could not be formatted correctly. +-- +-- * 'QueryError': the result contains no columns (i.e. you should be +-- using 'execute' instead of 'query'). +-- +-- * 'ResultError': result conversion failed. +-- +-- * 'SqlError': the postgresql backend returned an error, e.g. +-- a syntax or type error, or an incorrect table or column name. +query :: (MonadIO m, MonadGetContext m, ToRow q, FromRow r) => Connection -> Query -> q -> m [r] +query = liftIO $ Simple.query + +-- | A version of 'query' that does not perform query substitution. +query_ :: (MonadIO m, MonadGetContext m, FromRow r) => Connection -> Query -> m [r] +query_ = _ + +-- | A version of 'query' taking parser as argument +queryWith :: (MonadIO m, MonadGetContext m, ToRow q) => Simple.RowParser r -> Connection -> Query -> q -> m [r] +queryWith parser conn template qs = _ + +-- | A version of 'query_' taking parser as argument +queryWith_ :: (MonadIO m, MonadGetContext m) => Simple.RowParser r -> Connection -> Query -> m [r] +queryWith_ parser conn q = _ + +-- | Perform a @SELECT@ or other SQL query that is expected to return +-- results. Results are streamed incrementally from the server, and +-- consumed via a left fold. +-- +-- When dealing with small results, it may be simpler (and perhaps +-- faster) to use 'query' instead. +-- +-- This fold is /not/ strict. The stream consumer is responsible for +-- forcing the evaluation of its result to avoid space leaks. +-- +-- This is implemented using a database cursor. As such, this requires +-- a transaction. This function will detect whether or not there is a +-- transaction in progress, and will create a 'ReadCommitted' 'ReadOnly' +-- transaction if needed. The cursor is given a unique temporary name, +-- so the consumer may itself call fold. +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string could not be formatted correctly. +-- +-- * 'QueryError': the result contains no columns (i.e. you should be +-- using 'execute' instead of 'query'). +-- +-- * 'ResultError': result conversion failed. +-- +-- * 'SqlError': the postgresql backend returned an error, e.g. +-- a syntax or type error, or an incorrect table or column name. +fold :: (MonadBracketError m, MonadLocalContext m, FromRow row, ToRow params) + => Connection + -> Query + -> params + -> a + -> (a -> row -> m a) + -> m a +fold = _ + +-- | A version of 'fold' taking a parser as an argument +foldWith :: (MonadBracketError m, MonadLocalContext m, ToRow params) + => Simple.RowParser row + -> Connection + -> Query + -> params + -> a + -> (a -> row -> m a) + -> m a +foldWith = _ +-- | The same as 'fold', but this provides a bit more control over +-- lower-level details. Currently, the number of rows fetched per +-- round-trip to the server and the transaction mode may be adjusted +-- accordingly. If the connection is already in a transaction, +-- then the existing transaction is used and thus the 'transactionMode' +-- option is ignored. +foldWithOptions :: (MonadBracketError m, MonadLocalContext m, FromRow row, ToRow params) + => FoldOptions + -> Connection + -> Query + -> params + -> a + -> (a -> row -> m a) + -> m a +foldWithOptions opts = _ + +-- | A version of 'foldWithOptions' taking a parser as an argument +foldWithOptionsAndParser :: (MonadBracketError m, MonadLocalContext m, ToRow params) + => FoldOptions + -> Simple.RowParser row + -> Connection + -> Query + -> params + -> a + -> (a -> row -> m a) + -> m a +foldWithOptionsAndParser opts parser conn template qs a f = _ + +-- | A version of 'fold' that does not perform query substitution. +fold_ :: (MonadBracketError m, MonadLocalContext m, FromRow r) => + Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> m a) -- ^ Result consumer. + -> m a +fold_ = _ + +-- | A version of 'fold_' taking a parser as an argument +foldWith_ :: (MonadUnliftIO m, MonadBracketError m, MonadLocalContext m) => + Simple.RowParser r + -> Connection + -> Query + -> a + -> (a -> r -> m a) + -> m a +foldWith_ = _ + +foldWithOptions_ :: (MonadUnliftIO m, MonadBracketError m, MonadLocalContext m, FromRow r) => + FoldOptions + -> Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> m a) -- ^ Result consumer. + -> m a +foldWithOptions_ opts conn query' a f = Simple.foldWithOptions_ opts conn query' a f + +-- | A version of 'foldWithOptions_' taking a parser as an argument +foldWithOptionsAndParser_ :: FoldOptions + -> Simple.RowParser r + -> Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +foldWithOptionsAndParser_ opts parser conn query' a f = _ + +-- | A version of 'fold' that does not transform a state value. +forEach :: (MonadUnliftIO m, MonadBracketError m, MonadLocalContext m, ToRow q, FromRow r) => + Connection + -> Query -- ^ Query template. + -> q -- ^ Query parameters. + -> (r -> m ()) -- ^ Result consumer. + -> m () +forEach = _ +{-# INLINE forEach #-} + +-- | A version of 'forEach' taking a parser as an argument +forEachWith :: (MonadBracketError m, MonadLocalContext m, ToRow q) + => Simple.RowParser r + -> Connection + -> Query + -> q + -> (r -> m ()) + -> m () +forEachWith parser conn template qs = _ +{-# INLINE forEachWith #-} + +-- | A version of 'forEach' that does not perform query substitution. +forEach_ :: (MonadBracketError m, MonadLocalContext m, FromRow r) => + Connection + -> Query -- ^ Query template. + -> (r -> m ()) -- ^ Result consumer. + -> m () +forEach_ = _ +{-# INLINE forEach_ #-} + +forEachWith_ :: (MonadBracketError m, MonadLocalContext m) => + Simple.RowParser r + -> Connection + -> Query + -> (r -> m ()) + -> m () +forEachWith_ parser conn template = _ +{-# INLINE forEachWith_ #-} + +-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL +-- query that accepts multi-row input and is expected to return results. +-- Note that it is possible to write +-- @'query' conn "INSERT ... RETURNING ..." ...@ +-- in cases where you are only inserting a single row, and do not need +-- functionality analogous to 'executeMany'. +-- +-- If the list of parameters is empty, this function will simply return @[]@ +-- without issuing the query to the backend. If this is not desired, +-- consider using the 'Values' constructor instead. +-- +-- Throws 'FormatError' if the query could not be formatted correctly. +returning :: (MonadIO m, MonadGetContext m, ToRow q, FromRow r) => Connection -> Query -> [q] -> m [r] +returning = _ + +-- | A version of 'returning' taking parser as argument +returningWith :: (MonadIO m, MonadGetContext m, ToRow q) => Simple.RowParser r -> Connection -> Query -> [q] -> m [r] +returningWith = _ + +-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not +-- expected to return results. +-- +-- Returns the number of rows affected. +-- +-- Throws 'FormatError' if the query could not be formatted correctly, or +-- a 'SqlError' exception if the backend returns an error. +execute :: (MonadIO m, MonadGetContext m, ToRow q) => Connection -> Query -> q -> m Int64 +execute conn template qs = _ + +-- | A version of 'execute' that does not perform query substitution. +execute_ :: (MonadIO m, MonadGetContext m) => Connection -> Query -> m Int64 +execute_ = _ + +-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not +-- expected to return results. +-- +-- Returns the number of rows affected. If the list of parameters is empty, +-- this function will simply return 0 without issuing the query to the backend. +-- If this is not desired, consider using the 'Values' constructor instead. +-- +-- Throws 'FormatError' if the query could not be formatted correctly, or +-- a 'SqlError' exception if the backend returns an error. +-- +-- For example, here's a command that inserts two rows into a table +-- with two columns: +-- +-- @ +-- executeMany c [sql| +-- INSERT INTO sometable VALUES (?,?) +-- |] [(1, \"hello\"),(2, \"world\")] +-- @ +-- +-- Here's an canonical example of a multi-row update command: +-- +-- @ +-- executeMany c [sql| +-- UPDATE sometable +-- SET y = upd.y +-- FROM (VALUES (?,?)) as upd(x,y) +-- WHERE sometable.x = upd.x +-- |] [(1, \"hello\"),(2, \"world\")] +-- @ + +executeMany :: (MonadIO m, MonadGetContext m, ToRow q) => Connection -> Query -> [q] -> m Int64 +executeMany = _ +-} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"