diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# nri-postgresql + +A library for querying postgresql. Wrapper around `postgresql-typed`. diff --git a/nri-postgresql.cabal b/nri-postgresql.cabal new file mode 100644 --- /dev/null +++ b/nri-postgresql.cabal @@ -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 . +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 diff --git a/src/Postgres.hs b/src/Postgres.hs new file mode 100644 --- /dev/null +++ b/src/Postgres.hs @@ -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" diff --git a/src/Postgres/Connection.hs b/src/Postgres/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/Connection.hs @@ -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 diff --git a/src/Postgres/Error.hs b/src/Postgres/Error.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/Error.hs @@ -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 diff --git a/src/Postgres/Query.hs b/src/Postgres/Query.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/Query.hs @@ -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) + } diff --git a/src/Postgres/QueryParser.hs b/src/Postgres/QueryParser.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/QueryParser.hs @@ -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"} diff --git a/src/Postgres/Settings.hs b/src/Postgres/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/Settings.hs @@ -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) diff --git a/src/Postgres/Test.hs b/src/Postgres/Test.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/Test.hs @@ -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 diff --git a/src/Postgres/Time.hs b/src/Postgres/Time.hs new file mode 100644 --- /dev/null +++ b/src/Postgres/Time.hs @@ -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)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/ObservabilitySpec.hs b/test/ObservabilitySpec.hs new file mode 100644 --- /dev/null +++ b/test/ObservabilitySpec.hs @@ -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) + } diff --git a/test/PostgresSettingsSpec.hs b/test/PostgresSettingsSpec.hs new file mode 100644 --- /dev/null +++ b/test/PostgresSettingsSpec.hs @@ -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 + ] diff --git a/test/QueryParserSpec.hs b/test/QueryParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/QueryParserSpec.hs @@ -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 diff --git a/test/TimeSpec.hs b/test/TimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/TimeSpec.hs @@ -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 + ]