diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,159 @@ +Copyright (c) 2026, Marcelo Zabani + +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 Marcelo Zabani 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. + + +Copyright (c) 2011, Leon P Smith + +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 Leon P Smith 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. + + +Copyright (c) 2011, MailRank, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. + + +Copyright (c) 2014, Aleksey Uimanov + +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 Aleksey Uimanov 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. + + +Copyright (c) 2010, Grant Monroe +Copyright (c) 2011, Leon P Smith + +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 authors 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/hpgsql-simple-compat.cabal b/hpgsql-simple-compat.cabal new file mode 100644 --- /dev/null +++ b/hpgsql-simple-compat.cabal @@ -0,0 +1,144 @@ +cabal-version: 1.12 +name: hpgsql-simple-compat +version: 0.1.0.0 +synopsis: Fork of postgresql-simple implemented with hpgsql instead of postgresql-libpq. +description: + This is a fork of postgresql-simple that tries to preserve its API as much as possible, but + uses hpgsql instead of postgresql-libpq under the hood. + The idea is to ease migrating to hpgsql itself. Check the GitHub for more information. + +license: BSD3 +license-file: LICENSE +-- Authors of postgresql-simple, postgresql-libpq, and postgresql-query, plus myself +author: Bryan O'Sullivan, Leon P Smith, Aleksey Uimanov, Grant Monroe, Marcelo Zabani +maintainer: Marcelo Zabani +copyright: + (c) 2026 Marcelo Zabani + (c) 2011 MailRank, Inc. + (c) 2011-2018 Leon P Smith + (c) 2018-2020 Oleg Grenrus + (c) 2014 Aleksey Uimanov + (c) 2010 Grant Monroe + +category: Database +homepage: https://github.com/mzabani/hpgsql#readme +bug-reports: https://github.com/mzabani/hpgsql/issues +build-type: Simple + +source-repository head + type: git + location: http://github.com/mzabani/hpgsql/hpgsql-simple-compat + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: + -- postgresql-libpq + Database.PostgreSQL.LibPQ + -- postgresql-simple + Database.PostgreSQL.Simple + Database.PostgreSQL.Simple.Arrays + Database.PostgreSQL.Simple.Copy + Database.PostgreSQL.Simple.Cursor + Database.PostgreSQL.Simple.Errors + Database.PostgreSQL.Simple.FromField + Database.PostgreSQL.Simple.FromRow + Database.PostgreSQL.Simple.HStore + Database.PostgreSQL.Simple.HStore.Internal + Database.PostgreSQL.Simple.Internal + Database.PostgreSQL.Simple.Newtypes + Database.PostgreSQL.Simple.Notification + Database.PostgreSQL.Simple.Ok + Database.PostgreSQL.Simple.Range + Database.PostgreSQL.Simple.SqlQQ + Database.PostgreSQL.Simple.Time + Database.PostgreSQL.Simple.Time.Internal + Database.PostgreSQL.Simple.ToField + Database.PostgreSQL.Simple.ToRow + Database.PostgreSQL.Simple.Transaction + Database.PostgreSQL.Simple.TypeInfo + Database.PostgreSQL.Simple.TypeInfo.Macro + Database.PostgreSQL.Simple.TypeInfo.Static + Database.PostgreSQL.Simple.Types + Database.PostgreSQL.Simple.HpgsqlUtils + -- postgresql-query + Database.PostgreSQL.Query + Database.PostgreSQL.Query.Functions + Database.PostgreSQL.Query.SqlBuilder + Database.PostgreSQL.Query.SqlBuilder.Builder + Database.PostgreSQL.Query.SqlBuilder.Class + Database.PostgreSQL.Query.SqlBuilder.Types + Database.PostgreSQL.Query.TH + Database.PostgreSQL.Query.TH.SqlExp + Database.PostgreSQL.Query.Types + + -- Other-modules: + other-modules: + Database.PostgreSQL.Simple.Compat + Database.PostgreSQL.Simple.HStore.Implementation + Database.PostgreSQL.Simple.Internal.PQResultUtils + Database.PostgreSQL.Simple.Time.Implementation + Database.PostgreSQL.Simple.Time.Internal.Parser + Database.PostgreSQL.Simple.Time.Internal.Printer + Database.PostgreSQL.Simple.TypeInfo.Types + + -- GHC bundled libs + build-depends: + base >= 4.18 && < 4.21 + , bytestring >= 0.11 && < 0.13 + , case-insensitive >= 1.2 && < 1.3 + , containers >= 0.6 && < 0.8 + , template-haskell >= 2.20 && < 2.23 + , text >= 2.0 && < 2.2 + , aeson >= 2.2 && < 2.3 + , attoparsec >= 0.14 && < 0.15 + , haskell-src-meta >= 0.8 && < 0.9 + , hpgsql >= 0.1 && < 0.2 + , hashable >= 1.5 && < 1.6 + , mtl >= 2.3 && < 2.4 + , streaming >= 0.2 && < 0.3 + , time-compat >= 1.9 && < 1.10 + , transformers >= 0.6 && < 0.7 + , Only >= 0.1 && < 0.2 + , scientific >= 0.3 && < 0.4 + , uuid-types >= 1.0 && < 1.1 + , vector >= 0.13 && < 0.14 + + default-extensions: + CPP + BangPatterns + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + LambdaCase + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + OverloadedRecordDot + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + TypeFamilyDependencies + TypeOperators + QuasiQuotes + TemplateHaskell + ViewPatterns + + ghc-options: -Wall -Wincomplete-uni-patterns -Wunused-packages -Wpartial-fields -optP-Wno-nonportable-include-path -fno-warn-name-shadowing diff --git a/src/Database/PostgreSQL/LibPQ.hs b/src/Database/PostgreSQL/LibPQ.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/LibPQ.hs @@ -0,0 +1,26 @@ +module Database.PostgreSQL.LibPQ (fname, transactionStatus, Column (..), Connection (..), ExecStatus (..), Format (..), Oid (..), Result (..), Row (..), TransactionStatus (..)) where + +import Data.ByteString (ByteString) +import qualified Hpgsql +import Hpgsql.Transaction (TransactionStatus (..)) +import qualified Hpgsql.Transaction +import Hpgsql.TypeInfo (Oid (..)) + +data Connection = Connection {hpgConn :: Hpgsql.HPgConnection} + +data ExecStatus = FatalError + deriving (Eq, Show) + +data Result = Result + +data Column = Column + +data Row = Row + +data Format = Text | Binary + +fname :: Result -> Column -> IO (Maybe ByteString) +fname _ _ = pure Nothing + +transactionStatus :: Connection -> IO TransactionStatus +transactionStatus conn = Hpgsql.Transaction.transactionStatus $ hpgConn conn diff --git a/src/Database/PostgreSQL/Query.hs b/src/Database/PostgreSQL/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query.hs @@ -0,0 +1,62 @@ +module Database.PostgreSQL.Query + ( -- * Common usage modules + + -- module Database.PostgreSQL.Query.Entity + module Database.PostgreSQL.Query.Functions, + module Database.PostgreSQL.Query.SqlBuilder, + module Database.PostgreSQL.Query.TH, + module Database.PostgreSQL.Query.Types, + + -- * Some re-exports from postgresql-simple + Connection, + connect, + defaultConnectInfo, + connectPostgreSQL, + ConnectInfo (..), + ToField (..), + ToRow (..), + FromField (..), + FromRow (..), + Query (..), + Only (..), + In (..), + Oid (..), + Values (..), + (:.) (..), + PGArray (..), + HStoreList (..), + HStoreMap (..), + ToHStore (..), + HStoreBuilder, + hstore, + parseHStoreList, + ToHStoreText (..), + HStoreText, + ) +where + +-- to prevent conflicts + +-- import Database.PostgreSQL.Query.Entity +import Database.PostgreSQL.Query.Functions +import Database.PostgreSQL.Query.SqlBuilder +import Database.PostgreSQL.Query.TH +import Database.PostgreSQL.Query.Types +import Database.PostgreSQL.Simple + ( ConnectInfo (..), + Connection, + FromRow, + ToRow, + connect, + connectPostgreSQL, + defaultConnectInfo, + ) +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.FromRow (FromRow (..)) +import Database.PostgreSQL.Simple.HStore hiding + ( toBuilder, + toLazyByteString, + ) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Database.PostgreSQL.Simple.ToRow (ToRow (..)) +import Database.PostgreSQL.Simple.Types diff --git a/src/Database/PostgreSQL/Query/Functions.hs b/src/Database/PostgreSQL/Query/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/Functions.hs @@ -0,0 +1,25 @@ +module Database.PostgreSQL.Query.Functions + ( pgQuery, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Database.PostgreSQL.Query.SqlBuilder (ToSqlBuilder (..), defaultLogMasker, runSqlBuilder) +import Database.PostgreSQL.Query.Types (HasPostgres (..), MonadPostgres) +import Database.PostgreSQL.Simple (query) +import Database.PostgreSQL.Simple.FromRow (FromRow) +import GHC.Stack (HasCallStack) + +-- | Execute a query generated by 'sqlExp' and return results. +-- +-- @ +-- let userName = "Vovka Erohin" :: Text +-- pgQuery [sqlExp| SELECT id, name FROM users WHERE name = \#{userName}|] +-- @ +pgQuery :: + (MonadPostgres m, ToSqlBuilder q, FromRow r, HasCallStack) => + q -> + m [r] +pgQuery q = withPGConnection $ \conn -> liftIO $ do + (simpleQ, row) <- runSqlBuilder conn defaultLogMasker (toSqlBuilder q) + query conn simpleQ row diff --git a/src/Database/PostgreSQL/Query/SqlBuilder.hs b/src/Database/PostgreSQL/Query/SqlBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/SqlBuilder.hs @@ -0,0 +1,10 @@ +module Database.PostgreSQL.Query.SqlBuilder + ( module Database.PostgreSQL.Query.SqlBuilder.Builder, + module Database.PostgreSQL.Query.SqlBuilder.Class, + module Database.PostgreSQL.Query.SqlBuilder.Types, + ) +where + +import Database.PostgreSQL.Query.SqlBuilder.Builder +import Database.PostgreSQL.Query.SqlBuilder.Class +import Database.PostgreSQL.Query.SqlBuilder.Types diff --git a/src/Database/PostgreSQL/Query/SqlBuilder/Builder.hs b/src/Database/PostgreSQL/Query/SqlBuilder/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/SqlBuilder/Builder.hs @@ -0,0 +1,19 @@ +module Database.PostgreSQL.Query.SqlBuilder.Builder + ( SqlBuilder, + + -- * Running + runSqlBuilder, + ) +where + +import Database.PostgreSQL.Query.SqlBuilder.Types (LogMasker) +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.HpgsqlUtils (PgSimpleRow, toPgSimpleQuery) +import qualified Database.PostgreSQL.Simple.Types as PgSimple +import qualified Hpgsql.InternalTypes as HQ + +-- | This is just an alias for hpgsql's `Query` type in hpgsql-simple-compat. +type SqlBuilder = HQ.Query + +runSqlBuilder :: Connection -> LogMasker -> SqlBuilder -> IO (PgSimple.Query, PgSimpleRow) +runSqlBuilder _ _ q = pure $ toPgSimpleQuery q diff --git a/src/Database/PostgreSQL/Query/SqlBuilder/Class.hs b/src/Database/PostgreSQL/Query/SqlBuilder/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/SqlBuilder/Class.hs @@ -0,0 +1,13 @@ +module Database.PostgreSQL.Query.SqlBuilder.Class + ( ToSqlBuilder (..), + ) +where + +import Database.PostgreSQL.Query.SqlBuilder.Builder (SqlBuilder) + +-- | Typeclass for types convertible to 'SqlBuilder'. +class ToSqlBuilder a where + toSqlBuilder :: a -> SqlBuilder + +instance ToSqlBuilder SqlBuilder where + toSqlBuilder = id diff --git a/src/Database/PostgreSQL/Query/SqlBuilder/Types.hs b/src/Database/PostgreSQL/Query/SqlBuilder/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/SqlBuilder/Types.hs @@ -0,0 +1,49 @@ +module Database.PostgreSQL.Query.SqlBuilder.Types + ( -- * Sql builder result + SqlBuilderResult (..), + builderResultPure, + + -- * Field masking in logs + FieldOption (..), + LogMasker, + defaultLogMasker, + ) +where + +import Data.ByteString (ByteString) +import qualified Hpgsql.InternalTypes as HQ + +-- | Result of SqlBuilder. In hpgsql-simple-compat the query string is an +-- hpgsql 'HQ.Query' and logging is a no-op. +data SqlBuilderResult = SqlBuilderResult + { sbQueryString :: HQ.Query, + sbLogString :: () + } + +instance Semigroup SqlBuilderResult where + (SqlBuilderResult a ()) <> (SqlBuilderResult a' ()) = + SqlBuilderResult (a <> a') () + +instance Monoid SqlBuilderResult where + mempty = SqlBuilderResult "" () + +builderResultPure :: HQ.Query -> SqlBuilderResult +builderResultPure q = SqlBuilderResult q () + +-- | Option for field instructing 'LogMasker' what to do with field when logging +data FieldOption + = -- | Do nothing. Field should be pasted as is + FieldDefault + | -- | Mask field in logs with placeholder. + FieldMasked + deriving (Eq, Ord, Show) + +-- | Function modifying query parameter value before pasting it to log. +-- In hpgsql-simple-compat this is a no-op since logging is not supported, +-- but the type is preserved for some API compatibility. +type LogMasker = FieldOption -> ByteString -> ByteString + +-- | Simply replaces masked fields with placeholder. +defaultLogMasker :: LogMasker +defaultLogMasker FieldDefault bb = bb +defaultLogMasker FieldMasked _ = "" diff --git a/src/Database/PostgreSQL/Query/TH.hs b/src/Database/PostgreSQL/Query/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/TH.hs @@ -0,0 +1,63 @@ +module Database.PostgreSQL.Query.TH + ( -- * Deriving instances + + -- deriveEverything, + -- , module Database.PostgreSQL.Query.TH.Entity + -- , module Database.PostgreSQL.Query.TH.Enum + -- , module Database.PostgreSQL.Query.TH.Row + module Database.PostgreSQL.Query.TH.SqlExp, + ) +where + +-- import Database.PostgreSQL.Query.TH.Entity +-- import Database.PostgreSQL.Query.TH.Enum +-- import Database.PostgreSQL.Query.TH.Row +import Database.PostgreSQL.Query.TH.SqlExp + +-- | Calls sequently `deriveFromRow` `deriveToRow` `deriveEntity`. E.g. code like this: +-- +-- @ +-- data Agent = Agent +-- { aName :: !Text +-- , aAttributes :: !HStoreMap +-- , aLongWeirdName :: !Int +-- } deriving (Ord, Eq, Show) +-- +-- \$(deriveEverything +-- def { eoIdType = ''Id +-- , eoTableName = textFN . toUnderscore' +-- , eoColumnNames = textFN . toUnderscore' . drop 1 +-- , eoDeriveClasses = +-- [''Show, ''Read, ''Ord, ''Eq +-- , ''FromField, ''ToField, ''PathPiece] +-- } +-- ''Agent ) +-- @ +-- +-- will generate that: +-- +-- @ +-- instance ToRow Agent where +-- toRow (Agent a_aE3w a_aE3x a_aE3y) +-- = [toField a_aE3w, toField a_aE3x, toField a_aE3y] +-- instance FromRow Agent where +-- fromRow +-- = Agent <$> Database.PostgreSQL.Simple.FromRow.field +-- <*> Database.PostgreSQL.Simple.FromRow.field +-- <*> Database.PostgreSQL.Simple.FromRow.field +-- instance Database.PostgreSQL.Query.Entity Agent where +-- newtype EntityId Agent +-- = AgentId {getAgentId :: Id} +-- deriving (Show, Read, Ord, Eq, FromField, ToField, PathPiece) +-- tableName _ = "agent" +-- fieldNames _ = ["name", "attributes", "long_weird_name"] +-- type AgentId = EntityId Agent +-- @ +-- deriveEverything :: EntityOptions -> Name -> Q [Dec] +-- deriveEverything opts tname = +-- fmap concat $ +-- sequence +-- [ deriveToRow tname, +-- deriveFromRow tname, +-- deriveEntity opts tname +-- ] diff --git a/src/Database/PostgreSQL/Query/TH/SqlExp.hs b/src/Database/PostgreSQL/Query/TH/SqlExp.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/TH/SqlExp.hs @@ -0,0 +1,14 @@ +module Database.PostgreSQL.Query.TH.SqlExp + ( -- * QQ + sqlExp, + ) +where + +import Hpgsql.Query (sql) +import Language.Haskell.TH.Quote (QuasiQuoter) + +-- | Quasiquoter for SQL expressions. Returns a 'SqlBuilder' (which is an alias +-- for hpgsql's 'Hpgsql.Query.Query'). Supports @#{}@ for parameter interpolation +-- and @^{}@ for query fragment embedding. +sqlExp :: QuasiQuoter +sqlExp = sql diff --git a/src/Database/PostgreSQL/Query/Types.hs b/src/Database/PostgreSQL/Query/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Query/Types.hs @@ -0,0 +1,82 @@ +module Database.PostgreSQL.Query.Types + ( -- * Auxiliary types + FN (..), + fnToQuery, + + -- * Query execution + HasPostgres (..), + MonadPostgres, + PgMonadT (..), + runPgMonadT, + ) +where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Reader (MonadReader (..), ReaderT (..)) +import Control.Monad.Trans (MonadTrans) +import qualified Data.List as L +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Database.PostgreSQL.Query.SqlBuilder (ToSqlBuilder (..)) +import Database.PostgreSQL.Simple.Internal (Connection) +import Hpgsql.InternalTypes (Query) +import Hpgsql.Query (escapeIdentifier) + +-- | Dot-separated field name. Each element in nested list will be +-- properly quoted and separated by dot. +-- +-- >>> "user.name" :: FN +-- FN ["user","name"] +-- +-- >>> ("user" <> "name") :: FN +-- FN ["user","name"] +newtype FN = FN [Text] + deriving stock (Ord, Eq, Show) + deriving newtype (Semigroup, Monoid) + +instance IsString FN where + fromString s = + FN $ + map T.pack $ + filter (/= ".") $ + L.groupBy f s + where + f a b = not $ a == '.' || b == '.' + +instance ToSqlBuilder FN where + toSqlBuilder = fnToQuery + +-- | Convert a 'FN' to a 'Query' by quoting each part and joining with dots. +fnToQuery :: FN -> Query +fnToQuery (FN parts) = + case parts of + [] -> "" + _ -> + foldr1 (<>) $ + L.intersperse "." $ + map (escapeIdentifier . T.encodeUtf8) parts + +-- | Instances of this typeclass can acquire a connection and pass it to +-- a computation. +class (MonadIO m) => HasPostgres m where + withPGConnection :: (Connection -> m a) -> m a + +type MonadPostgres m = HasPostgres m + +-- | Reader of connection. Has instance of 'HasPostgres'. If you have a +-- connection you can run queries in this monad using 'runPgMonadT'. +newtype PgMonadT m a = PgMonadT + { unPgMonadT :: ReaderT Connection m a + } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadFail) + +instance (MonadIO m) => HasPostgres (PgMonadT m) where + withPGConnection action = do + conn <- PgMonadT ask + action conn + {-# INLINEABLE withPGConnection #-} + +runPgMonadT :: Connection -> PgMonadT m a -> m a +runPgMonadT conn (PgMonadT action) = runReaderT action conn diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple.hs @@ -0,0 +1,920 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- A mid-level client library for the PostgreSQL database, aimed at ease of +-- use and high performance. +module Database.PostgreSQL.Simple + ( hpgConn, + + -- * Writing queries + -- $use + + -- ** The Query type + -- $querytype + + -- ** Parameter substitution + -- $subst + + -- *** Type inference + -- $inference + + -- ** Substituting a single parameter + -- $only_param + + -- ** Representing a list of values + -- $in + + -- ** Modifying multiple rows at once + -- $many + + -- ** @RETURNING@: modifications that return results + -- $returning + + -- * Extracting results + -- $result + + -- ** Handling null values + -- $null + + -- ** Type conversions + -- $types + + -- * Types + Connection, + Query, + ToRow, + FromRow, + In (..), + Binary (..), + Only (..), + (:.) (..), + + -- ** Exceptions + SomePostgreSqlException (..), + SqlError (..), + PQ.ExecStatus (..), + FormatError (..), + QueryError (..), + ResultError (..), + + -- * Connection management + Base.connectPostgreSQL, + Base.close, + Base.connect, + Base.withConnect, + Base.ConnectInfo (..), + Base.defaultConnectInfo, + Base.postgreSQLConnectionString, + + -- * Queries that return results + query, + query_, + + -- ** Queries taking parser as argument + queryWith, + queryWith_, + + -- * Queries that stream results + FoldOptions (..), + FetchQuantity (..), + defaultFoldOptions, + 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, + -- , Base.insertID + + -- * Transaction handling + withTransaction, + withSavepoint, + -- , Base.autocommit + begin, + commit, + rollback, + + -- * Helper functions + formatMany, + ) +where + +import Control.Exception (bracket) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (char8) +import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) +import Data.List (intersperse) +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.Compat (toByteString) +import Database.PostgreSQL.Simple.Cursor (closeCursor, declareCursor, foldForwardWithParser) +import Database.PostgreSQL.Simple.FromField (ResultError (..)) +import Database.PostgreSQL.Simple.FromRow (FromRow (..), RowParser) +import Database.PostgreSQL.Simple.HpgsqlUtils (toHpgsqlQuery, toHpgsqlRowParams) +import Database.PostgreSQL.Simple.Internal as Base +import Database.PostgreSQL.Simple.ToRow (ToRow (..)) +import Database.PostgreSQL.Simple.Transaction +import Database.PostgreSQL.Simple.Types + ( Binary (..), + In (..), + Only (..), + Query (..), + (:.) (..), + ) +import qualified Hpgsql +import qualified Hpgsql.Query as Hpgsql + +-- | Format a query string with a variable number of rows. +-- +-- This function is exposed to help with debugging and logging. Do not +-- use it to prepare queries for execution. +-- +-- The query string must contain exactly one substitution group, +-- identified by the SQL keyword \"@VALUES@\" (case insensitive) +-- followed by an \"@(@\" character, a series of one or more \"@?@\" +-- characters separated by commas, and a \"@)@\" character. White +-- space in a substitution group is permitted. +-- +-- Throws 'FormatError' if the query string could not be formatted +-- correctly. +formatMany :: forall q. (ToRow q) => Connection -> Query -> [q] -> IO Hpgsql.Query +formatMany _ q [] = fmtError "no rows supplied" q [] +formatMany _conn q@(Query template) qs = do + -- First we replace the query string's ? with (?,?,?,...) with as many + -- parameters as each row contains + pgSimpleQuery <- case parseTemplate template of + Nothing -> fmtError "query is not of the expected form" q + Just (before, qbits, after) -> + let numCols = B.count '?' qbits + in case filter (\r -> length (toHpgsqlRowParams r) /= numCols) qs of + (bad : _) -> + error + ( show numCols + ++ " single '?' characters, but " + ++ show (length $ toHpgsqlRowParams bad) + ++ " parameters" + ) + [] -> + pure $ before <> BS.intercalate "," (map renderRow qs) <> after + -- Now we ask Hpgsql to parse the query with one ? per query parameter + pure $ Hpgsql.mkQueryInternal pgSimpleQuery (concatMap toHpgsqlRowParams qs) + where + renderRow :: (ToRow q) => q -> B.ByteString + renderRow row = + let numCols = length $ toHpgsqlRowParams row + in toByteString $ + char8 '(' <> mconcat (intersperse (char8 ',') (replicate numCols "?")) <> char8 ')' + +-- Split the input string into three pieces, @before@, @qbits@, and @after@, +-- following this grammar: +-- +-- start: ^ before qbits after $ +-- before: ([^?]* [^?\w])? 'VALUES' \s* +-- qbits: '(' \s* '?' \s* (',' \s* '?' \s*)* ')' +-- after: [^?]* +-- +-- \s: [ \t\n\r\f] +-- \w: [A-Z] | [a-z] | [\x80-\xFF] | '_' | '$' | [0-9] +-- +-- This would be much more concise with some sort of regex engine. +-- 'formatMany' used to use pcre-light instead of this hand-written parser, +-- but pcre is a hassle to install on Windows. +parseTemplate :: ByteString -> Maybe (ByteString, ByteString, ByteString) +parseTemplate template = + -- Convert input string to uppercase, to facilitate searching. + search $ B.map toUpper_ascii template + where + -- Search for the next occurrence of "VALUES" + search bs = + case B.breakSubstring "VALUES" bs of + (x, y) + -- If "VALUES" is not present in the string, or any '?' characters + -- were encountered prior to it, fail. + | B.null y || ('?' `B.elem` x) -> + Nothing + -- If "VALUES" is preceded by an identifier character (a.k.a. \w), + -- try the next occurrence. + | not (B.null x) && isIdent (B.last x) -> + search $ B.drop 6 y + -- Otherwise, we have a legitimate "VALUES" token. + | otherwise -> + parseQueryBits $ skipSpace $ B.drop 6 y + + -- Parse '(' \s* '?' \s* . If this doesn't match + -- (and we don't consume a '?'), look for another "VALUES". + -- + -- qb points to the open paren (if present), meaning it points to the + -- beginning of the "qbits" production described above. This is why we + -- pass it down to finishQueryBits. + parseQueryBits qb + | Just ('(', skipSpace -> bs1) <- B.uncons qb, + Just ('?', skipSpace -> bs2) <- B.uncons bs1 = + finishQueryBits qb bs2 + | otherwise = + search qb + + -- Parse (',' \s* '?' \s*)* ')' [^?]* . + -- + -- Since we've already consumed at least one '?', there's no turning back. + -- The parse has to succeed here, or the whole thing fails + -- (because we don't allow '?' to appear outside of the VALUES list). + finishQueryBits qb bs0 + | Just (')', bs1) <- B.uncons bs0 = + if '?' `B.elem` bs1 + then Nothing + else Just $ slice3 template qb bs1 + | Just (',', skipSpace -> bs1) <- B.uncons bs0, + Just ('?', skipSpace -> bs2) <- B.uncons bs1 = + finishQueryBits qb bs2 + | otherwise = + Nothing + + -- Slice a string into three pieces, given the start offset of the second + -- and third pieces. Each "offset" is actually a tail of the uppercase + -- version of the template string. Its length is used to infer the offset. + -- + -- It is important to note that we only slice the original template. + -- We don't want our all-caps trick messing up the actual query string. + slice3 source p1 p2 = + (s1, s2, source'') + where + (s1, source') = B.splitAt (B.length source - B.length p1) source + (s2, source'') = B.splitAt (B.length p1 - B.length p2) source' + + toUpper_ascii c + | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) + | otherwise = c + + -- Based on the definition of {ident_cont} in src/backend/parser/scan.l + -- in the PostgreSQL source. No need to check [a-z], since we converted + -- the whole string to uppercase. + isIdent c = + (c >= '0' && c <= '9') + || (c >= 'A' && c <= 'Z') + || (c >= '\x80' && c <= '\xFF') + || c == '_' + || c == '$' + + -- Based on {space} in scan.l + isSpace_ascii c = (c == ' ') || (c >= '\t' && c <= '\r') + + skipSpace = B.dropWhile isSpace_ascii + +-- | 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 :: (ToRow q) => Connection -> Query -> q -> IO Int64 +execute conn template qs = + mapHpgsqlErrors $ + Hpgsql.execute (hpgConn conn) (toHpgsqlQuery template qs) + +-- | 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 :: (ToRow q) => Connection -> Query -> [q] -> IO Int64 +executeMany _ _ [] = return 0 +executeMany conn q qs = mapHpgsqlErrors $ do + qry <- formatMany conn q qs + Hpgsql.execute (hpgConn conn) qry + +-- | 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 :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r] +returning = returningWith fromRow + +-- | A version of 'returning' taking parser as argument +returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r] +returningWith _ _ _ [] = return [] +returningWith _parser _conn _q _qs = error "TODO Hpgsql" + +-- | 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 :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] +query conn q qs = queryWith fromRow conn q qs + +-- | A version of 'query' that does not perform query substitution. +query_ :: (FromRow r) => Connection -> Query -> IO [r] +query_ conn q = query conn q () + +-- | A version of 'query' taking parser as argument +queryWith :: (ToRow q) => RowParser r -> Connection -> Query -> q -> IO [r] +queryWith parser conn template qs = + mapHpgsqlErrors $ + Hpgsql.queryMWith parser (hpgConn conn) (toHpgsqlQuery template qs) + +-- | A version of 'query_' taking parser as argument +queryWith_ :: RowParser r -> Connection -> Query -> IO [r] +queryWith_ parser conn q = 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 :: + (FromRow row, ToRow params) => + Connection -> + Query -> + params -> + a -> + (a -> row -> IO a) -> + IO a +fold = foldWithOptions defaultFoldOptions + +-- | A version of 'fold' taking a parser as an argument +foldWith :: + (ToRow params) => + RowParser row -> + Connection -> + Query -> + params -> + a -> + (a -> row -> IO a) -> + IO a +foldWith = foldWithOptionsAndParser defaultFoldOptions + +-- | Number of rows to fetch at a time. 'Automatic' currently defaults +-- to 256 rows, although it might be nice to make this more intelligent +-- based on e.g. the average size of the rows. +data FetchQuantity + = Automatic + | Fixed !Int + +data FoldOptions + = FoldOptions + { fetchQuantity :: !FetchQuantity, + transactionMode :: !TransactionMode + } + +-- | defaults to 'Automatic', and 'TransactionMode' 'ReadCommitted' 'ReadOnly' +defaultFoldOptions :: FoldOptions +defaultFoldOptions = + FoldOptions + { fetchQuantity = Automatic, + transactionMode = TransactionMode ReadCommitted ReadOnly + } + +-- | 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 :: + (FromRow row, ToRow params) => + FoldOptions -> + Connection -> + Query -> + params -> + a -> + (a -> row -> IO a) -> + IO a +foldWithOptions opts = foldWithOptionsAndParser opts fromRow + +-- | A version of 'foldWithOptions' taking a parser as an argument +foldWithOptionsAndParser :: + (ToRow params) => + FoldOptions -> + RowParser row -> + Connection -> + Query -> + params -> + a -> + (a -> row -> IO a) -> + IO a +foldWithOptionsAndParser opts parser conn template qs a f = do + doFold opts parser conn template qs a f + +-- | A version of 'fold' that does not perform query substitution. +fold_ :: + (FromRow r) => + Connection -> + -- | Query. + Query -> + -- | Initial state for result consumer. + a -> + -- | Result consumer. + (a -> r -> IO a) -> + IO a +fold_ = foldWithOptions_ defaultFoldOptions + +-- | A version of 'fold_' taking a parser as an argument +foldWith_ :: + RowParser r -> + Connection -> + Query -> + a -> + (a -> r -> IO a) -> + IO a +foldWith_ = foldWithOptionsAndParser_ defaultFoldOptions + +foldWithOptions_ :: + (FromRow r) => + FoldOptions -> + Connection -> + -- | Query. + Query -> + -- | Initial state for result consumer. + a -> + -- | Result consumer. + (a -> r -> IO a) -> + IO a +foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' () a f + +-- | A version of 'foldWithOptions_' taking a parser as an argument +foldWithOptionsAndParser_ :: + FoldOptions -> + RowParser r -> + Connection -> + -- | Query. + Query -> + -- | Initial state for result consumer. + a -> + -- | Result consumer. + (a -> r -> IO a) -> + IO a +foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' () a f + +doFold :: + (ToRow q) => + FoldOptions -> + RowParser row -> + Connection -> + Query -> + q -> + a -> + (a -> row -> IO a) -> + IO a +doFold FoldOptions {..} parser conn q params a0 f = mapHpgsqlErrors $ do + stat <- withConnection conn PQ.transactionStatus + case stat of + PQ.TransIdle -> withTransactionMode transactionMode conn go + PQ.TransInTrans -> go + PQ.TransActive -> fail "foldWithOpts FIXME: PQ.TransActive" + -- This _shouldn't_ occur in the current incarnation of + -- the library, as we aren't using libpq asynchronously. + -- However, it could occur in future incarnations of + -- this library or if client code uses the Internal module + -- to use raw libpq commands on postgresql-simple connections. + PQ.TransInError -> fail "foldWithOpts FIXME: PQ.TransInError" + where + -- This should be turned into a better error message. + -- It is probably a bad idea to automatically roll + -- back the transaction and start another. + + declare = + declareCursor conn $ toHpgsqlQuery q params + fetch cursor a = + foldForwardWithParser cursor parser chunkSize f a + + go = bracket declare closeCursor $ \cursor -> + let loop a = + fetch cursor a + >>= \r -> case r of + Left x -> return x + Right x -> loop x + in loop a0 + -- FIXME: choose the Automatic chunkSize more intelligently + -- One possibility is to use the type of the results, although this + -- still isn't a perfect solution, given that common types (e.g. text) + -- are of highly variable size. + -- A refinement of this technique is to pick this number adaptively + -- as results are read in from the database. + chunkSize = case fetchQuantity of + Automatic -> 256 + Fixed n -> n + +-- | A version of 'fold' that does not transform a state value. +forEach :: + (ToRow q, FromRow r) => + Connection -> + -- | Query template. + Query -> + -- | Query parameters. + q -> + -- | Result consumer. + (r -> IO ()) -> + IO () +forEach = forEachWith fromRow +{-# INLINE forEach #-} + +-- | A version of 'forEach' taking a parser as an argument +forEachWith :: + (ToRow q) => + RowParser r -> + Connection -> + Query -> + q -> + (r -> IO ()) -> + IO () +forEachWith parser conn template qs = foldWith parser conn template qs () . const +{-# INLINE forEachWith #-} + +-- | A version of 'forEach' that does not perform query substitution. +forEach_ :: + (FromRow r) => + Connection -> + -- | Query template. + Query -> + -- | Result consumer. + (r -> IO ()) -> + IO () +forEach_ = forEachWith_ fromRow +{-# INLINE forEach_ #-} + +forEachWith_ :: + RowParser r -> + Connection -> + Query -> + (r -> IO ()) -> + IO () +forEachWith_ parser conn template = foldWith_ parser conn template () . const +{-# INLINE forEachWith_ #-} + +-- $use +-- +-- SQL-based applications are somewhat notorious for their +-- susceptibility to attacks through the injection of maliciously +-- crafted data. The primary reason for widespread vulnerability to +-- SQL injections is that many applications are sloppy in handling +-- user data when constructing SQL queries. +-- +-- This library provides a 'Query' type and a parameter substitution +-- facility to address both ease of use and security. + +-- $querytype +-- +-- A 'Query' is a @newtype@-wrapped 'ByteString'. It intentionally +-- exposes a tiny API that is not compatible with the 'ByteString' +-- API; this makes it difficult to construct queries from fragments of +-- strings. The 'query' and 'execute' functions require queries to be +-- of type 'Query'. +-- +-- To most easily construct a query, enable GHC's @OverloadedStrings@ +-- language extension and write your query as a normal literal string. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Database.PostgreSQL.Simple +-- > +-- > hello :: IO Int +-- > hello = do +-- > conn <- connectPostgreSQL "" +-- > [Only i] <- query_ conn "select 2 + 2" +-- > return i +-- +-- A 'Query' value does not represent the actual query that will be +-- executed, but is a template for constructing the final query. + +-- $subst +-- +-- Since applications need to be able to construct queries with +-- parameters that change, this library provides a query substitution +-- capability. +-- +-- The 'Query' template accepted by 'query' and 'execute' can contain +-- any number of \"@?@\" characters. Both 'query' and 'execute' +-- accept a third argument, typically a tuple. When constructing the +-- real query to execute, these functions replace the first \"@?@\" in +-- the template with the first element of the tuple, the second +-- \"@?@\" with the second element, and so on. If necessary, each +-- tuple element will be quoted and escaped prior to substitution; +-- this defeats the single most common injection vector for malicious +-- data. +-- +-- For example, given the following 'Query' template: +-- +-- > select * from user where first_name = ? and age > ? +-- +-- And a tuple of this form: +-- +-- > ("Boris" :: String, 37 :: Int) +-- +-- The query to be executed will look like this after substitution: +-- +-- > select * from user where first_name = 'Boris' and age > 37 +-- +-- If there is a mismatch between the number of \"@?@\" characters in +-- your template and the number of elements in your tuple, a +-- 'FormatError' will be thrown. +-- +-- Note that the substitution functions do not attempt to parse or +-- validate your query. It's up to you to write syntactically valid +-- SQL, and to ensure that each \"@?@\" in your query template is +-- matched with the right tuple element. + +-- $inference +-- +-- Automated type inference means that you will often be able to avoid +-- supplying explicit type signatures for the elements of a tuple. +-- However, sometimes the compiler will not be able to infer your +-- types. Consider a case where you write a numeric literal in a +-- parameter tuple: +-- +-- > query conn "select ? + ?" (40,2) +-- +-- The above query will be rejected by the compiler, because it does +-- not know the specific numeric types of the literals @40@ and @2@. +-- This is easily fixed: +-- +-- > query conn "select ? + ?" (40 :: Double, 2 :: Double) +-- +-- The same kind of problem can arise with string literals if you have +-- the @OverloadedStrings@ language extension enabled. Again, just +-- use an explicit type signature if this happens. +-- +-- Finally, remember that the compiler must be able to infer the type +-- of a query's /results/ as well as its parameters. We might like +-- the following example to work: +-- +-- > print =<< query_ conn "select 2 + 2" +-- +-- Unfortunately, while a quick glance tells us that the result type +-- should be a single row containing a single numeric column, the +-- compiler has no way to infer what the types are. We can easily fix +-- this by providing an explicit type annotation: +-- +-- > xs <- query_ conn "select 2 + 2" +-- > print (xs :: [Only Int]) + +-- $only_param +-- +-- Haskell lacks a single-element tuple type, so if you have just one +-- value you want substituted into a query or a single-column result, +-- what should you do? +-- +-- The obvious approach would appear to be something like this: +-- +-- > instance (ToField a) => ToRow a where +-- > ... +-- +-- Unfortunately, this wreaks havoc with type inference, so we take a +-- different tack. To represent a single value @val@ as a parameter, write +-- a singleton list @[val]@, use 'Just' @val@, or use 'Only' @val@. +-- +-- Here's an example using a singleton list: +-- +-- > execute conn "insert into users (first_name) values (?)" +-- > ["Nuala"] +-- +-- A row of /n/ query results is represented using an /n/-tuple, so +-- you should use 'Only' to represent a single-column result. + +-- $in +-- +-- Suppose you want to write a query using an @IN@ clause: +-- +-- > select * from users where first_name in ('Anna', 'Boris', 'Carla') +-- +-- In such cases, it's common for both the elements and length of the +-- list after the @IN@ keyword to vary from query to query. +-- +-- To address this case, use the 'In' type wrapper, and use a single +-- \"@?@\" character to represent the list. Omit the parentheses +-- around the list; these will be added for you. +-- +-- Here's an example: +-- +-- > query conn "select * from users where first_name in ?" $ +-- > Only $ In ["Anna", "Boris", "Carla"] +-- +-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be +-- substituted instead, to ensure that your clause remains +-- syntactically valid. + +-- $many +-- +-- If you know that you have many rows of data to insert into a table, +-- it is much more efficient to perform all the insertions in a single +-- multi-row @INSERT@ statement than individually. +-- +-- The 'executeMany' function is intended specifically for helping +-- with multi-row @INSERT@ and @UPDATE@ statements. Its rules for +-- query substitution are different than those for 'execute'. +-- +-- What 'executeMany' searches for in your 'Query' template is a +-- single substring of the form: +-- +-- > values (?,?,?) +-- +-- The rules are as follows: +-- +-- * The keyword @VALUES@ is matched case insensitively. +-- +-- * There must be no other \"@?@\" characters anywhere in your +-- template. +-- +-- * There must be one or more \"@?@\" in the parentheses. +-- +-- * Extra white space is fine. +-- +-- The last argument to 'executeMany' is a list of parameter +-- tuples. These will be substituted into the query where the @(?,?)@ +-- string appears, in a form suitable for use in a multi-row @INSERT@ +-- or @UPDATE@. +-- +-- Here is an example: +-- +-- > executeMany conn +-- > "insert into users (first_name,last_name) values (?,?)" +-- > [("Boris","Karloff"),("Ed","Wood")] +-- +-- The query that will be executed here will look like this +-- (reformatted for tidiness): +-- +-- > insert into users (first_name,last_name) values +-- > ('Boris','Karloff'),('Ed','Wood') + +-- $returning +-- +-- PostgreSQL supports returning values from data manipulation statements +-- such as @INSERT@ and @UPDATE@. You can use these statements by +-- using 'query' instead of 'execute'. For multi-tuple inserts, +-- use 'returning' instead of 'executeMany'. +-- +-- For example, were there an auto-incrementing @id@ column and +-- timestamp column @t@ that defaulted to the present time for the +-- @sales@ table, then the following query would insert two new +-- sales records and also return their new @id@s and timestamps. +-- +-- > let q = "insert into sales (amount, label) values (?,?) returning id, t" +-- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust") +-- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")] + +-- $result +-- +-- The 'query' and 'query_' functions return a list of values in the +-- 'FromRow' typeclass. This class performs automatic extraction +-- and type conversion of rows from a query result. +-- +-- Here is a simple example of how to extract results: +-- +-- > import qualified Data.Text as Text +-- > +-- > xs <- query_ conn "select name,age from users" +-- > forM_ xs $ \(name,age) -> +-- > putStrLn $ Text.unpack name ++ " is " ++ show (age :: Int) +-- +-- Notice two important details about this code: +-- +-- * The number of columns we ask for in the query template must +-- exactly match the number of elements we specify in a row of the +-- result tuple. If they do not match, a 'ResultError' exception +-- will be thrown. +-- +-- * Sometimes, the compiler needs our help in specifying types. It +-- can infer that @name@ must be a 'Text', due to our use of the +-- @unpack@ function. However, we have to tell it the type of @age@, +-- as it has no other information to determine the exact type. + +-- $null +-- +-- The type of a result tuple will look something like this: +-- +-- > (Text, Int, Int) +-- +-- Although SQL can accommodate @NULL@ as a value for any of these +-- types, Haskell cannot. If your result contains columns that may be +-- @NULL@, be sure that you use 'Maybe' in those positions of your +-- tuple. +-- +-- > (Text, Maybe Int, Int) +-- +-- If 'query' encounters a @NULL@ in a row where the corresponding +-- Haskell type is not 'Maybe', it will throw a 'ResultError' +-- exception. + +-- $only_result +-- +-- To specify that a query returns a single-column result, use the +-- 'Only' type. +-- +-- > xs <- query_ conn "select id from users" +-- > forM_ xs $ \(Only dbid) -> {- ... -} + +-- $types +-- +-- Conversion of SQL values to Haskell values is somewhat +-- permissive. Here are the rules. +-- +-- * For numeric types, any Haskell type that can accurately represent +-- all values of the given PostgreSQL type is considered \"compatible\". +-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@ +-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately +-- represent a @SMALLINT@, so it is considered compatible with those types. +-- +-- * A numeric compatibility check is based only on the type of a +-- column, /not/ on its values. For instance, a PostgreSQL 64-bit +-- @BIGINT@ column will be considered incompatible with a Haskell +-- 'Int16', even if it contains the value @1@. +-- +-- * If a numeric incompatibility is found, 'query' will throw a +-- 'ResultError'. +-- +-- * The 'String' and 'Text' types are assumed to be encoded as +-- UTF-8. If you use some other encoding, decoding may fail or give +-- wrong results. In such cases, write a @newtype@ wrapper and a +-- custom 'Result' instance to handle your encoding. diff --git a/src/Database/PostgreSQL/Simple.hs-boot b/src/Database/PostgreSQL/Simple.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple.hs-boot @@ -0,0 +1,21 @@ +module Database.PostgreSQL.Simple + ( Connection, + Query, + query, + query_, + execute, + execute_, + executeMany, + ) +where + +import Data.Int (Int64) +import Database.PostgreSQL.Simple.FromRow (FromRow) +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.ToRow (ToRow) +import Database.PostgreSQL.Simple.Types + +query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] +query_ :: (FromRow r) => Connection -> Query -> IO [r] +execute :: (ToRow q) => Connection -> Query -> q -> IO Int64 +executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64 diff --git a/src/Database/PostgreSQL/Simple/Arrays.hs b/src/Database/PostgreSQL/Simple/Arrays.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Arrays.hs @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Arrays +-- Copyright: (c) 2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- A Postgres array parser and pretty-printer. +module Database.PostgreSQL.Simple.Arrays where + +import Control.Applicative (Alternative (..)) +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B + +-- | Parse one of three primitive field formats: array, quoted and plain. +arrayFormat :: Char -> Parser ArrayFormat +arrayFormat delim = + Array + <$> array delim + <|> Plain + <$> plain delim + <|> Quoted + <$> quoted + +data ArrayFormat + = Array [ArrayFormat] + | Plain ByteString + | Quoted ByteString + deriving (Eq, Show, Ord) + +array :: Char -> Parser [ArrayFormat] +array delim = char '{' *> option [] (arrays <|> strings) <* char '}' + where + strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) + arrays = sepBy1 (Array <$> array delim) (char ',') + +-- NB: Arrays seem to always be delimited by commas. + +-- | Recognizes a quoted string. +quoted :: Parser ByteString +quoted = char '"' *> option "" contents <* char '"' + where + esc' = char '\\' *> (char '\\' <|> char '"') + unQ = takeWhile1 (notInClass "\"\\") + contents = mconcat <$> many (unQ <|> B.singleton <$> esc') + +-- | Recognizes a plain string literal, not containing quotes or brackets and +-- not containing the delimiter character. +plain :: Char -> Parser ByteString +plain delim = takeWhile1 (notInClass (delim : "\"{}")) + +-- Mutually recursive 'fmt' and 'delimit' separate out value formatting +-- from the subtleties of delimiting. + +-- | Format an array format item, using the delimiter character if the item is +-- itself an array. +fmt :: Char -> ArrayFormat -> ByteString +fmt = fmt' False + +-- | Format a list of array format items, inserting the appropriate delimiter +-- between them. When the items are arrays, they will be delimited with +-- commas; otherwise, they are delimited with the passed-in-delimiter. +delimit :: Char -> [ArrayFormat] -> ByteString +delimit _ [] = "" +delimit c [x] = fmt' True c x +delimit c (x : y : z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y : z) + where + c' + | Array _ <- x = ',' + | otherwise = c + +-- | Format an array format item, using the delimiter character if the item is +-- itself an array, optionally applying quoting rules. Creates copies for +-- safety when used in 'FromField' instances. +fmt' :: Bool -> Char -> ArrayFormat -> ByteString +fmt' quoting c x = + case x of + Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') + Plain bytes -> B.copy bytes + Quoted q + | quoting -> '"' `B.cons` (esc q `B.snoc` '"') + | otherwise -> B.copy q + +-- NB: The 'snoc' and 'cons' functions always copy. + +-- | Escape a string according to Postgres double-quoted string format. +esc :: ByteString -> ByteString +esc = B.concatMap f + where + f '"' = "\\\"" + f '\\' = "\\\\" + f c = B.singleton c + +-- TODO: Implement easy performance improvements with unfoldr. diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -0,0 +1,39 @@ +-- | This is a module of its own, partly because it uses the CPP extension, +-- which doesn't play well with backslash-broken string literals. +module Database.PostgreSQL.Simple.Compat + ( mask, + (<>), + unsafeDupablePerformIO, + toByteString, + scientificBuilder, + toPico, + fromPico, + ) where + +import qualified Control.Exception as E +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder, toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Fixed (Fixed (MkFixed), Pico) +import Data.Text.Lazy.Builder.Scientific (scientificBuilder) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- | Like 'E.mask', but backported to base before version 4.3.0. +-- +-- Note that the restore callback is monomorphic, unlike in 'E.mask'. This +-- could be fixed by changing the type signature, but it would require us to +-- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The +-- 'withTransactionMode' function calls the restore callback only once, so we +-- don't need that polymorphism. +mask :: ((IO a -> IO a) -> IO b) -> IO b +mask io = E.mask $ \restore -> io restore +{-# INLINE mask #-} + +toByteString :: Builder -> ByteString +toByteString x = toStrict (toLazyByteString x) + +toPico :: Integer -> Pico +toPico = MkFixed + +fromPico :: Pico -> Integer +fromPico (MkFixed i) = i diff --git a/src/Database/PostgreSQL/Simple/Copy.hs b/src/Database/PostgreSQL/Simple/Copy.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Copy.hs @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Copy +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- mid-level support for COPY IN and COPY OUT. See +-- for +-- more information. +-- +-- To use this binding, first call 'copy' with an appropriate +-- query as documented in the link above. Then, in the case of a +-- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it +-- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@ +-- query, call 'putCopyData' repeatedly and then finish by calling +-- either 'putCopyEnd' to proceed or 'putCopyError' to abort. +-- +-- You cannot issue another query on the same connection while a copy +-- is ongoing; this will result in an exception. It is harmless to +-- concurrently call @getNotification@ on a connection while it is in +-- a @CopyIn@ or @CopyOut@ state, however be aware that current versions +-- of the PostgreSQL backend will not deliver notifications to a client +-- while a transaction is ongoing. +module Database.PostgreSQL.Simple.Copy + ( copy, + copy_, + CopyOutResult (..), + -- foldCopyData, + -- getCopyData, + putCopyData, + putCopyEnd, + putCopyError, + ) +where + +import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) +import Data.Typeable (Typeable) +import Database.PostgreSQL.Simple.HpgsqlUtils (toHpgsqlQuery) +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.ToRow (ToRow) +import Database.PostgreSQL.Simple.Types +import qualified Hpgsql.Copy +import qualified Hpgsql.Query + +-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former +-- case, the connection's state will change to @CopyIn@; in the latter, +-- @CopyOut@. The connection must be in the ready state in order +-- to call this function. Performs parameter substitution. +copy :: (ToRow params) => Connection -> Query -> params -> IO () +copy conn template qs = do + let qry = toHpgsqlQuery template qs + doCopy "Database.PostgreSQL.Simple.Copy.copy" conn qry + +-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former +-- case, the connection's state will change to @CopyIn@; in the latter, +-- @CopyOut@. The connection must be in the ready state in order +-- to call this function. Does not perform parameter substitution. +copy_ :: Connection -> Query -> IO () +copy_ conn template = do + let qry = toHpgsqlQuery template () + doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn qry + +doCopy :: B.ByteString -> Connection -> Hpgsql.Query.Query -> IO () +doCopy _funcName conn q = mapHpgsqlErrors $ do + Hpgsql.Copy.copyStart (hpgConn conn) q + +data CopyOutResult + = -- | Data representing either exactly + -- one row of the result, or header + -- or footer data depending on format. + CopyOutRow !B.ByteString + | -- | No more rows, and a count of the + -- number of rows returned. + CopyOutDone {-# UNPACK #-} !Int64 + deriving (Eq, Typeable, Show) + +-- | Feed some data to a @COPY FROM STDIN@ query. Note that +-- the data does not need to represent a single row, or even an +-- integral number of rows. The net result of +-- @putCopyData conn a >> putCopyData conn b@ +-- is the same as @putCopyData conn c@ whenever @c == BS.append a b@. +-- +-- A connection must be in the @CopyIn@ state in order to call this +-- function, otherwise a 'SqlError' exception will result. The +-- connection remains in the @CopyIn@ state after this function +-- is called. +putCopyData :: Connection -> B.ByteString -> IO () +putCopyData conn dat = mapHpgsqlErrors $ Hpgsql.Copy.putCopyData (hpgConn conn) dat + +-- | Completes a @COPY FROM STDIN@ query. Returns the number of rows +-- processed. +-- +-- A connection must be in the @CopyIn@ state in order to call this +-- function, otherwise a 'SqlError' exception will result. The +-- connection's state changes back to ready after this function +-- is called. +putCopyEnd :: Connection -> IO Int64 +putCopyEnd conn = mapHpgsqlErrors $ Hpgsql.Copy.copyEnd (hpgConn conn) + +-- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply +-- an arbitrary error message that may show up in the PostgreSQL +-- server's log. +-- +-- A connection must be in the @CopyIn@ state in order to call this +-- function, otherwise a 'SqlError' exception will result. The +-- connection's state changes back to ready after this function +-- is called. +putCopyError :: Connection -> B.ByteString -> IO () +putCopyError conn err = mapHpgsqlErrors $ Hpgsql.Copy.putCopyError (hpgConn conn) (Text.unpack $ decodeUtf8 err) diff --git a/src/Database/PostgreSQL/Simple/Cursor.hs b/src/Database/PostgreSQL/Simple/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Cursor.hs @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Cursor +-- Copyright: (c) 2011-2012 Leon P Smith +-- (c) 2017 Bardur Arantsson +-- License: BSD3 +-- Maintainer: Leon P Smith +module Database.PostgreSQL.Simple.Cursor + ( -- * Types + Cursor, + + -- * Cursor management + declareCursor, + closeCursor, + + -- * Folding over rows from a cursor + foldForward, + foldForwardWithParser, + ) +where + +import Control.Exception as E +import Control.Monad (foldM, unless, void) +import Data.String (fromString) +import Database.PostgreSQL.Simple.FromRow (FromRow (..)) +import Database.PostgreSQL.Simple.Internal as Base +import Database.PostgreSQL.Simple.Transaction +import Database.PostgreSQL.Simple.Types (Query (..)) +import Hpgsql (execute_, queryMWith) +import Hpgsql.Encoding.RowDecoderMonadic (RowDecoderMonadic) +import Hpgsql.Query (Query, escapeIdentifier, sql) + +-- | Cursor within a transaction. +data Cursor = Cursor !Database.PostgreSQL.Simple.Types.Query !Connection + +-- | Declare a temporary cursor. The cursor is given a +-- unique name for the given connection. +declareCursor :: Connection -> Hpgsql.Query.Query -> IO Cursor +declareCursor conn q = mapHpgsqlErrors $ do + name <- newTempName conn + void $ Hpgsql.execute_ (hpgConn conn) [sql|DECLARE ^{escapeIdentifier (fromQuery name)} NO SCROLL CURSOR FOR ^{q}|] + return $ Cursor name conn + +-- | Close the given cursor. +closeCursor :: Cursor -> IO () +closeCursor (Cursor name conn) = + (void $ mapHpgsqlErrors $ Hpgsql.execute_ (hpgConn conn) [sql|CLOSE ^{escapeIdentifier $ fromQuery name}|]) `E.catch` \ex -> + -- Don't throw exception if CLOSE failed because the transaction is + -- aborted. Otherwise, it will throw away the original error. + unless (isFailedTransactionError ex) $ throwIO ex + +-- | Fold over a chunk of rows from the given cursor, calling the +-- supplied fold-like function on each row as it is received. In case +-- the cursor is exhausted, a 'Left' value is returned, otherwise a +-- 'Right' value is returned. +foldForwardWithParser :: Cursor -> RowDecoderMonadic r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) +foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = mapHpgsqlErrors $ do + let q = + [sql|FETCH FORWARD ^{fromString (show chunkSize)} FROM ^{escapeIdentifier (fromQuery name)}|] + rows <- queryMWith parser (hpgConn conn) q + case rows of + [] -> pure $ Left a0 + _ -> Right <$> foldM f a0 rows + +-- | Fold over a chunk of rows, calling the supplied fold-like function +-- on each row as it is received. In case the cursor is exhausted, +-- a 'Left' value is returned, otherwise a 'Right' value is returned. +foldForward :: (FromRow r) => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) +foldForward cursor = foldForwardWithParser cursor fromRow diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ + +---------------------------------------------------------- + +-- | +-- Module: Database.PostgreSQL.Simple.Errors +-- Copyright: (c) 2012-2013 Leonid Onokhov, Joey Adams +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- | Module for parsing errors from postgresql error messages. +-- Currently only parses integrity violation errors (class 23). +-- +-- /Note: Success of parsing may depend on language settings./ +module Database.PostgreSQL.Simple.Errors + ( ConstraintViolation (..), + constraintViolation, + constraintViolationE, + catchViolation, + isSerializationError, + isNoActiveTransactionError, + isFailedTransactionError, + ) +where + +import Control.Exception as E + +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString (ByteString) +import Data.Typeable + +import Database.PostgreSQL.Simple.Internal + +-- Examples of parsed error messages +-- +-- `ERROR: new row for relation "users" violates check +-- constraint "user_kind_check"` +-- +-- `ERROR: insert or update on table "user_group_map" violates foreign key +-- constraint "user_id"` +-- +-- `ERROR: null value in column "login" violates not-null constraint` +-- +-- `ERROR: duplicate key value violates unique constraint "users_login_key"` + +data ConstraintViolation + = -- | The field is a column name + NotNullViolation ByteString + | -- | Table name and name of violated constraint + ForeignKeyViolation ByteString ByteString + | -- | Name of violated constraint + UniqueViolation ByteString + | -- | Relation name (usually table), constraint name + CheckViolation ByteString ByteString + | -- | Name of the exclusion violation constraint + ExclusionViolation ByteString + deriving (Show, Eq, Ord, Typeable) + +-- Default instance should be enough +instance Exception ConstraintViolation where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException + +-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and +-- succeeds only if able to parse sqlErrorMsg. +-- +-- > createUser = handleJust constraintViolation handler $ execute conn ... +-- > where +-- > handler (UniqueViolation "user_login_key") = ... +-- > handler _ = ... +constraintViolation :: SqlError -> Maybe ConstraintViolation +constraintViolation e = + case sqlState e of + "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg + "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg + "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg + "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg + "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg + _ -> Nothing + where + msg = sqlErrorMsg e + +-- | Like constraintViolation, but also packs original SqlError. +-- +-- > createUser = handleJust constraintViolationE handler $ execute conn ... +-- > where +-- > handler (_, UniqueViolation "user_login_key") = ... +-- > handler (e, _) = throwIO e +constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) +constraintViolationE e = fmap ((,) e) $ constraintViolation e + +-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws +-- on fail. Provides alternative interface to 'E.handleJust' +-- +-- > createUser = catchViolation catcher $ execute conn ... +-- > where +-- > catcher _ (UniqueViolation "user_login_key") = ... +-- > catcher e _ = throwIO e +catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a +catchViolation f m = + E.catch + m + (\e -> maybe (throwIO e) (f e) $ constraintViolation e) + +-- Parsers just try to extract quoted strings from error messages, number +-- of quoted strings depend on error type. +scanTillQuote :: Parser ByteString +scanTillQuote = scan False go + where + go True _ = Just False -- escaped character + go False '"' = Nothing -- end parse + go False '\\' = Just True -- next one is escaped + go _ _ = Just False + +parseQ1 :: Parser ByteString +parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"' + +parseQ2 :: Parser (ByteString, ByteString) +parseQ2 = (,) <$> parseQ1 <*> parseQ1 + +parseMaybe :: Parser a -> ByteString -> Maybe a +parseMaybe p b = either (const Nothing) Just $ parseOnly p b + +------------------------------------------------------------------------ +-- Error predicates +-- +-- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html + +isSerializationError :: SqlError -> Bool +isSerializationError = isSqlState "40001" + +isNoActiveTransactionError :: SqlError -> Bool +isNoActiveTransactionError = isSqlState "25P01" + +isFailedTransactionError :: SqlError -> Bool +isFailedTransactionError = isSqlState "25P02" + +isSqlState :: ByteString -> SqlError -> Bool +isSqlState s SqlError {..} = sqlState == s diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -0,0 +1,323 @@ +-- | +-- Module: Database.PostgreSQL.Simple.FromField +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- The 'FromField' typeclass, for converting a single value in a row +-- returned by a SQL query into a more useful Haskell representation. +-- Note that each instance of 'FromField' is documented by a list of +-- compatible postgresql types. +-- +-- A Haskell numeric type is considered to be compatible with all +-- PostgreSQL numeric types that are less accurate than it. For instance, +-- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit +-- @int@ type because it can represent a @int@ exactly. On the other hand, +-- since a 'Double' might lose precision if representing PostgreSQL's 64-bit +-- @bigint@, the two are /not/ considered compatible. +-- +-- Note that the 'Float' and 'Double' instances use attoparsec's 'double' +-- conversion routine, which sacrifices some accuracy for speed. If you +-- need accuracy, consider first converting data to a 'Scientific' or 'Rational' +-- type, and then converting to a floating-point type. If you are defining +-- your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be +-- achieved simply by +-- @'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although +-- this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@ +-- types. If this is unacceptable, you may find +-- 'Database.PostgreSQL.Simple.FromRow.fieldWith' useful. +-- +-- Also note that while converting to a 'Double' through the 'Scientific' type +-- is likely somewhat faster than converting through the 'Rational' type, +-- the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values. +-- Thus, if you need precision conversion of regular floating point values +-- and the possibility of receiving these special values from the backend, +-- stick with 'Rational'. +-- +-- Because 'FromField' is a typeclass, one may provide conversions to +-- additional Haskell types without modifying hpgsql-simple-compat. This is +-- particularly useful for supporting PostgreSQL types that hpgsql-simple-compat +-- does not support out-of-box. Here's an example of what such an instance +-- might look like for a UUID type that implements the @Read@ class: +-- +-- @ +-- import Data.UUID ( UUID ) +-- import Database.PostgreSQL.Simple.FromField +-- ( FromField (fromField) , typeOid, returnError, ResultError (..) ) +-- import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid) +-- import qualified Data.ByteString.Char8 as B +-- +-- instance FromField UUID where +-- fromField f mdata = +-- if typeOid f /= typoid uuid +-- then returnError Incompatible f \"\" +-- else case B.unpack \`fmap\` mdata of +-- Nothing -> returnError UnexpectedNull f \"\" +-- Just dat -> +-- case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of +-- [x] -> return x +-- _ -> returnError ConversionFailed f dat +-- @ +-- +-- Note that because PostgreSQL's @uuid@ type is built into postgres and is +-- not provided by an extension, the 'typeOid' of @uuid@ does not change and +-- thus we can examine it directly. One could hard-code the type oid, or +-- obtain it by other means, but in this case we simply pull it out of the +-- static table provided by hpgsql-simple-compat. +-- +-- On the other hand if the type is provided by an extension, such as +-- @PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from +-- database to database. In this case it is recommended that FromField +-- instances use 'typename' instead. +module Database.PostgreSQL.Simple.FromField + ( FromField (..), + FromPgField (..), + FieldParser, + Conversion (..), + -- conversionMap, + conversionError, + ResultError (..), + returnError, + Field, + typename, + TypeInfo (..), + Attribute (..), + typeInfo, + typeInfoByOid, + name, + typeOid, + PQ.Oid (..), + PQ.Format (..), + optionalField, + fromFieldJSONByteString, + fromJSONField, + ) +where + +import Control.Exception (Exception (fromException, toException)) +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as LBS +import Data.CaseInsensitive (CI) +import Data.Int (Int16, Int32, Int64) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as LT +import Data.Time.Calendar.Compat (Day) +import Data.Time.Compat (UTCTime) +import Data.Time.LocalTime.Compat (CalendarDiffTime, LocalTime, TimeOfDay, ZonedTime) +import Data.Typeable (Typeable, typeOf) +import Data.UUID.Types (UUID) +import Data.Vector (Vector) +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.HpgsqlUtils +import Database.PostgreSQL.Simple.Internal (postgresqlExceptionFromException, postgresqlExceptionToException) +import Database.PostgreSQL.Simple.Ok (Ok (..)) +import Database.PostgreSQL.Simple.TypeInfo as TI +import Database.PostgreSQL.Simple.TypeInfo.Types (fromHpgsqlTypeInfo) +import Database.PostgreSQL.Simple.Types (Binary (..)) +import Hpgsql.Encoding (EncodingContext (..), FieldInfo (..), FromPgField (..)) +import qualified Hpgsql.Encoding as Hpgsql +import Hpgsql.Time (Unbounded (..)) +import Hpgsql.TypeInfo (Oid, lookupTypeByOid) +import Hpgsql.Types (Aeson, PGArray (..), getAeson, pgJsonByteString) + +-- | Exception thrown if conversion from a SQL value to a Haskell +-- value fails. +data ResultError + = -- | The SQL and Haskell types are not compatible. + Incompatible + { errSQLType :: String, + errSQLTableOid :: Maybe PQ.Oid, + errSQLField :: String, + errHaskellType :: String, + errMessage :: String + } + | -- | A SQL @NULL@ was encountered when the Haskell + -- type did not permit it. + UnexpectedNull + { errSQLType :: String, + errSQLTableOid :: Maybe PQ.Oid, + errSQLField :: String, + errHaskellType :: String, + errMessage :: String + } + | -- | The SQL value could not be parsed, or could not + -- be represented as a valid Haskell value, or an + -- unexpected low-level error occurred (e.g. mismatch + -- between metadata and actual data in a row). + ConversionFailed + { errSQLType :: String, + errSQLTableOid :: Maybe PQ.Oid, + errSQLField :: String, + errHaskellType :: String, + errMessage :: String + } + deriving (Eq, Show, Typeable) + +instance Exception ResultError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException + +-- | This might be very different from postgresql-simple. +conversionError :: (Exception err) => err -> Conversion a +conversionError ex = Conversion $ \_ -> Errors [toException ex] + +left :: (Exception a) => a -> Conversion b +left = conversionError + +class FromField a where + fromField :: FieldParser a + default fromField :: (Hpgsql.FromPgField a) => FieldParser a + fromField = + let dec = Hpgsql.fieldDecoder + in \f -> + if (Hpgsql.allowedPgTypes dec) f + then \mbs -> Conversion $ \_encCtx -> case (Hpgsql.fieldValueDecoder dec) f mbs of + Right v -> Ok v + Left err -> Errors [toException $ userError err] + else \_ -> Conversion $ \_encCtx -> Errors [toException $ userError "Invalid type OID for FromField instance"] + +instance FromField () + +instance FromField Int + +instance FromField Int16 + +instance FromField Int32 + +instance FromField Int64 + +instance FromField Integer + +instance FromField Oid + +instance FromField Scientific + +instance FromField Rational + +instance FromField Float + +instance FromField Double + +instance FromField Bool + +instance FromField Char + +instance FromField ByteString + +instance FromField LBS.ByteString + +instance FromField Text + +instance FromField LT.Text + +instance FromField String + +instance FromField UTCTime + +instance FromField ZonedTime + +instance FromField LocalTime + +instance FromField TimeOfDay + +instance FromField Day + +instance FromField CalendarDiffTime + +instance FromField Aeson.Value + +instance FromField UUID + +instance FromField (CI Text) + +instance FromField (CI LT.Text) + +instance FromField (CI String) + +instance FromField (Unbounded Day) + +instance FromField (Unbounded UTCTime) + +instance FromField (Unbounded ZonedTime) + +instance (FromField a) => FromField (Maybe a) where + fromField = optionalField fromField + +-- instance (FromField a) => FromField (Vector a) + +-- instance (FromField a) => FromField (PGArray a) + +instance (Hpgsql.FromPgField a) => FromField (PGArray a) + +instance (Hpgsql.FromPgField a) => FromField (Vector a) + +instance {-# OVERLAPPING #-} (Hpgsql.FromPgField a) => FromField (Vector (Vector a)) + +instance FromField (Binary ByteString) + +instance (Aeson.FromJSON a) => FromField (Aeson a) + +typeOid :: Field -> Oid +typeOid field = field.fieldTypeOid + +typename :: Field -> Conversion ByteString +typename field = typname <$> typeInfo field + +typeInfo :: Field -> Conversion TypeInfo +typeInfo colInfo = typeInfoByOid colInfo.fieldTypeOid + +typeInfoByOid :: PQ.Oid -> Conversion TypeInfo +typeInfoByOid oid = Conversion $ \encCtx -> do + case lookupTypeByOid oid encCtx.typeInfoCache of + Nothing -> Errors [toException $ userError $ "Type OID " ++ show oid ++ " not found in TypeInfoCache"] + Just t -> Ok (fromHpgsqlTypeInfo encCtx t) + +-- | Returns the name of the column. This is often determined by a table +-- definition, but it can be set using an @as@ clause. +name :: Field -> Maybe ByteString +name f = encodeUtf8 <$> fieldName f + +-- | Given one of the constructors from 'ResultError', the field, +-- and an 'errMessage', this fills in the other fields in the +-- exception value and returns it in a 'Left . SomeException' +-- constructor. +returnError :: + forall a err. + (Typeable a, Exception err) => + (String -> Maybe PQ.Oid -> String -> String -> String -> err) -> + Field -> + String -> + Conversion a +returnError mkErr f msg = do + typnam <- typename f + left $ + mkErr + (B8.unpack typnam) + (error "no tableOid in hpgsql") + -- (maybe "" B8.unpack (name f)) + "column name not available in hpgsql-simple-compat" + (show (typeOf (undefined :: a))) + msg + +-- | For dealing with SQL @null@ values outside of the 'FromField' class. +-- Alternatively, one could use 'Control.Applicative.optional', but that +-- also turns type and conversion errors into 'Nothing', whereas this is +-- more specific and turns only @null@ values into 'Nothing'. +optionalField :: FieldParser a -> FieldParser (Maybe a) +optionalField p f mv = + case mv of + Nothing -> pure Nothing + Just _ -> Just <$> p f mv +{-# INLINE optionalField #-} + +fromJSONField :: (Aeson.FromJSON a) => FieldParser a +fromJSONField f mbs = getAeson <$> fromField f mbs + +fromFieldJSONByteString :: FieldParser ByteString +fromFieldJSONByteString = fromHpgsqlFieldDecoder $ pgJsonByteString <$> fieldDecoder diff --git a/src/Database/PostgreSQL/Simple/FromField.hs-boot b/src/Database/PostgreSQL/Simple/FromField.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromField.hs-boot @@ -0,0 +1,1 @@ +module Database.PostgreSQL.Simple.FromField where diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE UndecidableInstances #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.FromRow +-- Copyright: (c) 2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- The 'FromRow' typeclass, for converting a row of results +-- returned by a SQL query into a more useful Haskell representation. +-- +-- Predefined instances are provided for tuples containing up to ten +-- elements. The instances for 'Maybe' types return 'Nothing' if all +-- the columns that would have been otherwise consumed are null, otherwise +-- it attempts a regular conversion. +module Database.PostgreSQL.Simple.FromRow + ( FromRow (..), + FromPgRow (..), + RowParser, + field, + fieldWith, + numFieldsRemaining, + ) +where + +import Database.PostgreSQL.Simple.FromField (FromField (..)) +import Database.PostgreSQL.Simple.HpgsqlUtils +import GHC.Generics (Generic (..), K1 (..), M1 (..), (:*:) (..)) +import Hpgsql.Encoding (FieldDecoder, FromPgField (..), FromPgRow (..), singleField) +import Hpgsql.Encoding.RowDecoderMonadic (ConversionState (..), RowDecoderMonadic (..), toMonadicRowDecoder) +import Hpgsql.Types (Only (..), (:.) (..)) +import Prelude hiding (null) + +type RowParser = RowDecoderMonadic + +class FromRow a where + fromRow :: RowParser a + default fromRow :: (Generic a, ProductTypeDecoder (Rep a)) => RowParser a + fromRow = genericFromPgRow + +fromHpgsqlField :: (FromField a) => FieldDecoder a +fromHpgsqlField = toHpgsqlFieldDecoder fromField + +instance (FromField a) => FromRow (Only a) where + fromRow = Only <$> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b) => FromRow (a, b) where + fromRow = (,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c) => FromRow (a, b, c) where + fromRow = (,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a, b, c, d) where + fromRow = (,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a, b, c, d, e) where + fromRow = (,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (a, b, c, d, e, f) where + fromRow = (,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => FromRow (a, b, c, d, e, f, g) where + fromRow = (,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h) => FromRow (a, b, c, d, e, f, g, h) where + fromRow = (,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i) => FromRow (a, b, c, d, e, f, g, h, i) where + fromRow = (,,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j) => FromRow (a, b, c, d, e, f, g, h, i, j) where + fromRow = (,,,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k) => FromRow (a, b, c, d, e, f, g, h, i, j, k) where + fromRow = (,,,,,,,,,,) <$> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) <*> toMonadicRowDecoder (singleField fromHpgsqlField) + +instance (FromRow a, FromRow b) => FromRow (a :. b) where + fromRow = (:.) <$> fromRow <*> fromRow + +field :: (FromPgField a) => RowDecoderMonadic a +field = toMonadicRowDecoder $ singleField fieldDecoder + +-- | Parse a single field using the given 'FieldParser'. +fieldWith :: FieldParser a -> RowParser a +fieldWith fp = toMonadicRowDecoder $ singleField $ toHpgsqlFieldDecoder fp + +-- | Return the number of fields remaining in the current row. +numFieldsRemaining :: RowParser Int +numFieldsRemaining = RowDecoderMonadic $ \cs -> pure (length (colsLeftToParse cs), 0) + +class ProductTypeDecoder f where + genRowDecoder :: RowDecoderMonadic (f a) + +instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where + genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder + +instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where + genRowDecoder = M1 <$> genRowDecoder + +instance (FromField a) => ProductTypeDecoder (K1 r a) where + genRowDecoder = fmap K1 $ toMonadicRowDecoder $ singleField $ fromHpgsqlField @a + +genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowParser a +genericFromPgRow = to <$> genRowDecoder @(Rep a) diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs-boot b/src/Database/PostgreSQL/Simple/FromRow.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromRow.hs-boot @@ -0,0 +1,3 @@ +module Database.PostgreSQL.Simple.FromRow where + +class FromRow a diff --git a/src/Database/PostgreSQL/Simple/HStore.hs b/src/Database/PostgreSQL/Simple/HStore.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore.hs @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.HStore +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Parsers and printers for hstore, a extended type bundled with +-- PostgreSQL providing finite maps from text strings to text strings. +-- See for more +-- information. +-- +-- Note that in order to use this type, a database superuser must +-- install it by running a sql script in the share directory. This +-- can be done on PostgreSQL 9.1 and later with the command +-- @CREATE EXTENSION hstore@. See +-- for more +-- information. +module Database.PostgreSQL.Simple.HStore + ( HStoreList (..), + HStoreMap (..), + ToHStore (..), + HStoreBuilder, + toBuilder, + toLazyByteString, + hstore, + parseHStoreList, + ToHStoreText (..), + HStoreText, + ) where + +import Database.PostgreSQL.Simple.HStore.Implementation diff --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.HStore.Implementation +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- This code has yet to be profiled and optimized. +module Database.PostgreSQL.Simple.HStore.Implementation where + +import Control.Applicative +import qualified Data.Attoparsec.ByteString as P +import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder, byteString, char8) +import qualified Data.ByteString.Builder as BU +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy as BL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as TS +import qualified Data.Text.Encoding as TS +import Data.Text.Encoding.Error (UnicodeException) +import qualified Data.Text.Lazy as TL +import Data.Typeable + +class ToHStore a where + toHStore :: a -> HStoreBuilder + +-- | Represents valid hstore syntax. +data HStoreBuilder + = Empty + | Comma !Builder + deriving (Typeable) + +instance ToHStore HStoreBuilder where + toHStore = id + +toBuilder :: HStoreBuilder -> Builder +toBuilder x = case x of + Empty -> mempty + Comma c -> c + +toLazyByteString :: HStoreBuilder -> BL.ByteString +toLazyByteString x = case x of + Empty -> BL.empty + Comma c -> BU.toLazyByteString c + +instance Semigroup HStoreBuilder where + Empty <> x = x + Comma a <> x = + Comma + ( a `mappend` case x of + Empty -> mempty + Comma b -> char8 ',' `mappend` b + ) + +instance Monoid HStoreBuilder where + mempty = Empty + +class ToHStoreText a where + toHStoreText :: a -> HStoreText + +-- | Represents escape text, ready to be the key or value to a hstore value +newtype HStoreText = HStoreText Builder + deriving stock (Typeable) + deriving newtype (Semigroup, Monoid) + +instance ToHStoreText HStoreText where + toHStoreText = id + +-- | Assumed to be UTF-8 encoded +instance ToHStoreText BS.ByteString where + toHStoreText str = HStoreText (escapeAppend str mempty) + +-- | Assumed to be UTF-8 encoded +instance ToHStoreText BL.ByteString where + toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty + +instance ToHStoreText TS.Text where + toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty) + +instance ToHStoreText TL.Text where + toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty + +escapeAppend :: BS.ByteString -> Builder -> Builder +escapeAppend = loop + where + loop (BS.break quoteNeeded -> (a, b)) rest = + byteString a + `mappend` case BS.uncons b of + Nothing -> rest + Just (c, d) -> quoteChar c `mappend` loop d rest + + quoteNeeded c = c == c2w '\"' || c == c2w '\\' + quoteChar c + | c == c2w '\"' = byteString "\\\"" + | otherwise = byteString "\\\\" + +hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder +hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = + Comma + ( char8 '"' + `mappend` key + `mappend` byteString "\"=>\"" + `mappend` val + `mappend` char8 '"' + ) + +newtype HStoreList = HStoreList {fromHStoreList :: [(Text, Text)]} deriving (Typeable, Show) + +-- | hstore +instance ToHStore HStoreList where + toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs) + +newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show) + +instance ToHStore HStoreMap where + toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs + where + f k v xs' = hstore k v `mappend` xs' + +parseHStoreList :: BS.ByteString -> Either String HStoreList +parseHStoreList dat = + case P.parseOnly (parseHStore <* P.endOfInput) dat of + Left err -> Left (show err) + Right (Left err) -> Left (show err) + Right (Right val) -> Right val + +parseHStore :: P.Parser (Either UnicodeException HStoreList) +parseHStore = do + kvs <- + P.sepBy' + (skipWhiteSpace *> parseHStoreKeyVal) + (skipWhiteSpace *> P.word8 (c2w ',')) + return $ HStoreList <$> sequence kvs + +parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text, Text)) +parseHStoreKeyVal = do + mkey <- parseHStoreText + case mkey of + Left err -> return (Left err) + Right key -> do + skipWhiteSpace + _ <- P.string "=>" + skipWhiteSpace + mval <- parseHStoreText + case mval of + Left err -> return (Left err) + Right val -> return (Right (key, val)) + +skipWhiteSpace :: P.Parser () +skipWhiteSpace = P.skipWhile P.isSpace_w8 + +parseHStoreText :: P.Parser (Either UnicodeException Text) +parseHStoreText = do + _ <- P.word8 (c2w '"') + mtexts <- parseHStoreTexts id + case mtexts of + Left err -> return (Left err) + Right texts -> do + _ <- P.word8 (c2w '"') + return (Right (TS.concat texts)) + +parseHStoreTexts :: + ([Text] -> [Text]) -> + P.Parser (Either UnicodeException [Text]) +parseHStoreTexts acc = do + mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar) + case mchunk of + Left err -> return (Left err) + Right chunk -> + ( do + _ <- P.word8 (c2w '\\') + c <- TS.singleton . w2c <$> P.satisfy isSpecialChar + parseHStoreTexts (acc . (chunk :) . (c :)) + ) + <|> return (Right (acc [chunk])) + where + isSpecialChar c = c == c2w '\\' || c == c2w '"' diff --git a/src/Database/PostgreSQL/Simple/HStore/Internal.hs b/src/Database/PostgreSQL/Simple/HStore/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore/Internal.hs @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.HStore.Internal +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +module Database.PostgreSQL.Simple.HStore.Internal + ( HStoreBuilder (..), + HStoreText (..), + parseHStore, + parseHStoreKeyVal, + parseHStoreText, + ) where + +import Database.PostgreSQL.Simple.HStore.Implementation diff --git a/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs b/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HpgsqlUtils.hs @@ -0,0 +1,126 @@ +module Database.PostgreSQL.Simple.HpgsqlUtils + ( toHpgsqlQuery, + toHpgsqlRowParams, + toPgSimpleQuery, + Conversion (..), + PgSimpleRow (..), + toHpgsqlFieldDecoder, + fromHpgsqlFieldDecoder, + Field, + FieldParser, + ) +where + +import Control.Applicative (Alternative (..)) +import Control.Exception (toException) +import Control.Monad (MonadPlus (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.IntMap.Strict as IntMap +import Database.PostgreSQL.Simple.Ok (Ok (..)) +import Database.PostgreSQL.Simple.ToField (Action (..)) +import Database.PostgreSQL.Simple.ToRow (ToRow (..)) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Hpgsql.Builder (BinaryField) +import Hpgsql.Encoding (FieldDecoder (..), FieldInfo (..)) +import Hpgsql.InternalTypes (SingleQueryFragment (..)) +import qualified Hpgsql.InternalTypes as HpgsqlTypes +import qualified Hpgsql.Query as Hpgsql +import Hpgsql.TypeInfo (EncodingContext, Oid) + +toHpgsqlQuery :: (ToRow q) => Query -> q -> Hpgsql.Query +toHpgsqlQuery (Query qry) row = Hpgsql.mkQueryInternal qry (toHpgsqlRowParams row) + +toHpgsqlRowParams :: (ToRow q) => q -> [[Either ByteString (EncodingContext -> (Maybe Oid, BinaryField))]] +toHpgsqlRowParams = concatMap actionToPgParams . toRow + where + actionToPgParams :: Action -> [[Either ByteString (EncodingContext -> (Maybe Oid, BinaryField))]] + actionToPgParams = \case + Plain sql -> [[Left $ LBS.toStrict sql]] -- Static SQL fragments go to the query string directly + QueryArgument qa -> [[Right qa]] + EscapeIdentifier ident -> [[Left $ escapeIdentifier ident]] -- These should be encoded into the query string directly + Many actions -> [mconcat $ concatMap actionToPgParams actions] + +escapeIdentifier :: ByteString -> ByteString +escapeIdentifier v = "\"" <> BS.intercalate "\"\"" (BS.split 0x22 {- '"' -} v) <> "\"" + +newtype PgSimpleRow = PgSimpleRow [Action] + deriving newtype (ToRow) + +-- | This is different from postgresql-simple's `Conversion` type, but it's the +-- best we can do, because hpgsql-simple-compat's decoding cannot run IO. +newtype Conversion a = Conversion {runConversion :: EncodingContext -> Ok a} + +-- liftConversion :: IO a -> Conversion a +-- liftConversion m = Conversion (\_ -> Ok <$> m) + +instance Functor Conversion where + fmap f m = Conversion $ \encCtx -> fmap f (runConversion m encCtx) + +instance Applicative Conversion where + pure a = Conversion $ \_conn -> pure a + mf <*> ma = Conversion $ \conn -> do + case runConversion mf conn of + Ok f -> fmap f (runConversion ma conn) + Errors errs -> (Errors errs) + +instance Alternative Conversion where + empty = Conversion $ \_ -> empty + ma <|> mb = Conversion $ \encCtx -> + case runConversion ma encCtx of + Ok v -> return v + Errors _ -> runConversion mb encCtx + +instance Monad Conversion where + m >>= f = Conversion $ \conn -> do + case runConversion m conn of + Ok a -> runConversion (f a) conn + Errors err -> Errors err + +instance MonadPlus Conversion where + mzero = empty + mplus = (<|>) + +-- conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b +-- conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn + +-- conversionError :: (Exception err) => err -> Conversion a +-- conversionError err = Conversion $ \_ -> return (Errors [toException err]) + +type Field = FieldInfo + +type FieldParser a = Field -> Maybe ByteString -> Conversion a + +toHpgsqlFieldDecoder :: FieldParser a -> FieldDecoder a +toHpgsqlFieldDecoder fp = + FieldDecoder + { fieldValueDecoder = \colInfo mbs -> + let valConv = fp colInfo mbs + in case runConversion valConv colInfo.encodingContext of + Ok v -> Right v + Errors errs -> Left (show errs), + allowedPgTypes = const True -- No way to check if types are valid ahead of time + } + +fromHpgsqlFieldDecoder :: FieldDecoder a -> FieldParser a +fromHpgsqlFieldDecoder dec = \f mbs -> Conversion $ \_encCtx -> case dec.fieldValueDecoder f mbs of + Right v -> Ok v + Left err -> Errors [toException $ userError $ show err] + +-- | Given a Hpgsql query, returns the text format with question marks +-- for query arguments and a row object. With both, you can call +-- hpgsql-simple-compat's querying functions as you normally would. +toPgSimpleQuery :: Hpgsql.Query -> (Query, PgSimpleRow) +toPgSimpleQuery hpgsqlQuery = + let paramsMap = IntMap.fromList $ zip [1 ..] hpgsqlQuery.queryParams + go frag (ts, as) = case frag of + FragmentOfStaticSql bs -> (bs : ts, as) + FragmentWithSemiColon -> (";" : ts, as) + FragmentOfCommentsOrWhitespace bs -> (bs : ts, as) + QueryArgumentPlaceHolder n -> case IntMap.lookup n paramsMap of + Just p -> ("?" : ts, QueryArgument p : as) + Nothing -> error $ "toPgSimpleQuery: query argument placeholder $" ++ show n ++ " has no corresponding parameter" + (textParts, actions) = foldr go ([], []) hpgsqlQuery.queryString + queryText = mconcat textParts + in (Query queryText, PgSimpleRow actions) diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -0,0 +1,369 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Internal +-- Copyright: (c) 2011-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Internal bits. This interface is less stable and can change at any time. +-- In particular this means that while the rest of the hpgsql-simple-compat +-- package endeavors to follow the package versioning policy, this module +-- does not. Also, at the moment there are things in here that aren't +-- particularly internal and are exported elsewhere; these will eventually +-- disappear from this module. +module Database.PostgreSQL.Simple.Internal where + +import Control.Concurrent.MVar +import Control.Exception +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as LBS +import Data.IORef +import Data.Int (Int64) +import qualified Data.IntMap as IntMap +import qualified Data.Map.Strict as Map +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Typeable +import Data.Word +import Database.PostgreSQL.LibPQ (ExecStatus (..), Oid (..)) +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.ToField (Action (..)) +import Database.PostgreSQL.Simple.TypeInfo.Types (TypeInfo) +import Database.PostgreSQL.Simple.Types (Query (..)) +import GHC.Generics +import GHC.IO.Exception +import Hpgsql (ErrorDetail (..), HPgConnection, IrrecoverableHpgsqlError (..), PostgresError (..)) +import qualified Hpgsql +import qualified Hpgsql.Connection + +type TypeInfoCache = IntMap.IntMap TypeInfo + +data Connection = Connection + { connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache), + connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64), + hpgConn :: HPgConnection + } + deriving (Typeable) + +instance Eq Connection where + x == y = hpgConn x == hpgConn y + +-- | Superclass for postgresql exceptions +data SomePostgreSqlException = forall e. (Exception e) => SomePostgreSqlException e + deriving (Typeable) + +postgresqlExceptionToException :: (Exception e) => e -> SomeException +postgresqlExceptionToException = toException . SomePostgreSqlException + +postgresqlExceptionFromException :: (Exception e) => SomeException -> Maybe e +postgresqlExceptionFromException x = do + SomePostgreSqlException a <- fromException x + cast a + +instance Show SomePostgreSqlException where + showsPrec :: Int -> SomePostgreSqlException -> ShowS + showsPrec p (SomePostgreSqlException e) = showsPrec p e + +instance Exception SomePostgreSqlException where + displayException (SomePostgreSqlException e) = displayException e + +data SqlError = SqlError + { sqlState :: ByteString, + sqlExecStatus :: ExecStatus, + sqlErrorMsg :: ByteString, + sqlErrorDetail :: ByteString, + sqlErrorHint :: ByteString, + -- | This is a new field present only in hpgsql-simple-compat, + -- to help debugging the source of errors. + sqlStatement :: ByteString + } + deriving (Eq, Show, Typeable) + +fatalError :: ByteString -> SqlError +fatalError msg = SqlError "" FatalError msg "" "" "" + +instance Exception SqlError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException + +-- | Exception thrown if 'query' is used to perform an @INSERT@-like +-- operation, or 'execute' is used to perform a @SELECT@-like operation. +data QueryError = QueryError + { qeMessage :: String, + qeQuery :: Query + } + deriving (Eq, Show, Typeable) + +instance Exception QueryError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException + +-- | Exception thrown if a 'Query' could not be formatted correctly. +-- This may occur if the number of \'@?@\' characters in the query +-- string does not match the number of parameters provided. +data FormatError = FormatError + { fmtMessage :: String, + fmtQuery :: Query, + fmtParams :: [ByteString] + } + deriving (Eq, Show, Typeable) + +instance Exception FormatError where + toException = postgresqlExceptionToException + fromException = postgresqlExceptionFromException + +data ConnectInfo = ConnectInfo + { connectHost :: String, + connectPort :: Word16, + connectUser :: String, + connectPassword :: String, + connectDatabase :: String + } + deriving (Generic, Eq, Read, Show, Typeable) + +-- | Default information for setting up a connection. +-- +-- Defaults are as follows: +-- +-- * Server on @localhost@ +-- +-- * Port on @5432@ +-- +-- * User @postgres@ +-- +-- * No password +-- +-- * Database @postgres@ +-- +-- Use as in the following example: +-- +-- > connect defaultConnectInfo { connectHost = "db.example.com" } +defaultConnectInfo :: ConnectInfo +defaultConnectInfo = + ConnectInfo + { connectHost = "127.0.0.1", + connectPort = 5432, + connectUser = "postgres", + connectPassword = "", + connectDatabase = "" + } + +-- | Connect with the given username to the given database. Will throw +-- an exception if it cannot connect. +connect :: ConnectInfo -> IO Connection +connect = connectPostgreSQL . postgreSQLConnectionString + +-- | Memory bracket around 'connect' and 'close'. +-- +-- @since 0.6.5 +withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c +withConnect connInfo = bracket (connect connInfo) close + +-- | Atomically perform an action with the database handle, if there is one. +withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a +withConnection Connection {..} m = m $ PQ.Connection hpgConn + +-- | Attempt to make a connection based on a libpq connection string. +-- See +-- for more information. Also note that environment variables also affect +-- parameters not provided, parameters provided as the empty string, and a +-- few other things; see +-- +-- for details. Here is an example with some of the most commonly used +-- parameters: +-- +-- > host='db.somedomain.com' port=5432 ... +-- +-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port +-- will normally default to 5432. +-- +-- On systems that provide unix domain sockets, omitting the host parameter +-- will cause libpq to attempt to connect via unix domain sockets. +-- The default filesystem path to the socket is constructed from the +-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the +-- @pg_config_manual.h@ header file. Connecting via unix sockets tends +-- to use the @peer@ authentication method, which is very secure and +-- does not require a password. +-- +-- On Windows and other systems without unix domain sockets, omitting +-- the host will default to @localhost@. +-- +-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw' +-- +-- This attempts to connect to a database named @postgres@ with +-- user @postgres@ and password @secret \' \\ pw@. Backslash +-- characters will have to be double-quoted in literal Haskell strings, +-- of course. Omitting @dbname@ and @user@ will both default to the +-- system username that the client process is running as. +-- +-- Omitting @password@ will default to an appropriate password found +-- in the @pgpass@ file, or no password at all if a matching line is +-- not found. The path of the @pgpass@ file may be specified by setting +-- the @PGPASSFILE@ environment variable. See +-- for +-- more information regarding this file. +-- +-- As all parameters are optional and the defaults are sensible, the +-- empty connection string can be useful for development and +-- exploratory use, assuming your system is set up appropriately. +-- +-- On Unix, such a setup would typically consist of a local +-- postgresql server listening on port 5432, as well as a system user, +-- database user, and database sharing a common name, with permissions +-- granted to the user on the database. +-- +-- On Windows, in addition you will either need @pg_hba.conf@ +-- to specify the use of the @trust@ authentication method for +-- the connection, which may not be appropriate for multiuser +-- or production machines, or you will need to use a @pgpass@ file +-- with the @password@ or @md5@ authentication methods. +-- +-- See +-- for more information regarding the authentication process. +-- +-- SSL/TLS will typically "just work" if your postgresql server supports or +-- requires it. However, note that libpq is trivially vulnerable to a MITM +-- attack without setting additional SSL connection parameters. In +-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or +-- @verify-full@ in order to perform certificate validation. When @sslmode@ +-- is @require@, then you will also need to specify a @sslrootcert@ file, +-- otherwise no validation of the server's identity will be performed. +-- Client authentication via certificates is also possible via the +-- @sslcert@ and @sslkey@ parameters. See +-- +-- for detailed information regarding libpq and SSL. +connectPostgreSQL :: ByteString -> IO Connection +connectPostgreSQL connstr = do + connectionObjects <- newMVar (IntMap.empty) + connectionTempNameCounter <- newIORef 0 + case Hpgsql.Connection.parseLibpqConnectionString (TE.decodeUtf8 connstr) of + Left err -> error err + Right connStr -> do + hpgConn <- mapHpgsqlErrors $ Hpgsql.Connection.connect connStr 30 + pure $ Connection {..} + +-- | Turns a 'ConnectInfo' data structure into a libpq connection string. +postgreSQLConnectionString :: ConnectInfo -> ByteString +postgreSQLConnectionString connectInfo = fromString connstr + where + connstr = + str "host=" connectHost $ + num "port=" connectPort $ + str "user=" connectUser $ + str "password=" connectPassword $ + str "dbname=" connectDatabase $ + [] + + str name field + | null value = id + | otherwise = showString name . addQuotes value . space + where + value = field connectInfo + + num name field + | value <= 0 = id + | otherwise = showString name . shows value . space + where + value = field connectInfo + + addQuotes s rest = '\'' : foldr delta ('\'' : rest) s + where + delta c cs = case c of + '\\' -> '\\' : '\\' : cs + '\'' -> '\\' : '\'' : cs + _ -> c : cs + + space [] = [] + space xs = ' ' : xs + +oid2int :: Oid -> Int +oid2int (Oid x) = fromIntegral x +{-# INLINE oid2int #-} + +-- | Maps Hpgsql's 'PostgresError' to postgresql-simple's 'SqlError', and +-- some IrrecoverableHpgsqlError errors with a PostgresError behind them +-- as well. +postgresErrorToSqlError :: SomeException -> Maybe SqlError +postgresErrorToSqlError e + | Just (sqlEx :: PostgresError) <- fromException e = Just $ mkSqlError sqlEx + | Just IrrecoverableHpgsqlError {innerException} <- fromException e = + case fromException <$> innerException of + Just (Just (sqlEx :: PostgresError)) -> Just $ mkSqlError sqlEx + _ -> Nothing + | otherwise = Nothing + where + mkSqlError PostgresError {pgErrorDetails, failedStatement} = + let lookupDetail key = maybe "" LBS.toStrict (Map.lookup key pgErrorDetails) + in SqlError + { sqlState = lookupDetail ErrorCode, + sqlExecStatus = FatalError, -- TODO: lookupDetail ErrorSeverity, + sqlErrorMsg = lookupDetail ErrorHumanReadableMsg, + sqlErrorDetail = lookupDetail ErrorDetail, + sqlErrorHint = lookupDetail ErrorHint, + sqlStatement = failedStatement + } + +-- | Wraps an IO action to rethrow Hpgsql's 'PostgresError' as postgresql-simple's 'SqlError'. +mapHpgsqlErrors :: IO a -> IO a +mapHpgsqlErrors = handleJust postgresErrorToSqlError throwIO + +-- | A version of 'execute' that does not perform query substitution. +execute_ :: Connection -> Query -> IO Int64 +execute_ conn (Query stmt) = + mapHpgsqlErrors $ + Hpgsql.execute (hpgConn conn) (fromString $ T.unpack $ TE.decodeUtf8 stmt) + +disconnectedError :: SqlError +disconnectedError = fatalError "connection disconnected" + +close :: Connection -> IO () +close Connection {..} = mapHpgsqlErrors $ Hpgsql.Connection.closeGracefully hpgConn + +newTempName :: Connection -> IO Query +newTempName Connection {..} = do + !n <- + atomicModifyIORef + connectionTempNameCounter + (\n -> let !n' = n + 1 in (n', n')) + return $! Query $ B8.pack $ "temp" ++ show n + +-- FIXME? What error should getNotification and getCopyData throw? +fdError :: ByteString -> IOError +fdError funcName = + IOError + { ioe_handle = Nothing, + ioe_type = ResourceVanished, + ioe_location = B8.unpack funcName, + ioe_description = "failed to fetch file descriptor", + ioe_errno = Nothing, + ioe_filename = Nothing + } + +libPQError :: ByteString -> IOError +libPQError desc = + IOError + { ioe_handle = Nothing, + ioe_type = OtherError, + ioe_location = "libpq", + ioe_description = B8.unpack desc, + ioe_errno = Nothing, + ioe_filename = Nothing + } + +fmtError :: String -> Query -> a +fmtError msg q = + throw + FormatError + { fmtMessage = msg, + fmtQuery = q, + fmtParams = [] + } + +fmtErrorBs :: Query -> [Action] -> ByteString -> a +fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs diff --git a/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs @@ -0,0 +1,12 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +module Database.PostgreSQL.Simple.Internal.PQResultUtils () where diff --git a/src/Database/PostgreSQL/Simple/Newtypes.hs b/src/Database/PostgreSQL/Simple/Newtypes.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Newtypes.hs @@ -0,0 +1,9 @@ +-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone. +-- +-- The newtypes are named after packages they wrap. +module Database.PostgreSQL.Simple.Newtypes + ( Aeson (..), + ) +where + +import Hpgsql.Types (Aeson (..)) diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- | +-- Module : Database.PostgreSQL.Simple.Notification +-- Copyright : (c) 2011-2015 Leon P Smith +-- (c) 2012 Joey Adams +-- License : BSD3 +-- +-- Maintainer : leon@melding-monads.com +-- Stability : experimental +-- +-- Support for receiving asynchronous notifications via PostgreSQL's +-- Listen/Notify mechanism. See +-- for more +-- information. +-- +-- Note that on Windows, @getNotification@ currently uses a polling loop +-- of 1 second to check for more notifications, due to some inadequacies +-- in GHC's IO implementation and interface on that platform. See GHC +-- issue #7353 for more information. While this workaround is less than +-- ideal, notifications are still better than polling the database directly. +-- Notifications do not create any extra work for the backend, and are +-- likely cheaper on the client side as well. +-- +-- +module Database.PostgreSQL.Simple.Notification + ( Notification (..), + getNotification, + getNotificationNonBlocking, + getBackendPID, + ) +where + +import qualified Data.ByteString as B +import Data.Text.Encoding (encodeUtf8) +import Database.PostgreSQL.Simple.Internal +import qualified Hpgsql.Connection +import qualified Hpgsql.Notification +import System.Posix.Types (CPid) + +data Notification = Notification + { notificationPid :: {-# UNPACK #-} !CPid, + notificationChannel :: {-# UNPACK #-} !B.ByteString, + notificationData :: {-# UNPACK #-} !B.ByteString + } + deriving (Show, Eq) + +-- | Returns a single notification. If no notifications are available, +-- 'getNotification' blocks until one arrives. +-- +-- It is safe to call 'getNotification' on a connection that is concurrently +-- being used for other purposes, note however that PostgreSQL does not +-- deliver notifications while a connection is inside a transaction. +getNotification :: Connection -> IO Notification +getNotification conn = fromHpgsqlNotification <$> Hpgsql.Notification.getNotification (hpgConn conn) + +-- | Non-blocking variant of 'getNotification'. Returns a single notification, +-- if available. If no notifications are available, returns 'Nothing'. +getNotificationNonBlocking :: Connection -> IO (Maybe Notification) +getNotificationNonBlocking conn = fmap fromHpgsqlNotification <$> Hpgsql.Notification.getNotificationNonBlocking (hpgConn conn) + +fromHpgsqlNotification :: Hpgsql.Notification.NotificationResponse -> Notification +fromHpgsqlNotification Hpgsql.Notification.NotificationResponse {..} = + Notification + { notificationPid = fromIntegral notifierPid, + notificationChannel = encodeUtf8 channelName, + notificationData = encodeUtf8 notifPayload + } + +-- | Returns the process 'CPid' of the backend server process +-- handling this connection. +-- +-- The backend PID is useful for debugging purposes and for comparison +-- to NOTIFY messages (which include the PID of the notifying backend +-- process). Note that the PID belongs to a process executing on the +-- database server host, not the local host! +getBackendPID :: Connection -> IO CPid +getBackendPID conn = pure $ fromIntegral $ Hpgsql.Connection.getBackendPid (hpgConn conn) diff --git a/src/Database/PostgreSQL/Simple/Ok.hs b/src/Database/PostgreSQL/Simple/Ok.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Ok.hs @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module : Database.PostgreSQL.Simple.Ok +-- Copyright : (c) 2012-2015 Leon P Smith +-- License : BSD3 +-- +-- Maintainer : leon@melding-monads.com +-- Stability : experimental +-- +-- The 'Ok' type is a simple error handler, basically equivalent to +-- @Either [SomeException]@. This type (without the list) was used to +-- handle conversion errors in early versions of hpgsql-simple-compat. +-- +-- One of the primary reasons why this type was introduced is that +-- @Either SomeException@ had not been provided an instance for 'Alternative', +-- and it would have been a bad idea to provide an orphaned instance for a +-- commonly-used type and typeclass included in @base@. +-- +-- Extending the failure case to a list of 'SomeException's enables a +-- more sensible 'Alternative' instance definitions: '<|>' concatenates +-- the list of exceptions when both cases fail, and 'empty' is defined as +-- 'Errors []'. Though '<|>' one could pick one of two exceptions, and +-- throw away the other, and have 'empty' provide a generic exception, +-- this avoids cases where 'empty' overrides a more informative exception +-- and allows you to see all the different ways your computation has failed. +module Database.PostgreSQL.Simple.Ok where + +import Control.Applicative +import Control.Exception +import Control.Monad (MonadPlus (..)) +import Data.Typeable + +import qualified Control.Monad.Fail as Fail + +-- FIXME: [SomeException] should probably be something else, maybe +-- a difference list (or a tree?) + +data Ok a = Errors [SomeException] | Ok !a + deriving (Show, Typeable, Functor) + +-- | Two 'Errors' cases are considered equal, regardless of what the +-- list of exceptions looks like. +instance (Eq a) => Eq (Ok a) where + Errors _ == Errors _ = True + Ok a == Ok b = a == b + _ == _ = False + +instance Applicative Ok where + pure = Ok + + Errors es <*> _ = Errors es + _ <*> Errors es = Errors es + Ok f <*> Ok a = Ok (f a) + +instance Alternative Ok where + empty = Errors [] + + a@(Ok _) <|> _ = a + Errors _ <|> b@(Ok _) = b + Errors as <|> Errors bs = Errors (as ++ bs) + +instance MonadPlus Ok where + mzero = empty + mplus = (<|>) + +instance Monad Ok where + Errors es >>= _ = Errors es + Ok a >>= f = f a + +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + +instance Fail.MonadFail Ok where + fail str = Errors [SomeException (ErrorCall str)] + +-- | a way to reify a list of exceptions into a single exception +newtype ManyErrors = ManyErrors [SomeException] + deriving (Show, Typeable) + +instance Exception ManyErrors diff --git a/src/Database/PostgreSQL/Simple/Range.hs b/src/Database/PostgreSQL/Simple/Range.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Range.hs @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Range +-- Copyright: (c) 2014-2015 Leonid Onokhov +-- (c) 2014-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +module Database.PostgreSQL.Simple.Range + ( RangeBound (..), + PGRange (..), + empty, + isEmpty, + isEmptyBy, + contains, + containsBy, + ) +where + +import Data.Typeable (Typeable) + +-- | Represents boundary of a range +data RangeBound a + = NegInfinity + | Inclusive !a + | Exclusive !a + | PosInfinity + deriving (Show, Typeable, Eq, Functor) + +-- | Generic range type +data PGRange a = PGRange !(RangeBound a) !(RangeBound a) + deriving (Show, Typeable, Functor) + +empty :: PGRange a +empty = PGRange PosInfinity NegInfinity + +instance (Ord a) => Eq (PGRange a) where + x == y = eq x y || (isEmpty x && isEmpty y) + where + eq (PGRange a m) (PGRange b n) = a == b && m == n + +isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool +isEmptyBy cmp v = + case v of + (PGRange PosInfinity _) -> True + (PGRange _ NegInfinity) -> True + (PGRange NegInfinity _) -> False + (PGRange _ PosInfinity) -> False + (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT + (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT + (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT + (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT + +-- | Is a range empty? If this returns 'True', then the 'contains' +-- predicate will always return 'False'. However, if this returns +-- 'False', it is not necessarily true that there exists a point for +-- which 'contains' returns 'True'. +-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@, +-- for example. +isEmpty :: (Ord a) => PGRange a -> Bool +isEmpty = isEmptyBy compare + +-- | Does a range contain a given point? Note that in some cases, this may +-- not correspond exactly with a server-side computation. Consider @UTCTime@ +-- for example, which has a resolution of a picosecond, whereas postgresql's +-- @timestamptz@ types have a resolution of a microsecond. Putting such +-- Haskell values into the database will result in them being rounded, which +-- can change the value of the containment predicate. +contains :: (Ord a) => PGRange a -> (a -> Bool) +contains = containsBy compare + +containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool) +containsBy cmp rng x = + case rng of + PGRange _lb NegInfinity -> False + PGRange lb ub -> checkLB lb x && checkUB ub x + where + checkLB lb y = + case lb of + NegInfinity -> True + PosInfinity -> False + Inclusive a -> cmp a y /= GT + Exclusive a -> cmp a y == LT + + checkUB ub y = + case ub of + NegInfinity -> False + PosInfinity -> True + Inclusive z -> cmp y z /= GT + Exclusive z -> cmp y z == LT diff --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.SqlQQ +-- Copyright: (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +module Database.PostgreSQL.Simple.SqlQQ (sql) where + +import Data.Char +import Data.String +import Database.PostgreSQL.Simple.Types (Query) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +-- | 'sql' is a quasiquoter that eases the syntactic burden +-- of writing big sql statements in Haskell source code. For example: +-- +-- > {-# LANGUAGE QuasiQuotes #-} +-- > +-- > query conn [sql| SELECT column_a, column_b +-- > FROM table1 NATURAL JOIN table2 +-- > WHERE ? <= time AND time < ? +-- > AND name LIKE ? +-- > ORDER BY size DESC +-- > LIMIT 100 |] +-- > (beginTime,endTime,string) +-- +-- This quasiquoter returns a literal string expression of type 'Query', +-- and attempts to minimize whitespace; otherwise the above query would +-- consist of approximately half whitespace when sent to the database +-- backend. It also recognizes and strips out standard sql comments "--". +-- +-- The implementation of the whitespace reducer is currently incomplete. +-- Thus it can mess up your syntax in cases where whitespace should be +-- preserved as-is. It does preserve whitespace inside standard SQL string +-- literals. But it can get confused by the non-standard PostgreSQL string +-- literal syntax (which is the default setting in PostgreSQL 8 and below), +-- the extended escape string syntax, quoted identifiers, and other similar +-- constructs. +-- +-- Of course, this caveat only applies to text written inside the SQL +-- quasiquoter; whitespace reduction is a compile-time computation and +-- thus will not touch the @string@ parameter above, which is a run-time +-- value. +-- +-- Also note that this will not work if the substring @|]@ is contained +-- in the query. +sql :: QuasiQuoter +sql = + QuasiQuoter + { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context", + quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context", + quoteExp = sqlExp, + quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context" + } + +sqlExp :: String -> Q Exp +sqlExp = appE [|fromString :: String -> Query|] . stringE . minimizeSpace + +minimizeSpace :: String -> String +minimizeSpace = drop 1 . reduceSpace + where + needsReduced [] = False + needsReduced ('-' : '-' : _) = True + needsReduced (x : _) = isSpace x + + reduceSpace xs = + case dropWhile isSpace xs of + [] -> [] + ('-' : '-' : ys) -> reduceSpace (dropWhile (/= '\n') ys) + ys -> ' ' : insql ys + + insql ('\'' : xs) = '\'' : instring xs + insql xs | needsReduced xs = reduceSpace xs + insql (x : xs) = x : insql xs + insql [] = [] + + instring ('\'' : '\'' : xs) = '\'' : '\'' : instring xs + instring ('\'' : xs) = '\'' : insql xs + instring (x : xs) = x : instring xs + instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated" diff --git a/src/Database/PostgreSQL/Simple/Time.hs b/src/Database/PostgreSQL/Simple/Time.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time.hs @@ -0,0 +1,245 @@ +-- | +-- Module: Database.PostgreSQL.Simple.Time +-- Copyright: (c) 2012-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- This module provides time types that supports positive and negative +-- infinity, as well as some functions for converting to and from strings. +-- +-- Also, this module also contains commentary regarding postgresql's timestamp +-- types, civil timekeeping in general, and how it relates to +-- hpgsql-simple-compat. You can read more about PostgreSQL's date and time types +-- at , +-- and the IANA time zone database at . +-- +-- Stack Overflow also has some excellent commentary on time, if it is a +-- wiki page or a highly upvoted question and answer. If the answer regarding +-- time has not received about a hundred upvotes at least, then the answer is +-- almost invariably completely and painfully wrong, even if it's the chosen +-- answer or the most highly upvoted answer to a question. +-- +-- PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be +-- converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types, +-- because values of these types represent a self-contained, unambiguous point +-- in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@) +-- can be converted to Haskell's 'Data.Time.LocalTime', because values of these +-- types are ambiguous by themselves, and require context to disambiguate. +-- +-- While this behavior may be superficially counterintuitive because the +-- names might suggest otherwise, this behavior is correct. In fact, +-- the \"timezone\" language in both the postgresql and haskell types would +-- be better read as \"offset (from UTC)\", thus we have postgresql's +-- \"timestamp with offset\" corresponding to Haskell's \"time with the +-- offset \'zero\'\" and Haskell's \"time with an offset (that might be +-- nonzero)\". Similarly, postgresql's \"timestamp without an offset\" +-- corresponds to Haskell's \"local time (without an offset)\". +-- +-- It's important to distinguish between an offset, a standard time, and +-- a time zone. An offset is simply a difference of a local time from UTC, +-- such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset +-- (which may vary throughout the year, due to daylight savings) that a +-- region follows, such as Universal Coordinated Time (UTC), Eastern Standard +-- Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST). +-- And a time zone, much like a standard time, is a function from +-- timestamps to offsets. +-- +-- A time zone is different from a standard time because different regions +-- inside a standard time can be governed by different civil authorities with +-- different laws and thus have different histories of civil time. An IANA +-- time zone is any region of the world that has had the same history of +-- civil time since @1970-01-01 00:00+00@. +-- +-- For example, as of today, both @America\/New_York@ and +-- @America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but +-- Indiana used to be on Central Standard Time until 1942, and did not observe +-- daylight savings time (EST only) until 2006. Thus, the choice between +-- these two time zones still matters if you are dealing with timestamps +-- prior to 2006, and could become relevant again if (most of) Indiana +-- moves back to Central Time. (Of course, if the Central to Eastern switch +-- was the only difference, then these two time zones would be the same in +-- IANA's eyes, due to their cutoff date of 1970-01-01.) +-- +-- Getting back to practicalities, PostgreSQL's @timestamptz@ type does not +-- actually store an offset; rather, it uses the offset provided to calculate +-- UTC, and stores the timestamp as UTC. If an offset is not provided, the +-- given timestamp is assumed to be a local time for whatever the @timezone@ +-- variable is set to, and the IANA TZ database is consulted to calculate an +-- offset from UTC for the time in question. +-- +-- Note that while most (local timestamp, time zone) pairs correspond to exactly +-- one UTC timestamp, some correspond to two UTC timestamps, while others +-- correspond to none at all. The ambiguous case occurs when the civil time +-- is rolled back, making a calendar day longer than 24 hours. In this case, +-- PostgreSQL silently chooses the second, later possibility. The inconsistent +-- case occurs when the civil time is moved forward, making a calendar day less +-- than 24 hours. In this case, PostgreSQL silently assumes the local time +-- was read off a clock that had not been moved forward at the prescribed time, +-- and moves the clock forward for you. Thus, converting from local time +-- to UTC need not be monotonic, if these inconsistent cases are allowed. +-- +-- When retrieving a @timestamptz@, the backend looks at the @time zone@ +-- connection variable and then consults the IANA TZ database to calculate +-- an offset for the timestamp in the given time zone. +-- +-- Note that while some of the information contained in the IANA TZ database +-- is a bit of a standardized fiction, the conversion from UTC time to a +-- (local time, offset) pair in a particular time zone is always unambiguous, +-- and the result can always be unambiguously converted back to UTC. Thus, +-- hpgsql-simple-compat can interpret such a result as a 'Data.Time.ZonedTime', +-- or use the offset to convert back to 'Data.Time.UTCTime'. +-- +-- By contrast, the @timestamp@ type ignores any offsets provided to it, +-- and never sends back an offset. Thus, hpgsql-simple-compat equates this +-- with 'Data.Time.LocalTime', which has no concept of an offset. One can +-- convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@ +-- operator, whose semantics also demonstrates that @timestamptz@ is +-- 'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'. +-- +-- PostgreSQL's @timezone@ is a per-connection variable that by default is +-- initialized to @\'localtime\'@, which normally corresponds to the server's +-- time zone. However, this default can be modified on the server side for an +-- entire cluster, or on a per-user or per-database basis. Moreover, a client +-- can modify their instance of the variable at any time, and can apply that +-- change to the remaining duration of the connection, the current transaction, +-- or the execution context of a server-side function. In addition, upon +-- connection initialization, the libpq client checks for the existence of +-- the @PGTZ@ environment variable, and if it exists, modifies @timezone@ +-- accordingly. +-- +-- With a few caveats, hpgsql-simple-compat is designed so that you can both send +-- and receive timestamps with the server and get a correct result, no matter +-- what the @timezone@ setting is. But it is important to understand the caveats: +-- +-- 1. The correctness of server-side computations can depend on the @timezone@ +-- setting. Examples include adding an @interval@ to a @timestamptz@, or +-- type casting between @timestamp@ and @timestamptz@, or applying +-- the @DATE@ function to a @timestamptz@. +-- +-- 2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result +-- will depend on the @timezone@ setting, although the result will always +-- represent the same instant in time regardless of the time zone. +-- +-- 3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@ +-- can be useful, as it will be converted to UTC via the tz database, +-- but correctness will depend on the @timezone@ setting. You may prefer +-- to use an explicit @AT TIME ZONE@ conversion instead, which would avoid +-- this contextual dependence. +-- +-- Furthermore, although these following points don't involve the @timezone@ +-- setting, they are related to the last point above: +-- +-- 1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can +-- be useful. In practice, the most common context used to disambiguate +-- @timestamp@ is that it represents UTC, and this coding technique will +-- work as expected in this situation. +-- +-- 2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is +-- almost always the wrong thing to do, as the offset will be ignored and +-- discarded. This is likely to lead to inconsistencies in the database, +-- and may lead to partial data loss. +-- +-- When dealing with local timestamps that refer to the future, it is often +-- useful to store it as a local time in a @timestamp@ column and store the +-- time zone in a second column. One reason to do this is so that you can +-- convert to UTC on the fly as needed, and be protected against future changes +-- to the TZ database due to changes in local time standards. In any case, +-- 'Data.Time.ZonedTime' is not suitable for this application, because despite +-- its name, it represents an offset and not a time zone. Time zones can change; +-- offsets do not. In reality, we can't convert a local timestamp that occurs +-- sufficiently far in the future to UTC, because we don't know how to do it yet. +-- +-- There are a few limitations and caveats that one might need to be aware +-- of with the current implementation when dealing with older timestamps: +-- +-- For sufficiently old timestamps in almost all time zones, the IANA TZ +-- database specifies offsets from UTC that is not an integral number of +-- minutes. This corresponds to local mean time; that is, astronomical +-- time in the city that defines the time zone. Different time zones moved +-- away from local mean time to a standard time at different points in +-- history, so \"sufficiently old\" depends on the time zone in question. +-- +-- Thus, when retrieving a @timestamptz@ postgresql will in some cases +-- provide seconds in the offset. For example: +-- +-- @ +-- \$ psql +-- psql (9.4.5) +-- Type \"help\" for help. +-- +-- lpsmith=> SET timezone TO \'America/New_York\'; +-- SET +-- lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz), +-- (\'1883-11-18 17:00:00+00\'::timestamptz); +-- column1 +-- ------------------------------ +-- 1883-11-18 12:03:57-04:56:02 +-- 1883-11-18 12:00:00-05 +-- (2 rows) +-- @ +-- +-- Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type, +-- however 'Data.Time.ZonedTime' will fail on the former timestamp. +-- Because 'Data.Time.ZonedTime' assumes that offsets are an integer number +-- of minutes, there isn't an particularly good solution here. +-- +-- PostgreSQL, like most software, uses the proleptic Gregorian calendar +-- for its date calculations, extending the Gregorian calendar backwards +-- in time before its introduction and pretending that the Julian calendar +-- does not exist. For most purposes, the adoption of the Gregorian calendar +-- ranges from @1582-10-15@ to @1923-03-01@, depending on location and +-- sometimes even political allegiances within a single location. +-- +-- Timestamps BCE are not supported. For example, PostgreSQL +-- will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of +-- the year the Roman Empire adopted the Julian Calendar, but +-- hpgsql-simple-compat does not (yet?) have the ability to either parse or +-- generate this syntax. Unfortunately this syntax isn't convenient to +-- print or especially parse. +-- +-- Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@, +-- which is the Julian date on the proleptic Gregorian Calendar. Although +-- postgresql's timestamp types are perfectly capable of representing timestamps +-- nearly 300,000 years in the past, using this would require hpgsql-simple-compat +-- and other client programs to support binary parameters and results. +-- +-- Dealing with years BCE is also complicated slightly by the fact that +-- Haskell's time library has a year \"0000\", which is a convention often +-- used by astronomers, while postgresql adopts the more historically +-- accurate convention that there is no year zero, but rather \"1 BCE\" +-- was immediately followed by \"1 CE\". +module Database.PostgreSQL.Simple.Time + ( Unbounded (..), + Date, + UTCTimestamp, + ZonedTimestamp, + LocalTimestamp, + parseDay, + parseUTCTime, + parseZonedTime, + parseLocalTime, + parseTimeOfDay, + parseDate, + parseUTCTimestamp, + parseZonedTimestamp, + parseLocalTimestamp, + parseCalendarDiffTime, + dayToBuilder, + utcTimeToBuilder, + zonedTimeToBuilder, + localTimeToBuilder, + timeOfDayToBuilder, + timeZoneToBuilder, + dateToBuilder, + utcTimestampToBuilder, + zonedTimestampToBuilder, + localTimestampToBuilder, + unboundedToBuilder, + nominalDiffTimeToBuilder, + calendarDiffTimeToBuilder, + ) +where + +import Database.PostgreSQL.Simple.Time.Implementation +import Hpgsql.Time (Unbounded (..)) diff --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +------------------------------------------------------------------------------ +------------------------------------------------------------------------------ +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Time.Implementation +-- Copyright: (c) 2012-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +module Database.PostgreSQL.Simple.Time.Implementation where + +import Control.Applicative +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString as B +import Data.ByteString.Builder (Builder, byteString) +import Data.ByteString.Builder.Prim (primBounded) +import Data.Maybe (fromMaybe) +import Data.Time.Compat (Day, LocalTime, NominalDiffTime, TimeOfDay, TimeZone, UTCTime, ZonedTime, utc) +import Data.Time.LocalTime.Compat (CalendarDiffTime) +import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP +import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP +import Hpgsql.Time (Unbounded (..)) +import Prelude hiding (take) + +type LocalTimestamp = Unbounded LocalTime + +type UTCTimestamp = Unbounded UTCTime + +type ZonedTimestamp = Unbounded ZonedTime + +type Date = Unbounded Day + +parseUTCTime :: B.ByteString -> Either String UTCTime +parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) + +parseZonedTime :: B.ByteString -> Either String ZonedTime +parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput) + +parseLocalTime :: B.ByteString -> Either String LocalTime +parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput) + +parseDay :: B.ByteString -> Either String Day +parseDay = A.parseOnly (getDay <* A.endOfInput) + +parseTimeOfDay :: B.ByteString -> Either String TimeOfDay +parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput) + +parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp +parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput) + +parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp +parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput) + +parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp +parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput) + +parseDate :: B.ByteString -> Either String Date +parseDate = A.parseOnly (getDate <* A.endOfInput) + +parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime +parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput) + +getUnbounded :: A.Parser a -> A.Parser (Unbounded a) +getUnbounded getFinite = + (pure NegInfinity <* A.string "-infinity") + <|> (pure PosInfinity <* A.string "infinity") + <|> (Finite <$> getFinite) + +getDay :: A.Parser Day +getDay = TP.day + +getDate :: A.Parser Date +getDate = getUnbounded getDay + +getTimeOfDay :: A.Parser TimeOfDay +getTimeOfDay = TP.timeOfDay + +getLocalTime :: A.Parser LocalTime +getLocalTime = TP.localTime + +getLocalTimestamp :: A.Parser LocalTimestamp +getLocalTimestamp = getUnbounded getLocalTime + +getTimeZone :: A.Parser TimeZone +getTimeZone = fromMaybe utc <$> TP.timeZone + +type TimeZoneHMS = (Int, Int, Int) + +getTimeZoneHMS :: A.Parser TimeZoneHMS +getTimeZoneHMS = munge <$> TP.timeZoneHMS + where + munge Nothing = (0, 0, 0) + munge (Just (TP.UTCOffsetHMS h m s)) = (h, m, s) + +localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay) +localToUTCTimeOfDayHMS (dh, dm, ds) tod = + TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod + +getZonedTime :: A.Parser ZonedTime +getZonedTime = TP.zonedTime + +getZonedTimestamp :: A.Parser ZonedTimestamp +getZonedTimestamp = getUnbounded getZonedTime + +getUTCTime :: A.Parser UTCTime +getUTCTime = TP.utcTime + +getUTCTimestamp :: A.Parser UTCTimestamp +getUTCTimestamp = getUnbounded getUTCTime + +getCalendarDiffTime :: A.Parser CalendarDiffTime +getCalendarDiffTime = TP.calendarDiffTime + +dayToBuilder :: Day -> Builder +dayToBuilder = primBounded TPP.day + +timeOfDayToBuilder :: TimeOfDay -> Builder +timeOfDayToBuilder = primBounded TPP.timeOfDay + +timeZoneToBuilder :: TimeZone -> Builder +timeZoneToBuilder = primBounded TPP.timeZone + +utcTimeToBuilder :: UTCTime -> Builder +utcTimeToBuilder = primBounded TPP.utcTime + +zonedTimeToBuilder :: ZonedTime -> Builder +zonedTimeToBuilder = primBounded TPP.zonedTime + +localTimeToBuilder :: LocalTime -> Builder +localTimeToBuilder = primBounded TPP.localTime + +unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) +unboundedToBuilder finiteToBuilder unbounded = + case unbounded of + NegInfinity -> byteString "-infinity" + Finite a -> finiteToBuilder a + PosInfinity -> byteString "infinity" + +utcTimestampToBuilder :: UTCTimestamp -> Builder +utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder + +zonedTimestampToBuilder :: ZonedTimestamp -> Builder +zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder + +localTimestampToBuilder :: LocalTimestamp -> Builder +localTimestampToBuilder = unboundedToBuilder localTimeToBuilder + +dateToBuilder :: Date -> Builder +dateToBuilder = unboundedToBuilder dayToBuilder + +nominalDiffTimeToBuilder :: NominalDiffTime -> Builder +nominalDiffTimeToBuilder = TPP.nominalDiffTime + +calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder +calendarDiffTimeToBuilder = TPP.calendarDiffTime diff --git a/src/Database/PostgreSQL/Simple/Time/Internal.hs b/src/Database/PostgreSQL/Simple/Time/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal.hs @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Time.Internal +-- Copyright: (c) 2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +module Database.PostgreSQL.Simple.Time.Internal + ( getDay, + getDate, + getTimeOfDay, + getLocalTime, + getLocalTimestamp, + getTimeZone, + getZonedTime, + getZonedTimestamp, + getUTCTime, + getUTCTimestamp, + TimeZoneHMS, + getTimeZoneHMS, + localToUTCTimeOfDayHMS, + ) where + +import Database.PostgreSQL.Simple.Time.Implementation diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs @@ -0,0 +1,210 @@ +-- | +-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser +-- Copyright: (c) 2012-2015 Leon P Smith +-- (c) 2015 Bryan O'Sullivan +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Parsers for parsing dates and times. +module Database.PostgreSQL.Simple.Time.Internal.Parser + ( day, + localTime, + timeOfDay, + timeZone, + UTCOffsetHMS (..), + timeZoneHMS, + localToUTCTimeOfDayHMS, + utcTime, + zonedTime, + calendarDiffTime, + ) +where + +import Data.Attoparsec.ByteString.Char8 as A +import Data.Bits ((.&.)) +import qualified Data.ByteString.Char8 as B8 +import Data.Char (ord) +import Data.Fixed (Pico) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar.Compat (Day, addDays, fromGregorianValid) +import Data.Time.Clock.Compat (UTCTime (..)) +import Data.Time.Format.ISO8601.Compat (iso8601ParseM) +import Data.Time.LocalTime.Compat (CalendarDiffTime) +import qualified Data.Time.LocalTime.Compat as Local +import Database.PostgreSQL.Simple.Compat (toPico) + +-- | Parse a date of the form @YYYY-MM-DD@. +day :: Parser Day +day = do + y <- decimal <* char '-' + m <- twoDigits <* char '-' + d <- twoDigits + maybe (fail "invalid date") return (fromGregorianValid y m d) + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: Parser Int +twoDigits = do + a <- digit + b <- digit + let c2d c = ord c .&. 15 + return $! c2d a * 10 + c2d b + +-- | Parse a time of the form @HH:MM[:SS[.SSS]]@. +timeOfDay :: Parser Local.TimeOfDay +timeOfDay = do + h <- twoDigits <* char ':' + m <- twoDigits + mc <- peekChar + s <- case mc of + Just ':' -> anyChar *> seconds + _ -> return 0 + if h < 24 && m < 60 && s <= 60 + then return (Local.TimeOfDay h m s) + else fail "invalid time" + +-- | Parse a count of seconds, with the integer part being two digits +-- long. +seconds :: Parser Pico +seconds = do + real <- twoDigits + mc <- peekChar + case mc of + Just '.' -> do + t <- anyChar *> takeWhile1 isDigit + return $! parsePicos (fromIntegral real) t + _ -> return $! fromIntegral real + where + parsePicos :: Int64 -> B8.ByteString -> Pico + parsePicos a0 t = toPico (fromIntegral (t' * 10 ^ n)) + where + n = max 0 (12 - B8.length t) + t' = + B8.foldl' + (\a c -> 10 * a + fromIntegral (ord c .&. 15)) + a0 + (B8.take 12 t) + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZone :: Parser (Maybe Local.TimeZone) +timeZone = do + ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + mm <- peekChar + m <- case mm of + Just ':' -> anyChar *> twoDigits + _ -> return 0 + let off + | ch == '-' = negate off0 + | otherwise = off0 + off0 = h * 60 + m + case undefined of + _ + | off == 0 -> + return Nothing + | h > 23 || m > 59 -> + fail "invalid time zone offset" + | otherwise -> + let !tz = Local.minutesToTimeZone off + in return (Just tz) + +data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZoneHMS :: Parser (Maybe UTCOffsetHMS) +timeZoneHMS = do + ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + m <- maybeTwoDigits + s <- maybeTwoDigits + case undefined of + _ + | h == 0 && m == 0 && s == 0 -> + return Nothing + | h > 23 || m >= 60 || s >= 60 -> + fail "invalid time zone offset" + | otherwise -> + if ch == '+' + then + let !tz = UTCOffsetHMS h m s + in return (Just tz) + else + let !tz = UTCOffsetHMS (-h) (-m) (-s) + in return (Just tz) + where + maybeTwoDigits = do + ch <- peekChar + case ch of + Just ':' -> anyChar *> twoDigits + _ -> return 0 + +localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay) +localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) = + (\ !a !b -> (a, b)) dday (Local.TimeOfDay h'' m'' s'') + where + s' = s - fromIntegral ds + (!s'', m') + | s' < 0 = (s' + 60, m - dm - 1) + | s' >= 60 = (s' - 60, m - dm + 1) + | otherwise = (s', m - dm) + (!m'', h') + | m' < 0 = (m' + 60, h - dh - 1) + | m' >= 60 = (m' - 60, h - dh + 1) + | otherwise = (m', h - dh) + (!h'', dday) + | h' < 0 = (h' + 24, -1) + | h' >= 24 = (h' - 24, 1) + | otherwise = (h', 0) + +-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. +-- The space may be replaced with a @T@. The number of seconds may be +-- followed by a fractional component. +localTime :: Parser Local.LocalTime +localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay + where + daySep = satisfy (\c -> c == ' ' || c == 'T') + +-- | Behaves as 'zonedTime', but converts any time zone offset into a +-- UTC time. +utcTime :: Parser UTCTime +utcTime = do + (Local.LocalTime d t) <- localTime + mtz <- timeZoneHMS + case mtz of + Nothing -> + let !tt = Local.timeOfDayToTime t + in return (UTCTime d tt) + Just tz -> + let !(dd, t') = localToUTCTimeOfDayHMS tz t + !d' = addDays dd d + !tt = Local.timeOfDayToTime t' + in return (UTCTime d' tt) + +-- | Parse a date with time zone info. Acceptable formats: +-- +-- @YYYY-MM-DD HH:MM:SS Z@ +-- +-- The first space may instead be a @T@, and the second space is +-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a +-- time zone offset of the form @+0000@ or @-08:00@, where the first +-- two digits are hours, the @:@ is optional and the second two digits +-- (also optional) are minutes. +zonedTime :: Parser Local.ZonedTime +zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) + +utc :: Local.TimeZone +utc = Local.TimeZone 0 False "" + +calendarDiffTime :: Parser CalendarDiffTime +calendarDiffTime = do + contents <- takeByteString + iso8601ParseM $ B8.unpack contents diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer +-- Copyright: (c) 2012-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Time.Internal.Printer + ( day, + timeOfDay, + timeZone, + utcTime, + localTime, + zonedTime, + nominalDiffTime, + calendarDiffTime, + ) +where + +import Control.Arrow ((>>>)) +import Data.ByteString.Builder (Builder, byteString, integerDec) +import Data.ByteString.Builder.Prim + ( BoundedPrim, + FixedPrim, + char8, + condB, + emptyB, + int32Dec, + liftFixedToBounded, + primBounded, + (>$<), + (>*<), + ) +import Data.Char (chr) +import Data.Int (Int32, Int64) +import Data.String (fromString) +import Data.Time.Compat + ( Day, + LocalTime (..), + NominalDiffTime, + TimeOfDay (..), + TimeZone, + UTCTime (..), + ZonedTime (..), + timeToTimeOfDay, + timeZoneMinutes, + toGregorian, + ) +import Data.Time.Format.ISO8601.Compat (iso8601Show) +import Data.Time.LocalTime.Compat (CalendarDiffTime) +import Database.PostgreSQL.Simple.Compat (fromPico) +import Unsafe.Coerce (unsafeCoerce) + +liftB :: FixedPrim a -> BoundedPrim a +liftB = liftFixedToBounded + +digit :: FixedPrim Int +digit = (\x -> chr (x + 48)) >$< char8 + +digits2 :: FixedPrim Int +digits2 = (`quotRem` 10) >$< (digit >*< digit) + +digits3 :: FixedPrim Int +digits3 = (`quotRem` 10) >$< (digits2 >*< digit) + +digits4 :: FixedPrim Int +digits4 = (`quotRem` 10) >$< (digits3 >*< digit) + +frac :: BoundedPrim Int64 +frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) + where + trunc12 :: BoundedPrim Int64 + trunc12 = + (`quotRem` 1000000) + >$< condB + (\(_, y) -> y == 0) + (fst >$< trunc6) + (liftB digits6 >*< trunc6) + + digitB = liftB digit + + digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit) + digits5 = (`quotRem` 10) >$< (digits4 >*< digit) + + trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5) + trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4)) + trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3)) + trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2)) + trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1)) + trunc1 = condB (== 0) emptyB digitB + +year :: BoundedPrim Int32 +year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4) + where + checkBCE :: Int32 -> Int + checkBCE y + | y > 0 = fromIntegral y + | otherwise = error msg + + msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported" + +day :: BoundedPrim Day +day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2)) + where + toYMD (toGregorian -> (fromIntegral -> !y, !m, !d)) = (y, ('-', (m, ('-', d)))) + +timeOfDay :: BoundedPrim TimeOfDay +timeOfDay = f >$< (hh_mm_ >*< ss) + where + f (TimeOfDay h m s) = ((h, (':', (m, ':'))), s) + + hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8) + + ss = + (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) + >$< (liftB (fromIntegral >$< digits2) >*< frac) + +timeZone :: BoundedPrim TimeZone +timeZone = timeZoneMinutes >$< tz + where + tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh) + + tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm)) + + tzm = condB (== 0) emptyB ((,) ':' >$< liftB (char8 >*< digits2)) + +utcTime :: BoundedPrim UTCTime +utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8) + where + f (UTCTime d (timeToTimeOfDay -> tod)) = (d, (' ', (tod, 'Z'))) + +localTime :: BoundedPrim LocalTime +localTime = f >$< (day >*< liftB char8 >*< timeOfDay) + where + f (LocalTime d tod) = (d, (' ', tod)) + +zonedTime :: BoundedPrim ZonedTime +zonedTime = f >$< (localTime >*< timeZone) + where + f (ZonedTime lt tz) = (lt, tz) + +nominalDiffTime :: NominalDiffTime -> Builder +nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) + where + (x, y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 + +calendarDiffTime :: CalendarDiffTime -> Builder +calendarDiffTime = + byteString + . fromString + -- from the docs: "Beware: fromString truncates multi-byte characters to octets". + -- However, I think this is a safe usage, because ISO8601-encoding seems restricted + -- to ASCII output. + . iso8601Show diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE UndecidableInstances #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.ToField +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- The 'ToField' typeclass, for rendering a parameter to a SQL query. +module Database.PostgreSQL.Simple.ToField + ( Action (..), + ToField (..), + ToPgField (..), + toJSONField, + ) +where + +import qualified Data.Aeson as Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.CaseInsensitive (CI) +import Data.Int (Int16, Int32, Int64) +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import Data.Time.Calendar.Compat (Day) +import Data.Time.Compat (CalendarDiffTime, NominalDiffTime, UTCTime, ZonedTime) +import Data.Time.LocalTime.Compat (LocalTime, TimeOfDay) +import Data.Typeable (Typeable) +import Data.UUID.Types (UUID) +import Data.Vector (Vector) +import Hpgsql.Builder (BinaryField (..)) +import Hpgsql.Encoding (EncodingContext, FieldEncoder (toTypeOid), ToPgField (..)) +import Hpgsql.Query (encodeParam) +import Hpgsql.Time (Unbounded (..)) +import Hpgsql.TypeInfo (Oid) +import Hpgsql.Types (Aeson, PGArray) + +-- | How to render an element when substituting it into a query. +data Action + = QueryArgument (EncodingContext -> (Maybe Oid, BinaryField)) + | -- | Escape before substituting. Use for all sql identifiers like + -- table, column names, etc. This is used by the 'Identifier' newtype + -- wrapper. + EscapeIdentifier ByteString + | -- | Concatenate a series of rendering actions. + Many [Action] + | -- | Just a static SQL fragment to render + Plain LB.ByteString + deriving (Typeable) + +instance Show Action where + show (QueryArgument _) = "QueryArgument" + show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b + show (Many b) = "Many " ++ show b + show (Plain b) = "Plain " ++ show b + +-- | A type that may be used as a single parameter to a SQL query. +class ToField a where + toField :: a -> Action + default toField :: (ToPgField a) => a -> Action + toField v = QueryArgument $ encodeParam v + +instance ToField Action where + toField v = v + +instance ToField Int + +instance ToField Int16 + +instance ToField Int32 + +instance ToField Int64 + +instance ToField Integer + +instance ToField Oid + +instance ToField Scientific + +instance ToField Rational + +instance ToField Float + +instance ToField Double + +instance ToField Bool + +instance ToField Day + +instance ToField CalendarDiffTime + +instance ToField NominalDiffTime + +instance ToField UTCTime + +instance ToField ZonedTime + +instance ToField LocalTime + +instance ToField TimeOfDay + +instance ToField Char + +instance ToField ByteString + +instance ToField LB.ByteString + +instance ToField Text + +instance ToField LT.Text + +instance ToField String + +instance ToField Aeson.Value + +instance ToField UUID + +instance ToField (CI Text) + +instance ToField (CI LT.Text) + +instance ToField (CI String) + +instance ToField (Unbounded Day) + +instance ToField (Unbounded UTCTime) + +instance ToField (Unbounded ZonedTime) + +class HasFieldType a where + fieldTypeOid :: Proxy a -> EncodingContext -> Maybe Oid + +instance (ToPgField a) => HasFieldType a where + fieldTypeOid _ = toTypeOid (fieldEncoder @a) + +instance forall a. (ToField a, HasFieldType a) => ToField (Maybe a) where + toField = \case + Nothing -> QueryArgument $ \encCtx -> (fieldTypeOid (Proxy @a) encCtx, SqlNull) + Just v -> case toField v of + QueryArgument enc -> QueryArgument enc + _ -> error "hpgsql-simple-compat does not support (ToField (Maybe a)) instances that aren't simple query arguments" + +instance (ToPgField a) => ToField (Vector a) + +instance (ToPgField a) => ToField (PGArray a) + +instance (Aeson.ToJSON a) => ToField (Aeson a) + +toJSONField :: (Aeson.ToJSON a) => a -> Action +toJSONField v = QueryArgument $ encodeParam $ Aeson.toJSON v diff --git a/src/Database/PostgreSQL/Simple/ToField.hs-boot b/src/Database/PostgreSQL/Simple/ToField.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToField.hs-boot @@ -0,0 +1,1 @@ +module Database.PostgreSQL.Simple.ToField where diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs b/src/Database/PostgreSQL/Simple/ToRow.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToRow.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE UndecidableInstances #-} + +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.ToRow +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- The 'ToRow' typeclass, for rendering a collection of +-- parameters to a SQL query. +-- +-- Predefined instances are provided for tuples containing up to ten +-- elements. +module Database.PostgreSQL.Simple.ToRow + ( ToRow (..), + ToPgRow (..), + ) +where + +import Data.Functor.Contravariant (Contravariant (..)) +import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) +import GHC.Generics (Generic (..), K1 (..), M1 (..), type (:*:) (..)) +import Hpgsql.Encoding (ToPgRow (..)) +import Hpgsql.Types (Only (..), (:.) (..)) + +-- | A collection type that can be turned into a list of rendering +-- 'Action's. +-- +-- Instances should use the 'toField' method of the 'ToField' class +-- to perform conversion of each element of the collection. +-- +-- You can derive 'ToRow' for your data type using GHC generics, like this: +-- +-- @ +-- \{-# LANGUAGE DeriveAnyClass \#-} +-- \{-# LANGUAGE DeriveGeneric \#-} +-- +-- import "GHC.Generics" ('GHC.Generics.Generic') +-- import "Database.PostgreSQL.Simple" ('ToRow') +-- +-- data User = User { name :: String, fileQuota :: Int } +-- deriving ('GHC.Generics.Generic', 'ToRow') +-- @ +-- +-- Note that this only works for product types (e.g. records) and does not +-- support sum types or recursive types. +class ToRow a where + toRow :: a -> [Action] + default toRow :: (Generic a, ProductTypeEncoder (Rep a)) => a -> [Action] + toRow = toPgParams genericToPgRow + -- ^ ToField a collection of values. + +instance ToRow () where + toRow () = [] + +instance (ToField a) => ToRow (Only a) where + toRow (Only v) = [toField v] + +instance (ToField a, ToField b) => ToRow (a, b) where + toRow (a, b) = [toField a, toField b] + +instance (ToField a, ToField b, ToField c) => ToRow (a, b, c) where + toRow (a, b, c) = [toField a, toField b, toField c] + +instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a, b, c, d) where + toRow (a, b, c, d) = [toField a, toField b, toField c, toField d] + +instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a, b, c, d, e) where + toRow (a, b, c, d, e) = [toField a, toField b, toField c, toField d, toField e] + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a, b, c, d, e, f) where + toRow (a, b, c, d, e, f) = [toField a, toField b, toField c, toField d, toField e, toField f] + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a, b, c, d, e, f, g) where + toRow (a, b, c, d, e, f, g) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g] + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h) => ToRow (a, b, c, d, e, f, g, h) where + toRow (a, b, c, d, e, f, g, h) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h] + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i) => ToRow (a, b, c, d, e, f, g, h, i) where + toRow (a, b, c, d, e, f, g, h, i) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i] + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j) => ToRow (a, b, c, d, e, f, g, h, i, j) where + toRow (a, b, c, d, e, f, g, h, i, j) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j] + +instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k) => ToRow (a, b, c, d, e, f, g, h, i, j, k) where + toRow (a, b, c, d, e, f, g, h, i, j, k) = [toField a, toField b, toField c, toField d, toField e, toField f, toField g, toField h, toField i, toField j, toField k] + +instance (ToField a) => ToRow [a] where + toRow = map toField + +instance (ToRow a, ToRow b) => ToRow (a :. b) where + toRow (a :. b) = toRow a ++ toRow b + +-- | This is a simplified version of hpgsql's RowEncoder; it contains just as much as necessary +-- for this module. +newtype RowEncoder a = RowEncoder {toPgParams :: a -> [Action]} + +instance Contravariant RowEncoder where + contramap f rec = RowEncoder (\v -> (toPgParams rec) (f v)) + +-- | These are from `Divisible`, but we don't currently pull in the extra dependency that has that. +divide :: (a -> (b, c)) -> RowEncoder b -> RowEncoder c -> RowEncoder a +divide d re1 re2 = + RowEncoder + { toPgParams = \a -> let (b, c) = d a in (toPgParams re1) b ++ (toPgParams re2) c + } + +genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a +genericToPgRow = contramap from genRowEncoder + +class ProductTypeEncoder f where + genRowEncoder :: RowEncoder (f a) + +instance (ProductTypeEncoder a, ProductTypeEncoder b) => ProductTypeEncoder (a :*: b) where + genRowEncoder = divide (\(a :*: b) -> (a, b)) genRowEncoder genRowEncoder + +instance (ProductTypeEncoder f) => ProductTypeEncoder (M1 i c f) where + genRowEncoder = contramap unM1 genRowEncoder + +instance (ToField a) => ProductTypeEncoder (K1 r a) where + genRowEncoder = contramap unK1 (RowEncoder $ (: []) . toField) diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs-boot b/src/Database/PostgreSQL/Simple/ToRow.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToRow.hs-boot @@ -0,0 +1,2 @@ + +module Database.PostgreSQL.Simple.ToRow () where diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -0,0 +1,264 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Transaction +-- Copyright: (c) 2011-2013 Leon P Smith +-- (c) 2013 Joey Adams +-- License: BSD3 +-- Maintainer: Leon P Smith +module Database.PostgreSQL.Simple.Transaction + ( -- * Transaction handling + withTransaction, + withTransactionLevel, + withTransactionMode, + withTransactionModeRetry, + withTransactionModeRetry', + withTransactionSerializable, + TransactionMode (..), + IsolationLevel (..), + ReadWriteMode (..), + defaultTransactionMode, + defaultIsolationLevel, + defaultReadWriteMode, + -- , Base.autocommit + begin, + beginLevel, + beginMode, + commit, + rollback, + + -- * Savepoint + withSavepoint, + Savepoint, + newSavepoint, + releaseSavepoint, + rollbackToSavepoint, + rollbackToAndReleaseSavepoint, + + -- * Error predicates + isSerializationError, + isNoActiveTransactionError, + isFailedTransactionError, + ) +where + +import qualified Control.Exception as E +import qualified Data.ByteString as B +import Database.PostgreSQL.Simple.Compat (mask) +import Database.PostgreSQL.Simple.Errors +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Types + +-- | Of the four isolation levels defined by the SQL standard, +-- these are the three levels distinguished by PostgreSQL as of version 9.0. +-- See +-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' +-- was equivalent to 'Serializable'. +data IsolationLevel + = -- | the isolation level will be taken from + -- PostgreSQL's per-connection + -- @default_transaction_isolation@ variable, + -- which is initialized according to the + -- server's config. The default configuration + -- is 'ReadCommitted'. + DefaultIsolationLevel + | ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Eq, Ord, Enum, Bounded) + +data ReadWriteMode + = -- | the read-write mode will be taken from + -- PostgreSQL's per-connection + -- @default_transaction_read_only@ variable, + -- which is initialized according to the + -- server's config. The default configuration + -- is 'ReadWrite'. + DefaultReadWriteMode + | ReadWrite + | ReadOnly + deriving (Show, Eq, Ord, Enum, Bounded) + +data TransactionMode = TransactionMode + { isolationLevel :: !IsolationLevel, + readWriteMode :: !ReadWriteMode + } + deriving (Show, Eq) + +defaultTransactionMode :: TransactionMode +defaultTransactionMode = + TransactionMode + defaultIsolationLevel + defaultReadWriteMode + +defaultIsolationLevel :: IsolationLevel +defaultIsolationLevel = DefaultIsolationLevel + +defaultReadWriteMode :: ReadWriteMode +defaultReadWriteMode = DefaultReadWriteMode + +-- | Execute an action inside a SQL transaction. +-- +-- This function initiates a transaction with a \"@begin +-- transaction@\" statement, then executes the supplied action. If +-- the action succeeds, the transaction will be completed with +-- 'Base.commit' before this function returns. +-- +-- If the action throws /any/ kind of exception (not just a +-- PostgreSQL-related exception), the transaction will be rolled back using +-- 'rollback', then the exception will be rethrown. +-- +-- For nesting transactions, see 'withSavepoint'. +withTransaction :: Connection -> IO a -> IO a +withTransaction = withTransactionMode defaultTransactionMode + +-- | Execute an action inside of a 'Serializable' transaction. If a +-- serialization failure occurs, roll back the transaction and try again. +-- Be warned that this may execute the IO action multiple times. +-- +-- A 'Serializable' transaction creates the illusion that your program has +-- exclusive access to the database. This means that, even in a concurrent +-- setting, you can perform queries in sequence without having to worry about +-- what might happen between one statement and the next. +-- +-- Think of it as STM, but without @retry@. +withTransactionSerializable :: Connection -> IO a -> IO a +withTransactionSerializable = + withTransactionModeRetry + TransactionMode + { isolationLevel = Serializable, + readWriteMode = ReadWrite + } + isSerializationError + +-- | Execute an action inside a SQL transaction with a given isolation level. +withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a +withTransactionLevel lvl = + withTransactionMode defaultTransactionMode {isolationLevel = lvl} + +-- | Execute an action inside a SQL transaction with a given transaction mode. +withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a +withTransactionMode mode conn act = + mask $ \restore -> do + beginMode mode conn + r <- restore act `E.onException` rollback_ conn + commit conn + return r + +-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'. +withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a +withTransactionModeRetry = withTransactionModeRetry' + +-- | Like 'withTransactionMode', but also takes a custom callback to +-- determine if a transaction should be retried if an exception occurs. +-- If the callback returns 'True', then the transaction will be retried. +-- If the callback returns 'False', or an exception other than an @e@ +-- occurs then the transaction will be rolled back and the exception rethrown. +-- +-- This is used to implement 'withTransactionSerializable'. +withTransactionModeRetry' :: forall a e. (E.Exception e) => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a +withTransactionModeRetry' mode shouldRetry conn act = + mask $ \restore -> + retryLoop $ E.try $ do + a <- restore act `E.onException` rollback_ conn + commit conn + return a + where + retryLoop :: IO (Either e a) -> IO a + retryLoop act' = do + beginMode mode conn + r <- act' + case r of + Left e -> + case shouldRetry e of + True -> retryLoop act' + False -> E.throwIO e + Right a -> + return a + +-- | Rollback a transaction. +rollback :: Connection -> IO () +rollback conn = execute_ conn "ROLLBACK" >> return () + +-- | Rollback a transaction, ignoring any @IOErrors@ +rollback_ :: Connection -> IO () +rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return () + +-- | Commit a transaction. +commit :: Connection -> IO () +commit conn = execute_ conn "COMMIT" >> return () + +-- | Begin a transaction. +begin :: Connection -> IO () +begin = beginMode defaultTransactionMode + +-- | Begin a transaction with a given isolation level +beginLevel :: IsolationLevel -> Connection -> IO () +beginLevel lvl = beginMode defaultTransactionMode {isolationLevel = lvl} + +-- | Begin a transaction with a given transaction mode +beginMode :: TransactionMode -> Connection -> IO () +beginMode mode conn = do + _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) + return () + where + isolevel = case isolationLevel mode of + DefaultIsolationLevel -> "" + ReadCommitted -> " ISOLATION LEVEL READ COMMITTED" + RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ" + Serializable -> " ISOLATION LEVEL SERIALIZABLE" + readmode = case readWriteMode mode of + DefaultReadWriteMode -> "" + ReadWrite -> " READ WRITE" + ReadOnly -> " READ ONLY" + +------------------------------------------------------------------------ +-- Savepoint + +-- | Create a savepoint, and roll back to it if an error occurs. This may only +-- be used inside of a transaction, and provides a sort of +-- \"nested transaction\". +-- +-- See +withSavepoint :: Connection -> IO a -> IO a +withSavepoint conn body = + mask $ \restore -> do + sp <- newSavepoint conn + r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp + releaseSavepoint conn sp `E.catch` \err -> + if isFailedTransactionError err + then rollbackToAndReleaseSavepoint conn sp + else E.throwIO err + return r + +-- | Create a new savepoint. This may only be used inside of a transaction. +newSavepoint :: Connection -> IO Savepoint +newSavepoint conn = do + name <- newTempName conn + _ <- execute_ conn ("SAVEPOINT " <> name) + return (Savepoint name) + +-- | Destroy a savepoint, but retain its effects. +-- +-- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if +-- the transaction is aborted due to an error. 'commit' would merely warn and +-- roll back. +releaseSavepoint :: Connection -> Savepoint -> IO () +releaseSavepoint conn (Savepoint name) = + execute_ conn ("RELEASE SAVEPOINT " <> name) >> return () + +-- | Roll back to a savepoint. This will not release the savepoint. +rollbackToSavepoint :: Connection -> Savepoint -> IO () +rollbackToSavepoint conn (Savepoint name) = + execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return () + +-- | Roll back to a savepoint and release it. This is like calling +-- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a +-- round trip to the database server. +rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO () +rollbackToAndReleaseSavepoint conn (Savepoint name) = + execute_ conn sql >> return () + where + sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name diff --git a/src/Database/PostgreSQL/Simple/TypeInfo.hs b/src/Database/PostgreSQL/Simple/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo.hs @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- This module provides convenient and efficient access to parts of the +-- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if +-- you need to work with types that do not appear in +-- 'Database.PostgreSQL.Simple.TypeInfo.Static'. +-- +-- The current scheme could be more efficient, especially for some use +-- cases. In particular, connection pools that use many user-added +-- types and connect to a set of servers with identical (or at least +-- compatible) @pg_type@ and associated tables could share a common +-- typeinfo cache, thus saving memory and communication between the +-- client and server. +module Database.PostgreSQL.Simple.TypeInfo + ( getTypeInfo, + TypeInfo (..), + Attribute (..), + ) +where + +import Control.Concurrent.MVar +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.TypeInfo.Static +import Database.PostgreSQL.Simple.TypeInfo.Types +import Hpgsql.Encoding () + +-- | Returns the metadata of the type with a particular oid. To find +-- this data, 'getTypeInfo' first consults hpgsql-simple-compat's +-- built-in 'staticTypeInfo' table, then checks the connection's +-- typeinfo cache. Finally, the database's 'pg_type' table will +-- be queried only if necessary, and the result will be stored +-- in the connections's cache. +getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo +getTypeInfo conn@Connection {..} oid' = + case staticTypeInfo oid' of + Just name' -> return name' + Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid' + +getTypeInfo' :: + Connection -> + PQ.Oid -> + TypeInfoCache -> + IO (TypeInfoCache, TypeInfo) +getTypeInfo' _conn _oid' _oidmap = error "TODO getTypeInfo'" diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo.Macro +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- A Template Haskell macro for efficiently checking membership in +-- a set of type oids. +module Database.PostgreSQL.Simple.TypeInfo.Macro + ( mkCompats, + inlineTypoid, + ) where + +import Database.PostgreSQL.Simple.TypeInfo.Static +import Database.PostgreSQL.Simple.Types (Oid (..)) +import Language.Haskell.TH + +-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the +-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's. +mkCompats :: [TypeInfo] -> ExpQ +mkCompats tys = do + x <- newName "x" + lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll]) + where + alt :: TypeInfo -> MatchQ + alt ty = match (inlineTypoidP ty) (normalB [|True|]) [] + + catchAll :: MatchQ + catchAll = match wildP (normalB [|False|]) [] + +-- | Literally substitute the 'typoid' of a 'TypeInfo' expression. +-- Returns an expression of type 'Oid'. Useful because GHC tends +-- not to fold constants. +inlineTypoid :: TypeInfo -> ExpQ +inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty) + +inlineTypoidP :: TypeInfo -> PatQ +inlineTypoidP ty = litP (getTypoid ty) + +getTypoid :: TypeInfo -> Lit +getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x) diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs @@ -0,0 +1,1689 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- Note that this file is generated by tools/GenTypeInfo.hs, and should +-- not be edited directly + +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo +-- Copyright: (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- This module contains portions of the @pg_type@ table that are relevant +-- to hpgsql-simple-compat and are believed to not change between PostgreSQL +-- versions. +module Database.PostgreSQL.Simple.TypeInfo.Static + ( TypeInfo (..), + staticTypeInfo, + bool, + boolOid, + bytea, + byteaOid, + char, + charOid, + name, + nameOid, + int8, + int8Oid, + int2, + int2Oid, + int4, + int4Oid, + regproc, + regprocOid, + text, + textOid, + oid, + oidOid, + tid, + tidOid, + xid, + xidOid, + cid, + cidOid, + xml, + xmlOid, + point, + pointOid, + lseg, + lsegOid, + path, + pathOid, + box, + boxOid, + polygon, + polygonOid, + line, + lineOid, + cidr, + cidrOid, + float4, + float4Oid, + float8, + float8Oid, + unknown, + unknownOid, + circle, + circleOid, + money, + moneyOid, + macaddr, + macaddrOid, + inet, + inetOid, + bpchar, + bpcharOid, + varchar, + varcharOid, + date, + dateOid, + time, + timeOid, + timestamp, + timestampOid, + timestamptz, + timestamptzOid, + interval, + intervalOid, + timetz, + timetzOid, + bit, + bitOid, + varbit, + varbitOid, + numeric, + numericOid, + refcursor, + refcursorOid, + record, + recordOid, + void, + voidOid, + array_record, + array_recordOid, + regprocedure, + regprocedureOid, + regoper, + regoperOid, + regoperator, + regoperatorOid, + regclass, + regclassOid, + regtype, + regtypeOid, + uuid, + uuidOid, + json, + jsonOid, + jsonb, + jsonbOid, + int2vector, + int2vectorOid, + oidvector, + oidvectorOid, + array_xml, + array_xmlOid, + array_json, + array_jsonOid, + array_line, + array_lineOid, + array_cidr, + array_cidrOid, + array_circle, + array_circleOid, + array_money, + array_moneyOid, + array_bool, + array_boolOid, + array_bytea, + array_byteaOid, + array_char, + array_charOid, + array_name, + array_nameOid, + array_int2, + array_int2Oid, + array_int2vector, + array_int2vectorOid, + array_int4, + array_int4Oid, + array_regproc, + array_regprocOid, + array_text, + array_textOid, + array_tid, + array_tidOid, + array_xid, + array_xidOid, + array_cid, + array_cidOid, + array_oidvector, + array_oidvectorOid, + array_bpchar, + array_bpcharOid, + array_varchar, + array_varcharOid, + array_int8, + array_int8Oid, + array_point, + array_pointOid, + array_lseg, + array_lsegOid, + array_path, + array_pathOid, + array_box, + array_boxOid, + array_float4, + array_float4Oid, + array_float8, + array_float8Oid, + array_polygon, + array_polygonOid, + array_oid, + array_oidOid, + array_macaddr, + array_macaddrOid, + array_inet, + array_inetOid, + array_timestamp, + array_timestampOid, + array_date, + array_dateOid, + array_time, + array_timeOid, + array_timestamptz, + array_timestamptzOid, + array_interval, + array_intervalOid, + array_numeric, + array_numericOid, + array_timetz, + array_timetzOid, + array_bit, + array_bitOid, + array_varbit, + array_varbitOid, + array_refcursor, + array_refcursorOid, + array_regprocedure, + array_regprocedureOid, + array_regoper, + array_regoperOid, + array_regoperator, + array_regoperatorOid, + array_regclass, + array_regclassOid, + array_regtype, + array_regtypeOid, + array_uuid, + array_uuidOid, + array_jsonb, + array_jsonbOid, + int4range, + int4rangeOid, + _int4range, + _int4rangeOid, + numrange, + numrangeOid, + _numrange, + _numrangeOid, + tsrange, + tsrangeOid, + _tsrange, + _tsrangeOid, + tstzrange, + tstzrangeOid, + _tstzrange, + _tstzrangeOid, + daterange, + daterangeOid, + _daterange, + _daterangeOid, + int8range, + int8rangeOid, + _int8range, + _int8rangeOid, + ) +where + +import Database.PostgreSQL.LibPQ (Oid (..)) +import Database.PostgreSQL.Simple.TypeInfo.Types + +staticTypeInfo :: Oid -> Maybe TypeInfo +staticTypeInfo (Oid x) = case x of + 16 -> Just bool + 17 -> Just bytea + 18 -> Just char + 19 -> Just name + 20 -> Just int8 + 21 -> Just int2 + 23 -> Just int4 + 24 -> Just regproc + 25 -> Just text + 26 -> Just oid + 27 -> Just tid + 28 -> Just xid + 29 -> Just cid + 142 -> Just xml + 600 -> Just point + 601 -> Just lseg + 602 -> Just path + 603 -> Just box + 604 -> Just polygon + 628 -> Just line + 650 -> Just cidr + 700 -> Just float4 + 701 -> Just float8 + 705 -> Just unknown + 718 -> Just circle + 790 -> Just money + 829 -> Just macaddr + 869 -> Just inet + 1042 -> Just bpchar + 1043 -> Just varchar + 1082 -> Just date + 1083 -> Just time + 1114 -> Just timestamp + 1184 -> Just timestamptz + 1186 -> Just interval + 1266 -> Just timetz + 1560 -> Just bit + 1562 -> Just varbit + 1700 -> Just numeric + 1790 -> Just refcursor + 2249 -> Just record + 2278 -> Just void + 2287 -> Just array_record + 2202 -> Just regprocedure + 2203 -> Just regoper + 2204 -> Just regoperator + 2205 -> Just regclass + 2206 -> Just regtype + 2950 -> Just uuid + 114 -> Just json + 3802 -> Just jsonb + 22 -> Just int2vector + 30 -> Just oidvector + 143 -> Just array_xml + 199 -> Just array_json + 629 -> Just array_line + 651 -> Just array_cidr + 719 -> Just array_circle + 791 -> Just array_money + 1000 -> Just array_bool + 1001 -> Just array_bytea + 1002 -> Just array_char + 1003 -> Just array_name + 1005 -> Just array_int2 + 1006 -> Just array_int2vector + 1007 -> Just array_int4 + 1008 -> Just array_regproc + 1009 -> Just array_text + 1010 -> Just array_tid + 1011 -> Just array_xid + 1012 -> Just array_cid + 1013 -> Just array_oidvector + 1014 -> Just array_bpchar + 1015 -> Just array_varchar + 1016 -> Just array_int8 + 1017 -> Just array_point + 1018 -> Just array_lseg + 1019 -> Just array_path + 1020 -> Just array_box + 1021 -> Just array_float4 + 1022 -> Just array_float8 + 1027 -> Just array_polygon + 1028 -> Just array_oid + 1040 -> Just array_macaddr + 1041 -> Just array_inet + 1115 -> Just array_timestamp + 1182 -> Just array_date + 1183 -> Just array_time + 1185 -> Just array_timestamptz + 1187 -> Just array_interval + 1231 -> Just array_numeric + 1270 -> Just array_timetz + 1561 -> Just array_bit + 1563 -> Just array_varbit + 2201 -> Just array_refcursor + 2207 -> Just array_regprocedure + 2208 -> Just array_regoper + 2209 -> Just array_regoperator + 2210 -> Just array_regclass + 2211 -> Just array_regtype + 2951 -> Just array_uuid + 3807 -> Just array_jsonb + 3904 -> Just int4range + 3905 -> Just _int4range + 3906 -> Just numrange + 3907 -> Just _numrange + 3908 -> Just tsrange + 3909 -> Just _tsrange + 3910 -> Just tstzrange + 3911 -> Just _tstzrange + 3912 -> Just daterange + 3913 -> Just _daterange + 3926 -> Just int8range + 3927 -> Just _int8range + _ -> Nothing + +bool :: TypeInfo +bool = + Basic + { typoid = boolOid, + typname = "bool" + } + +boolOid :: Oid +boolOid = Oid 16 +{-# INLINE boolOid #-} + +bytea :: TypeInfo +bytea = + Basic + { typoid = byteaOid, + typname = "bytea" + } + +byteaOid :: Oid +byteaOid = Oid 17 +{-# INLINE byteaOid #-} + +char :: TypeInfo +char = + Basic + { typoid = charOid, + typname = "char" + } + +charOid :: Oid +charOid = Oid 18 +{-# INLINE charOid #-} + +name :: TypeInfo +name = + Basic + { typoid = nameOid, + typname = "name" + } + +nameOid :: Oid +nameOid = Oid 19 +{-# INLINE nameOid #-} + +int8 :: TypeInfo +int8 = + Basic + { typoid = int8Oid, + typname = "int8" + } + +int8Oid :: Oid +int8Oid = Oid 20 +{-# INLINE int8Oid #-} + +int2 :: TypeInfo +int2 = + Basic + { typoid = int2Oid, + typname = "int2" + } + +int2Oid :: Oid +int2Oid = Oid 21 +{-# INLINE int2Oid #-} + +int4 :: TypeInfo +int4 = + Basic + { typoid = int4Oid, + typname = "int4" + } + +int4Oid :: Oid +int4Oid = Oid 23 +{-# INLINE int4Oid #-} + +regproc :: TypeInfo +regproc = + Basic + { typoid = regprocOid, + typname = "regproc" + } + +regprocOid :: Oid +regprocOid = Oid 24 +{-# INLINE regprocOid #-} + +text :: TypeInfo +text = + Basic + { typoid = textOid, + typname = "text" + } + +textOid :: Oid +textOid = Oid 25 +{-# INLINE textOid #-} + +oid :: TypeInfo +oid = + Basic + { typoid = oidOid, + typname = "oid" + } + +oidOid :: Oid +oidOid = Oid 26 +{-# INLINE oidOid #-} + +tid :: TypeInfo +tid = + Basic + { typoid = tidOid, + typname = "tid" + } + +tidOid :: Oid +tidOid = Oid 27 +{-# INLINE tidOid #-} + +xid :: TypeInfo +xid = + Basic + { typoid = xidOid, + typname = "xid" + } + +xidOid :: Oid +xidOid = Oid 28 +{-# INLINE xidOid #-} + +cid :: TypeInfo +cid = + Basic + { typoid = cidOid, + typname = "cid" + } + +cidOid :: Oid +cidOid = Oid 29 +{-# INLINE cidOid #-} + +xml :: TypeInfo +xml = + Basic + { typoid = xmlOid, + typname = "xml" + } + +xmlOid :: Oid +xmlOid = Oid 142 +{-# INLINE xmlOid #-} + +point :: TypeInfo +point = + Basic + { typoid = pointOid, + typname = "point" + } + +pointOid :: Oid +pointOid = Oid 600 +{-# INLINE pointOid #-} + +lseg :: TypeInfo +lseg = + Basic + { typoid = lsegOid, + typname = "lseg" + } + +lsegOid :: Oid +lsegOid = Oid 601 +{-# INLINE lsegOid #-} + +path :: TypeInfo +path = + Basic + { typoid = pathOid, + typname = "path" + } + +pathOid :: Oid +pathOid = Oid 602 +{-# INLINE pathOid #-} + +box :: TypeInfo +box = + Basic + { typoid = boxOid, + typname = "box" + } + +boxOid :: Oid +boxOid = Oid 603 +{-# INLINE boxOid #-} + +polygon :: TypeInfo +polygon = + Basic + { typoid = polygonOid, + typname = "polygon" + } + +polygonOid :: Oid +polygonOid = Oid 604 +{-# INLINE polygonOid #-} + +line :: TypeInfo +line = + Basic + { typoid = lineOid, + typname = "line" + } + +lineOid :: Oid +lineOid = Oid 628 +{-# INLINE lineOid #-} + +cidr :: TypeInfo +cidr = + Basic + { typoid = cidrOid, + typname = "cidr" + } + +cidrOid :: Oid +cidrOid = Oid 650 +{-# INLINE cidrOid #-} + +float4 :: TypeInfo +float4 = + Basic + { typoid = float4Oid, + typname = "float4" + } + +float4Oid :: Oid +float4Oid = Oid 700 +{-# INLINE float4Oid #-} + +float8 :: TypeInfo +float8 = + Basic + { typoid = float8Oid, + typname = "float8" + } + +float8Oid :: Oid +float8Oid = Oid 701 +{-# INLINE float8Oid #-} + +unknown :: TypeInfo +unknown = + Basic + { typoid = unknownOid, + typname = "unknown" + } + +unknownOid :: Oid +unknownOid = Oid 705 +{-# INLINE unknownOid #-} + +circle :: TypeInfo +circle = + Basic + { typoid = circleOid, + typname = "circle" + } + +circleOid :: Oid +circleOid = Oid 718 +{-# INLINE circleOid #-} + +money :: TypeInfo +money = + Basic + { typoid = moneyOid, + typname = "money" + } + +moneyOid :: Oid +moneyOid = Oid 790 +{-# INLINE moneyOid #-} + +macaddr :: TypeInfo +macaddr = + Basic + { typoid = macaddrOid, + typname = "macaddr" + } + +macaddrOid :: Oid +macaddrOid = Oid 829 +{-# INLINE macaddrOid #-} + +inet :: TypeInfo +inet = + Basic + { typoid = inetOid, + typname = "inet" + } + +inetOid :: Oid +inetOid = Oid 869 +{-# INLINE inetOid #-} + +bpchar :: TypeInfo +bpchar = + Basic + { typoid = bpcharOid, + typname = "bpchar" + } + +bpcharOid :: Oid +bpcharOid = Oid 1042 +{-# INLINE bpcharOid #-} + +varchar :: TypeInfo +varchar = + Basic + { typoid = varcharOid, + typname = "varchar" + } + +varcharOid :: Oid +varcharOid = Oid 1043 +{-# INLINE varcharOid #-} + +date :: TypeInfo +date = + Basic + { typoid = dateOid, + typname = "date" + } + +dateOid :: Oid +dateOid = Oid 1082 +{-# INLINE dateOid #-} + +time :: TypeInfo +time = + Basic + { typoid = timeOid, + typname = "time" + } + +timeOid :: Oid +timeOid = Oid 1083 +{-# INLINE timeOid #-} + +timestamp :: TypeInfo +timestamp = + Basic + { typoid = timestampOid, + typname = "timestamp" + } + +timestampOid :: Oid +timestampOid = Oid 1114 +{-# INLINE timestampOid #-} + +timestamptz :: TypeInfo +timestamptz = + Basic + { typoid = timestamptzOid, + typname = "timestamptz" + } + +timestamptzOid :: Oid +timestamptzOid = Oid 1184 +{-# INLINE timestamptzOid #-} + +interval :: TypeInfo +interval = + Basic + { typoid = intervalOid, + typname = "interval" + } + +intervalOid :: Oid +intervalOid = Oid 1186 +{-# INLINE intervalOid #-} + +timetz :: TypeInfo +timetz = + Basic + { typoid = timetzOid, + typname = "timetz" + } + +timetzOid :: Oid +timetzOid = Oid 1266 +{-# INLINE timetzOid #-} + +bit :: TypeInfo +bit = + Basic + { typoid = bitOid, + typname = "bit" + } + +bitOid :: Oid +bitOid = Oid 1560 +{-# INLINE bitOid #-} + +varbit :: TypeInfo +varbit = + Basic + { typoid = varbitOid, + typname = "varbit" + } + +varbitOid :: Oid +varbitOid = Oid 1562 +{-# INLINE varbitOid #-} + +numeric :: TypeInfo +numeric = + Basic + { typoid = numericOid, + typname = "numeric" + } + +numericOid :: Oid +numericOid = Oid 1700 +{-# INLINE numericOid #-} + +refcursor :: TypeInfo +refcursor = + Basic + { typoid = refcursorOid, + typname = "refcursor" + } + +refcursorOid :: Oid +refcursorOid = Oid 1790 +{-# INLINE refcursorOid #-} + +record :: TypeInfo +record = + Basic + { typoid = recordOid, + typname = "record" + } + +recordOid :: Oid +recordOid = Oid 2249 +{-# INLINE recordOid #-} + +void :: TypeInfo +void = + Basic + { typoid = voidOid, + typname = "void" + } + +voidOid :: Oid +voidOid = Oid 2278 +{-# INLINE voidOid #-} + +array_record :: TypeInfo +array_record = + Array + { typoid = array_recordOid, + typname = "_record", + typelem = Just record + } + +array_recordOid :: Oid +array_recordOid = Oid 2287 +{-# INLINE array_recordOid #-} + +regprocedure :: TypeInfo +regprocedure = + Basic + { typoid = regprocedureOid, + typname = "regprocedure" + } + +regprocedureOid :: Oid +regprocedureOid = Oid 2202 +{-# INLINE regprocedureOid #-} + +regoper :: TypeInfo +regoper = + Basic + { typoid = regoperOid, + typname = "regoper" + } + +regoperOid :: Oid +regoperOid = Oid 2203 +{-# INLINE regoperOid #-} + +regoperator :: TypeInfo +regoperator = + Basic + { typoid = regoperatorOid, + typname = "regoperator" + } + +regoperatorOid :: Oid +regoperatorOid = Oid 2204 +{-# INLINE regoperatorOid #-} + +regclass :: TypeInfo +regclass = + Basic + { typoid = regclassOid, + typname = "regclass" + } + +regclassOid :: Oid +regclassOid = Oid 2205 +{-# INLINE regclassOid #-} + +regtype :: TypeInfo +regtype = + Basic + { typoid = regtypeOid, + typname = "regtype" + } + +regtypeOid :: Oid +regtypeOid = Oid 2206 +{-# INLINE regtypeOid #-} + +uuid :: TypeInfo +uuid = + Basic + { typoid = uuidOid, + typname = "uuid" + } + +uuidOid :: Oid +uuidOid = Oid 2950 +{-# INLINE uuidOid #-} + +json :: TypeInfo +json = + Basic + { typoid = jsonOid, + typname = "json" + } + +jsonOid :: Oid +jsonOid = Oid 114 +{-# INLINE jsonOid #-} + +jsonb :: TypeInfo +jsonb = + Basic + { typoid = jsonbOid, + typname = "jsonb" + } + +jsonbOid :: Oid +jsonbOid = Oid 3802 +{-# INLINE jsonbOid #-} + +int2vector :: TypeInfo +int2vector = + Array + { typoid = int2vectorOid, + typname = "int2vector", + typelem = Just int2 + } + +int2vectorOid :: Oid +int2vectorOid = Oid 22 +{-# INLINE int2vectorOid #-} + +oidvector :: TypeInfo +oidvector = + Array + { typoid = oidvectorOid, + typname = "oidvector", + typelem = Just oid + } + +oidvectorOid :: Oid +oidvectorOid = Oid 30 +{-# INLINE oidvectorOid #-} + +array_xml :: TypeInfo +array_xml = + Array + { typoid = array_xmlOid, + typname = "_xml", + typelem = Just xml + } + +array_xmlOid :: Oid +array_xmlOid = Oid 143 +{-# INLINE array_xmlOid #-} + +array_json :: TypeInfo +array_json = + Array + { typoid = array_jsonOid, + typname = "_json", + typelem = Just json + } + +array_jsonOid :: Oid +array_jsonOid = Oid 199 +{-# INLINE array_jsonOid #-} + +array_line :: TypeInfo +array_line = + Array + { typoid = array_lineOid, + typname = "_line", + typelem = Just line + } + +array_lineOid :: Oid +array_lineOid = Oid 629 +{-# INLINE array_lineOid #-} + +array_cidr :: TypeInfo +array_cidr = + Array + { typoid = array_cidrOid, + typname = "_cidr", + typelem = Just cidr + } + +array_cidrOid :: Oid +array_cidrOid = Oid 651 +{-# INLINE array_cidrOid #-} + +array_circle :: TypeInfo +array_circle = + Array + { typoid = array_circleOid, + typname = "_circle", + typelem = Just circle + } + +array_circleOid :: Oid +array_circleOid = Oid 719 +{-# INLINE array_circleOid #-} + +array_money :: TypeInfo +array_money = + Array + { typoid = array_moneyOid, + typname = "_money", + typelem = Just money + } + +array_moneyOid :: Oid +array_moneyOid = Oid 791 +{-# INLINE array_moneyOid #-} + +array_bool :: TypeInfo +array_bool = + Array + { typoid = array_boolOid, + typname = "_bool", + typelem = Just bool + } + +array_boolOid :: Oid +array_boolOid = Oid 1000 +{-# INLINE array_boolOid #-} + +array_bytea :: TypeInfo +array_bytea = + Array + { typoid = array_byteaOid, + typname = "_bytea", + typelem = Just bytea + } + +array_byteaOid :: Oid +array_byteaOid = Oid 1001 +{-# INLINE array_byteaOid #-} + +array_char :: TypeInfo +array_char = + Array + { typoid = array_charOid, + typname = "_char", + typelem = Just char + } + +array_charOid :: Oid +array_charOid = Oid 1002 +{-# INLINE array_charOid #-} + +array_name :: TypeInfo +array_name = + Array + { typoid = array_nameOid, + typname = "_name", + typelem = Just name + } + +array_nameOid :: Oid +array_nameOid = Oid 1003 +{-# INLINE array_nameOid #-} + +array_int2 :: TypeInfo +array_int2 = + Array + { typoid = array_int2Oid, + typname = "_int2", + typelem = Just int2 + } + +array_int2Oid :: Oid +array_int2Oid = Oid 1005 +{-# INLINE array_int2Oid #-} + +array_int2vector :: TypeInfo +array_int2vector = + Array + { typoid = array_int2vectorOid, + typname = "_int2vector", + typelem = Just int2vector + } + +array_int2vectorOid :: Oid +array_int2vectorOid = Oid 1006 +{-# INLINE array_int2vectorOid #-} + +array_int4 :: TypeInfo +array_int4 = + Array + { typoid = array_int4Oid, + typname = "_int4", + typelem = Just int4 + } + +array_int4Oid :: Oid +array_int4Oid = Oid 1007 +{-# INLINE array_int4Oid #-} + +array_regproc :: TypeInfo +array_regproc = + Array + { typoid = array_regprocOid, + typname = "_regproc", + typelem = Just regproc + } + +array_regprocOid :: Oid +array_regprocOid = Oid 1008 +{-# INLINE array_regprocOid #-} + +array_text :: TypeInfo +array_text = + Array + { typoid = array_textOid, + typname = "_text", + typelem = Just text + } + +array_textOid :: Oid +array_textOid = Oid 1009 +{-# INLINE array_textOid #-} + +array_tid :: TypeInfo +array_tid = + Array + { typoid = array_tidOid, + typname = "_tid", + typelem = Just tid + } + +array_tidOid :: Oid +array_tidOid = Oid 1010 +{-# INLINE array_tidOid #-} + +array_xid :: TypeInfo +array_xid = + Array + { typoid = array_xidOid, + typname = "_xid", + typelem = Just xid + } + +array_xidOid :: Oid +array_xidOid = Oid 1011 +{-# INLINE array_xidOid #-} + +array_cid :: TypeInfo +array_cid = + Array + { typoid = array_cidOid, + typname = "_cid", + typelem = Just cid + } + +array_cidOid :: Oid +array_cidOid = Oid 1012 +{-# INLINE array_cidOid #-} + +array_oidvector :: TypeInfo +array_oidvector = + Array + { typoid = array_oidvectorOid, + typname = "_oidvector", + typelem = Just oidvector + } + +array_oidvectorOid :: Oid +array_oidvectorOid = Oid 1013 +{-# INLINE array_oidvectorOid #-} + +array_bpchar :: TypeInfo +array_bpchar = + Array + { typoid = array_bpcharOid, + typname = "_bpchar", + typelem = Just bpchar + } + +array_bpcharOid :: Oid +array_bpcharOid = Oid 1014 +{-# INLINE array_bpcharOid #-} + +array_varchar :: TypeInfo +array_varchar = + Array + { typoid = array_varcharOid, + typname = "_varchar", + typelem = Just varchar + } + +array_varcharOid :: Oid +array_varcharOid = Oid 1015 +{-# INLINE array_varcharOid #-} + +array_int8 :: TypeInfo +array_int8 = + Array + { typoid = array_int8Oid, + typname = "_int8", + typelem = Just int8 + } + +array_int8Oid :: Oid +array_int8Oid = Oid 1016 +{-# INLINE array_int8Oid #-} + +array_point :: TypeInfo +array_point = + Array + { typoid = array_pointOid, + typname = "_point", + typelem = Just point + } + +array_pointOid :: Oid +array_pointOid = Oid 1017 +{-# INLINE array_pointOid #-} + +array_lseg :: TypeInfo +array_lseg = + Array + { typoid = array_lsegOid, + typname = "_lseg", + typelem = Just lseg + } + +array_lsegOid :: Oid +array_lsegOid = Oid 1018 +{-# INLINE array_lsegOid #-} + +array_path :: TypeInfo +array_path = + Array + { typoid = array_pathOid, + typname = "_path", + typelem = Just path + } + +array_pathOid :: Oid +array_pathOid = Oid 1019 +{-# INLINE array_pathOid #-} + +array_box :: TypeInfo +array_box = + Array + { typoid = array_boxOid, + typname = "_box", + typelem = Just box + } + +array_boxOid :: Oid +array_boxOid = Oid 1020 +{-# INLINE array_boxOid #-} + +array_float4 :: TypeInfo +array_float4 = + Array + { typoid = array_float4Oid, + typname = "_float4", + typelem = Just float4 + } + +array_float4Oid :: Oid +array_float4Oid = Oid 1021 +{-# INLINE array_float4Oid #-} + +array_float8 :: TypeInfo +array_float8 = + Array + { typoid = array_float8Oid, + typname = "_float8", + typelem = Just float8 + } + +array_float8Oid :: Oid +array_float8Oid = Oid 1022 +{-# INLINE array_float8Oid #-} + +array_polygon :: TypeInfo +array_polygon = + Array + { typoid = array_polygonOid, + typname = "_polygon", + typelem = Just polygon + } + +array_polygonOid :: Oid +array_polygonOid = Oid 1027 +{-# INLINE array_polygonOid #-} + +array_oid :: TypeInfo +array_oid = + Array + { typoid = array_oidOid, + typname = "_oid", + typelem = Just oid + } + +array_oidOid :: Oid +array_oidOid = Oid 1028 +{-# INLINE array_oidOid #-} + +array_macaddr :: TypeInfo +array_macaddr = + Array + { typoid = array_macaddrOid, + typname = "_macaddr", + typelem = Just macaddr + } + +array_macaddrOid :: Oid +array_macaddrOid = Oid 1040 +{-# INLINE array_macaddrOid #-} + +array_inet :: TypeInfo +array_inet = + Array + { typoid = array_inetOid, + typname = "_inet", + typelem = Just inet + } + +array_inetOid :: Oid +array_inetOid = Oid 1041 +{-# INLINE array_inetOid #-} + +array_timestamp :: TypeInfo +array_timestamp = + Array + { typoid = array_timestampOid, + typname = "_timestamp", + typelem = Just timestamp + } + +array_timestampOid :: Oid +array_timestampOid = Oid 1115 +{-# INLINE array_timestampOid #-} + +array_date :: TypeInfo +array_date = + Array + { typoid = array_dateOid, + typname = "_date", + typelem = Just date + } + +array_dateOid :: Oid +array_dateOid = Oid 1182 +{-# INLINE array_dateOid #-} + +array_time :: TypeInfo +array_time = + Array + { typoid = array_timeOid, + typname = "_time", + typelem = Just time + } + +array_timeOid :: Oid +array_timeOid = Oid 1183 +{-# INLINE array_timeOid #-} + +array_timestamptz :: TypeInfo +array_timestamptz = + Array + { typoid = array_timestamptzOid, + typname = "_timestamptz", + typelem = Just timestamptz + } + +array_timestamptzOid :: Oid +array_timestamptzOid = Oid 1185 +{-# INLINE array_timestamptzOid #-} + +array_interval :: TypeInfo +array_interval = + Array + { typoid = array_intervalOid, + typname = "_interval", + typelem = Just interval + } + +array_intervalOid :: Oid +array_intervalOid = Oid 1187 +{-# INLINE array_intervalOid #-} + +array_numeric :: TypeInfo +array_numeric = + Array + { typoid = array_numericOid, + typname = "_numeric", + typelem = Just numeric + } + +array_numericOid :: Oid +array_numericOid = Oid 1231 +{-# INLINE array_numericOid #-} + +array_timetz :: TypeInfo +array_timetz = + Array + { typoid = array_timetzOid, + typname = "_timetz", + typelem = Just timetz + } + +array_timetzOid :: Oid +array_timetzOid = Oid 1270 +{-# INLINE array_timetzOid #-} + +array_bit :: TypeInfo +array_bit = + Array + { typoid = array_bitOid, + typname = "_bit", + typelem = Just bit + } + +array_bitOid :: Oid +array_bitOid = Oid 1561 +{-# INLINE array_bitOid #-} + +array_varbit :: TypeInfo +array_varbit = + Array + { typoid = array_varbitOid, + typname = "_varbit", + typelem = Just varbit + } + +array_varbitOid :: Oid +array_varbitOid = Oid 1563 +{-# INLINE array_varbitOid #-} + +array_refcursor :: TypeInfo +array_refcursor = + Array + { typoid = array_refcursorOid, + typname = "_refcursor", + typelem = Just refcursor + } + +array_refcursorOid :: Oid +array_refcursorOid = Oid 2201 +{-# INLINE array_refcursorOid #-} + +array_regprocedure :: TypeInfo +array_regprocedure = + Array + { typoid = array_regprocedureOid, + typname = "_regprocedure", + typelem = Just regprocedure + } + +array_regprocedureOid :: Oid +array_regprocedureOid = Oid 2207 +{-# INLINE array_regprocedureOid #-} + +array_regoper :: TypeInfo +array_regoper = + Array + { typoid = array_regoperOid, + typname = "_regoper", + typelem = Just regoper + } + +array_regoperOid :: Oid +array_regoperOid = Oid 2208 +{-# INLINE array_regoperOid #-} + +array_regoperator :: TypeInfo +array_regoperator = + Array + { typoid = array_regoperatorOid, + typname = "_regoperator", + typelem = Just regoperator + } + +array_regoperatorOid :: Oid +array_regoperatorOid = Oid 2209 +{-# INLINE array_regoperatorOid #-} + +array_regclass :: TypeInfo +array_regclass = + Array + { typoid = array_regclassOid, + typname = "_regclass", + typelem = Just regclass + } + +array_regclassOid :: Oid +array_regclassOid = Oid 2210 +{-# INLINE array_regclassOid #-} + +array_regtype :: TypeInfo +array_regtype = + Array + { typoid = array_regtypeOid, + typname = "_regtype", + typelem = Just regtype + } + +array_regtypeOid :: Oid +array_regtypeOid = Oid 2211 +{-# INLINE array_regtypeOid #-} + +array_uuid :: TypeInfo +array_uuid = + Array + { typoid = array_uuidOid, + typname = "_uuid", + typelem = Just uuid + } + +array_uuidOid :: Oid +array_uuidOid = Oid 2951 +{-# INLINE array_uuidOid #-} + +array_jsonb :: TypeInfo +array_jsonb = + Array + { typoid = array_jsonbOid, + typname = "_jsonb", + typelem = Just jsonb + } + +array_jsonbOid :: Oid +array_jsonbOid = Oid 3807 +{-# INLINE array_jsonbOid #-} + +int4range :: TypeInfo +int4range = + Range + { typoid = int4rangeOid, + typname = "int4range" + -- rngsubtype = int4 + } + +int4rangeOid :: Oid +int4rangeOid = Oid 3904 +{-# INLINE int4rangeOid #-} + +_int4range :: TypeInfo +_int4range = + Array + { typoid = _int4rangeOid, + typname = "_int4range", + typelem = Just int4range + } + +_int4rangeOid :: Oid +_int4rangeOid = Oid 3905 +{-# INLINE _int4rangeOid #-} + +numrange :: TypeInfo +numrange = + Range + { typoid = numrangeOid, + typname = "numrange" + -- rngsubtype = numeric + } + +numrangeOid :: Oid +numrangeOid = Oid 3906 +{-# INLINE numrangeOid #-} + +_numrange :: TypeInfo +_numrange = + Array + { typoid = _numrangeOid, + typname = "_numrange", + typelem = Just numrange + } + +_numrangeOid :: Oid +_numrangeOid = Oid 3907 +{-# INLINE _numrangeOid #-} + +tsrange :: TypeInfo +tsrange = + Range + { typoid = tsrangeOid, + typname = "tsrange" + -- rngsubtype = timestamp + } + +tsrangeOid :: Oid +tsrangeOid = Oid 3908 +{-# INLINE tsrangeOid #-} + +_tsrange :: TypeInfo +_tsrange = + Array + { typoid = _tsrangeOid, + typname = "_tsrange", + typelem = Just tsrange + } + +_tsrangeOid :: Oid +_tsrangeOid = Oid 3909 +{-# INLINE _tsrangeOid #-} + +tstzrange :: TypeInfo +tstzrange = + Range + { typoid = tstzrangeOid, + typname = "tstzrange" + -- rngsubtype = timestamptz + } + +tstzrangeOid :: Oid +tstzrangeOid = Oid 3910 +{-# INLINE tstzrangeOid #-} + +_tstzrange :: TypeInfo +_tstzrange = + Array + { typoid = _tstzrangeOid, + typname = "_tstzrange", + typelem = Just tstzrange + } + +_tstzrangeOid :: Oid +_tstzrangeOid = Oid 3911 +{-# INLINE _tstzrangeOid #-} + +daterange :: TypeInfo +daterange = + Range + { typoid = daterangeOid, + typname = "daterange" + -- rngsubtype = date + } + +daterangeOid :: Oid +daterangeOid = Oid 3912 +{-# INLINE daterangeOid #-} + +_daterange :: TypeInfo +_daterange = + Array + { typoid = _daterangeOid, + typname = "_daterange", + typelem = Just daterange + } + +_daterangeOid :: Oid +_daterangeOid = Oid 3913 +{-# INLINE _daterangeOid #-} + +int8range :: TypeInfo +int8range = + Range + { typoid = int8rangeOid, + typname = "int8range" + -- rngsubtype = int8 + } + +int8rangeOid :: Oid +int8rangeOid = Oid 3926 +{-# INLINE int8rangeOid #-} + +_int8range :: TypeInfo +_int8range = + Array + { typoid = _int8rangeOid, + typname = "_int8range", + typelem = Just int8range + } + +_int8rangeOid :: Oid +_int8rangeOid = Oid 3927 +{-# INLINE _int8rangeOid #-} diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo.Types +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +module Database.PostgreSQL.Simple.TypeInfo.Types where + +import Data.ByteString (ByteString) +import Data.Text.Encoding (encodeUtf8) +import Database.PostgreSQL.LibPQ (Oid) +import Hpgsql.TypeInfo (ArrayTypeDetails (..), TypeDetails (..), lookupTypeByOid) +import qualified Hpgsql.TypeInfo as Hpgsql + +-- | This is not exactly like postgresql-simple's TypeInfo, +-- since some fields are slightly altered and others have been removed. +data TypeInfo + = Basic + { typoid :: Oid, + -- typcategory :: Char, + -- typdelim :: Char, + typname :: ByteString + } + | Array + { typoid :: Oid, + -- typcategory :: Char, + -- typdelim :: Char, + typname :: ByteString, + -- | In postgresql-simple typelem is not a Maybe + typelem :: Maybe TypeInfo + } + | Composite + { typoid :: Oid, + -- typcategory :: Char, + -- typdelim :: Char, + typname :: ByteString + -- typrelid :: Oid, + -- attributes :: (Vector Attribute) + } + | Range + { typoid :: Oid, + -- typcategory :: Char, + -- typdelim :: Char, + typname :: ByteString + -- rngsubtype :: TypeInfo + } + deriving + ( Show + ) + +fromHpgsqlTypeInfo :: Hpgsql.EncodingContext -> Hpgsql.TypeInfo -> TypeInfo +fromHpgsqlTypeInfo encCtx ti = case ti.typeDetails of + ArrayType arrDetails -> + Array + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName, + typelem = fromHpgsqlTypeInfo encCtx <$> lookupTypeByOid arrDetails.elemTypeOid encCtx.typeInfoCache + } + BasicType -> + Basic + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName + } + CompositeType -> + Composite + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName + } + RangeType -> + Range + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName + -- rngsubtype = error "rngsubtype not available in hpgsql-simple-compat" + } + DomainType -> + Basic + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName + } + EnumType -> + Basic + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName + } + PseudoType -> + Basic + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName + } + MultiRangeType -> + Basic + { typoid = ti.typeOid, + typname = encodeUtf8 ti.typeName + } + +data Attribute + = Attribute + { attname :: !ByteString, + atttype :: !TypeInfo + } + deriving (Show) diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -0,0 +1,330 @@ +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ + +-- | +-- Module: Database.PostgreSQL.Simple.Types +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Basic types. +module Database.PostgreSQL.Simple.Types + ( Null (..), + Default (..), + Only (..), + In (..), + Binary (..), + Identifier (..), + QualifiedIdentifier (..), + Query (..), + Oid (..), + (:.) (..), + Savepoint (..), + PGArray (..), + Values (..), + ) +where + +import Control.Arrow (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Builder (stringUtf8) +import Data.Foldable (toList) +import Data.Functor.Contravariant (contramap) +import Data.Hashable (Hashable (hashWithSalt)) +import qualified Data.List as List +import Data.Semigroup +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Tuple.Only (Only (..)) +import Data.Typeable (Typeable) +import Database.PostgreSQL.LibPQ (Oid (..)) +import Database.PostgreSQL.Simple.Compat (toByteString) +import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) +import Database.PostgreSQL.Simple.ToRow (ToRow (..)) +import Hpgsql.Encoding (ToPgField (..)) +import qualified Hpgsql.Encoding as Hpgsql +import Hpgsql.Types (PGArray (..), (:.) (..)) + +-- | A placeholder for the SQL @NULL@ value. +data Null = Null + deriving (Read, Show, Typeable) + +-- | A placeholder for the PostgreSQL @DEFAULT@ value. +data Default = Default + deriving (Read, Show, Typeable) + +-- | A query string. This type is intended to make it difficult to +-- construct a SQL query by concatenating string fragments, as that is +-- an extremely common way to accidentally introduce SQL injection +-- vulnerabilities into an application. +-- +-- This type is an instance of 'IsString', so the easiest way to +-- construct a query is to enable the @OverloadedStrings@ language +-- extension and then simply write the query in double quotes. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Database.PostgreSQL.Simple +-- > +-- > q :: Query +-- > q = "select ?" +-- +-- The underlying type is a 'ByteString', and literal Haskell strings +-- that contain Unicode characters will be correctly transformed to +-- UTF-8. +newtype Query = Query + { fromQuery :: ByteString + } + deriving (Eq, Ord, Typeable) + +instance Show Query where + show = show . fromQuery + +instance Read Query where + readsPrec i = fmap (first Query) . readsPrec i + +instance IsString Query where + fromString = Query . toByteString . stringUtf8 + +instance Semigroup Query where + Query a <> Query b = Query (B.append a b) + {-# INLINE (<>) #-} + sconcat xs = Query (B.concat $ map fromQuery $ toList xs) + +instance Monoid Query where + mempty = Query B.empty + +-- | Wrap a list of values for use in an @IN@ clause. Replaces a +-- single \"@?@\" character with a parenthesized list of rendered +-- values. +-- +-- Example: +-- +-- > query c "select * from whatever where id in ?" (Only (In [3,4,5])) +-- +-- Note that @In []@ expands to @(null)@, which works as expected in +-- the query above, but evaluates to the logical null value on every +-- row instead of @TRUE@. This means that changing the query above +-- to @... id NOT in ?@ and supplying the empty list as the parameter +-- returns zero rows, instead of all of them as one would expect. +-- +-- Since postgresql doesn't seem to provide a syntax for actually specifying +-- an empty list, which could solve this completely, there are two +-- workarounds particularly worth mentioning, namely: +-- +-- 1. Use hpgsql-simple-compat's 'Values' type instead, which can handle the +-- empty case correctly. Note however that while specifying the +-- postgresql type @"int4"@ is mandatory in the empty case, specifying +-- the haskell type @Values (Only Int)@ would not normally be needed in +-- realistic use cases. +-- +-- > query c "select * from whatever where id not in ?" +-- > (Only (Values ["int4"] [] :: Values (Only Int))) +-- +-- +-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct +-- boolean. Note however that the correct boolean depends on the use +-- case: +-- +-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)" +-- > (Only (In [] :: In [Int])) +-- +-- > query c "select * from whatever where coalesce(id IN ?, FALSE)" +-- > (Only (In [] :: In [Int])) +-- +-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside +-- the @COALESCE@ operator, so if you have an index on @id@ then you +-- probably don't want to write the last example with @COALESCE@, which +-- would result in a table scan. There are further caveats if @id@ can +-- be null or you want null treated sensibly as a component of @IN@ or +-- @NOT IN@. +newtype In a = In a + deriving (Eq, Ord, Read, Show, Typeable, Functor) + +instance (ToField a) => ToField (In [a]) where + toField (In []) = Plain "(NULL)" + toField (In xs) = Many $ Plain "(" : List.intersperse (Plain ",") (map toField xs) ++ [Plain ")"] + +-- | Wrap binary data for use as a @bytea@ value. +newtype Binary a = Binary {fromBinary :: a} + deriving (Eq, Ord, Read, Show, Typeable, Functor) + +instance ToField (Binary ByteString) + +instance Hpgsql.FromPgField (Binary ByteString) where + fieldDecoder = Binary <$> Hpgsql.fieldDecoder + +instance ToPgField (Binary ByteString) where + fieldEncoder = contramap fromBinary fieldEncoder + +-- | Wrap text for use as sql identifier, i.e. a table or column name. +newtype Identifier = Identifier {fromIdentifier :: Text} + deriving stock (Eq, Ord, Read, Show, Typeable) + deriving newtype (IsString) + +instance ToField Identifier where + toField (Identifier ident) = EscapeIdentifier $ encodeUtf8 ident + +instance Hashable Identifier where + hashWithSalt i (Identifier t) = hashWithSalt i t + +-- | Wrap text for use as (maybe) qualified identifier, i.e. a table +-- with schema, or column with table. +data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text + deriving (Eq, Ord, Read, Show, Typeable) + +instance ToField QualifiedIdentifier where + toField (QualifiedIdentifier m n) = case m of + Nothing -> toField $ Identifier n + Just m' -> Many [toField (Identifier m'), Plain ".", toField (Identifier n)] + +instance Hashable QualifiedIdentifier where + hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t) + +-- | @\"foo.bar\"@ will get turned into +-- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get +-- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance +-- is for convenience, and does not match postgres syntax. It +-- only examines the first period character, and thus cannot be used if the +-- qualifying identifier contains a period for example. +instance IsString QualifiedIdentifier where + fromString str = + let (x, y) = T.break (== '.') (fromString str) + in if T.null y + then QualifiedIdentifier Nothing x + else QualifiedIdentifier (Just x) (T.tail y) + +newtype Savepoint = Savepoint Query + deriving (Eq, Ord, Show, Read, Typeable) + +-- | Represents a @VALUES@ table literal, usable as an alternative to +-- 'Database.PostgreSQL.Simple.executeMany' and +-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that +-- you can parametrize more than just a single @VALUES@ expression. +-- For example, here's a query to insert a thing into one table +-- and some attributes of that thing into another, returning the +-- new id generated by the database: +-- +-- +-- > query c [sql| +-- > WITH new_thing AS ( +-- > INSERT INTO thing (name) VALUES (?) RETURNING id +-- > ), new_attributes AS ( +-- > INSERT INTO thing_attributes +-- > SELECT new_thing.id, attrs.* +-- > FROM new_thing JOIN ? attrs ON TRUE +-- > ) SELECT * FROM new_thing +-- > |] ("foo", Values [ "int4", "text" ] +-- > [ ( 1 , "hello" ) +-- > , ( 2 , "world" ) ]) +-- +-- (Note this example uses writable common table expressions, +-- which were added in PostgreSQL 9.1) +-- +-- The second parameter gets expanded into the following SQL syntax: +-- +-- > (VALUES (1::"int4",'hello'::"text"),(2,'world')) +-- +-- When the list of attributes is empty, the second parameter expands to: +-- +-- > (VALUES (null::"int4",null::"text") LIMIT 0) +-- +-- By contrast, @executeMany@ and @returning@ don't issue the query +-- in the empty case, and simply return @0@ and @[]@ respectively. +-- This behavior is usually correct given their intended use cases, +-- but would certainly be wrong in the example above. +-- +-- The first argument is a list of postgresql type names. Because this +-- is turned into a properly quoted identifier, the type name is case +-- sensitive and must be as it appears in the @pg_type@ table. Thus, +-- you must write @timestamptz@ instead of @timestamp with time zone@, +-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@, +-- etcetera. +-- +-- You may omit the type names, however, if you do so the list +-- of values must be non-empty, and postgresql must be able to infer +-- the types of the columns from the surrounding context. If the first +-- condition is not met, hpgsql-simple-compat will throw an exception +-- without issuing the query. In the second case, the postgres server +-- will return an error which will be turned into a @SqlError@ exception. +-- +-- See for +-- more information. +data Values a = Values [QualifiedIdentifier] [a] + deriving (Eq, Ord, Show, Read, Typeable) + +interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] +interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as +{-# INLINE interleaveFoldr #-} + +instance (ToRow a) => ToField (Values a) where + toField (Values types rows) = + case rows of + [] -> case types of + [] -> error norows + (_ : _) -> + values $ + typedRow + (repeat (lit "null")) + types + [lit " LIMIT 0)"] + (_ : _) -> case types of + [] -> values $ untypedRows rows [lit ")"] + (_ : _) -> values $ typedRows rows types [lit ")"] + where + funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action" + norows = funcname ++ " either values or types must be non-empty" + emptyrow = funcname ++ " each row must contain at least one column" + lit = Plain + values x = Many (lit "(VALUES " : x) + + typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action] + typedField (val, typ) rest = val : lit "::" : toField typ : rest + + typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action] + typedRow (val : vals) (typ : typs) rest = + lit "(" + : typedField + (val, typ) + ( interleaveFoldr + typedField + (lit ",") + (lit ")" : rest) + (zip vals typs) + ) + typedRow _ _ _ = error emptyrow + + untypedRow :: [Action] -> [Action] -> [Action] + untypedRow (val : vals) rest = + lit "(" + : val + : interleaveFoldr + (:) + (lit ",") + (lit ")" : rest) + vals + untypedRow _ _ = error emptyrow + + typedRows :: (ToRow a) => [a] -> [QualifiedIdentifier] -> [Action] -> [Action] + typedRows [] _ _ = error funcname + typedRows (val : vals) typs rest = + typedRow (toRow val) typs (multiRows vals rest) + + untypedRows :: (ToRow a) => [a] -> [Action] -> [Action] + untypedRows [] _ = error funcname + untypedRows (val : vals) rest = + untypedRow (toRow val) (multiRows vals rest) + + multiRows :: (ToRow a) => [a] -> [Action] -> [Action] + multiRows vals rest = + interleaveFoldr + (untypedRow . toRow) + (lit ",") + rest + vals