beam-postgres 0.3.2.0 → 0.3.2.2

raw patch · 6 files changed

+331/−15 lines, 6 filesdep ~aesondep ~basedep ~beam-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, base, beam-core

API changes (from Hackage documentation)

Files

• Database/Beam/Postgres.hs +1/−1
• Database/Beam/Postgres/Full.hs +2/−3
• Database/Beam/Postgres/Migrate.hs +3/−1
• Database/Beam/Postgres/PgSpecific.hs +317/−4
• Database/Beam/Postgres/Syntax.hs +6/−3
• beam-postgres.cabal +2/−3

@@ -7,7 +7,7 @@ -- -- @beam-postgres@ supports most beam features as well as many postgres-specific -- features. For example, @beam-postgres@ provides support for full-text search,--- @DISTINCT ON@, JSON handling, postgres @ARRAY@s, and the @MONEY@ type.+-- @DISTINCT ON@, JSON handling, postgres @ARRAY@s, @RANGE@s, and the @MONEY@ type. -- -- The documentation for @beam-postgres@ functionality below indicates which -- postgres function each function or type wraps. Postgres maintains its own

@@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Module providing (almost) full support for Postgres query and data -- manipulation statements. These functions shadow the functions in@@ -63,9 +64,7 @@ -- function. You can combine these values monoidally to combine multiple locks for use with the -- 'withLocks_' function. newtype PgLockedTables s = PgLockedTables [ T.Text ]-instance Monoid (PgLockedTables s) where-  mempty = PgLockedTables []-  mappend (PgLockedTables a) (PgLockedTables b) = PgLockedTables (a <> b)+  deriving (Semigroup, Monoid)  -- | Combines the result of a query along with a set of locked tables. Used as a -- return value for the 'lockingFor_' function.

@@ -66,6 +66,8 @@ import           Data.Typeable #if !MIN_VERSION_base(4, 11, 0) import           Data.Semigroup+#else+import           Data.Monoid (Endo(..)) #endif  -- | Top-level migration backend for use by @beam-migrate@ tools@@ -276,7 +278,7 @@       columnChecks <-        fmap mconcat . forM tbls $ \(oid, tbl) ->-       do columns <- Pg.query conn "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) FROM pg_catalog.pg_attribute att WHERE att.attrelid=? AND att.attnum>0"+       do columns <- Pg.query conn "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) FROM pg_catalog.pg_attribute att WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f'"                        (Pg.Only (oid :: Pg.Oid))           let columnChecks = map (\(nm, typId :: Pg.Oid, typmod, _, typ :: ByteString) ->                                     let typmod' = if typmod == -1 then Nothing else Just (typmod - 4)

@@ -7,6 +7,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE CPP #-} @@ -21,6 +22,7 @@      -- *** @TSQUERY@ data type   , TsQuery(..), (@@)+  , toTsQuery      -- ** @JSON@ and @JSONB@ data types     -- $json@@ -70,6 +72,28 @@    , isSupersetOf_, isSubsetOf_ +    -- ** @RANGE@ types+    -- $ranges+  , PgRange(..), PgRangeBound(..), PgBoundType(..)+  , PgIsRange(..)+  , PgInt4Range, PgInt8Range, PgNumRange+  , PgTsRange, PgTsTzRange, PgDateRange++    -- *** Building ranges from expressions+  , range_+  +    -- *** Building @PgRangeBound@s+  , inclusive, exclusive, unbounded++    -- *** Range operators and functions+  , (-@>-), (-@>), (-<@-), (<@-)+  , (-&&-), (-<<-), (->>-)+  , (-&<-), (-&>-), (--|--)+  , (-+-), (-*-), (-.-)+  , rLower_, rUpper_, isEmpty_+  , lowerInc_, upperInc_, lowerInf_, upperInf_+  , rangeMerge_+       -- ** Postgres functions and aggregates   , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver @@ -112,6 +136,7 @@ import qualified Database.PostgreSQL.Simple.FromField as Pg import qualified Database.PostgreSQL.Simple.ToField as Pg import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg+import qualified Database.PostgreSQL.Simple.Range as Pg  import           GHC.TypeLits import           GHC.Exts hiding (toList)@@ -180,10 +205,10 @@ toTsVector Nothing (QExpr x) =   QExpr (fmap (\(PgExpressionSyntax x') ->                  PgExpressionSyntax $-                 emit "to_tsquery(" <> x' <> emit ")") x)+                 emit "to_tsvector(" <> x' <> emit ")") x) toTsVector (Just (TsVectorConfig configNm)) (QExpr x) =   QExpr (fmap (\(PgExpressionSyntax x') -> PgExpressionSyntax $-                 emit "to_tsquery('" <> escapeString configNm <> emit "', " <> x' <> emit ")") x)+                 emit "to_tsvector('" <> escapeString configNm <> emit "', " <> x' <> emit ")") x)  -- | Determine if the given @TSQUERY@ matches the document represented by the -- @TSVECTOR@. Behaves exactly like the similarly-named operator in postgres.@@ -215,6 +240,19 @@  instance FromBackendRow Postgres TsQuery +-- | The Postgres @to_tsquery@ function. Given a configuration and string,+-- return the @TSQUERY@ that represents the contents of the string.+toTsQuery :: IsSqlExpressionSyntaxStringType PgExpressionSyntax str+           => Maybe TsVectorConfig -> QGenExpr context PgExpressionSyntax s str+           -> QGenExpr context PgExpressionSyntax s TsQuery+toTsQuery Nothing (QExpr x) =+  QExpr (fmap (\(PgExpressionSyntax x') ->+                 PgExpressionSyntax $+                 emit "to_tsquery(" <> x' <> emit ")") x)+toTsQuery (Just (TsVectorConfig configNm)) (QExpr x) =+  QExpr (fmap (\(PgExpressionSyntax x') -> PgExpressionSyntax $+                 emit "to_tsquery('" <> escapeString configNm <> emit "', " <> x' <> emit ")") x)+ -- ** Array operators  -- TODO this should be robust to slices@@ -381,6 +419,264 @@   in QExpr (\t -> let PgExpressionSyntax sub' = sub t                   in PgExpressionSyntax (emit "ARRAY(" <> sub' <> emit ")")) +-- ** Ranges++-- | Represents the types of bounds a range can have. A range can and often does have mis-matched+-- bound types.+data PgBoundType+  = Inclusive+  | Exclusive+  deriving (Show, Generic)+instance Hashable PgBoundType++lBound :: PgBoundType -> ByteString+lBound Inclusive = "["+lBound Exclusive = "("++uBound :: PgBoundType -> ByteString+uBound Inclusive = "]"+uBound Exclusive = ")"++-- | Represents a single bound on a Range. A bound always has a type, but may not have a value+-- (the absense of a value represents unbounded).+data PgRangeBound a = PgRangeBound PgBoundType (Maybe a) deriving (Show, Generic)++inclusive :: a -> PgRangeBound a+inclusive = PgRangeBound Inclusive . Just++exclusive :: a -> PgRangeBound a+exclusive = PgRangeBound Exclusive . Just++unbounded :: PgRangeBound a+unbounded = PgRangeBound Exclusive Nothing++-- | A range of a given Haskell type (represented by @a@) stored as a given Postgres Range Type+-- (represented by @n@).+--+-- A reasonable example might be @Range PgInt8Range Int64@.+-- This represents a range of Haskell @Int64@ values stored as a range of 'bigint' in Postgres.+data PgRange (n :: *) a+  = PgEmptyRange+  | PgRange (PgRangeBound a) (PgRangeBound a)+  deriving (Show, Generic)++instance Hashable a => Hashable (PgRangeBound a)++instance Hashable a => Hashable (PgRange n a)++-- | A class representing Postgres Range types and how to refer to them when speaking to the+-- database.+--+-- For custom Range types, create an uninhabited type, and make it an instance of this class.+class PgIsRange n where+  -- | The range type name in the database.+  rangeName :: ByteString++data PgInt4Range+instance PgIsRange PgInt4Range where+  rangeName = "int4range"++data PgInt8Range+instance PgIsRange PgInt8Range where+  rangeName = "int8range"++data PgNumRange+instance PgIsRange PgNumRange where+  rangeName = "numrange"++data PgTsRange+instance PgIsRange PgTsRange where+  rangeName = "tsrange"++data PgTsTzRange+instance PgIsRange PgTsTzRange where+  rangeName = "tstzrange"++data PgDateRange+instance PgIsRange PgDateRange where+  rangeName = "daterange"++instance (Pg.FromField a, Typeable a, Ord a) => Pg.FromField (PgRange n a) where+  fromField field d = do+    pgR :: Pg.PGRange a <- Pg.fromField field d+    if Pg.isEmpty pgR+    then pure PgEmptyRange+    else let Pg.PGRange lRange rRange = pgR+         in pure $ PgRange (boundConv lRange) (boundConv rRange)++-- According to Postgres docs, there is no such thing as an inclusive infinite bound.+-- https://www.postgresql.org/docs/10/static/rangetypes.html#RANGETYPES-INFINITE+boundConv :: Pg.RangeBound a -> PgRangeBound a+boundConv Pg.NegInfinity = PgRangeBound Exclusive Nothing+boundConv Pg.PosInfinity = PgRangeBound Exclusive Nothing+boundConv (Pg.Inclusive a) = PgRangeBound Inclusive (Just a)+boundConv (Pg.Exclusive a) = PgRangeBound Exclusive (Just a)++instance (Pg.ToField (Pg.PGRange a)) => Pg.ToField (PgRange n a) where+  toField PgEmptyRange = Pg.toField (Pg.empty :: Pg.PGRange a)+  toField (PgRange (PgRangeBound lt lb) (PgRangeBound ut ub)) = Pg.toField r'+    where+      r' = Pg.PGRange lb' ub'+      lb' = case (lt, lb) of (_, Nothing) -> Pg.NegInfinity+                             (Inclusive, Just a) -> Pg.Inclusive a+                             (Exclusive, Just a) -> Pg.Exclusive a+      ub' = case (ut, ub) of (_, Nothing) -> Pg.PosInfinity+                             (Inclusive, Just a) -> Pg.Inclusive a+                             (Exclusive, Just a) -> Pg.Exclusive a++instance HasSqlEqualityCheck PgExpressionSyntax (PgRange n a)+instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgRange n a)++instance (Pg.FromField a, Typeable a, Ord a) => FromBackendRow Postgres (PgRange n a)+instance (HasSqlValueSyntax PgValueSyntax a, PgIsRange n) =>+  HasSqlValueSyntax PgValueSyntax (PgRange n a) where+  sqlValueSyntax PgEmptyRange =+    PgValueSyntax $+    emit "'empty'::" <> escapeIdentifier (rangeName @n)+  sqlValueSyntax (PgRange (PgRangeBound lbt mlBound) (PgRangeBound rbt muBound)) =+    PgValueSyntax $+    escapeIdentifier (rangeName @n) <> pgParens (pgSepBy (emit ", ") [lb, rb, bounds])+    where+      lb = sqlValueSyntax' mlBound+      rb = sqlValueSyntax' muBound+      bounds = emit "'" <> emit (lBound lbt <> uBound rbt) <> emit "'"+      sqlValueSyntax' = fromPgValue . sqlValueSyntax+++binOpDefault :: ByteString+             -> QGenExpr context PgExpressionSyntax s a+             -> QGenExpr context PgExpressionSyntax s b+             -> QGenExpr context PgExpressionSyntax s c+binOpDefault symbol (QExpr r1) (QExpr r2)  = QExpr (pgBinOp symbol <$> r1 <*> r2)++(-@>-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s Bool+(-@>-) = binOpDefault "@>"++(-@>) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s a+      -> QGenExpr context PgExpressionSyntax s Bool+(-@>) = binOpDefault "@>"++(-<@-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s Bool+(-<@-) = binOpDefault "<@"++(<@-) :: QGenExpr context PgExpressionSyntax s a+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s Bool+(<@-) = binOpDefault "<@"++(-&&-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s Bool+(-&&-) = binOpDefault "&&"++(-<<-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s Bool+(-<<-) = binOpDefault "<<"++(->>-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s Bool+(->>-) = binOpDefault ">>"++(-&<-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s Bool+(-&<-) = binOpDefault "&<"++(-&>-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s Bool+(-&>-) = binOpDefault "&>"++(--|--) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+        -> QGenExpr context PgExpressionSyntax s (PgRange n a)+        -> QGenExpr context PgExpressionSyntax s Bool+(--|--) = binOpDefault "-|-"++(-+-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+(-+-) = binOpDefault "+"++(-*-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+(-*-) = binOpDefault "*"++-- | The postgres range operator @-@ .+(-.-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+      -> QGenExpr context PgExpressionSyntax s (PgRange n a)+(-.-) = binOpDefault "-"++defUnaryFn :: ByteString+           -> QGenExpr context PgExpressionSyntax s a+           -> QGenExpr context PgExpressionSyntax s b+defUnaryFn fn (QExpr s) = QExpr (pgExprFrom <$> s)+  where+    pgExprFrom s' = PgExpressionSyntax (emit fn <> emit "(" <> fromPgExpression s' <> emit ")")++rLower_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (Maybe a)+rLower_ = defUnaryFn "LOWER"++rUpper_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+       -> QGenExpr context PgExpressionSyntax s (Maybe a)+rUpper_ = defUnaryFn "UPPER"++isEmpty_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+         -> QGenExpr context PgExpressionSyntax s Bool+isEmpty_ = defUnaryFn "ISEMPTY"++lowerInc_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+          -> QGenExpr context PgExpressionSyntax s Bool+lowerInc_ = defUnaryFn "LOWER_INC"++upperInc_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+          -> QGenExpr context PgExpressionSyntax s Bool+upperInc_ = defUnaryFn "UPPER_INC"++lowerInf_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+          -> QGenExpr context PgExpressionSyntax s Bool+lowerInf_ = defUnaryFn "LOWER_INF"++upperInf_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+          -> QGenExpr context PgExpressionSyntax s Bool+upperInf_ = defUnaryFn "UPPER_INF"++rangeMerge_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)+            -> QGenExpr context PgExpressionSyntax s (PgRange n a)+            -> QGenExpr context PgExpressionSyntax s (PgRange n a)+rangeMerge_ (QExpr r1) (QExpr r2) = QExpr (pgExprFrom <$> r1 <*> r2)+  where+    pgExprFrom r1' r2' =+      PgExpressionSyntax+      (emit "RANGE_MERGE(" <>+       fromPgExpression r1' <>+       emit ", " <>+       fromPgExpression r2' <>+       emit ")")++range_ :: forall n a context s. PgIsRange n+       => PgBoundType -- ^ Lower bound type+       -> PgBoundType -- ^ Upper bound type+       -> QGenExpr context PgExpressionSyntax s (Maybe a) -- ^. Lower bound value+       -> QGenExpr context PgExpressionSyntax s (Maybe a) -- ^. Lower bound value+       -> QGenExpr context PgExpressionSyntax s (PgRange n a)+range_ lbt ubt (QExpr e1) (QExpr e2) = QExpr (pgExprFrom <$> e1 <*> e2)+  where+    bounds = emit "'" <> emit (lBound lbt <> uBound ubt) <> emit "'"+    pgExprFrom e1' e2' =+      PgExpressionSyntax+      (escapeIdentifier (rangeName @n) <>+       pgParens (pgSepBy (emit ", ") [fromPgExpression e1', fromPgExpression e2', bounds]))+ -- ** JSON  -- | The Postgres @JSON@ type, which stores textual values that represent JSON@@ -391,7 +687,7 @@ -- The 'defaultMigratableDbSettings' function automatically assigns the postgres -- @JSON@ type to fields with this type. newtype PgJSON a = PgJSON a-  deriving ( Show, Eq, Ord, Hashable, Monoid )+  deriving ( Show, Eq, Ord, Hashable, Monoid, Semigroup )  instance HasSqlEqualityCheck PgExpressionSyntax (PgJSON a) instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSON a)@@ -416,7 +712,7 @@ -- -- Fields with this type are automatically given the Postgres @JSONB@ type newtype PgJSONB a = PgJSONB a-  deriving ( Show, Eq, Ord, Hashable, Monoid )+  deriving ( Show, Eq, Ord, Hashable, Monoid, Semigroup )  instance HasSqlEqualityCheck PgExpressionSyntax (PgJSONB a) instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSONB a)@@ -977,6 +1273,23 @@ -- -- For more information on Postgres array support, refer to the postgres -- <https://www.postgresql.org/docs/current/static/functions-array.html manual>.++-- $ranges+--+-- Postgres supports storing Range types in columns. There are serveral+-- predefined Range types and users may create their own. @beam-postgres@+-- fully supports these types, including user-defined range types. In general,+-- the names of functions in this section closely match names of the native+-- Postgres functions they map to. As with most beam expression functions,+-- names are suffixed with an underscore and CamelCased. Where ambiguous,+-- functions are prefixed with an @r@. Operators closely match their native+-- Postgres counterparts, except they are prefixed and/or suffixed with an @-@+-- to indicate the expression on that side is a Range. For example @-<\@-@ maps+-- to the native operator @<\@@ when both arguments are Ranges, while @<\@-@ maps+-- to the same operator when the first argument is an element, not a range.+--+-- For more information on Postgres range support, refer to the postgres+-- <https://www.postgresql.org/docs/current/static/rangetypes.html manual>.  -- $json --

@@ -178,11 +178,11 @@   = PgSyntax { buildPgSyntax :: PgSyntaxM () }  instance Semigroup PgSyntax where-  (<>) = mappend+  a <> b = PgSyntax (buildPgSyntax a >> buildPgSyntax b)  instance Monoid PgSyntax where   mempty = PgSyntax (pure ())-  mappend a b = PgSyntax (buildPgSyntax a >> buildPgSyntax b)+  mappend = (<>)  instance Eq PgSyntax where   PgSyntax x == PgSyntax y = (fromF x :: Free PgSyntaxF ()) == fromF y@@ -425,10 +425,13 @@ instance IsSql92DeleteSyntax PgDeleteSyntax where   type Sql92DeleteExpressionSyntax PgDeleteSyntax = PgExpressionSyntax -  deleteStmt tbl where_ =+  deleteStmt tbl alias where_ =     PgDeleteSyntax $     emit "DELETE FROM " <> pgQuotedIdentifier tbl <>+    maybe mempty (\alias_ -> emit " AS " <> pgQuotedIdentifier alias_) alias <>     maybe mempty (\where_ -> emit " WHERE " <> fromPgExpression where_) where_++  deleteSupportsAlias _ = True  instance IsSql92SelectSyntax PgSelectSyntax where   type Sql92SelectSelectTableSyntax PgSelectSyntax = PgSelectTableSyntax

@@ -1,5 +1,5 @@ name:                 beam-postgres-version:              0.3.2.0+version:              0.3.2.2 synopsis:             Connection layer between beam and postgres description:          Beam driver for <https://www.postgresql.org/ PostgreSQL>, an advanced open-source RDBMS homepage:             http://tathougies.github.io/beam/user-guide/backends/beam-postgres@@ -43,7 +43,7 @@                       monad-control        >=1.0  && <1.1,                       mtl                  >=2.1  && <2.3,                       conduit              >=1.2  && <1.4,-                      aeson                >=0.11 && <1.3,+                      aeson                >=0.11 && <1.5,                       uuid-types           >=1.0  && <1.1,                       case-insensitive     >=1.2  && <1.3,                       scientific           >=0.3  && <0.4,@@ -70,4 +70,3 @@   type: git   location: https://github.com/tathougies/beam.git   subdir: beam-postgres-