beam-postgres 0.3.2.3 → 0.4.0.0
raw patch · 19 files changed
+1850/−633 lines, 19 filesdep +attoparsecdep +beam-postgresdep +directorydep ~basedep ~beam-coredep ~beam-migrate
Dependencies added: attoparsec, beam-postgres, directory, filepath, hedgehog, process, tasty, tasty-hunit, temporary, uuid
Dependency ranges changed: base, beam-core, beam-migrate, bytestring, haskell-src-exts, postgresql-simple, text
Files
- Database/Beam/Postgres.hs +9/−9
- Database/Beam/Postgres/Conduit.hs +8/−8
- Database/Beam/Postgres/Connection.hs +81/−98
- Database/Beam/Postgres/CustomTypes.hs +192/−0
- Database/Beam/Postgres/Debug.hs +73/−0
- Database/Beam/Postgres/Extensions.hs +10/−8
- Database/Beam/Postgres/Full.hs +230/−72
- Database/Beam/Postgres/Migrate.hs +134/−57
- Database/Beam/Postgres/PgCrypto.hs +2/−2
- Database/Beam/Postgres/PgSpecific.hs +356/−252
- Database/Beam/Postgres/Syntax.hs +129/−109
- Database/Beam/Postgres/Types.hs +85/−11
- beam-postgres.cabal +27/−7
- test/Database/Beam/Postgres/Test.hs +88/−0
- test/Database/Beam/Postgres/Test/DataTypes.hs +138/−0
- test/Database/Beam/Postgres/Test/Marshal.hs +163/−0
- test/Database/Beam/Postgres/Test/Migrate.hs +72/−0
- test/Database/Beam/Postgres/Test/Select.hs +36/−0
- test/Main.hs +17/−0
Database/Beam/Postgres.hs view
@@ -18,15 +18,8 @@ -- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ its manual>. module Database.Beam.Postgres- (- -- * @beam-postgres@ errors- -- @beam-postgres@ query and data manipulation functions may throw any error- -- thrown by @postgresql-simple@ as well as the following two beam-specific- -- errors.- PgRowReadError(..), PgError(..)-- -- * Beam Postgres backend- , Postgres(..), Pg+ ( -- * Beam Postgres backend+ Postgres(..), Pg -- ** Postgres syntax , PgCommandSyntax, PgSyntax@@ -55,6 +48,12 @@ , pgCreateExtension, pgDropExtension , getPgExtension + -- ** Debug support++ , PgDebugStmt+ , pgTraceStmtIO, pgTraceStmtIO'+ , pgTraceStmt+ -- * @postgresql-simple@ re-exports , Pg.ResultError(..), Pg.SqlError(..)@@ -77,5 +76,6 @@ import Database.Beam.Postgres.Extensions ( PgExtensionEntity, IsPgExtension(..) , pgCreateExtension, pgDropExtension , getPgExtension )+import Database.Beam.Postgres.Debug import qualified Database.PostgreSQL.Simple as Pg
Database/Beam/Postgres/Conduit.hs view
@@ -39,7 +39,7 @@ -- | Run a PostgreSQL @SELECT@ statement in any 'MonadIO'. runSelect :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a )- => Pg.Connection -> SqlSelect PgSelectSyntax a+ => Pg.Connection -> SqlSelect Postgres a -> (CONDUIT_TRANSFORMER () a m () -> m b) -> m b runSelect conn (SqlSelect (PgSelectSyntax syntax)) withSrc = runQueryReturning conn syntax withSrc@@ -49,14 +49,14 @@ -- | Run a PostgreSQL @INSERT@ statement in any 'MonadIO'. Returns the number of -- rows affected. runInsert :: MonadIO m- => Pg.Connection -> SqlInsert PgInsertSyntax -> m Int64+ => Pg.Connection -> SqlInsert Postgres tbl -> m Int64 runInsert _ SqlInsertNoRows = pure 0-runInsert conn (SqlInsert (PgInsertSyntax i)) =+runInsert conn (SqlInsert _ (PgInsertSyntax i)) = executeStatement conn i -- | Run a PostgreSQL @INSERT ... RETURNING ...@ statement in any 'MonadIO' and -- get a 'C.Source' of the newly inserted rows.-runInsertReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a)+runInsertReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a ) => Pg.Connection -> PgInsertReturning a -> (CONDUIT_TRANSFORMER () a m () -> m b)@@ -70,9 +70,9 @@ -- | Run a PostgreSQL @UPDATE@ statement in any 'MonadIO'. Returns the number of -- rows affected. runUpdate :: MonadIO m- => Pg.Connection -> SqlUpdate PgUpdateSyntax tbl -> m Int64+ => Pg.Connection -> SqlUpdate Postgres tbl -> m Int64 runUpdate _ SqlIdentityUpdate = pure 0-runUpdate conn (SqlUpdate (PgUpdateSyntax i)) =+runUpdate conn (SqlUpdate _ (PgUpdateSyntax i)) = executeStatement conn i -- | Run a PostgreSQL @UPDATE ... RETURNING ...@ statement in any 'MonadIO' and@@ -91,9 +91,9 @@ -- | Run a PostgreSQL @DELETE@ statement in any 'MonadIO'. Returns the number of -- rows affected. runDelete :: MonadIO m- => Pg.Connection -> SqlDelete PgDeleteSyntax tbl+ => Pg.Connection -> SqlDelete Postgres tbl -> m Int64-runDelete conn (SqlDelete (PgDeleteSyntax d)) =+runDelete conn (SqlDelete _ (PgDeleteSyntax d)) = executeStatement conn d -- | Run a PostgreSQl @DELETE ... RETURNING ...@ statement in any
Database/Beam/Postgres/Connection.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-partial-type-signatures #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -12,8 +13,7 @@ {-# LANGUAGE CPP #-} module Database.Beam.Postgres.Connection- ( PgRowReadError(..), PgError(..)- , Pg(..), PgF(..)+ ( Pg(..), PgF(..) , runBeamPostgres, runBeamPostgresDebug @@ -23,16 +23,17 @@ , postgresUriSyntax ) where -import Control.Exception (Exception, throwIO)+import Control.Exception (SomeException(..), throwIO) import Control.Monad.Free.Church import Control.Monad.IO.Class import Database.Beam hiding (runDelete, runUpdate, runInsert, insert)-import Database.Beam.Schema.Tables-import Database.Beam.Backend.SQL import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Backend.SQL.Row ( FromBackendRowF(..), FromBackendRowM(..)+ , BeamRowReadError(..), ColumnParseError(..) ) import Database.Beam.Backend.URI import Database.Beam.Query.Types (QGenExpr(..))+import Database.Beam.Schema.Tables import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Full@@ -48,7 +49,7 @@ , exec, throwResultError ) import qualified Database.PostgreSQL.Simple.Internal as PgI import qualified Database.PostgreSQL.Simple.Ok as Pg-import qualified Database.PostgreSQL.Simple.Types as Pg (Null(..), Query(..))+import qualified Database.PostgreSQL.Simple.Types as Pg (Query(..)) import Control.Monad.Reader import Control.Monad.State@@ -58,10 +59,16 @@ import Data.ByteString (ByteString) import Data.ByteString.Builder (toLazyByteString, byteString) import qualified Data.ByteString.Lazy as BL+import Data.Maybe (listToMaybe, fromMaybe) import Data.Proxy import Data.String import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8)+#if MIN_VERSION_base(4,12,0)+import Data.Typeable (cast)+#else+import Data.Typeable (cast, typeOf)+#endif #if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup #endif@@ -70,23 +77,16 @@ import Network.URI (uriToString) --- | Errors that may arise while using the 'Pg' monad.-data PgError- = PgRowParseError PgRowReadError- | PgInternalError String- deriving Show-instance Exception PgError--data PgStream a = PgStreamDone (Either PgError a)+data PgStream a = PgStreamDone (Either BeamRowReadError a) | PgStreamContinue (Maybe PgI.Row -> IO (PgStream a)) -- | 'BeamURIOpeners' for the standard @postgresql:@ URI scheme. See the -- postgres documentation for more details on the formatting. See documentation -- for 'BeamURIOpeners' for more information on how to use this with beam-postgresUriSyntax :: c PgCommandSyntax Postgres Pg.Connection Pg+postgresUriSyntax :: c Postgres Pg.Connection Pg -> BeamURIOpeners c postgresUriSyntax =- mkUriOpener "postgresql:"+ mkUriOpener runBeamPostgres "postgresql:" (\uri -> do let pgConnStr = fromString (uriToString id uri "") hdl <- Pg.connectPostgreSQL pgConnStr@@ -123,21 +123,6 @@ -- * Run row readers --- | An error that may occur while parsing a row-data PgRowReadError- = PgRowReadNoMoreColumns !CInt !CInt- -- ^ We attempted to read more columns than postgres returned. First- -- argument is the zero-based index of the column we attempted to read,- -- and the second is the total number of columns- | PgRowCouldNotParseField !CInt- -- ^ There was an error while parsing the field. The first argument gives- -- the zero-based index of the column that could not have been- -- parsed. This is usually caused by your Haskell schema type being- -- incompatible with the one in the database.- deriving Show--instance Exception PgRowReadError- getFields :: Pg.Result -> IO [Pg.Field] getFields res = do Pg.Col colCount <- Pg.nfields res@@ -148,52 +133,56 @@ mapM getField [0..colCount - 1] runPgRowReader ::- Pg.Connection -> Pg.Row -> Pg.Result -> [Pg.Field] -> FromBackendRowM Postgres a -> IO (Either PgRowReadError a)-runPgRowReader conn rowIdx res fields readRow =+ Pg.Connection -> Pg.Row -> Pg.Result -> [Pg.Field] -> FromBackendRowM Postgres a -> IO (Either BeamRowReadError a)+runPgRowReader conn rowIdx res fields (FromBackendRowM readRow) = Pg.nfields res >>= \(Pg.Col colCount) -> runF readRow finish step 0 colCount fields where- step (ParseOneField _) curCol colCount [] = pure (Left (PgRowReadNoMoreColumns curCol colCount))- step (ParseOneField _) curCol colCount _- | curCol >= colCount = pure (Left (PgRowReadNoMoreColumns curCol colCount))- step (ParseOneField next) curCol colCount remainingFields =- let next' Nothing _ _ _ = pure (Left (PgRowCouldNotParseField curCol))- next' (Just {}) _ _ [] = fail "Internal error"- next' (Just x) curCol' colCount' (_:remainingFields') = next x (curCol' + 1) colCount' remainingFields'- in step (PeekField next') curCol colCount remainingFields - step (PeekField next) curCol colCount [] = next Nothing curCol colCount []- step (PeekField next) curCol colCount remainingFields- | curCol >= colCount = next Nothing curCol colCount remainingFields- step (PeekField next) curCol colCount remainingFields@(field:_) =+ step :: forall x. FromBackendRowF Postgres (CInt -> CInt -> [PgI.Field] -> IO (Either BeamRowReadError x))+ -> CInt -> CInt -> [PgI.Field] -> IO (Either BeamRowReadError x)+ step (ParseOneField _) curCol colCount [] = pure (Left (BeamRowReadError (Just (fromIntegral curCol)) (ColumnNotEnoughColumns (fromIntegral colCount))))+ step (ParseOneField _) curCol colCount _+ | curCol >= colCount = pure (Left (BeamRowReadError (Just (fromIntegral curCol)) (ColumnNotEnoughColumns (fromIntegral colCount))))+ step (ParseOneField (next' :: next -> _)) curCol colCount (field:remainingFields) = do fieldValue <- Pg.getvalue res rowIdx (Pg.Col curCol) res' <- Pg.runConversion (Pg.fromField field fieldValue) conn case res' of- Pg.Errors {} -> next Nothing curCol colCount remainingFields- Pg.Ok x -> next (Just x) curCol colCount remainingFields-- step (CheckNextNNull n next) curCol colCount remainingFields =- doCheckNextN (fromIntegral n) (curCol :: CInt) (colCount :: CInt) remainingFields >>= \yes ->- next yes (curCol + if yes then fromIntegral n else 0) colCount (if yes then drop (fromIntegral n) remainingFields else remainingFields)+ Pg.Errors errs ->+ let err = fromMaybe (ColumnErrorInternal "Column parse failed with unknown exception") $+ listToMaybe $+ do SomeException e <- errs+ Just pgErr <- pure (cast e)+ case pgErr of+ Pg.ConversionFailed { Pg.errSQLType = sql+ , Pg.errHaskellType = hs+ , Pg.errMessage = msg } ->+ pure (ColumnTypeMismatch hs sql msg)+ Pg.Incompatible { Pg.errSQLType = sql+ , Pg.errHaskellType = hs+ , Pg.errMessage = msg } ->+ pure (ColumnTypeMismatch hs sql msg)+ Pg.UnexpectedNull {} ->+ pure ColumnUnexpectedNull+ in pure (Left (BeamRowReadError (Just (fromIntegral curCol)) err))+ Pg.Ok x -> next' x (curCol + 1) colCount remainingFields - doCheckNextN 0 _ _ _ = pure False- doCheckNextN n curCol colCount remainingFields- | curCol + n > colCount = pure False- | otherwise =- let fieldsInQuestion = zip [curCol..] (take (fromIntegral n) remainingFields)- in readAndCheck fieldsInQuestion+ step (Alt (FromBackendRowM a) (FromBackendRowM b) next) curCol colCount cols =+ do aRes <- runF a (\x curCol' colCount' cols' -> pure (Right (next x curCol' colCount' cols'))) step curCol colCount cols+ case aRes of+ Right next' -> next'+ Left aErr -> do+ bRes <- runF b (\x curCol' colCount' cols' -> pure (Right (next x curCol' colCount' cols'))) step curCol colCount cols+ case bRes of+ Right next' -> next'+ Left {} -> pure (Left aErr) - readAndCheck [] = pure True- readAndCheck ((i, field):xs) =- do fieldValue <- Pg.getvalue res rowIdx (Pg.Col i)- res' <- Pg.runConversion (Pg.fromField field fieldValue) conn- case res' of- Pg.Errors _ -> pure False- Pg.Ok Pg.Null -> readAndCheck xs+ step (FailParseWith err) _ _ _ =+ pure (Left err) finish x _ _ _ = pure (Right x) -withPgDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO (Either PgError a)+withPgDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO (Either BeamRowReadError a) withPgDebug dbg conn (Pg action) = let finish x = pure (Right x) step (PgLiftIO io next) = io >>= next@@ -236,13 +225,13 @@ let Pg process = mkProcess (Pg (liftF (PgFetchNext id))) runF process next stepReturningNone - stepReturningNone :: forall a. PgF (IO (Either PgError a)) -> IO (Either PgError a)+ stepReturningNone :: forall a. PgF (IO (Either BeamRowReadError a)) -> IO (Either BeamRowReadError a) stepReturningNone (PgLiftIO action' next) = action' >>= next stepReturningNone (PgLiftWithHandle withConn next) = withConn conn >>= next stepReturningNone (PgFetchNext next) = next Nothing- stepReturningNone (PgRunReturning _ _ _) = pure (Left (PgInternalError "Nested queries not allowed"))+ stepReturningNone (PgRunReturning _ _ _) = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))) - stepReturningList :: forall a. Pg.Result -> PgF (CInt -> IO (Either PgError a)) -> CInt -> IO (Either PgError a)+ stepReturningList :: forall a. Pg.Result -> PgF (CInt -> IO (Either BeamRowReadError a)) -> CInt -> IO (Either BeamRowReadError a) stepReturningList _ (PgLiftIO action' next) rowIdx = action' >>= \x -> next x rowIdx stepReturningList res (PgFetchNext next) rowIdx = do fields <- getFields res@@ -250,10 +239,10 @@ if rowIdx >= rowCount then next Nothing rowIdx else runPgRowReader conn (Pg.Row rowIdx) res fields fromBackendRow >>= \case- Left err -> pure (Left (PgRowParseError err))+ Left err -> pure (Left err) Right r -> next (Just r) (rowIdx + 1)- stepReturningList _ (PgRunReturning _ _ _) _ = pure (Left (PgInternalError "Nested queries not allowed"))- stepReturningList _ (PgLiftWithHandle {}) _ = pure (Left (PgInternalError "Nested queries not allowed"))+ stepReturningList _ (PgRunReturning _ _ _) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))+ stepReturningList _ (PgLiftWithHandle {}) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))) finishProcess :: forall a. a -> Maybe PgI.Row -> IO (PgStream a) finishProcess x _ = pure (PgStreamDone (Right x))@@ -267,15 +256,15 @@ Just (PgI.Row rowIdx res') -> getFields res' >>= \fields -> runPgRowReader conn rowIdx res' fields fromBackendRow >>= \case- Left err -> pure (PgStreamDone (Left (PgRowParseError err)))+ Left err -> pure (PgStreamDone (Left err)) Right r -> next (Just r) Nothing stepProcess (PgFetchNext next) (Just (PgI.Row rowIdx res)) = getFields res >>= \fields -> runPgRowReader conn rowIdx res fields fromBackendRow >>= \case- Left err -> pure (PgStreamDone (Left (PgRowParseError err)))+ Left err -> pure (PgStreamDone (Left err)) Right r -> pure (PgStreamContinue (next (Just r)))- stepProcess (PgRunReturning _ _ _) _ = pure (PgStreamDone (Left (PgInternalError "Nested queries not allowed")))- stepProcess (PgLiftWithHandle _ _) _ = pure (PgStreamDone (Left (PgInternalError "Nested queries not allowed")))+ stepProcess (PgRunReturning _ _ _) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))))+ stepProcess (PgLiftWithHandle _ _) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))) runConsumer :: forall a. PgStream a -> PgI.Row -> IO (PgStream a) runConsumer s@(PgStreamDone {}) _ = pure s@@ -317,19 +306,15 @@ runBeamPostgres :: Pg.Connection -> Pg a -> IO a runBeamPostgres = runBeamPostgresDebug (\_ -> pure ()) -instance MonadBeam PgCommandSyntax Postgres Pg.Connection Pg where- withDatabase = runBeamPostgres- withDatabaseDebug = runBeamPostgresDebug-+instance MonadBeam Postgres Pg where runReturningMany cmd consume = liftF (PgRunReturning cmd consume id) -instance MonadBeamInsertReturning PgCommandSyntax Postgres Pg.Connection Pg where- runInsertReturningList tbl values = do- let insertReturningCmd' =- insertReturning tbl values onConflictDefault- (Just (changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr PgExpressionSyntax PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr PgExpressionSyntax ()) ty)))+instance MonadBeamInsertReturning Postgres Pg where+ runInsertReturningList i = do+ let insertReturningCmd' = i `returning`+ changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) -- Make savepoint case insertReturningCmd' of@@ -338,12 +323,11 @@ PgInsertReturning insertReturningCmd -> runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning insertReturningCmd) -instance MonadBeamUpdateReturning PgCommandSyntax Postgres Pg.Connection Pg where- runUpdateReturningList tbl mkAssignments mkWhere = do- let updateReturningCmd' =- updateReturning tbl mkAssignments mkWhere- (changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr PgExpressionSyntax PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr PgExpressionSyntax ()) ty))+instance MonadBeamUpdateReturning Postgres Pg where+ runUpdateReturningList u = do+ let updateReturningCmd' = u `returning`+ changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) case updateReturningCmd' of PgUpdateReturningEmpty ->@@ -351,11 +335,10 @@ PgUpdateReturning updateReturningCmd -> runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning updateReturningCmd) -instance MonadBeamDeleteReturning PgCommandSyntax Postgres Pg.Connection Pg where- runDeleteReturningList tbl mkWhere = do- let PgDeleteReturning deleteReturningCmd =- deleteReturning tbl mkWhere- (changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr PgExpressionSyntax PostgresInaccessible) ty) ->- Columnar' (QExpr s) :: Columnar' (QExpr PgExpressionSyntax ()) ty))+instance MonadBeamDeleteReturning Postgres Pg where+ runDeleteReturningList d = do+ let PgDeleteReturning deleteReturningCmd = d `returning`+ changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+ Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning deleteReturningCmd)
+ Database/Beam/Postgres/CustomTypes.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE EmptyCase #-}+module Database.Beam.Postgres.CustomTypes+ ( PgType, PgTypeCheck(..)+ , PgDataTypeSchema++ , IsPgCustomDataType(..)++ , PgHasEnum(..)++ , HasSqlValueSyntax, FromBackendRow++ , pgCustomEnumSchema, pgBoundedEnumSchema++ , pgCustomEnumActionProvider+ , pgCreateEnumActionProvider+ , pgDropEnumActionProvider++ , pgChecksForTypeSchema++ , pgEnumValueSyntax, pgParseEnum++ , createEnum+ , beamTypeForCustomPg+ ) where++import Database.Beam+import Database.Beam.Schema.Tables+import Database.Beam.Backend.SQL+import Database.Beam.Migrate+import Database.Beam.Postgres.Types+import Database.Beam.Postgres.Syntax++import Control.Monad+import Control.Monad.Free.Church+import Data.Aeson (object, (.=))+import qualified Data.ByteString.Char8 as BC+import Data.Functor.Const+import qualified Data.HashSet as HS+import Data.Proxy (Proxy(..))+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif+import Data.Text (Text)+import qualified Data.Text.Encoding as TE++import qualified Database.PostgreSQL.Simple.FromField as Pg++data PgType a+newtype PgTypeCheck = PgTypeCheck (Text -> SomeDatabasePredicate)++data PgDataTypeSchema a where+ PgDataTypeEnum :: HasSqlValueSyntax PgValueSyntax a => [a] -> PgDataTypeSchema a++class IsPgCustomDataType a where+ pgDataTypeName :: Proxy a -> Text+ pgDataTypeDescription :: PgDataTypeSchema a++pgCustomEnumSchema :: HasSqlValueSyntax PgValueSyntax a => [a] -> PgDataTypeSchema a+pgCustomEnumSchema = PgDataTypeEnum++pgBoundedEnumSchema :: ( Enum a, Bounded a, HasSqlValueSyntax PgValueSyntax a )+ => PgDataTypeSchema a+pgBoundedEnumSchema = pgCustomEnumSchema [minBound..maxBound]++pgCustomEnumActionProvider :: ActionProvider Postgres+pgCustomEnumActionProvider = pgCreateEnumActionProvider <> pgDropEnumActionProvider++pgCreateEnumActionProvider :: ActionProvider Postgres+pgCreateEnumActionProvider =+ ActionProvider $ \findPre findPost ->+ do enumP@(PgHasEnum nm vals) <- findPost+ ensuringNot_ $+ do (PgHasEnum beforeNm _) <- findPre+ guard (beforeNm == nm)++ let cmd = pgCreateEnumSyntax nm (fmap sqlValueSyntax vals)+ pure (PotentialAction mempty (HS.fromList [p enumP])+ (pure (MigrationCommand cmd MigrationKeepsData))+ ("Create the enumeration " <> nm) 1)++pgDropEnumActionProvider :: ActionProvider Postgres+pgDropEnumActionProvider =+ ActionProvider $ \findPre findPost ->+ do enumP@(PgHasEnum nm _) <- findPre+ ensuringNot_ $+ do (PgHasEnum afterNm _) <- findPost+ guard (afterNm == nm)++ let cmd = pgDropTypeSyntax nm+ pure (PotentialAction (HS.fromList [p enumP]) mempty+ (pure (MigrationCommand cmd MigrationKeepsData))+ ("Drop the enumeration type " <> nm) 1)++pgChecksForTypeSchema :: PgDataTypeSchema a -> [ PgTypeCheck ]+pgChecksForTypeSchema (PgDataTypeEnum vals) =+ let valTxts = map encodeToString vals++ -- TODO better reporting+ encodeToString val =+ let PgValueSyntax (PgSyntax syntax) = sqlValueSyntax val+ in runF syntax (\_ -> error "Expecting a simple text encoding for enumeration type")+ (\case+ EmitByteString "'" next -> next+ EscapeString s _ -> TE.decodeUtf8 s -- TODO Make this more robust+ _ -> error "Expecting a simple text encoding for enumeration type")+ in [ PgTypeCheck (\nm -> p (PgHasEnum nm valTxts)) ]++instance IsDatabaseEntity Postgres (PgType a) where++ data DatabaseEntityDescriptor Postgres (PgType a) where+ PgTypeDescriptor :: Maybe Text -> Text -> PgDataTypeSyntax+ -> DatabaseEntityDescriptor Postgres (PgType a)++ type DatabaseEntityDefaultRequirements Postgres (PgType a) =+ ( HasSqlValueSyntax PgValueSyntax a+ , FromBackendRow Postgres a+ , IsPgCustomDataType a)++ type DatabaseEntityRegularRequirements Postgres (PgType a) =+ ( HasSqlValueSyntax PgValueSyntax a+ , FromBackendRow Postgres a )++ dbEntityName f (PgTypeDescriptor sch nm ty) = (\nm' -> PgTypeDescriptor sch nm' ty) <$> f nm+ dbEntitySchema f (PgTypeDescriptor sch nm ty) = PgTypeDescriptor <$> f sch <*> pure nm <*> pure ty+ dbEntityAuto _ = PgTypeDescriptor Nothing typeName+ (PgDataTypeSyntax (PgDataTypeDescrDomain typeName)+ (pgQuotedIdentifier typeName)+ (pgDataTypeJSON (object [ "customType" .= typeName])))+ where+ typeName = pgDataTypeName (Proxy @a)++instance IsCheckedDatabaseEntity Postgres (PgType a) where+ data CheckedDatabaseEntityDescriptor Postgres (PgType a) where+ CheckedPgTypeDescriptor :: DatabaseEntityDescriptor Postgres (PgType a)+ -> [ PgTypeCheck ]+ -> CheckedDatabaseEntityDescriptor Postgres (PgType a)+ type CheckedDatabaseEntityDefaultRequirements Postgres (PgType a) =+ DatabaseEntityDefaultRequirements Postgres (PgType a)++ unChecked f (CheckedPgTypeDescriptor ty d) = fmap (\ty' -> CheckedPgTypeDescriptor ty' d) (f ty)+ collectEntityChecks (CheckedPgTypeDescriptor e chks) =+ fmap (\(PgTypeCheck mkCheck) -> mkCheck (getConst (dbEntityName Const e))) chks+ checkedDbEntityAuto nm = CheckedPgTypeDescriptor (dbEntityAuto nm)+ (pgChecksForTypeSchema (pgDataTypeDescription @a))++instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor Postgres (PgType a))) where+ renamingFields _ = FieldRenamer id++createEnum :: forall a db+ . ( HasSqlValueSyntax PgValueSyntax a+ , Enum a, Bounded a )+ => Text -> Migration Postgres (CheckedDatabaseEntity Postgres db (PgType a))+createEnum nm = do+ upDown (pgCreateEnumSyntax nm (fmap sqlValueSyntax [minBound..(maxBound::a)]))+ (Just (pgDropTypeSyntax nm))++ let tyDesc = PgTypeDescriptor Nothing nm $+ PgDataTypeSyntax (PgDataTypeDescrDomain nm)+ (pgQuotedIdentifier nm)+ (pgDataTypeJSON (object [ "customType" .= nm ]))++ pure (CheckedDatabaseEntity+ (CheckedPgTypeDescriptor tyDesc+ (pgChecksForTypeSchema (PgDataTypeEnum [minBound..maxBound::a])))+ [])+++pgEnumValueSyntax :: (a -> String) -> a -> PgValueSyntax+pgEnumValueSyntax namer = sqlValueSyntax . namer++newtype PgRawString = PgRawString String+instance FromBackendRow Postgres PgRawString+instance Pg.FromField PgRawString where+ fromField f Nothing = Pg.returnError Pg.UnexpectedNull f "When parsing enumeration string"+ fromField _ (Just d) = pure (PgRawString (BC.unpack d))++pgParseEnum :: (Enum a, Bounded a) => (a -> String)+ -> FromBackendRowM Postgres a+pgParseEnum namer =+ let allNames = map (\x -> (namer x, x)) [minBound..maxBound]+ in do+ PgRawString name <- fromBackendRow+ case lookup name allNames of+ Nothing -> fail ("Invalid postgres enumeration value: " ++ name)+ Just v -> pure v++beamTypeForCustomPg :: CheckedDatabaseEntity Postgres db (PgType a) -> DataType Postgres a+beamTypeForCustomPg (CheckedDatabaseEntity (CheckedPgTypeDescriptor (PgTypeDescriptor _ _ dt) _) _)+ = DataType dt
+ Database/Beam/Postgres/Debug.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE PolyKinds #-}+module Database.Beam.Postgres.Debug where++import Database.Beam.Query+import Database.Beam.Postgres.Types (Postgres(..))+import Database.Beam.Postgres.Connection+ ( Pg, PgF(..)+ , pgRenderSyntax )+import Database.Beam.Postgres.Full+ ( PgInsertReturning(..)+ , PgUpdateReturning(..)+ , PgDeleteReturning(..) )+import Database.Beam.Postgres.Syntax+ ( PgSyntax+ , PgSelectSyntax(..)+ , PgInsertSyntax(..)+ , PgUpdateSyntax(..)+ , PgDeleteSyntax(..) )++import Control.Monad.Free ( liftF )++import qualified Data.ByteString.Char8 as BC+import Data.Maybe (maybe)++import qualified Database.PostgreSQL.Simple as Pg++-- | Type class for @Sql*@ types that can be turned into Postgres+-- syntax, for use in the following debugging functions+--+-- These include+--+-- * 'SqlSelect'+-- * 'SqlInsert'+-- * 'SqlUpdate'+-- * 'SqlDelete'+-- * 'PgInsertReturning'+-- * 'PgUpdateReturning'+-- * 'PgDeleteReturning'+class PgDebugStmt statement where+ pgStmtSyntax :: statement -> Maybe PgSyntax++instance PgDebugStmt (SqlSelect Postgres a) where+ pgStmtSyntax (SqlSelect (PgSelectSyntax e)) = Just e+instance PgDebugStmt (SqlInsert Postgres a) where+ pgStmtSyntax SqlInsertNoRows = Nothing+ pgStmtSyntax (SqlInsert _ (PgInsertSyntax e)) = Just e+instance PgDebugStmt (SqlUpdate Postgres a) where+ pgStmtSyntax SqlIdentityUpdate = Nothing+ pgStmtSyntax (SqlUpdate _ (PgUpdateSyntax e)) = Just e+instance PgDebugStmt (SqlDelete Postgres a) where+ pgStmtSyntax (SqlDelete _ (PgDeleteSyntax e)) = Just e+instance PgDebugStmt (PgInsertReturning a) where+ pgStmtSyntax PgInsertReturningEmpty = Nothing+ pgStmtSyntax (PgInsertReturning e) = Just e+instance PgDebugStmt (PgUpdateReturning a) where+ pgStmtSyntax PgUpdateReturningEmpty = Nothing+ pgStmtSyntax (PgUpdateReturning e) = Just e+instance PgDebugStmt (PgDeleteReturning a) where+ pgStmtSyntax (PgDeleteReturning e) = Just e++pgTraceStmtIO :: PgDebugStmt statement => Pg.Connection -> statement -> IO ()+pgTraceStmtIO conn s =+ BC.putStrLn =<< pgTraceStmtIO' conn s++pgTraceStmtIO' :: PgDebugStmt statement => Pg.Connection -> statement -> IO BC.ByteString+pgTraceStmtIO' conn stmt =+ let syntax = pgStmtSyntax stmt+ in maybe (return (BC.pack "(no statement)")) (pgRenderSyntax conn) syntax++pgTraceStmt :: PgDebugStmt statement => statement -> Pg ()+pgTraceStmt stmt =+ liftF (PgLiftWithHandle (flip pgTraceStmtIO stmt) id)+
Database/Beam/Postgres/Extensions.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} -- | Postgres extensions are run-time loadable plugins that can extend Postgres@@ -104,18 +105,19 @@ ( IsPgExtension extension ) dbEntityName f (PgDatabaseExtension nm ext) = fmap (\nm' -> PgDatabaseExtension nm' ext) (f nm)+ dbEntitySchema _ n = pure n dbEntityAuto _ = PgDatabaseExtension (pgExtensionName (Proxy @extension)) pgExtensionBuild instance IsCheckedDatabaseEntity Postgres (PgExtensionEntity extension) where newtype CheckedDatabaseEntityDescriptor Postgres (PgExtensionEntity extension) = CheckedPgExtension (DatabaseEntityDescriptor Postgres (PgExtensionEntity extension))- type CheckedDatabaseEntityDefaultRequirements Postgres (PgExtensionEntity extension) syntax =+ type CheckedDatabaseEntityDefaultRequirements Postgres (PgExtensionEntity extension) = DatabaseEntityRegularRequirements Postgres (PgExtensionEntity extension) - unCheck (CheckedPgExtension ext) = ext+ unChecked f (CheckedPgExtension ext) = CheckedPgExtension <$> f ext collectEntityChecks (CheckedPgExtension (PgDatabaseExtension {})) = [ SomeDatabasePredicate (PgHasExtension (pgExtensionName (Proxy @extension))) ]- checkedDbEntityAuto _ = CheckedPgExtension . dbEntityAuto+ checkedDbEntityAuto = CheckedPgExtension . dbEntityAuto -- | Get the extension record from a database entity. See the documentation for -- 'PgExtensionEntity'.@@ -135,9 +137,9 @@ -- 'DatabaseEntity'. pgCreateExtension :: forall extension db . IsPgExtension extension- => Migration PgCommandSyntax (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension))+ => Migration Postgres (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension)) pgCreateExtension =- let entity = checkedDbEntityAuto (Proxy @PgCommandSyntax) ""+ let entity = checkedDbEntityAuto "" extName = pgExtensionName (Proxy @extension) in upDown (pgCreateExtensionSyntax extName) Nothing >> pure (CheckedDatabaseEntity entity (collectEntityChecks entity))@@ -147,7 +149,7 @@ -- Unfortunately, without linear types, we cannot check this. pgDropExtension :: forall extension . CheckedDatabaseEntityDescriptor Postgres (PgExtensionEntity extension)- -> Migration PgCommandSyntax ()+ -> Migration Postgres () pgDropExtension (CheckedPgExtension (PgDatabaseExtension {})) = upDown (pgDropExtensionSyntax (pgExtensionName (Proxy @extension))) Nothing @@ -165,10 +167,10 @@ serializePredicate (PgHasExtension nm) = object [ "has-postgres-extension" .= nm ] -pgExtensionActionProvider :: ActionProvider PgCommandSyntax+pgExtensionActionProvider :: ActionProvider Postgres pgExtensionActionProvider = pgCreateExtensionProvider <> pgDropExtensionProvider -pgCreateExtensionProvider, pgDropExtensionProvider :: ActionProvider PgCommandSyntax+pgCreateExtensionProvider, pgDropExtensionProvider :: ActionProvider Postgres pgCreateExtensionProvider = ActionProvider $ \findPre findPost ->
Database/Beam/Postgres/Full.hs view
@@ -18,8 +18,13 @@ , locked_, lockAll_, withLocks_ + -- ** Lateral joins+ , lateral_+ -- * @INSERT@ and @INSERT RETURNING@ , insert, insertReturning+ , insertDefaults+ , runPgInsertReturningList , PgInsertReturning(..) @@ -36,11 +41,16 @@ -- * @UPDATE RETURNING@ , PgUpdateReturning(..)+ , runPgUpdateReturningList , updateReturning -- * @DELETE RETURNING@ , PgDeleteReturning(..)+ , runPgDeleteReturningList , deleteReturning++ -- * Generalized @RETURNING@+ , PgReturning(..) ) where import Database.Beam hiding (insert, insertValues)@@ -52,7 +62,10 @@ import Database.Beam.Postgres.Syntax import Control.Monad.Free.Church+import Control.Monad.Writer (execWriter, tell) +import Data.Functor.Const+import Data.Proxy (Proxy(..)) import qualified Data.Text as T #if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup@@ -69,10 +82,13 @@ -- | Combines the result of a query along with a set of locked tables. Used as a -- return value for the 'lockingFor_' function. data PgWithLocking s a = PgWithLocking (PgLockedTables s) a-instance ProjectibleWithPredicate c syntax a => ProjectibleWithPredicate c syntax (PgWithLocking s a) where- project' p mutateM (PgWithLocking tbls a) =- PgWithLocking tbls <$> project' p mutateM a+instance ProjectibleWithPredicate c be res a => ProjectibleWithPredicate c be res (PgWithLocking s a) where+ project' p be mutateM (PgWithLocking tbls a) =+ PgWithLocking tbls <$> project' p be mutateM a + projectSkeleton' ctxt be mkM =+ PgWithLocking mempty <$> projectSkeleton' ctxt be mkM+ -- | Use with 'lockingFor_' to lock all tables mentioned in the query lockAll_ :: a -> PgWithLocking s a lockAll_ = PgWithLocking mempty@@ -85,11 +101,14 @@ -- | Join with a table while locking it explicitly. Provides a 'PgLockedTables' value that can be -- used with 'withLocks_' to explicitly lock a table during a @SELECT@ statement-locked_ :: Database Postgres db+locked_ :: (Beamable tbl, Database Postgres db) => DatabaseEntity Postgres db (TableEntity tbl)- -> Q PgSelectSyntax db s (PgLockedTables s, tbl (QExpr PgExpressionSyntax s))-locked_ (DatabaseEntity (DatabaseTable tblNm tblSettings)) = do- (nm, joined) <- Q (liftF (QAll (\_ -> fromTable (tableNamed tblNm) . Just) tblSettings (\_ -> Nothing) id))+ -> Q Postgres db s (PgLockedTables s, tbl (QExpr Postgres s))+locked_ (DatabaseEntity dt) = do+ (nm, joined) <- Q (liftF (QAll (\_ -> fromTable (tableNamed (tableName (dbTableSchema dt) (dbTableCurrentName dt))) .+ Just . (,Nothing))+ (tableFieldsToExpressions (dbTableSettings dt))+ (\_ -> Nothing) id)) pure (PgLockedTables [nm], joined) -- | Lock some tables during the execution of a query. This is rather complicated, and there are@@ -113,42 +132,47 @@ -- -- If you want to use the most common behavior (lock all rows in every table mentioned), the -- 'lockingAllTablesFor_' function may be what you're after.-lockingFor_ :: ( Database Postgres db, Projectible PgExpressionSyntax a )+lockingFor_ :: forall a db s+ . ( Database Postgres db, Projectible Postgres a, ThreadRewritable (QNested s) a ) => PgSelectLockingStrength -> Maybe PgSelectLockingOptions- -> Q PgSelectSyntax db (QNested s) (PgWithLocking (QNested s) a)- -> Q PgSelectSyntax db s a+ -> Q Postgres db (QNested s) (PgWithLocking (QNested s) a)+ -> Q Postgres db s (WithRewrittenThread (QNested s) s a) lockingFor_ lockStrength mLockOptions (Q q) = Q (liftF (QForceSelect (\(PgWithLocking (PgLockedTables tblNms) _) tbl ords limit offset -> let locking = PgSelectLockingClauseSyntax lockStrength tblNms mLockOptions in pgSelectStmt tbl ords limit offset (Just locking))- q (\(PgWithLocking _ a) -> a)))+ q (\(PgWithLocking _ a) -> rewriteThread (Proxy @s) a))) -- | Like 'lockingFor_', but does not require an explicit set of locked tables. This produces an -- empty @FOR .. OF@ clause.-lockingAllTablesFor_ :: ( Database Postgres db, Projectible PgExpressionSyntax a )+lockingAllTablesFor_ :: ( Database Postgres db, Projectible Postgres a, ThreadRewritable (QNested s) a ) => PgSelectLockingStrength -> Maybe PgSelectLockingOptions- -> Q PgSelectSyntax db (QNested s) a- -> Q PgSelectSyntax db s a+ -> Q Postgres db (QNested s) a+ -> Q Postgres db s (WithRewrittenThread (QNested s) s a) lockingAllTablesFor_ lockStrength mLockOptions q = lockingFor_ lockStrength mLockOptions (lockAll_ <$> q) -- * @INSERT@ +-- | The Postgres @DEFAULT VALUES@ clause for the @INSERT@ command.+insertDefaults :: SqlInsertValues Postgres tbl+insertDefaults = SqlInsertValues (PgInsertValuesSyntax (emit "DEFAULT VALUES"))+ -- | A @beam-postgres@-specific version of 'Database.Beam.Query.insert', which -- provides fuller support for the much richer Postgres @INSERT@ syntax. This -- allows you to specify @ON CONFLICT@ actions. For even more complete support, -- see 'insertReturning'. insert :: DatabaseEntity Postgres db (TableEntity table)- -> SqlInsertValues PgInsertValuesSyntax (table (QExpr PgExpressionSyntax s)) -- TODO arbitrary projectibles+ -> SqlInsertValues Postgres (table (QExpr Postgres s)) -- TODO arbitrary projectibles -> PgInsertOnConflict table- -> SqlInsert PgInsertSyntax-insert tbl values onConflict_ =+ -> SqlInsert Postgres table+insert tbl@(DatabaseEntity dt@(DatabaseTable {})) values onConflict_ = case insertReturning tbl values onConflict_- (Nothing :: Maybe (table (QExpr PgExpressionSyntax PostgresInaccessible) -> QExpr PgExpressionSyntax PostgresInaccessible Int)) of+ (Nothing :: Maybe (table (QExpr Postgres PostgresInaccessible) -> QExpr Postgres PostgresInaccessible Int)) of PgInsertReturning a ->- SqlInsert (PgInsertSyntax a)+ SqlInsert (dbTableSettings dt) (PgInsertSyntax a) PgInsertReturningEmpty -> SqlInsertNoRows @@ -164,31 +188,44 @@ -- returns the expression to be returned as part of the @RETURNING@ clause. For -- a backend-agnostic version of this functionality see -- 'MonadBeamInsertReturning'. Use 'runInsertReturning' to get the results.-insertReturning :: Projectible PgExpressionSyntax a+insertReturning :: Projectible Postgres a => DatabaseEntity Postgres be (TableEntity table)- -> SqlInsertValues PgInsertValuesSyntax (table (QExpr PgExpressionSyntax s))+ -> SqlInsertValues Postgres (table (QExpr Postgres s)) -> PgInsertOnConflict table- -> Maybe (table (QExpr PgExpressionSyntax PostgresInaccessible) -> a)+ -> Maybe (table (QExpr Postgres PostgresInaccessible) -> a) -> PgInsertReturning (QExprToIdentity a) insertReturning _ SqlInsertValuesEmpty _ _ = PgInsertReturningEmpty-insertReturning (DatabaseEntity (DatabaseTable tblNm tblSettings))+insertReturning (DatabaseEntity tbl@(DatabaseTable {})) (SqlInsertValues (PgInsertValuesSyntax insertValues_)) (PgInsertOnConflict mkOnConflict)- returning =+ mMkProjection = PgInsertReturning $- emit "INSERT INTO " <> pgQuotedIdentifier tblNm <>+ emit "INSERT INTO " <> fromPgTableName (tableName (dbTableSchema tbl) (dbTableCurrentName tbl)) <> emit "(" <> pgSepBy (emit ", ") (allBeamValues (\(Columnar' f) -> pgQuotedIdentifier (_fieldName f)) tblSettings) <> emit ") " <> insertValues_ <> emit " " <> fromPgInsertOnConflict (mkOnConflict tblFields) <>- (case returning of+ (case mMkProjection of Nothing -> mempty Just mkProjection ->- emit " RETURNING "<>- pgSepBy (emit ", ") (map fromPgExpression (project (mkProjection tblQ) "t")))+ emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))) where tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (unqualifiedField (_fieldName f))))) tblSettings- tblFields = changeBeamRep (\(Columnar' f) -> Columnar' (QField True tblNm (_fieldName f))) tblSettings+ tblFields = changeBeamRep (\(Columnar' f) -> Columnar' (QField True (dbTableCurrentName tbl) (_fieldName f))) tblSettings + tblSettings = dbTableSettings tbl++runPgInsertReturningList+ :: ( MonadBeam be m+ , BeamSqlBackendSyntax be ~ PgCommandSyntax+ , FromBackendRow be a+ )+ => PgInsertReturning a+ -> m [a]+runPgInsertReturningList = \case+ PgInsertReturningEmpty -> pure []+ PgInsertReturning syntax -> runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax+ -- ** @ON CONFLICT@ clause -- | What to do when an @INSERT@ statement inserts a row into the table @tbl@@@ -198,12 +235,51 @@ -- | Specifies the kind of constraint that must be violated for the action to occur newtype PgInsertOnConflictTarget (tbl :: (* -> *) -> *) =- PgInsertOnConflictTarget (tbl (QExpr PgExpressionSyntax PostgresInaccessible) -> PgInsertOnConflictTargetSyntax)+ PgInsertOnConflictTarget (tbl (QExpr Postgres PostgresInaccessible) -> PgInsertOnConflictTargetSyntax) -- | A description of what to do when a constraint or index is violated. newtype PgConflictAction (tbl :: (* -> *) -> *) = PgConflictAction (tbl (QField PostgresInaccessible) -> PgConflictActionSyntax) +-- | Postgres @LATERAL JOIN@ support+--+-- Allows the use of variables introduced on the left side of a @JOIN@ to be used on the right hand+-- side.+--+-- Because of the default scoping rules, we can't use the typical monadic bind (@>>=@) operator to+-- create this join.+--+-- Instead, 'lateral_' takes two arguments. The first is the left hand side of the @JOIN@. The+-- second is a function that takes the result of the first join and uses those variables to create+-- the right hand side.+--+-- For example, to join table A with a subquery that returns the first three rows in B which matches+-- a column in A, ordered by another column in B:+--+-- > lateral_ (_tableA database) $ \tblA ->+-- > limit_ 3 $+-- > ordering_ (\(_, b) -> asc_ (_bField2 b)) $ do+-- > b <- _tableB database+-- > guard_ (_bField1 b ==. _aField1 a)+-- > pure (a, b0+lateral_ :: forall s a b db+ . ( ThreadRewritable s a, ThreadRewritable (QNested s) b, Projectible Postgres b )+ => a -> (WithRewrittenThread s (QNested s) a -> Q Postgres db (QNested s) b)+ -> Q Postgres db s (WithRewrittenThread (QNested s) s b)+lateral_ using mkSubquery = do+ let Q subquery = mkSubquery (rewriteThread (Proxy @(QNested s)) using)+ Q (liftF (QArbitraryJoin subquery+ (\a b on' ->+ case on' of+ Nothing ->+ PgFromSyntax $+ fromPgFrom a <> emit " CROSS JOIN LATERAL " <> fromPgFrom b+ Just on'' ->+ PgFromSyntax $+ fromPgFrom a <> emit " JOIN LATERAL " <> fromPgFrom b <> emit " ON " <> fromPgExpression on'')+ (\_ -> Nothing)+ (rewriteThread (Proxy @s))))+ -- | By default, Postgres will throw an error when a conflict is detected. This -- preserves that functionality. onConflictDefault :: PgInsertOnConflict tbl@@ -240,27 +316,32 @@ -- | Perform the conflict action only when these fields conflict. The first -- argument gets the current row as a table of expressions. Return the conflict -- key. For more information, see the @beam-postgres@ manual.-conflictingFields :: Projectible PgExpressionSyntax proj- => (tbl (QExpr PgExpressionSyntax PostgresInaccessible) -> proj)+conflictingFields :: Projectible Postgres proj+ => (tbl (QExpr Postgres PostgresInaccessible) -> proj) -> PgInsertOnConflictTarget tbl conflictingFields makeProjection = PgInsertOnConflictTarget $ \tbl -> PgInsertOnConflictTargetSyntax $- pgParens (pgSepBy (emit ", ") (map fromPgExpression (project (makeProjection tbl) "t"))) <> emit " "+ pgParens (pgSepBy (emit ", ") $+ map fromPgExpression $+ project (Proxy @Postgres) (makeProjection tbl) "t") <>+ emit " " -- | Like 'conflictingFields', but only perform the action if the condition -- given in the second argument is met. See the postgres -- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for -- more information.-conflictingFieldsWhere :: Projectible PgExpressionSyntax proj- => (tbl (QExpr PgExpressionSyntax PostgresInaccessible) -> proj)- -> (tbl (QExpr PgExpressionSyntax PostgresInaccessible) ->- QExpr PgExpressionSyntax PostgresInaccessible Bool)+conflictingFieldsWhere :: Projectible Postgres proj+ => (tbl (QExpr Postgres PostgresInaccessible) -> proj)+ -> (tbl (QExpr Postgres PostgresInaccessible) ->+ QExpr Postgres PostgresInaccessible Bool) -> PgInsertOnConflictTarget tbl conflictingFieldsWhere makeProjection makeWhere = PgInsertOnConflictTarget $ \tbl -> PgInsertOnConflictTargetSyntax $- pgParens (pgSepBy (emit ", ") (map fromPgExpression (project (makeProjection tbl) "t"))) <>+ pgParens (pgSepBy (emit ", ") $+ map fromPgExpression (project (Proxy @Postgres)+ (makeProjection tbl) "t")) <> emit " WHERE " <> pgParens (let QExpr mkE = makeWhere tbl PgExpressionSyntax e = mkE "t"@@ -284,18 +365,17 @@ -- value of the row in the database. onConflictUpdateSet :: Beamable tbl => (tbl (QField PostgresInaccessible) ->- tbl (QExpr PgExpressionSyntax PostgresInaccessible) ->- [ QAssignment PgFieldNameSyntax PgExpressionSyntax PostgresInaccessible ])+ tbl (QExpr Postgres PostgresInaccessible) ->+ QAssignment Postgres PostgresInaccessible) -> PgConflictAction tbl onConflictUpdateSet mkAssignments = PgConflictAction $ \tbl ->- let assignments = mkAssignments tbl tblExcluded+ let QAssignment assignments = mkAssignments tbl tblExcluded tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl - assignmentSyntaxes = do- QAssignment assignments' <- assignments- (fieldNm, expr) <- assignments'- pure (fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr))+ assignmentSyntaxes =+ [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)+ | (fieldNm, expr) <- assignments ] in PgConflictActionSyntax $ emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes @@ -306,46 +386,54 @@ -- more information. onConflictUpdateSetWhere :: Beamable tbl => (tbl (QField PostgresInaccessible) ->- tbl (QExpr PgExpressionSyntax PostgresInaccessible) ->- [ QAssignment PgFieldNameSyntax PgExpressionSyntax PostgresInaccessible ])- -> (tbl (QExpr PgExpressionSyntax PostgresInaccessible) -> QExpr PgExpressionSyntax PostgresInaccessible Bool)+ tbl (QExpr Postgres PostgresInaccessible) ->+ QAssignment Postgres PostgresInaccessible)+ -> (tbl (QExpr Postgres PostgresInaccessible) -> QExpr Postgres PostgresInaccessible Bool) -> PgConflictAction tbl onConflictUpdateSetWhere mkAssignments where_ = PgConflictAction $ \tbl ->- let assignments = mkAssignments tbl tblExcluded+ let QAssignment assignments = mkAssignments tbl tblExcluded QExpr where_' = where_ (changeBeamRep (\(Columnar' f) -> Columnar' (current_ f)) tbl) tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl - assignmentSyntaxes = do- QAssignment assignments' <- assignments- (fieldNm, expr) <- assignments'- pure (fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr))+ assignmentSyntaxes =+ [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)+ | (fieldNm, expr) <- assignments ] in PgConflictActionSyntax $ emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes <> emit " WHERE " <> fromPgExpression (where_' "t") -- | Sometimes you want to update certain columns in the row. Given a -- projection from a row to the fields you want, Beam can auto-generate -- an assignment that assigns the corresponding fields of the conflicting row.-onConflictUpdateInstead :: (Beamable tbl, Projectible T.Text proj)- => (tbl (QExpr T.Text PostgresInaccessible) -> proj)+onConflictUpdateInstead :: (Beamable tbl, ProjectibleWithPredicate AnyType () T.Text proj)+ => (tbl (Const T.Text) -> proj) -> PgConflictAction tbl onConflictUpdateInstead mkProj = onConflictUpdateSet $ \tbl _ ->- let tblFields = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> nm))) tbl- proj = project (mkProj tblFields) "t"+ let tblFields = changeBeamRep (\(Columnar' (QField _ _ nm) :: Columnar' (QField PostgresInaccessible) a) -> Columnar' (Const nm) :: Columnar' (Const T.Text) a) tbl+ proj = execWriter (project' (Proxy @AnyType) (Proxy @((), T.Text))+ (\_ _ e -> tell [e] >> pure e)+ (mkProj tblFields)) - in map (\fieldNm -> QAssignment [ (unqualifiedField fieldNm, fieldE (qualifiedField "excluded" fieldNm)) ]) proj+ in QAssignment (map (\fieldNm -> (unqualifiedField fieldNm, fieldE (qualifiedField "excluded" fieldNm))) proj) -- | Sometimes you want to update every value in the row. Beam can auto-generate -- an assignment that assigns the conflicting row to every field in the database -- row. This may not always be what you want.-onConflictSetAll :: (Beamable tbl, Projectible T.Text (tbl (QExpr T.Text PostgresInaccessible)))+onConflictSetAll :: ( Beamable tbl+ , ProjectibleWithPredicate AnyType () T.Text (tbl (Const T.Text)) ) => PgConflictAction tbl onConflictSetAll = onConflictUpdateInstead id -- * @UPDATE@ -- | The most general kind of @UPDATE@ that postgres can perform+--+-- You can build this from a 'SqlUpdate' by using 'returning'+--+-- > update tbl where `returning` projection+--+-- Run the result with 'runPgUpdateReturningList' data PgUpdateReturning a = PgUpdateReturning PgSyntax | PgUpdateReturningEmpty@@ -353,47 +441,117 @@ -- | Postgres @UPDATE ... RETURNING@ statement support. The last -- argument takes the newly inserted row and returns the values to be -- returned. Use 'runUpdateReturning' to get the results.-updateReturning :: Projectible PgExpressionSyntax a+updateReturning :: Projectible Postgres a => DatabaseEntity Postgres be (TableEntity table)- -> (forall s. table (QField s) -> [ QAssignment PgFieldNameSyntax PgExpressionSyntax s ])- -> (forall s. table (QExpr PgExpressionSyntax s) -> QExpr PgExpressionSyntax s Bool)- -> (table (QExpr PgExpressionSyntax PostgresInaccessible) -> a)+ -> (forall s. table (QField s) -> QAssignment Postgres s)+ -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)+ -> (table (QExpr Postgres PostgresInaccessible) -> a) -> PgUpdateReturning (QExprToIdentity a)-updateReturning table@(DatabaseEntity (DatabaseTable _ tblSettings))+updateReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings })) mkAssignments mkWhere mkProjection = case update table mkAssignments mkWhere of- SqlUpdate pgUpdate ->+ SqlUpdate _ pgUpdate -> PgUpdateReturning $ fromPgUpdate pgUpdate <> emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (mkProjection tblQ) "t"))+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t")) SqlIdentityUpdate -> PgUpdateReturningEmpty where tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings +runPgUpdateReturningList+ :: ( MonadBeam be m+ , BeamSqlBackendSyntax be ~ PgCommandSyntax+ , FromBackendRow be a+ )+ => PgUpdateReturning a+ -> m [a]+runPgUpdateReturningList = \case+ PgUpdateReturningEmpty -> pure []+ PgUpdateReturning syntax -> runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax+ -- * @DELETE@ -- | The most general kind of @DELETE@ that postgres can perform+--+-- You can build this from a 'SqlDelete' by using 'returning'+--+-- > delete tbl where `returning` projection+--+-- Run the result with 'runPgDeleteReturningList' newtype PgDeleteReturning a = PgDeleteReturning PgSyntax -- | Postgres @DELETE ... RETURNING@ statement support. The last -- argument takes the newly inserted row and returns the values to be -- returned. Use 'runDeleteReturning' to get the results.-deleteReturning :: Projectible PgExpressionSyntax a+deleteReturning :: Projectible Postgres a => DatabaseEntity Postgres be (TableEntity table)- -> (forall s. table (QExpr PgExpressionSyntax s) -> QExpr PgExpressionSyntax s Bool)- -> (table (QExpr PgExpressionSyntax PostgresInaccessible) -> a)+ -> (forall s. table (QExpr Postgres s) -> QExpr Postgres s Bool)+ -> (table (QExpr Postgres PostgresInaccessible) -> a) -> PgDeleteReturning (QExprToIdentity a)-deleteReturning table@(DatabaseEntity (DatabaseTable _ tblSettings))+deleteReturning table@(DatabaseEntity (DatabaseTable { dbTableSettings = tblSettings })) mkWhere mkProjection = PgDeleteReturning $ fromPgDelete pgDelete <> emit " RETURNING " <>- pgSepBy (emit ", ") (map fromPgExpression (project (mkProjection tblQ) "t"))+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t")) where- SqlDelete pgDelete = delete table mkWhere+ SqlDelete _ pgDelete = delete table mkWhere tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings++runPgDeleteReturningList+ :: ( MonadBeam be m+ , BeamSqlBackendSyntax be ~ PgCommandSyntax+ , FromBackendRow be a+ )+ => PgDeleteReturning a+ -> m [a]+runPgDeleteReturningList (PgDeleteReturning syntax) = runReturningList $ PgCommandSyntax PgCommandTypeDataUpdateReturning syntax++-- * General @RETURNING@ support++class PgReturning cmd where+ type PgReturningType cmd :: * -> *++ returning :: (Beamable tbl, Projectible Postgres a)+ => cmd Postgres tbl -> (tbl (QExpr Postgres PostgresInaccessible) -> a)+ -> PgReturningType cmd (QExprToIdentity a)++instance PgReturning SqlInsert where+ type PgReturningType SqlInsert = PgInsertReturning++ returning SqlInsertNoRows _ = PgInsertReturningEmpty+ returning (SqlInsert tblSettings (PgInsertSyntax syntax)) mkProjection =+ PgInsertReturning $+ syntax <> emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))++ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings++instance PgReturning SqlUpdate where+ type PgReturningType SqlUpdate = PgUpdateReturning++ returning SqlIdentityUpdate _ = PgUpdateReturningEmpty+ returning (SqlUpdate tblSettings (PgUpdateSyntax syntax)) mkProjection =+ PgUpdateReturning $+ syntax <> emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))++ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings++instance PgReturning SqlDelete where+ type PgReturningType SqlDelete = PgDeleteReturning++ returning (SqlDelete tblSettings (PgDeleteSyntax syntax)) mkProjection =+ PgDeleteReturning $+ syntax <> emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))++ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings
Database/Beam/Postgres/Migrate.hs view
@@ -10,35 +10,39 @@ -- | Migrations support for beam-postgres. See "Database.Beam.Migrate" for more -- information on beam migrations. module Database.Beam.Postgres.Migrate- ( migrationBackend+ ( PgCommandSyntax, migrationBackend , postgresDataTypeDeserializers , pgPredConverter , getDbConstraints , pgTypeToHs , migrateScript , writeMigrationScript+ , pgDataTypeFromAtt -- * Postgres data types , tsquery, tsvector, text, bytea , unboundedArray, uuid, money , json, jsonb , smallserial, serial, bigserial+ , point, line, lineSegment, box ) where import Database.Beam.Backend.SQL import Database.Beam.Migrate.Actions (defaultActionProvider) import qualified Database.Beam.Migrate.Backend as Tool import qualified Database.Beam.Migrate.Checks as Db-import Database.Beam.Migrate.SQL.BeamExtensions import qualified Database.Beam.Migrate.SQL as Db+import Database.Beam.Migrate.SQL.BeamExtensions import qualified Database.Beam.Migrate.Serialization as Db import qualified Database.Beam.Migrate.Types as Db+import qualified Database.Beam.Query.DataTypes as Db import Database.Beam.Postgres.Connection+import Database.Beam.Postgres.CustomTypes+import Database.Beam.Postgres.Extensions import Database.Beam.Postgres.PgSpecific import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Types-import Database.Beam.Postgres.Extensions import Database.Beam.Haskell.Syntax @@ -46,6 +50,7 @@ import qualified Database.PostgreSQL.Simple.Types as Pg import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg +import Control.Applicative ((<|>)) import Control.Arrow import Control.Exception (bracket) import Control.Monad@@ -53,25 +58,27 @@ import Data.Aeson hiding (json) import Data.Bits-import Data.Maybe import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BCL-import Data.String+import qualified Data.HashMap.Strict as HM import Data.Int+import Data.Maybe+import Data.String import qualified Data.Text as T import qualified Data.Text.Encoding as TE-import qualified Data.Vector as V-import Data.UUID.Types (UUID) import Data.Typeable+import Data.UUID.Types (UUID)+import qualified Data.Vector as V #if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup #else import Data.Monoid (Endo(..)) #endif+import Data.Word (Word64) -- | Top-level migration backend for use by @beam-migrate@ tools-migrationBackend :: Tool.BeamMigrationBackend PgCommandSyntax Postgres Pg.Connection Pg+migrationBackend :: Tool.BeamMigrationBackend Postgres Pg migrationBackend = Tool.BeamMigrationBackend "postgres" (unlines [ "For beam-postgres, this is a libpq connection string which can either be a list of key value pairs or a URI"@@ -82,20 +89,17 @@ , " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]" , "" , "See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> for more information" ])- (BL.concat . migrateScript) (liftF (PgLiftWithHandle getDbConstraints id)) (Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <> Db.sql2008BigIntDataTypeDeserializers <> postgresDataTypeDeserializers <> Db.beamCheckDeserializers) (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand) "postgres.sql"- pgPredConverter (defaultActionProvider <> pgExtensionActionProvider)+ pgPredConverter (defaultActionProvider <> pgExtensionActionProvider <>+ pgCustomEnumActionProvider) (\options action -> bracket (Pg.connectPostgreSQL (fromString options)) Pg.close $ \conn ->- left pgToToolError <$> withPgDebug (\_ -> pure ()) conn action)- where- pgToToolError (PgRowParseError err) = show err- pgToToolError (PgInternalError err) = err+ left show <$> withPgDebug (\_ -> pure ()) conn action) -- | 'BeamDeserializers' for postgres-specific types: --@@ -112,7 +116,7 @@ -- * 'money' -- postgresDataTypeDeserializers- :: Db.BeamDeserializers PgCommandSyntax+ :: Db.BeamDeserializers Postgres postgresDataTypeDeserializers = Db.beamDeserializer $ \_ v -> case v of@@ -127,18 +131,22 @@ "jsonb" -> pure pgJsonbType "uuid" -> pure pgUuidType "money" -> pure pgMoneyType+ "point" -> pure pgPointType+ "line" -> pure pgLineType+ "lseg" -> pure pgLineSegmentType+ "box" -> pure pgBoxType _ -> fail "Postgres data type" -- | Converts postgres 'DatabasePredicate's to 'DatabasePredicate's in the -- Haskell syntax. Allows automatic generation of Haskell schemas from postgres -- constraints. pgPredConverter :: Tool.HaskellPredicateConverter-pgPredConverter = Tool.sql92HsPredicateConverters @PgColumnSchemaSyntax pgTypeToHs <>+pgPredConverter = Tool.sql92HsPredicateConverters @Postgres pgTypeToHs <> Tool.hsPredicateConverter pgHasColumnConstraint where- pgHasColumnConstraint (Db.TableColumnHasConstraint tblNm colNm c :: Db.TableColumnHasConstraint PgColumnSchemaSyntax)+ pgHasColumnConstraint (Db.TableColumnHasConstraint tblNm colNm c :: Db.TableColumnHasConstraint Postgres) | c == Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing =- Just (Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tblNm colNm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint HsColumnSchema))+ Just (Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tblNm colNm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint HsMigrateBackend)) | otherwise = Nothing -- | Turn a 'PgDataTypeSyntax' into the corresponding 'HsDataType'. This is a@@ -211,11 +219,32 @@ (importSome "Database.Beam.Postgres" [importTyNamed "TsQuery"])) (pgDataTypeSerialized pgTsQueryType) + | Pg.typoid Pg.point == oid ->+ Just $ HsDataType (hsVarFrom "point" "Database.Beam.Postgres")+ (HsType (tyConNamed "PgPoint")+ (importSome "Database.Beam.Postgres" [ importTyNamed "PgPoint" ]))+ (pgDataTypeSerialized pgPointType)+ | Pg.typoid Pg.line == oid ->+ Just $ HsDataType (hsVarFrom "line" "Database.Beam.Postgres")+ (HsType (tyConNamed "PgLine")+ (importSome "Database.Beam.Postgres" [ importTyNamed "PgLine" ]))+ (pgDataTypeSerialized pgLineType)+ | Pg.typoid Pg.lseg == oid ->+ Just $ HsDataType (hsVarFrom "lineSegment" "Database.Beam.Postgres")+ (HsType (tyConNamed "PgLineSegment")+ (importSome "Database.Beam.Postgres" [ importTyNamed "PgLineSegment" ]))+ (pgDataTypeSerialized pgLineSegmentType)+ | Pg.typoid Pg.box == oid ->+ Just $ HsDataType (hsVarFrom "box" "Database.Beam.Postgres")+ (HsType (tyConNamed "PgBox")+ (importSome "Database.Beam.Postgres" [ importTyNamed "PgBox" ]))+ (pgDataTypeSerialized pgBoxType)+ _ -> Just (hsErrorType ("PG type " ++ show tyDescr)) -- | Turn a series of 'Db.MigrationSteps' into a line-by-line array of -- 'BL.ByteString's suitable for writing to a script.-migrateScript :: Db.MigrationSteps PgCommandSyntax () a' -> [BL.ByteString]+migrateScript :: Db.MigrationSteps Postgres () a' -> [BL.ByteString] migrateScript steps = "-- CAUTION: beam-postgres currently escapes postgres string literals somewhat\n" : "-- haphazardly when generating scripts (but not when generating commands)\n" :@@ -235,25 +264,40 @@ Endo ((pgRenderSyntaxScript (fromPgCommand command) <> ";\n"):) -- | Write the migration given by the 'Db.MigrationSteps' to a file.-writeMigrationScript :: FilePath -> Db.MigrationSteps PgCommandSyntax () a -> IO ()+writeMigrationScript :: FilePath -> Db.MigrationSteps Postgres () a -> IO () writeMigrationScript fp steps = let stepBs = migrateScript steps in BL.writeFile fp (BL.concat stepBs) -pgExpandDataType :: Db.DataType PgDataTypeSyntax a -> PgDataTypeSyntax+pgExpandDataType :: Db.DataType Postgres a -> PgDataTypeSyntax pgExpandDataType (Db.DataType pg) = pg -pgDataTypeFromAtt :: ByteString -> Pg.Oid -> Maybe Int32 -> PgDataTypeSyntax+pgCharLength :: Maybe Int32 -> Maybe Word+pgCharLength Nothing = Nothing+pgCharLength (Just (-1)) = Nothing+pgCharLength (Just x) = Just (fromIntegral x)++pgDataTypeFromAtt :: ByteString -> Pg.Oid -> Maybe Int32 -> Maybe PgDataTypeSyntax pgDataTypeFromAtt _ oid pgMod- | Pg.typoid Pg.bool == oid = pgExpandDataType Db.boolean- | Pg.typoid Pg.bytea == oid = pgExpandDataType Db.binaryLargeObject- | Pg.typoid Pg.char == oid = pgExpandDataType (Db.char Nothing) -- TODO length+ | Pg.typoid Pg.bool == oid = Just $ pgExpandDataType Db.boolean+ | Pg.typoid Pg.bytea == oid = Just $ pgExpandDataType Db.binaryLargeObject+ | Pg.typoid Pg.char == oid = Just $ pgExpandDataType (Db.char (pgCharLength pgMod)) -- TODO Pg.name- | Pg.typoid Pg.int8 == oid = pgExpandDataType (Db.bigint :: Db.DataType PgDataTypeSyntax Int64)- | Pg.typoid Pg.int4 == oid = pgExpandDataType (Db.int :: Db.DataType PgDataTypeSyntax Int32)- | Pg.typoid Pg.int2 == oid = pgExpandDataType (Db.smallint :: Db.DataType PgDataTypeSyntax Int16)- | Pg.typoid Pg.varchar == oid = pgExpandDataType (Db.varchar Nothing)- | Pg.typoid Pg.timestamp == oid = pgExpandDataType Db.timestamp+ | Pg.typoid Pg.int8 == oid = Just $ pgExpandDataType (Db.bigint :: Db.DataType Postgres Int64)+ | Pg.typoid Pg.int4 == oid = Just $ pgExpandDataType (Db.int :: Db.DataType Postgres Int32)+ | Pg.typoid Pg.int2 == oid = Just $ pgExpandDataType (Db.smallint :: Db.DataType Postgres Int16)+ | Pg.typoid Pg.varchar == oid = Just $ pgExpandDataType (Db.varchar (pgCharLength pgMod))+ | Pg.typoid Pg.timestamp == oid = Just $ pgExpandDataType Db.timestamp+ | Pg.typoid Pg.timestamptz == oid = Just $ pgExpandDataType Db.timestamptz+ | Pg.typoid Pg.float8 == oid = Just $ pgExpandDataType Db.double+ | Pg.typoid Pg.text == oid = Just $ pgTextType+ | Pg.typoid Pg.json == oid = Just $ pgJsonType+ | Pg.typoid Pg.jsonb == oid = Just $ pgJsonbType+ | Pg.typoid Pg.uuid == oid = Just $ pgUuidType+ | Pg.typoid Pg.point == oid = Just $ pgPointType+ | Pg.typoid Pg.line == oid = Just $ pgLineType+ | Pg.typoid Pg.lseg == oid = Just $ pgLineSegmentType+ | Pg.typoid Pg.box == oid = Just $ pgBoxType | Pg.typoid Pg.numeric == oid = let precAndDecimal = case pgMod of@@ -262,39 +306,57 @@ let prec = fromIntegral (pgMod' `shiftR` 16) dec = fromIntegral (pgMod' .&. 0xFFFF) in Just (prec, if dec == 0 then Nothing else Just dec)- in pgExpandDataType (Db.numeric precAndDecimal)- | otherwise = PgDataTypeSyntax (PgDataTypeDescrOid oid pgMod) (emit "{- UNKNOWN -}")- (pgDataTypeJSON (object [ "oid" .= (fromIntegral oid' :: Word), "mod" .= pgMod ]))- where- Pg.Oid oid' = oid- -- , \_ _ -> errorTypeHs (show fallback))+ in Just $ pgExpandDataType (Db.numeric precAndDecimal)+ | otherwise = Nothing +pgEnumerationTypeFromAtt :: [ (T.Text, Pg.Oid, V.Vector T.Text) ] -> ByteString -> Pg.Oid -> Maybe Int32 -> Maybe PgDataTypeSyntax+pgEnumerationTypeFromAtt enumData =+ let enumDataMap = HM.fromList [ (fromIntegral oid' :: Word64, -- Get around lack of Hashable for CUInt+ PgDataTypeSyntax (PgDataTypeDescrDomain nm) (emit (TE.encodeUtf8 nm))+ (pgDataTypeJSON (object [ "customType" .= nm ]))) | (nm, (Pg.Oid oid'), _) <- enumData ]+ in \_ (Pg.Oid oid) _ -> HM.lookup (fromIntegral oid) enumDataMap++pgUnknownDataType :: Pg.Oid -> Maybe Int32 -> PgDataTypeSyntax+pgUnknownDataType oid@(Pg.Oid oid') pgMod =+ PgDataTypeSyntax (PgDataTypeDescrOid oid pgMod) (emit "{- UNKNOWN -}")+ (pgDataTypeJSON (object [ "oid" .= (fromIntegral oid' :: Word), "mod" .= pgMod ]))+ -- * Create constraints from a connection getDbConstraints :: Pg.Connection -> IO [ Db.SomeDatabasePredicate ] getDbConstraints conn = do tbls <- Pg.query_ conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'"- let tblsExist = map (\(_, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate tbl)) tbls+ let tblsExist = map (\(_, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName Nothing tbl))) tbls + enumerationData <-+ Pg.query_ conn+ (fromString (unlines+ [ "SELECT t.typname, t.oid, array_agg(e.enumlabel ORDER BY e.enumsortorder)"+ , "FROM pg_enum e JOIN pg_type t ON t.oid = e.enumtypid"+ , "GROUP BY t.typname, t.oid" ]))+ 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 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)- pgDataType = pgDataTypeFromAtt typ typId typmod' - in Db.SomeDatabasePredicate (Db.TableHasColumn tbl nm pgDataType :: Db.TableHasColumn PgColumnSchemaSyntax)) columns+ pgDataType = fromMaybe (pgUnknownDataType typId typmod') $+ pgDataTypeFromAtt typ typId typmod' <|>+ pgEnumerationTypeFromAtt enumerationData typ typId typmod'++ in Db.SomeDatabasePredicate (Db.TableHasColumn (Db.QualifiedName Nothing tbl) nm pgDataType :: Db.TableHasColumn Postgres)) columns notNullChecks = concatMap (\(nm, _, _, isNotNull, _) -> if isNotNull then- [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tbl nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing)- :: Db.TableColumnHasConstraint PgColumnSchemaSyntax)]+ [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint (Db.QualifiedName Nothing tbl) nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing)+ :: Db.TableColumnHasConstraint Postgres)] else [] ) columns pure (columnChecks ++ notNullChecks) primaryKeys <-- map (\(relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey relnm (V.toList cols))) <$>+ map (\(relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey (Db.QualifiedName Nothing relnm) (V.toList cols))) <$> Pg.query_ conn (fromString (unlines [ "SELECT c.relname, array_agg(a.attname ORDER BY k.n ASC)" , "FROM pg_index i" , "CROSS JOIN unnest(i.indkey) WITH ORDINALITY k(attid, n)"@@ -302,68 +364,83 @@ , "JOIN pg_class c ON c.oid=i.indrelid" , "WHERE c.relkind='r' AND i.indisprimary GROUP BY relname, i.indrelid" ])) - pure (tblsExist ++ columnChecks ++ primaryKeys)+ let enumerations =+ map (\(enumNm, _, options) -> Db.SomeDatabasePredicate (PgHasEnum enumNm (V.toList options))) enumerationData + pure (tblsExist ++ columnChecks ++ primaryKeys ++ enumerations)+ -- * Postgres-specific data types -- | 'Db.DataType' for @tsquery@. See 'TsQuery' for more information-tsquery :: Db.DataType PgDataTypeSyntax TsQuery+tsquery :: Db.DataType Postgres TsQuery tsquery = Db.DataType pgTsQueryType -- | 'Db.DataType' for @tsvector@. See 'TsVector' for more information-tsvector :: Db.DataType PgDataTypeSyntax TsVector+tsvector :: Db.DataType Postgres TsVector tsvector = Db.DataType pgTsVectorType -- | 'Db.DataType' for Postgres @TEXT@. 'characterLargeObject' is also mapped to -- this data type-text :: Db.DataType PgDataTypeSyntax T.Text+text :: Db.DataType Postgres T.Text text = Db.DataType pgTextType -- | 'Db.DataType' for Postgres @BYTEA@. 'binaryLargeObject' is also mapped to -- this data type-bytea :: Db.DataType PgDataTypeSyntax ByteString+bytea :: Db.DataType Postgres ByteString bytea = Db.DataType pgByteaType -- | 'Db.DataType' for a Postgres array without any bounds. -- -- Note that array support in @beam-migrate@ is still incomplete. unboundedArray :: forall a. Typeable a- => Db.DataType PgDataTypeSyntax a- -> Db.DataType PgDataTypeSyntax (V.Vector a)+ => Db.DataType Postgres a+ -> Db.DataType Postgres (V.Vector a) unboundedArray (Db.DataType elTy) = Db.DataType (pgUnboundedArrayType elTy) -- | 'Db.DataType' for @JSON@. See 'PgJSON' for more information-json :: (ToJSON a, FromJSON a) => Db.DataType PgDataTypeSyntax (PgJSON a)+json :: (ToJSON a, FromJSON a) => Db.DataType Postgres (PgJSON a) json = Db.DataType pgJsonType -- | 'Db.DataType' for @JSONB@. See 'PgJSON' for more information-jsonb :: (ToJSON a, FromJSON a) => Db.DataType PgDataTypeSyntax (PgJSONB a)+jsonb :: (ToJSON a, FromJSON a) => Db.DataType Postgres (PgJSONB a) jsonb = Db.DataType pgJsonbType -- | 'Db.DataType' for @UUID@ columns. The 'pgCryptoGenRandomUUID' function in -- the 'PgCrypto' extension can be used to generate UUIDs at random.-uuid :: Db.DataType PgDataTypeSyntax UUID+uuid :: Db.DataType Postgres UUID uuid = Db.DataType pgUuidType -- | 'Db.DataType' for @MONEY@ columns.-money :: Db.DataType PgDataTypeSyntax PgMoney+money :: Db.DataType Postgres PgMoney money = Db.DataType pgMoneyType +point :: Db.DataType Postgres PgPoint+point = Db.DataType pgPointType++line :: Db.DataType Postgres PgLine+line = Db.DataType pgLineType++lineSegment :: Db.DataType Postgres PgLineSegment+lineSegment = Db.DataType pgLineSegmentType++box :: Db.DataType Postgres PgBox+box = Db.DataType pgBoxType+ -- * Pseudo-data types -- | Postgres @SERIAL@ data types. Automatically generates an appropriate -- @DEFAULT@ clause and sequence-smallserial, serial, bigserial :: Integral a => Db.DataType PgDataTypeSyntax (SqlSerial a)+smallserial, serial, bigserial :: Integral a => Db.DataType Postgres (SqlSerial a) smallserial = Db.DataType pgSmallSerialType serial = Db.DataType pgSerialType bigserial = Db.DataType pgBigSerialType data PgHasDefault = PgHasDefault-instance Db.FieldReturnType 'True 'False PgColumnSchemaSyntax resTy a =>- Db.FieldReturnType 'False 'False PgColumnSchemaSyntax resTy (PgHasDefault -> a) where+instance Db.FieldReturnType 'True 'False Postgres resTy a =>+ Db.FieldReturnType 'False 'False Postgres resTy (PgHasDefault -> a) where field' _ _ nm ty _ collation constraints PgHasDefault = Db.field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints -instance IsBeamSerialColumnSchemaSyntax PgColumnSchemaSyntax where+instance BeamSqlBackendHasSerial Postgres where genericSerial nm = Db.field nm serial PgHasDefault
Database/Beam/Postgres/PgCrypto.hs view
@@ -8,7 +8,7 @@ import Database.Beam import Database.Beam.Backend.SQL -import Database.Beam.Postgres.Syntax+import Database.Beam.Postgres.Types import Database.Beam.Postgres.Extensions import Data.Text (Text)@@ -16,7 +16,7 @@ import Data.Vector (Vector) import Data.UUID.Types (UUID) -type PgExpr ctxt s = QGenExpr ctxt PgExpressionSyntax s+type PgExpr ctxt s = QGenExpr ctxt Postgres s type family LiftPg ctxt s fn where LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b
Database/Beam/Postgres/PgSpecific.hs view
@@ -51,6 +51,11 @@ , pgSumMoneyOver_, pgAvgMoneyOver_ , pgSumMoney_, pgAvgMoney_ + -- ** Geometry types (not PostGIS)+ , PgPoint(..), PgLine(..), PgLineSegment(..)+ , PgBox(..), PgPath(..), PgPolygon(..)+ , PgCircle(..)+ -- ** Set-valued functions -- $set-valued-funs , PgSetOf, pgUnnest@@ -103,10 +108,9 @@ ) where -import Database.Beam+import Database.Beam hiding (char, double) import Database.Beam.Backend.SQL-import Database.Beam.Migrate ( HasDefaultSqlDataType(..)- , HasDefaultSqlDataTypeConstraints(..) )+import Database.Beam.Migrate ( HasDefaultSqlDataType(..) ) import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Types import Database.Beam.Query.Internal@@ -116,12 +120,15 @@ import Control.Monad.State.Strict (evalState, put, get) import Data.Aeson+import Data.Attoparsec.ByteString+import Data.Attoparsec.ByteString.Char8 import Data.ByteString (ByteString) import Data.ByteString.Builder import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import Data.Foldable import Data.Hashable+import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed)) import Data.String@@ -144,14 +151,14 @@ -- ** Postgres-specific functions -- | Postgres @NOW()@ function. Returns the server's timestamp-now_ :: QExpr PgExpressionSyntax s LocalTime+now_ :: QExpr Postgres s LocalTime now_ = QExpr (\_ -> PgExpressionSyntax (emit "NOW()")) -- | Postgres @ILIKE@ operator. A case-insensitive version of 'like_'.-ilike_ :: IsSqlExpressionSyntaxStringType PgExpressionSyntax text- => QExpr PgExpressionSyntax s text- -> QExpr PgExpressionSyntax s text- -> QExpr PgExpressionSyntax s Bool+ilike_ :: BeamSqlBackendIsString Postgres text+ => QExpr Postgres s text+ -> QExpr Postgres s text+ -> QExpr Postgres s Bool ilike_ (QExpr a) (QExpr b) = QExpr (pgBinOp "ILIKE" <$> a <*> b) -- ** TsVector type@@ -187,11 +194,11 @@ instance FromBackendRow Postgres TsVector -instance HasSqlEqualityCheck PgExpressionSyntax TsVectorConfig-instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsVectorConfig+instance HasSqlEqualityCheck Postgres TsVectorConfig+instance HasSqlQuantifiedEqualityCheck Postgres TsVectorConfig -instance HasSqlEqualityCheck PgExpressionSyntax TsVector-instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsVector+instance HasSqlEqualityCheck Postgres TsVector+instance HasSqlQuantifiedEqualityCheck Postgres TsVector -- | A full-text search configuration with sensible defaults for english english :: TsVectorConfig@@ -199,9 +206,9 @@ -- | The Postgres @to_tsvector@ function. Given a configuration and string, -- return the @TSVECTOR@ that represents the contents of the string.-toTsVector :: IsSqlExpressionSyntaxStringType PgExpressionSyntax str- => Maybe TsVectorConfig -> QGenExpr context PgExpressionSyntax s str- -> QGenExpr context PgExpressionSyntax s TsVector+toTsVector :: BeamSqlBackendIsString Postgres str+ => Maybe TsVectorConfig -> QGenExpr context Postgres s str+ -> QGenExpr context Postgres s TsVector toTsVector Nothing (QExpr x) = QExpr (fmap (\(PgExpressionSyntax x') -> PgExpressionSyntax $@@ -212,9 +219,9 @@ -- | Determine if the given @TSQUERY@ matches the document represented by the -- @TSVECTOR@. Behaves exactly like the similarly-named operator in postgres.-(@@) :: QGenExpr context PgExpressionSyntax s TsVector- -> QGenExpr context PgExpressionSyntax s TsQuery- -> QGenExpr context PgExpressionSyntax s Bool+(@@) :: QGenExpr context Postgres s TsVector+ -> QGenExpr context Postgres s TsQuery+ -> QGenExpr context Postgres s Bool QExpr vec @@ QExpr q = QExpr (pgBinOp "@@" <$> vec <*> q) @@ -227,8 +234,8 @@ newtype TsQuery = TsQuery ByteString deriving (Show, Eq, Ord) -instance HasSqlEqualityCheck PgExpressionSyntax TsQuery-instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsQuery+instance HasSqlEqualityCheck Postgres TsQuery+instance HasSqlQuantifiedEqualityCheck Postgres TsQuery instance Pg.FromField TsQuery where fromField field d =@@ -242,9 +249,9 @@ -- | 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 :: BeamSqlBackendIsString Postgres str+ => Maybe TsVectorConfig -> QGenExpr context Postgres s str+ -> QGenExpr context Postgres s TsQuery toTsQuery Nothing (QExpr x) = QExpr (fmap (\(PgExpressionSyntax x') -> PgExpressionSyntax $@@ -261,9 +268,9 @@ -- syntax in postgres. The beam operator name has been chosen to match the -- 'Data.Vector.(!)' operator. (!.) :: Integral ix- => QGenExpr context PgExpressionSyntax s (V.Vector a)- -> QGenExpr context PgExpressionSyntax s ix- -> QGenExpr context PgExpressionSyntax s a+ => QGenExpr context Postgres s (V.Vector a)+ -> QGenExpr context Postgres s ix+ -> QGenExpr context Postgres s a QExpr v !. QExpr ix = QExpr (index <$> v <*> ix) where@@ -272,9 +279,9 @@ -- | Postgres @array_dims()@ function. Returns a textual representation of the -- dimensions of the array.-arrayDims_ :: IsSqlExpressionSyntaxStringType PgExpressionSyntax text- => QGenExpr context PgExpressionSyntax s (V.Vector a)- -> QGenExpr context PgExpressionSyntax s text+arrayDims_ :: BeamSqlBackendIsString Postgres text+ => QGenExpr context Postgres s (V.Vector a)+ -> QGenExpr context Postgres s text arrayDims_ (QExpr v) = QExpr (fmap (\(PgExpressionSyntax v') -> PgExpressionSyntax (emit "array_dims(" <> v' <> emit ")")) v) type family CountDims (v :: *) :: Nat where@@ -301,12 +308,12 @@ arrayUpper_, arrayLower_ :: forall (dim :: Nat) context num v s. (KnownNat dim, WithinBounds dim (V.Vector v), Integral num)- => QGenExpr context PgExpressionSyntax s (V.Vector v)- -> QGenExpr context PgExpressionSyntax s num+ => QGenExpr context Postgres s (V.Vector v)+ -> QGenExpr context Postgres s num arrayUpper_ v =- unsafeRetype (arrayUpperUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context PgExpressionSyntax s (Maybe Integer))+ unsafeRetype (arrayUpperUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context Postgres s (Maybe Integer)) arrayLower_ v =- unsafeRetype (arrayLowerUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context PgExpressionSyntax s (Maybe Integer))+ unsafeRetype (arrayLowerUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context Postgres s (Maybe Integer)) -- | These functions can be used to find the lower and upper bounds of an array -- where the dimension number is not known until run-time. They are marked@@ -314,9 +321,9 @@ -- they typecheck successfully. arrayUpperUnsafe_, arrayLowerUnsafe_ :: (Integral dim, Integral length)- => QGenExpr context PgExpressionSyntax s (V.Vector v)- -> QGenExpr context PgExpressionSyntax s dim- -> QGenExpr context PgExpressionSyntax s (Maybe length)+ => QGenExpr context Postgres s (V.Vector v)+ -> QGenExpr context Postgres s dim+ -> QGenExpr context Postgres s (Maybe length) arrayUpperUnsafe_ (QExpr v) (QExpr dim) = QExpr (fmap (PgExpressionSyntax . mconcat) . sequenceA $ [ pure (emit "array_upper(")@@ -338,18 +345,18 @@ arrayLength_ :: forall (dim :: Nat) ctxt num v s. (KnownNat dim, WithinBounds dim (V.Vector v), Integral num)- => QGenExpr ctxt PgExpressionSyntax s (V.Vector v)- -> QGenExpr ctxt PgExpressionSyntax s num+ => QGenExpr ctxt Postgres s (V.Vector v)+ -> QGenExpr ctxt Postgres s num arrayLength_ v =- unsafeRetype (arrayLengthUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr ctxt PgExpressionSyntax s (Maybe Integer))+ unsafeRetype (arrayLengthUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr ctxt Postgres s (Maybe Integer)) -- | Get the size of an array at a dimension not known until run-time. Marked -- unsafe as this may cause runtime errors even if it type checks. arrayLengthUnsafe_ :: (Integral dim, Integral num)- => QGenExpr ctxt PgExpressionSyntax s (V.Vector v)- -> QGenExpr ctxt PgExpressionSyntax s dim- -> QGenExpr ctxt PgExpressionSyntax s (Maybe num)+ => QGenExpr ctxt Postgres s (V.Vector v)+ -> QGenExpr ctxt Postgres s dim+ -> QGenExpr ctxt Postgres s (Maybe num) arrayLengthUnsafe_ (QExpr a) (QExpr dim) = QExpr $ fmap (PgExpressionSyntax . mconcat) $ sequenceA $ [ pure (emit "array_length(")@@ -360,24 +367,24 @@ -- | The Postgres @@>@ operator. Returns true if every member of the second -- array is present in the first.-isSupersetOf_ :: QGenExpr ctxt PgExpressionSyntax s (V.Vector a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)- -> QGenExpr ctxt PgExpressionSyntax s Bool+isSupersetOf_ :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s Bool isSupersetOf_ (QExpr haystack) (QExpr needles) = QExpr (pgBinOp "@>" <$> haystack <*> needles) -- | The Postgres @<@@ operator. Returns true if every member of the first -- array is present in the second.-isSubsetOf_ :: QGenExpr ctxt PgExpressionSyntax s (V.Vector a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)- -> QGenExpr ctxt PgExpressionSyntax s Bool+isSubsetOf_ :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s Bool isSubsetOf_ (QExpr needles) (QExpr haystack) = QExpr (pgBinOp "<@" <$> needles <*> haystack) -- | Postgres @||@ operator. Concatenates two vectors and returns their result.-(++.) :: QGenExpr ctxt PgExpressionSyntax s (V.Vector a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)+(++.) :: QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s (V.Vector a)+ -> QGenExpr ctxt Postgres s (V.Vector a) QExpr a ++. QExpr b = QExpr (pgBinOp "||" <$> a <*> b) @@ -403,8 +410,8 @@ -- containing expressions. array_ :: forall context f s a. (PgIsArrayContext context, Foldable f)- => f (QGenExpr context PgExpressionSyntax s a)- -> QGenExpr context PgExpressionSyntax s (V.Vector a)+ => f (QGenExpr context Postgres s a)+ -> QGenExpr context Postgres s (V.Vector a) array_ vs = QExpr $ fmap (PgExpressionSyntax . mkArraySyntax (Proxy @context) . mconcat) $ sequenceA [ pure (emit "[")@@ -412,8 +419,8 @@ , pure (emit "]") ] -- | Build a 1-dimensional postgres array from a subquery-arrayOf_ :: Q PgSelectSyntax db s (QExpr PgExpressionSyntax s a)- -> QGenExpr context PgExpressionSyntax s (V.Vector a)+arrayOf_ :: Q Postgres db s (QExpr Postgres s a)+ -> QGenExpr context Postgres s (V.Vector a) arrayOf_ q = let QExpr sub = subquery_ q in QExpr (\t -> let PgExpressionSyntax sub' = sub t@@ -496,7 +503,7 @@ instance PgIsRange PgDateRange where rangeName = "daterange" -instance (Pg.FromField a, Typeable a, Ord a) => Pg.FromField (PgRange n a) where+instance (Pg.FromField a, Typeable a, Typeable n, Ord a) => Pg.FromField (PgRange n a) where fromField field d = do pgR :: Pg.PGRange a <- Pg.fromField field d if Pg.isEmpty pgR@@ -524,10 +531,10 @@ (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 HasSqlEqualityCheck Postgres (PgRange n a)+instance HasSqlQuantifiedEqualityCheck Postgres (PgRange n a) -instance (Pg.FromField a, Typeable a, Ord a) => FromBackendRow Postgres (PgRange n a)+instance (Pg.FromField a, Typeable a, Typeable n, Ord a) => FromBackendRow Postgres (PgRange n a) instance (HasSqlValueSyntax PgValueSyntax a, PgIsRange n) => HasSqlValueSyntax PgValueSyntax (PgRange n a) where sqlValueSyntax PgEmptyRange =@@ -544,115 +551,115 @@ binOpDefault :: ByteString- -> QGenExpr context PgExpressionSyntax s a- -> QGenExpr context PgExpressionSyntax s b- -> QGenExpr context PgExpressionSyntax s c+ -> QGenExpr context Postgres s a+ -> QGenExpr context Postgres s b+ -> QGenExpr context Postgres 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+(-@>-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (-@>-) = binOpDefault "@>" -(-@>) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s a- -> QGenExpr context PgExpressionSyntax s Bool+(-@>) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s a+ -> QGenExpr context Postgres s Bool (-@>) = binOpDefault "@>" -(-<@-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(-<@-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (-<@-) = binOpDefault "<@" -(<@-) :: QGenExpr context PgExpressionSyntax s a- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(<@-) :: QGenExpr context Postgres s a+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (<@-) = binOpDefault "<@" -(-&&-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(-&&-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (-&&-) = binOpDefault "&&" -(-<<-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(-<<-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (-<<-) = binOpDefault "<<" -(->>-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(->>-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (->>-) = binOpDefault ">>" -(-&<-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(-&<-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (-&<-) = binOpDefault "&<" -(-&>-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(-&>-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (-&>-) = binOpDefault "&>" -(--|--) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+(--|--) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool (--|--) = binOpDefault "-|-" -(-+-) :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (PgRange n a)+(-+-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres 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)+(-*-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres 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)+(-.-) :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a) (-.-) = binOpDefault "-" defUnaryFn :: ByteString- -> QGenExpr context PgExpressionSyntax s a- -> QGenExpr context PgExpressionSyntax s b+ -> QGenExpr context Postgres s a+ -> QGenExpr context Postgres 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_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (Maybe a) rLower_ = defUnaryFn "LOWER" -rUpper_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s (Maybe a)+rUpper_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (Maybe a) rUpper_ = defUnaryFn "UPPER" -isEmpty_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+isEmpty_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool isEmpty_ = defUnaryFn "ISEMPTY" -lowerInc_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+lowerInc_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool lowerInc_ = defUnaryFn "LOWER_INC" -upperInc_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+upperInc_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool upperInc_ = defUnaryFn "UPPER_INC" -lowerInf_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+lowerInf_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s Bool lowerInf_ = defUnaryFn "LOWER_INF" -upperInf_ :: QGenExpr context PgExpressionSyntax s (PgRange n a)- -> QGenExpr context PgExpressionSyntax s Bool+upperInf_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres 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_ :: QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a)+ -> QGenExpr context Postgres s (PgRange n a) rangeMerge_ (QExpr r1) (QExpr r2) = QExpr (pgExprFrom <$> r1 <*> r2) where pgExprFrom r1' r2' =@@ -666,9 +673,9 @@ 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)+ -> QGenExpr context Postgres s (Maybe a) -- ^. Lower bound value+ -> QGenExpr context Postgres s (Maybe a) -- ^. Upper bound value+ -> QGenExpr context Postgres s (PgRange n a) range_ lbt ubt (QExpr e1) (QExpr e2) = QExpr (pgExprFrom <$> e1 <*> e2) where bounds = emit "'" <> emit (lBound lbt <> uBound ubt) <> emit "'"@@ -689,8 +696,8 @@ newtype PgJSON a = PgJSON a deriving ( Show, Eq, Ord, Hashable, Monoid, Semigroup ) -instance HasSqlEqualityCheck PgExpressionSyntax (PgJSON a)-instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSON a)+instance HasSqlEqualityCheck Postgres (PgJSON a)+instance HasSqlQuantifiedEqualityCheck Postgres (PgJSON a) instance (Typeable x, FromJSON x) => Pg.FromField (PgJSON x) where fromField field d =@@ -714,8 +721,8 @@ newtype PgJSONB a = PgJSONB a deriving ( Show, Eq, Ord, Hashable, Monoid, Semigroup ) -instance HasSqlEqualityCheck PgExpressionSyntax (PgJSONB a)-instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSONB a)+instance HasSqlEqualityCheck Postgres (PgJSONB a)+instance HasSqlQuantifiedEqualityCheck Postgres (PgJSONB a) instance (Typeable x, FromJSON x) => Pg.FromField (PgJSONB x) where fromField field d =@@ -759,42 +766,43 @@ class IsPgJSON (json :: * -> *) where -- | The @json_each@ or @jsonb_each@ function. Values returned as @json@ or -- @jsonb@ respectively. Use 'pgUnnest' to join against the result- pgJsonEach :: QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONEach (json Value)))+ pgJsonEach :: QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach (json Value))) -- | Like 'pgJsonEach', but returning text values instead- pgJsonEachText :: QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONEach T.Text))+ pgJsonEachText :: QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONEach T.Text)) -- | The @json_object_keys@ and @jsonb_object_keys@ function. Use 'pgUnnest' -- to join against the result.- pgJsonKeys :: QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (PgSetOf PgJSONKey)+ pgJsonKeys :: QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (PgSetOf PgJSONKey) -- | The @json_array_elements@ and @jsonb_array_elements@ function. Use -- 'pgUnnest' to join against the result- pgJsonArrayElements :: QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONElement (json Value)))+ pgJsonArrayElements :: QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement (json Value))) -- | Like 'pgJsonArrayElements', but returning the values as 'T.Text'- pgJsonArrayElementsText :: QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONElement T.Text))+ pgJsonArrayElementsText :: QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (PgSetOf (PgJSONElement T.Text)) -- pgJsonToRecord -- pgJsonToRecordSet -- | The @json_typeof@ or @jsonb_typeof@ function- pgJsonTypeOf :: QGenExpr ctxt PgExpressionSyntax s (json a) -> QGenExpr ctxt PgExpressionSyntax s T.Text+ pgJsonTypeOf :: QGenExpr ctxt Postgres s (json a) -> QGenExpr ctxt Postgres s T.Text -- | The @json_strip_nulls@ or @jsonb_strip_nulls@ function.- pgJsonStripNulls :: QGenExpr ctxt PgExpressionSyntax s (json a) -> QGenExpr ctxt PgExpressionSyntax s (json b)+ pgJsonStripNulls :: QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (json b) -- | The @json_agg@ or @jsonb_agg@ aggregate.- pgJsonAgg :: QExpr PgExpressionSyntax s a -> QAgg PgExpressionSyntax s (json a)+ pgJsonAgg :: QExpr Postgres s a -> QAgg Postgres s (json a) -- | The @json_object_agg@ or @jsonb_object_agg@. The first argument gives the -- key source and the second the corresponding values.- pgJsonObjectAgg :: QExpr PgExpressionSyntax s key -> QExpr PgExpressionSyntax s value- -> QAgg PgExpressionSyntax s (json a)+ pgJsonObjectAgg :: QExpr Postgres s key -> QExpr Postgres s value+ -> QAgg Postgres s (json a) instance IsPgJSON PgJSON where pgJsonEach (QExpr a) =@@ -860,9 +868,9 @@ -- json object pointed to by the arrow is completely contained in the other. See -- the Postgres documentation for more in formation on what this means. (@>), (<@) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (json b)- -> QGenExpr ctxt PgExpressionSyntax s Bool+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (json b)+ -> QGenExpr ctxt Postgres s Bool QExpr a @> QExpr b = QExpr (pgBinOp "@>" <$> a <*> b) QExpr a <@ QExpr b =@@ -871,18 +879,18 @@ -- | Access a JSON array by index. Corresponds to the Postgres @->@ operator. -- See '(->$)' for the corresponding operator for object access. (->#) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s Int- -> QGenExpr ctxt PgExpressionSyntax s (json b)+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s Int+ -> QGenExpr ctxt Postgres s (json b) QExpr a -># QExpr b = QExpr (pgBinOp "->" <$> a <*> b) -- | Acces a JSON object by key. Corresponds to the Postgres @->@ operator. See -- '(->#)' for the corresponding operator for arrays. (->$) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s T.Text- -> QGenExpr ctxt PgExpressionSyntax s (json b)+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s T.Text+ -> QGenExpr ctxt Postgres s (json b) QExpr a ->$ QExpr b = QExpr (pgBinOp "->" <$> a <*> b) @@ -890,9 +898,9 @@ -- Corresponds to the Postgres @->>@ operator. See '(->>$)' for the -- corresponding operator on objects. (->>#) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s Int- -> QGenExpr ctxt PgExpressionSyntax s T.Text+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s Int+ -> QGenExpr ctxt Postgres s T.Text QExpr a ->># QExpr b = QExpr (pgBinOp "->>" <$> a <*> b) @@ -900,9 +908,9 @@ -- Corresponds to the Postgres @->>@ operator. See '(->>#)' for the -- corresponding operator on arrays. (->>$) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s T.Text- -> QGenExpr ctxt PgExpressionSyntax s T.Text+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s T.Text+ -> QGenExpr ctxt Postgres s T.Text QExpr a ->>$ QExpr b = QExpr (pgBinOp "->>" <$> a <*> b) @@ -912,35 +920,35 @@ -- function allows etiher string keys or integer indices, but this function only -- allows string keys. PRs to improve this functionality are welcome. (#>) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)- -> QGenExpr ctxt PgExpressionSyntax s (json b)+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (V.Vector T.Text)+ -> QGenExpr ctxt Postgres s (json b) QExpr a #> QExpr b = QExpr (pgBinOp "#>" <$> a <*> b) -- | Like '(#>)' but returns the result as a string. (#>>) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)- -> QGenExpr ctxt PgExpressionSyntax s T.Text+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (V.Vector T.Text)+ -> QGenExpr ctxt Postgres s T.Text QExpr a #>> QExpr b = QExpr (pgBinOp "#>>" <$> a <*> b) -- | Postgres @?@ operator. Checks if the given string exists as top-level key -- of the json object. (?) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s T.Text- -> QGenExpr ctxt PgExpressionSyntax s Bool+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s T.Text+ -> QGenExpr ctxt Postgres s Bool QExpr a ? QExpr b = QExpr (pgBinOp "?" <$> a <*> b) -- | Postgres @?|@ and @?&@ operators. Check if any or all of the given strings -- exist as top-level keys of the json object respectively. (?|), (?&) :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)- -> QGenExpr ctxt PgExpressionSyntax s Bool+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (V.Vector T.Text)+ -> QGenExpr ctxt Postgres s Bool QExpr a ?| QExpr b = QExpr (pgBinOp "?|" <$> a <*> b) QExpr a ?& QExpr b =@@ -950,34 +958,34 @@ -- with the supplied key deleted. See 'withoutIdx' for the corresponding -- operator on arrays. withoutKey :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s T.Text- -> QGenExpr ctxt PgExpressionSyntax s (json b)+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s T.Text+ -> QGenExpr ctxt Postgres s (json b) QExpr a `withoutKey` QExpr b = QExpr (pgBinOp "-" <$> a <*> b) -- | Postgres @-@ operator on json arrays. See 'withoutKey' for the -- corresponding operator on objects. withoutIdx :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s Int- -> QGenExpr ctxt PgExpressionSyntax s (json b)+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s Int+ -> QGenExpr ctxt Postgres s (json b) QExpr a `withoutIdx` QExpr b = QExpr (pgBinOp "-" <$> a <*> b) -- | Postgres @#-@ operator. Removes all the keys specificied from the JSON -- object and returns the result. withoutKeys :: IsPgJSON json- => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)- -> QGenExpr ctxt PgExpressionSyntax s (json b)+ => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s (V.Vector T.Text)+ -> QGenExpr ctxt Postgres s (json b) QExpr a `withoutKeys` QExpr b = QExpr (pgBinOp "#-" <$> a <*> b) -- | Postgres @json_array_length@ function. The supplied json object should be -- an array, but this isn't checked at compile-time.-pgJsonArrayLength :: IsPgJSON json => QGenExpr ctxt PgExpressionSyntax s (json a)- -> QGenExpr ctxt PgExpressionSyntax s Int+pgJsonArrayLength :: IsPgJSON json => QGenExpr ctxt Postgres s (json a)+ -> QGenExpr ctxt Postgres s Int pgJsonArrayLength (QExpr a) = QExpr $ \tbl -> PgExpressionSyntax (emit "json_array_length(" <> fromPgExpression (a tbl) <> emit ")")@@ -988,10 +996,10 @@ -- objects necessary. This corresponds to the @create_missing@ argument of -- @jsonb_set@ being set to false or true respectively. pgJsonbUpdate, pgJsonbSet- :: QGenExpr ctxt PgExpressionSyntax s (PgJSONB a)- -> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)- -> QGenExpr ctxt PgExpressionSyntax s (PgJSONB b)- -> QGenExpr ctxt PgExpressionSyntax s (PgJSONB a)+ :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s (V.Vector T.Text)+ -> QGenExpr ctxt Postgres s (PgJSONB b)+ -> QGenExpr ctxt Postgres s (PgJSONB a) pgJsonbUpdate (QExpr a) (QExpr path) (QExpr newVal) = QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_set") . pgParens . mconcat) $ sequenceA $ [ fromPgExpression <$> a, pure (emit ", "), fromPgExpression <$> path, pure (emit ", "), fromPgExpression <$> newVal ]@@ -1000,8 +1008,8 @@ [ fromPgExpression <$> a, pure (emit ", "), fromPgExpression <$> path, pure (emit ", "), fromPgExpression <$> newVal, pure (emit ", true") ] -- | Postgres @jsonb_pretty@ function-pgJsonbPretty :: QGenExpr ctxt PgExpressionSyntax s (PgJSONB a)- -> QGenExpr ctxt PgExpressionSyntax s T.Text+pgJsonbPretty :: QGenExpr ctxt Postgres s (PgJSONB a)+ -> QGenExpr ctxt Postgres s T.Text pgJsonbPretty (QExpr a) = QExpr (\tbl -> PgExpressionSyntax (emit "jsonb_pretty" <> pgParens (fromPgExpression (a tbl)))) @@ -1010,15 +1018,15 @@ -- | An aggregate that adds each value to the resulting array. See 'pgArrayOver' -- if you want to specify a quantifier. Corresponds to the Postgres @ARRAY_AGG@ -- function.-pgArrayAgg :: QExpr PgExpressionSyntax s a- -> QAgg PgExpressionSyntax s (V.Vector a)+pgArrayAgg :: QExpr Postgres s a+ -> QAgg Postgres s (V.Vector a) pgArrayAgg = pgArrayAggOver allInGroup_ -- | Postgres @ARRAY_AGG@ with an explicit quantifier. Includes each row that -- meets the quantification criteria in the result. pgArrayAggOver :: Maybe PgAggregationSetQuantifierSyntax- -> QExpr PgExpressionSyntax s a- -> QAgg PgExpressionSyntax s (V.Vector a)+ -> QExpr Postgres s a+ -> QAgg Postgres s (V.Vector a) pgArrayAggOver quantifier (QExpr a) = QExpr $ \tbl -> PgExpressionSyntax $@@ -1027,15 +1035,15 @@ fromPgExpression (a tbl)) -- | Postgres @bool_or@ aggregate. Returns true if any of the rows are true.-pgBoolOr :: QExpr PgExpressionSyntax s a- -> QAgg PgExpressionSyntax s (Maybe Bool)+pgBoolOr :: QExpr Postgres s a+ -> QAgg Postgres s (Maybe Bool) pgBoolOr (QExpr a) = QExpr $ \tbl -> PgExpressionSyntax $ emit "bool_or" <> pgParens (fromPgExpression (a tbl)) -- | Postgres @bool_and@ aggregate. Returns false unless every row is true.-pgBoolAnd :: QExpr PgExpressionSyntax s a- -> QAgg PgExpressionSyntax s (Maybe Bool)+pgBoolAnd :: QExpr Postgres s a+ -> QAgg Postgres s (Maybe Bool) pgBoolAnd (QExpr a) = QExpr $ \tbl -> PgExpressionSyntax $ emit "bool_and" <> pgParens (fromPgExpression (a tbl))@@ -1045,19 +1053,19 @@ -- | Joins the string value in each row of the first argument, using the second -- argument as a delimiter. See 'pgStringAggOver' if you want to provide -- explicit quantification.-pgStringAgg :: IsSqlExpressionSyntaxStringType PgExpressionSyntax str- => QExpr PgExpressionSyntax s str- -> QExpr PgExpressionSyntax s str- -> QAgg PgExpressionSyntax s (Maybe str)+pgStringAgg :: BeamSqlBackendIsString Postgres str+ => QExpr Postgres s str+ -> QExpr Postgres s str+ -> QAgg Postgres s (Maybe str) pgStringAgg = pgStringAggOver allInGroup_ -- | The Postgres @string_agg@ function, with an explicit quantifier. Joins the -- values of the second argument using the delimiter given by the third.-pgStringAggOver :: IsSqlExpressionSyntaxStringType PgExpressionSyntax str+pgStringAggOver :: BeamSqlBackendIsString Postgres str => Maybe PgAggregationSetQuantifierSyntax- -> QExpr PgExpressionSyntax s str- -> QExpr PgExpressionSyntax s str- -> QAgg PgExpressionSyntax s (Maybe str)+ -> QExpr Postgres s str+ -> QExpr Postgres s str+ -> QAgg Postgres s (Maybe str) pgStringAggOver quantifier (QExpr v) (QExpr delim) = QExpr $ \tbl -> PgExpressionSyntax $ emit "string_agg" <>@@ -1069,12 +1077,16 @@ -- | Modify a query to only return rows where the supplied key function returns -- a unique value. This corresponds to the Postgres @DISTINCT ON@ support.-pgNubBy_ :: ( Projectible PgExpressionSyntax key- , Projectible PgExpressionSyntax r )+pgNubBy_ :: ( Projectible Postgres key+ , Projectible Postgres r ) => (r -> key)- -> Q PgSelectSyntax db s r- -> Q PgSelectSyntax db s r-pgNubBy_ mkKey (Q q) = Q $ liftF (QDistinct (\r pfx -> pgSelectSetQuantifierDistinctOn (project (mkKey r) pfx)) q id)+ -> Q Postgres db s r+ -> Q Postgres db s r+pgNubBy_ mkKey (Q q) =+ Q . liftF $+ QDistinct (\r pfx -> pgSelectSetQuantifierDistinctOn+ (project (Proxy @Postgres) (mkKey r) pfx))+ q id -- ** PostgreSql @MONEY@ data type @@ -1095,8 +1107,8 @@ instance Pg.ToField PgMoney where toField (PgMoney a) = Pg.toField a -instance HasSqlEqualityCheck PgExpressionSyntax PgMoney-instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax PgMoney+instance HasSqlEqualityCheck Postgres PgMoney+instance HasSqlQuantifiedEqualityCheck Postgres PgMoney instance FromBackendRow Postgres PgMoney instance HasSqlValueSyntax PgValueSyntax PgMoney where@@ -1113,9 +1125,9 @@ -- | Multiply a @MONEY@ value by a numeric value. Corresponds to the Postgres -- @*@ operator. pgScaleMoney_ :: Num a- => QGenExpr context PgExpressionSyntax s a- -> QGenExpr context PgExpressionSyntax s PgMoney- -> QGenExpr context PgExpressionSyntax s PgMoney+ => QGenExpr context Postgres s a+ -> QGenExpr context Postgres s PgMoney+ -> QGenExpr context Postgres s PgMoney pgScaleMoney_ (QExpr scale) (QExpr v) = QExpr (pgBinOp "*" <$> scale <*> v) @@ -1124,26 +1136,26 @@ -- would like to divide two @MONEY@ values and have their units cancel out, use -- 'pgDivideMoneys_'. pgDivideMoney_ :: Num a- => QGenExpr context PgExpressionSyntax s PgMoney- -> QGenExpr context PgExpressionSyntax s a- -> QGenExpr context PgExpressionSyntax s PgMoney+ => QGenExpr context Postgres s PgMoney+ -> QGenExpr context Postgres s a+ -> QGenExpr context Postgres s PgMoney pgDivideMoney_ (QExpr v) (QExpr scale) = QExpr (pgBinOp "/" <$> v <*> scale) -- | Dividing two @MONEY@ value results in a number. Corresponds to Postgres @/@ -- on two @MONEY@ values. If you would like to divide @MONEY@ by a scalar, use 'pgDivideMoney_' pgDivideMoneys_ :: Num a- => QGenExpr context PgExpressionSyntax s PgMoney- -> QGenExpr context PgExpressionSyntax s PgMoney- -> QGenExpr context PgExpressionSyntax s a+ => QGenExpr context Postgres s PgMoney+ -> QGenExpr context Postgres s PgMoney+ -> QGenExpr context Postgres s a pgDivideMoneys_ (QExpr a) (QExpr b) = QExpr (pgBinOp "/" <$> a <*> b) -- | Postgres @+@ and @-@ operators on money. pgAddMoney_, pgSubtractMoney_- :: QGenExpr context PgExpressionSyntax s PgMoney- -> QGenExpr context PgExpressionSyntax s PgMoney- -> QGenExpr context PgExpressionSyntax s PgMoney+ :: QGenExpr context Postgres s PgMoney+ -> QGenExpr context Postgres s PgMoney+ -> QGenExpr context Postgres s PgMoney pgAddMoney_ (QExpr a) (QExpr b) = QExpr (pgBinOp "+" <$> a <*> b) pgSubtractMoney_ (QExpr a) (QExpr b) =@@ -1154,18 +1166,101 @@ -- 'pgAvgMoney_' for the unquantified versions. pgSumMoneyOver_, pgAvgMoneyOver_ :: Maybe PgAggregationSetQuantifierSyntax- -> QExpr PgExpressionSyntax s PgMoney -> QExpr PgExpressionSyntax s PgMoney+ -> QExpr Postgres s PgMoney -> QExpr Postgres s PgMoney pgSumMoneyOver_ q (QExpr a) = QExpr (sumE q <$> a) pgAvgMoneyOver_ q (QExpr a) = QExpr (avgE q <$> a) -- | The Postgres @MONEY@ type can be summed or averaged in an aggregation. To -- provide an explicit quantification, see 'pgSumMoneyOver_' and -- 'pgAvgMoneyOver_'.-pgSumMoney_, pgAvgMoney_ :: QExpr PgExpressionSyntax s PgMoney- -> QExpr PgExpressionSyntax s PgMoney+pgSumMoney_, pgAvgMoney_ :: QExpr Postgres s PgMoney+ -> QExpr Postgres s PgMoney pgSumMoney_ = pgSumMoneyOver_ allInGroup_ pgAvgMoney_ = pgAvgMoneyOver_ allInGroup_ +-- ** Geometry types++data PgPoint = PgPoint {-# UNPACK #-} !Double {-# UNPACK #-} !Double+ deriving (Show, Eq, Ord)++data PgLine = PgLine {-# UNPACK #-} !Double -- A+ {-# UNPACK #-} !Double -- B+ {-# UNPACK #-} !Double -- C+ deriving (Show, Eq, Ord)++data PgLineSegment = PgLineSegment {-# UNPACK #-} !PgPoint {-# UNPACK #-} !PgPoint+ deriving (Show, Eq, Ord)++data PgBox = PgBox {-# UNPACK #-} !PgPoint {-# UNPACK #-} !PgPoint+ deriving (Show)++instance Eq PgBox where+ PgBox a1 b1 == PgBox a2 b2 =+ (a1 == a2 && b1 == b2) ||+ (a1 == b2 && b1 == a2)++data PgPath+ = PgPathOpen (NE.NonEmpty PgPoint)+ | PgPathClosed (NE.NonEmpty PgPoint)+ deriving (Show, Eq, Ord)++data PgPolygon+ = PgPolygon (NE.NonEmpty PgPoint)+ deriving (Show, Eq, Ord)++data PgCircle = PgCircle {-# UNPACK #-} !PgPoint {-# UNPACK #-} !Double+ deriving (Show, Eq, Ord)++encodePgPoint :: PgPoint -> Builder+encodePgPoint (PgPoint x y) =+ "(" <> doubleDec x <> "," <> doubleDec y <> ")"++instance HasSqlValueSyntax PgValueSyntax PgPoint where+ sqlValueSyntax pt =+ PgValueSyntax $ emitBuilder ("'" <> encodePgPoint pt <> "'")+instance HasSqlValueSyntax PgValueSyntax PgLine where+ sqlValueSyntax (PgLine a b c) =+ PgValueSyntax $ emitBuilder ("'{" <> doubleDec a <> "," <> doubleDec b <> "," <> doubleDec c <> "}'")+instance HasSqlValueSyntax PgValueSyntax PgLineSegment where+ sqlValueSyntax (PgLineSegment a b) =+ PgValueSyntax $ emitBuilder ("'(" <> encodePgPoint a <> "," <> encodePgPoint b <> ")'")+instance HasSqlValueSyntax PgValueSyntax PgBox where+ sqlValueSyntax (PgBox a b) =+ PgValueSyntax $ emitBuilder ("'(" <> encodePgPoint a <> "," <> encodePgPoint b <> ")'")++-- TODO Pg polygon and such++-- TODO frombackendrow++instance Pg.FromField PgPoint where+ fromField field Nothing = Pg.returnError Pg.UnexpectedNull field ""+ fromField field (Just d) =+ if Pg.typeOid field /= Pg.typoid Pg.point+ then Pg.returnError Pg.Incompatible field ""+ else case parseOnly pgPointParser d of+ Left err -> Pg.returnError Pg.ConversionFailed field ("PgPoint: " ++ err)+ Right pt -> pure pt+instance FromBackendRow Postgres PgPoint++pgPointParser :: Parser PgPoint+pgPointParser = PgPoint <$> (char '(' *> double <* char ',')+ <*> (double <* char ')')++instance Pg.FromField PgBox where+ fromField field Nothing = Pg.returnError Pg.UnexpectedNull field ""+ fromField field (Just d) =+ if Pg.typeOid field /= Pg.typoid Pg.box+ then Pg.returnError Pg.Incompatible field ""+ else case parseOnly boxParser d of+ Left err -> Pg.returnError Pg.ConversionFailed field ("PgBox: " ++ err)+ Right box -> pure box++ where+ boxParser = PgBox <$> (pgPointParser <* char ',')+ <*> pgPointParser+instance FromBackendRow Postgres PgBox++ -- ** Set-valued functions data PgSetOf (tbl :: (* -> *) -> *)@@ -1173,15 +1268,15 @@ pgUnnest' :: forall tbl db s . Beamable tbl => (TablePrefix -> PgSyntax)- -> Q PgSelectSyntax db s (QExprTable PgExpressionSyntax s tbl)+ -> Q Postgres db s (QExprTable Postgres s tbl) pgUnnest' q = Q (liftF (QAll (\pfx alias -> PgFromSyntax . mconcat $ [ q pfx, emit " " , pgQuotedIdentifier alias- , pgParens (pgSepBy (emit ", ") (allBeamValues (\(Columnar' (TableField nm)) -> pgQuotedIdentifier nm) tblFields))+ , pgParens (pgSepBy (emit ", ") (allBeamValues (\(Columnar' (TableField _ nm)) -> pgQuotedIdentifier nm) tblFields)) ])- tblFields+ (tableFieldsToExpressions tblFields) (\_ -> Nothing) snd)) where tblFields :: TableSettings tbl@@ -1189,13 +1284,14 @@ evalState (zipBeamFieldsM (\_ _ -> do i <- get put (i + 1)- pure (Columnar' (TableField (fromString ("r" ++ show i)))))+ let fieldNm = fromString ("r" ++ show i)+ pure (Columnar' (TableField (pure fieldNm) fieldNm))) tblSkeleton tblSkeleton) (0 :: Int) pgUnnest :: forall tbl db s . Beamable tbl- => QExpr PgExpressionSyntax s (PgSetOf tbl)- -> Q PgSelectSyntax db s (QExprTable PgExpressionSyntax s tbl)+ => QExpr Postgres s (PgSetOf tbl)+ -> Q Postgres db s (QExprTable Postgres s tbl) pgUnnest (QExpr q) = pgUnnest' (\t -> pgParens (fromPgExpression (q t))) @@ -1203,8 +1299,8 @@ deriving Generic instance Beamable (PgUnnestArrayTbl a) -pgUnnestArray :: QExpr PgExpressionSyntax s (V.Vector a)- -> Q PgSelectSyntax db s (QExpr PgExpressionSyntax s a)+pgUnnestArray :: QExpr Postgres s (V.Vector a)+ -> Q Postgres db s (QExpr Postgres s a) pgUnnestArray (QExpr q) = fmap (\(PgUnnestArrayTbl x) -> x) $ pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t)))@@ -1213,35 +1309,43 @@ deriving Generic instance Beamable (PgUnnestArrayWithOrdinalityTbl a) -pgUnnestArrayWithOrdinality :: QExpr PgExpressionSyntax s (V.Vector a)- -> Q PgSelectSyntax db s (QExpr PgExpressionSyntax s Int, QExpr PgExpressionSyntax s a)+pgUnnestArrayWithOrdinality :: QExpr Postgres s (V.Vector a)+ -> Q Postgres db s (QExpr Postgres s Int, QExpr Postgres s a) pgUnnestArrayWithOrdinality (QExpr q) = fmap (\(PgUnnestArrayWithOrdinalityTbl i x) -> (i, x)) $ pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t)) <> emit " WITH ORDINALITY") -instance HasDefaultSqlDataType PgDataTypeSyntax TsQuery where- defaultSqlDataType _ _ = pgTsQueryType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax TsQuery+instance HasDefaultSqlDataType Postgres PgPoint where+ defaultSqlDataType _ _ _ = pgPointType -instance HasDefaultSqlDataType PgDataTypeSyntax TsVector where- defaultSqlDataType _ _ = pgTsVectorType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax TsVector+instance HasDefaultSqlDataType Postgres PgLine where+ defaultSqlDataType _ _ _ = pgLineType -instance HasDefaultSqlDataType PgDataTypeSyntax (PgJSON a) where- defaultSqlDataType _ _ = pgJsonType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (PgJSON a)+instance HasDefaultSqlDataType Postgres PgLineSegment where+ defaultSqlDataType _ _ _ = pgLineSegmentType -instance HasDefaultSqlDataType PgDataTypeSyntax (PgJSONB a) where- defaultSqlDataType _ _ = pgJsonbType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (PgJSONB a)+instance HasDefaultSqlDataType Postgres PgBox where+ defaultSqlDataType _ _ _ = pgBoxType -instance HasDefaultSqlDataType PgDataTypeSyntax PgMoney where- defaultSqlDataType _ _ = pgMoneyType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax PgMoney+instance HasDefaultSqlDataType Postgres TsQuery where+ defaultSqlDataType _ _ _ = pgTsQueryType -instance HasDefaultSqlDataType PgDataTypeSyntax a => HasDefaultSqlDataType PgDataTypeSyntax (V.Vector a) where- defaultSqlDataType _ embedded = pgUnboundedArrayType (defaultSqlDataType (Proxy :: Proxy a) embedded)-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (V.Vector a)+instance HasDefaultSqlDataType Postgres TsVector where+ defaultSqlDataType _ _ _ = pgTsVectorType++instance HasDefaultSqlDataType Postgres (PgJSON a) where+ defaultSqlDataType _ _ _ = pgJsonType++instance HasDefaultSqlDataType Postgres (PgJSONB a) where+ defaultSqlDataType _ _ _ = pgJsonbType++instance HasDefaultSqlDataType Postgres PgMoney where+ defaultSqlDataType _ _ _ = pgMoneyType++instance HasDefaultSqlDataType Postgres a+ => HasDefaultSqlDataType Postgres (V.Vector a) where+ defaultSqlDataType _ be embedded =+ pgUnboundedArrayType (defaultSqlDataType (Proxy :: Proxy a) be embedded) -- $full-text-search --
Database/Beam/Postgres/Syntax.hs view
@@ -30,7 +30,7 @@ , PgDeleteSyntax(..) , PgUpdateSyntax(..) - , PgExpressionSyntax(..), PgFromSyntax(..)+ , PgExpressionSyntax(..), PgFromSyntax(..), PgTableNameSyntax(..) , PgComparisonQuantifierSyntax(..) , PgExtractFieldSyntax(..) , PgProjectionSyntax(..), PgGroupingSyntax(..)@@ -55,10 +55,11 @@ , defaultPgValueSyntax , PgDataTypeDescr(..)+ , PgHasEnum(..) , pgCreateExtensionSyntax, pgDropExtensionSyntax+ , pgCreateEnumSyntax, pgDropTypeSyntax - , insertDefaults , pgSimpleMatchSyntax , pgSelectSetQuantifierDistinctOn@@ -73,6 +74,8 @@ , pgByteaType, pgTextType, pgUnboundedArrayType , pgSerialType, pgSmallSerialType, pgBigSerialType + , pgPointType, pgLineType, pgLineSegmentType, pgBoxType+ , pgQuotedIdentifier, pgSepBy, pgDebugRenderSyntax , pgRenderSyntaxScript, pgBuildAction @@ -84,14 +87,12 @@ import Database.Beam hiding (insert) import Database.Beam.Backend.SQL-import Database.Beam.Query.SQL92--import Database.Beam.Migrate.SQL+import Database.Beam.Migrate+import Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck(..)) import Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes) import Database.Beam.Migrate.Serialization -import Database.Beam.Migrate.Generics-+import Control.Monad (guard) import Control.Monad.Free import Control.Monad.Free.Church @@ -109,24 +110,23 @@ import Data.Hashable import Data.Int import Data.Maybe+#if !MIN_VERSION_base(4, 11, 0)+import Data.Semigroup+#endif import Data.Scientific (Scientific) import Data.String (IsString(..), fromString)-import Data.Tagged import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL-import Data.Time (LocalTime, UTCTime, ZonedTime, TimeOfDay, NominalDiffTime, Day)+import Data.Time (LocalTime, UTCTime, TimeOfDay, NominalDiffTime, Day) import Data.UUID.Types (UUID)-import qualified Data.Vector as V import Data.Word-#if !MIN_VERSION_base(4, 11, 0)-import Data.Semigroup-#endif+import qualified Data.Vector as V import qualified Database.PostgreSQL.Simple.ToField as Pg import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg import qualified Database.PostgreSQL.Simple.Types as Pg (Oid(..), Binary(..), Null(..))-import qualified Database.PostgreSQL.Simple.Time as Pg (Date, ZonedTimestamp, LocalTimestamp, UTCTimestamp)+import qualified Database.PostgreSQL.Simple.Time as Pg (Date, LocalTimestamp, UTCTimestamp) import qualified Database.PostgreSQL.Simple.HStore as Pg (HStoreList, HStoreMap, HStoreBuilder) data PostgresInaccessible@@ -233,8 +233,6 @@ -- | 'IsSql92SelectSyntax' for Postgres newtype PgSelectSyntax = PgSelectSyntax { fromPgSelect :: PgSyntax }-instance HasQBuilder PgSelectSyntax where- buildSqlQuery = buildSql92Query' True newtype PgSelectTableSyntax = PgSelectTableSyntax { fromPgSelectTable :: PgSyntax } @@ -251,6 +249,7 @@ newtype PgAggregationSetQuantifierSyntax = PgAggregationSetQuantifierSyntax { fromPgAggregationSetQuantifier :: PgSyntax } newtype PgSelectSetQuantifierSyntax = PgSelectSetQuantifierSyntax { fromPgSelectSetQuantifier :: PgSyntax } newtype PgFromSyntax = PgFromSyntax { fromPgFrom :: PgSyntax }+newtype PgTableNameSyntax = PgTableNameSyntax { fromPgTableName :: PgSyntax } newtype PgComparisonQuantifierSyntax = PgComparisonQuantifierSyntax { fromPgComparisonQuantifier :: PgSyntax } newtype PgExtractFieldSyntax = PgExtractFieldSyntax { fromPgExtractField :: PgSyntax } newtype PgProjectionSyntax = PgProjectionSyntax { fromPgProjection :: PgSyntax }@@ -267,6 +266,8 @@ data PgSelectLockingClauseSyntax = PgSelectLockingClauseSyntax { pgSelectLockingClauseStrength :: PgSelectLockingStrength , pgSelectLockingTables :: [T.Text] , pgSelectLockingClauseOptions :: Maybe PgSelectLockingOptions }+newtype PgCommonTableExpressionSyntax+ = PgCommonTableExpressionSyntax { fromPgCommonTableExpression :: PgSyntax } fromPgOrdering :: PgOrderingSyntax -> PgSyntax fromPgOrdering (PgOrderingSyntax s Nothing) = s@@ -384,6 +385,13 @@ instance Eq PgDataTypeSyntax where PgDataTypeSyntax a _ _ == PgDataTypeSyntax b _ _ = a == b +instance HasDataTypeCreatedCheck PgDataTypeSyntax where+ dataTypeHasBeenCreated (PgDataTypeSyntax (PgDataTypeDescrOid {}) _ _) _ = True+ dataTypeHasBeenCreated (PgDataTypeSyntax (PgDataTypeDescrDomain d) _ _) pre =+ not . null $+ do PgHasEnum nm _ <- pre+ guard (nm == d)+ instance Eq PgColumnConstraintDefinitionSyntax where PgColumnConstraintDefinitionSyntax a _ == PgColumnConstraintDefinitionSyntax b _ =@@ -409,13 +417,18 @@ dropTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce alterTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce +instance IsSql92TableNameSyntax PgTableNameSyntax where+ tableName Nothing t = PgTableNameSyntax (pgQuotedIdentifier t)+ tableName (Just s) t = PgTableNameSyntax (pgQuotedIdentifier s <> emit "." <> pgQuotedIdentifier t)+ instance IsSql92UpdateSyntax PgUpdateSyntax where type Sql92UpdateFieldNameSyntax PgUpdateSyntax = PgFieldNameSyntax type Sql92UpdateExpressionSyntax PgUpdateSyntax = PgExpressionSyntax+ type Sql92UpdateTableNameSyntax PgUpdateSyntax = PgTableNameSyntax updateStmt tbl fields where_ = PgUpdateSyntax $- emit "UPDATE " <> pgQuotedIdentifier tbl <>+ emit "UPDATE " <> fromPgTableName tbl <> (case fields of [] -> mempty fields ->@@ -425,10 +438,11 @@ instance IsSql92DeleteSyntax PgDeleteSyntax where type Sql92DeleteExpressionSyntax PgDeleteSyntax = PgExpressionSyntax+ type Sql92DeleteTableNameSyntax PgDeleteSyntax = PgTableNameSyntax deleteStmt tbl alias where_ = PgDeleteSyntax $- emit "DELETE FROM " <> pgQuotedIdentifier tbl <>+ emit "DELETE FROM " <> fromPgTableName tbl <> maybe mempty (\alias_ -> emit " AS " <> pgQuotedIdentifier alias_) alias <> maybe mempty (\where_ -> emit " WHERE " <> fromPgExpression where_) where_ @@ -475,9 +489,10 @@ type Sql92FromTableSourceSyntax PgFromSyntax = PgTableSourceSyntax fromTable tableSrc Nothing = coerce tableSrc- fromTable tableSrc (Just nm) =+ fromTable tableSrc (Just (nm, colNms)) = PgFromSyntax $- coerce tableSrc <> emit " AS " <> pgQuotedIdentifier nm+ coerce tableSrc <> emit " AS " <> pgQuotedIdentifier nm <>+ maybe mempty (\colNms' -> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier colNms'))) colNms innerJoin a b Nothing = PgFromSyntax (fromPgFrom a <> emit " CROSS JOIN " <> fromPgFrom b) innerJoin a b (Just e) = pgJoin "INNER JOIN" a b (Just e)@@ -502,7 +517,7 @@ domainType nm = PgDataTypeSyntax (PgDataTypeDescrDomain nm) (pgQuotedIdentifier nm) (domainType nm) - charType prec charSet = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bpchar) (fmap fromIntegral prec))+ charType prec charSet = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bpchar) (Just (fromIntegral (fromMaybe 1 prec)))) (emit "CHAR" <> pgOptPrec prec <> pgOptCharSet charSet) (charType prec charSet) varCharType prec charSet = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.varchar) (fmap fromIntegral prec))@@ -555,6 +570,30 @@ (arrayType serialized sz) rowType = error "rowType" +instance IsSql99CommonTableExpressionSelectSyntax PgSelectSyntax where+ type Sql99SelectCTESyntax PgSelectSyntax = PgCommonTableExpressionSyntax++ withSyntax ctes (PgSelectSyntax select) =+ PgSelectSyntax $+ emit "WITH " <>+ pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <>+ select++instance IsSql99RecursiveCommonTableExpressionSelectSyntax PgSelectSyntax where+ withRecursiveSyntax ctes (PgSelectSyntax select) =+ PgSelectSyntax $+ emit "WITH RECURSIVE " <>+ pgSepBy (emit ", ") (map fromPgCommonTableExpression ctes) <>+ select++instance IsSql99CommonTableExpressionSyntax PgCommonTableExpressionSyntax where+ type Sql99CTESelectSyntax PgCommonTableExpressionSyntax = PgSelectSyntax++ cteSubquerySyntax tbl fields (PgSelectSyntax select) =+ PgCommonTableExpressionSyntax $+ pgQuotedIdentifier tbl <> pgParens (pgSepBy (emit ",") (map pgQuotedIdentifier fields)) <>+ emit " AS " <> pgParens select+ instance IsSql2008BigIntDataTypeSyntax PgDataTypeSyntax where bigIntType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGINT") bigIntType @@ -586,6 +625,12 @@ pgSerialType = PgDataTypeSyntax (pgDataTypeDescr intType) (emit "SERIAL") (pgDataTypeJSON "serial") pgBigSerialType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGSERIAL") (pgDataTypeJSON "bigserial") +pgPointType, pgLineType, pgLineSegmentType, pgBoxType :: PgDataTypeSyntax+pgPointType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.point) Nothing) (emit "POINT") (pgDataTypeJSON "point")+pgLineType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.line) Nothing) (emit "LINE") (pgDataTypeJSON "line")+pgLineSegmentType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.lseg) Nothing) (emit "LSEG") (pgDataTypeJSON "lseg")+pgBoxType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.box) Nothing) (emit "BOX") (pgDataTypeJSON "box")+ pgUnboundedArrayType :: PgDataTypeSyntax -> PgDataTypeSyntax pgUnboundedArrayType (PgDataTypeSyntax _ syntax serialized) = PgDataTypeSyntax (error "Can't do array migrations yet")@@ -630,10 +675,13 @@ instance IsCustomSqlSyntax PgExpressionSyntax where newtype CustomSqlSyntax PgExpressionSyntax = PgCustomExpressionSyntax { fromPgCustomExpression :: PgSyntax }- deriving (Monoid, Semigroup)+ deriving Monoid customExprSyntax = PgExpressionSyntax . fromPgCustomExpression renderSyntax = PgCustomExpressionSyntax . pgParens . fromPgExpression +instance Semigroup (CustomSqlSyntax PgExpressionSyntax) where+ (<>) = mappend+ instance IsString (CustomSqlSyntax PgExpressionSyntax) where fromString = PgCustomExpressionSyntax . emit . fromString @@ -641,6 +689,14 @@ quantifyOverAll = PgComparisonQuantifierSyntax (emit "ALL") quantifyOverAny = PgComparisonQuantifierSyntax (emit "ANY") +instance IsSql92ExtractFieldSyntax PgExtractFieldSyntax where+ secondsField = PgExtractFieldSyntax (emit "SECOND")+ minutesField = PgExtractFieldSyntax (emit "MINUTE")+ hourField = PgExtractFieldSyntax (emit "HOUR")+ dayField = PgExtractFieldSyntax (emit "DAY")+ monthField = PgExtractFieldSyntax (emit "MONTH")+ yearField = PgExtractFieldSyntax (emit "YEAR")+ instance IsSql92ExpressionSyntax PgExpressionSyntax where type Sql92ExpressionValueSyntax PgExpressionSyntax = PgValueSyntax type Sql92ExpressionSelectSyntax PgExpressionSyntax = PgSelectSyntax@@ -717,18 +773,17 @@ inE e es = PgExpressionSyntax $ pgParens (fromPgExpression e) <> emit " IN " <> pgParens (pgSepBy (emit ", ") (map fromPgExpression es)) -instance IsSqlExpressionSyntaxStringType PgExpressionSyntax String-instance IsSqlExpressionSyntaxStringType PgExpressionSyntax T.Text--instance IsSql99ExpressionSyntax PgExpressionSyntax where- distinctE select = PgExpressionSyntax (emit "DISTINCT (" <> fromPgSelect select <> emit ")")- similarToE = pgBinOp "SIMILAR TO"-+instance IsSql99FunctionExpressionSyntax PgExpressionSyntax where functionCallE name args = PgExpressionSyntax $ fromPgExpression name <> pgParens (pgSepBy (emit ", ") (map fromPgExpression args))+ functionNameE nm = PgExpressionSyntax (emit (TE.encodeUtf8 nm)) +instance IsSql99ExpressionSyntax PgExpressionSyntax where+ distinctE select = PgExpressionSyntax (emit "DISTINCT (" <> fromPgSelect select <> emit ")")+ similarToE = pgBinOp "SIMILAR TO"+ instanceFieldE i nm = PgExpressionSyntax $ pgParens (fromPgExpression i) <> emit "." <> escapeIdentifier (TE.encodeUtf8 nm)@@ -751,6 +806,7 @@ overE expr frame = PgExpressionSyntax $ fromPgExpression expr <> emit " " <> fromPgWindowFrame frame+ rowNumberE = PgExpressionSyntax $ emit "ROW_NUMBER()" instance IsSql2003EnhancedNumericFunctionsExpressionSyntax PgExpressionSyntax where lnE x = PgExpressionSyntax (emit "LN(" <> fromPgExpression x <> emit ")")@@ -899,8 +955,16 @@ instance IsSql92TableSourceSyntax PgTableSourceSyntax where type Sql92TableSourceSelectSyntax PgTableSourceSyntax = PgSelectSyntax- tableNamed = PgTableSourceSyntax . pgQuotedIdentifier+ type Sql92TableSourceExpressionSyntax PgTableSourceSyntax = PgExpressionSyntax+ type Sql92TableSourceTableNameSyntax PgTableSourceSyntax = PgTableNameSyntax++ tableNamed = PgTableSourceSyntax . fromPgTableName tableFromSubSelect s = PgTableSourceSyntax $ emit "(" <> fromPgSelect s <> emit ")"+ tableFromValues vss = PgTableSourceSyntax . pgParens $+ emit "VALUES " <>+ pgSepBy (emit ", ")+ (map (\vs -> pgParens (pgSepBy (emit ", ")+ (map fromPgExpression vs))) vss) instance IsSql92ProjectionSyntax PgProjectionSyntax where type Sql92ProjectionExpressionSyntax PgProjectionSyntax = PgExpressionSyntax@@ -912,11 +976,12 @@ maybe mempty (\nm -> emit " AS " <> pgQuotedIdentifier nm) nm) exprs) instance IsSql92InsertSyntax PgInsertSyntax where+ type Sql92InsertTableNameSyntax PgInsertSyntax = PgTableNameSyntax type Sql92InsertValuesSyntax PgInsertSyntax = PgInsertValuesSyntax insertStmt tblName fields values = PgInsertSyntax $- emit "INSERT INTO " <> pgQuotedIdentifier tblName <> emit "(" <>+ emit "INSERT INTO " <> fromPgTableName tblName <> emit "(" <> pgSepBy (emit ", ") (map pgQuotedIdentifier fields) <> emit ") " <> fromPgInsertValues values @@ -932,20 +997,20 @@ es) insertFromSql (PgSelectSyntax a) = PgInsertValuesSyntax a -insertDefaults :: SqlInsertValues PgInsertValuesSyntax tbl-insertDefaults = SqlInsertValues (PgInsertValuesSyntax (emit "DEFAULT VALUES"))- instance IsSql92DropTableSyntax PgDropTableSyntax where+ type Sql92DropTableTableNameSyntax PgDropTableSyntax = PgTableNameSyntax+ dropTableSyntax tblNm = PgDropTableSyntax $- emit "DROP TABLE " <> pgQuotedIdentifier tblNm+ emit "DROP TABLE " <> fromPgTableName tblNm instance IsSql92AlterTableSyntax PgAlterTableSyntax where type Sql92AlterTableAlterTableActionSyntax PgAlterTableSyntax = PgAlterTableActionSyntax+ type Sql92AlterTableTableNameSyntax PgAlterTableSyntax = PgTableNameSyntax alterTableSyntax tblNm action = PgAlterTableSyntax $- emit "ALTER TABLE " <> pgQuotedIdentifier tblNm <> emit " " <> fromPgAlterTableAction action+ emit "ALTER TABLE " <> fromPgTableName tblNm <> emit " " <> fromPgAlterTableAction action instance IsSql92AlterTableActionSyntax PgAlterTableActionSyntax where type Sql92AlterTableAlterColumnActionSyntax PgAlterTableActionSyntax = PgAlterColumnActionSyntax@@ -976,6 +1041,7 @@ setNotNullSyntax = PgAlterColumnActionSyntax (emit "SET NOT NULL") instance IsSql92CreateTableSyntax PgCreateTableSyntax where+ type Sql92CreateTableTableNameSyntax PgCreateTableSyntax = PgTableNameSyntax type Sql92CreateTableColumnSchemaSyntax PgCreateTableSyntax = PgColumnSchemaSyntax type Sql92CreateTableTableConstraintSyntax PgCreateTableSyntax = PgTableConstraintSyntax type Sql92CreateTableOptionsSyntax PgCreateTableSyntax = PgTableOptionsSyntax@@ -988,7 +1054,7 @@ ( emit " " <> before <> emit " " , emit " " <> after <> emit " " ) in PgCreateTableSyntax $- emit "CREATE" <> beforeOptions <> emit "TABLE " <> pgQuotedIdentifier tblNm <>+ emit "CREATE" <> beforeOptions <> emit "TABLE " <> fromPgTableName tblNm <> emit " (" <> pgSepBy (emit ", ") (map (\(nm, type_) -> pgQuotedIdentifier nm <> emit " " <> fromPgColumnSchema type_) fieldTypes <>@@ -1090,6 +1156,20 @@ defaultPgValueSyntax = PgValueSyntax . pgBuildAction . pure . Pg.toField +-- Database Predicates++data PgHasEnum = PgHasEnum T.Text {- Enumeration name -} [T.Text] {- enum values -}+ deriving (Show, Eq, Generic)+instance Hashable PgHasEnum+instance DatabasePredicate PgHasEnum where+ englishDescription (PgHasEnum enumName values) =+ "Has postgres enumeration " ++ show enumName ++ " with values " ++ show values++ predicateSpecificity _ = PredicateSpecificityOnlyBackend "postgres"+ serializePredicate (PgHasEnum name values) =+ object [ "has-postgres-enum" .= object [ "name" .= name+ , "values" .= values ] ]+ #define DEFAULT_SQL_SYNTAX(ty) \ instance HasSqlValueSyntax PgValueSyntax ty where \ sqlValueSyntax = defaultPgValueSyntax@@ -1110,11 +1190,10 @@ DEFAULT_SQL_SYNTAX(Word64) DEFAULT_SQL_SYNTAX(T.Text) DEFAULT_SQL_SYNTAX(TL.Text)-DEFAULT_SQL_SYNTAX(UTCTime) DEFAULT_SQL_SYNTAX(Value) DEFAULT_SQL_SYNTAX(Pg.Oid) DEFAULT_SQL_SYNTAX(LocalTime)-DEFAULT_SQL_SYNTAX(ZonedTime)+DEFAULT_SQL_SYNTAX(UTCTime) DEFAULT_SQL_SYNTAX(TimeOfDay) DEFAULT_SQL_SYNTAX(NominalDiffTime) DEFAULT_SQL_SYNTAX(Day)@@ -1124,7 +1203,6 @@ DEFAULT_SQL_SYNTAX(Pg.HStoreList) DEFAULT_SQL_SYNTAX(Pg.HStoreBuilder) DEFAULT_SQL_SYNTAX(Pg.Date)-DEFAULT_SQL_SYNTAX(Pg.ZonedTimestamp) DEFAULT_SQL_SYNTAX(Pg.LocalTimestamp) DEFAULT_SQL_SYNTAX(Pg.UTCTimestamp) DEFAULT_SQL_SYNTAX(Scientific)@@ -1270,6 +1348,17 @@ pgDropExtensionSyntax extName = PgCommandSyntax PgCommandTypeDdl $ emit "DROP EXTENSION " <> pgQuotedIdentifier extName +pgCreateEnumSyntax :: T.Text -> [PgValueSyntax] -> PgCommandSyntax+pgCreateEnumSyntax enumName vals =+ PgCommandSyntax PgCommandTypeDdl $+ emit "CREATE TYPE " <> pgQuotedIdentifier enumName <> emit " AS ENUM(" <>+ pgSepBy (emit ", ") (fmap fromPgValue vals) <> emit ")"++pgDropTypeSyntax :: T.Text -> PgCommandSyntax+pgDropTypeSyntax typeName =+ PgCommandSyntax PgCommandTypeDdl $+ emit "DROP TYPE " <> pgQuotedIdentifier typeName+ -- -- * Pg-specific Q monad @@ -1321,72 +1410,3 @@ quoteIdentifierChar '"' = char8 '"' <> char8 '"' quoteIdentifierChar c = char8 c ---- * Instances for 'HasDefaultSqlDataType'--instance HasDefaultSqlDataType PgDataTypeSyntax ByteString where- defaultSqlDataType _ _ = pgByteaType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax ByteString--instance HasDefaultSqlDataType PgDataTypeSyntax LocalTime where- defaultSqlDataType _ _ = timestampType Nothing False-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax LocalTime--instance HasDefaultSqlDataType PgDataTypeSyntax (SqlSerial Int) where- defaultSqlDataType _ False = pgSerialType- defaultSqlDataType _ _ = intType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (SqlSerial Int)--instance HasDefaultSqlDataType PgDataTypeSyntax UUID where- defaultSqlDataType _ _ = pgUuidType-instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax UUID---- * Instances for 'HasSqlEqualityCheck'--#define PG_HAS_EQUALITY_CHECK(ty) \- instance HasSqlEqualityCheck PgExpressionSyntax (ty); \- instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (ty);--PG_HAS_EQUALITY_CHECK(Bool)-PG_HAS_EQUALITY_CHECK(Double)-PG_HAS_EQUALITY_CHECK(Float)-PG_HAS_EQUALITY_CHECK(Int)-PG_HAS_EQUALITY_CHECK(Int8)-PG_HAS_EQUALITY_CHECK(Int16)-PG_HAS_EQUALITY_CHECK(Int32)-PG_HAS_EQUALITY_CHECK(Int64)-PG_HAS_EQUALITY_CHECK(Integer)-PG_HAS_EQUALITY_CHECK(Word)-PG_HAS_EQUALITY_CHECK(Word8)-PG_HAS_EQUALITY_CHECK(Word16)-PG_HAS_EQUALITY_CHECK(Word32)-PG_HAS_EQUALITY_CHECK(Word64)-PG_HAS_EQUALITY_CHECK(T.Text)-PG_HAS_EQUALITY_CHECK(TL.Text)-PG_HAS_EQUALITY_CHECK(UTCTime)-PG_HAS_EQUALITY_CHECK(Value)-PG_HAS_EQUALITY_CHECK(Pg.Oid)-PG_HAS_EQUALITY_CHECK(LocalTime)-PG_HAS_EQUALITY_CHECK(ZonedTime)-PG_HAS_EQUALITY_CHECK(TimeOfDay)-PG_HAS_EQUALITY_CHECK(NominalDiffTime)-PG_HAS_EQUALITY_CHECK(Day)-PG_HAS_EQUALITY_CHECK(UUID)-PG_HAS_EQUALITY_CHECK([Char])-PG_HAS_EQUALITY_CHECK(Pg.HStoreMap)-PG_HAS_EQUALITY_CHECK(Pg.HStoreList)-PG_HAS_EQUALITY_CHECK(Pg.Date)-PG_HAS_EQUALITY_CHECK(Pg.ZonedTimestamp)-PG_HAS_EQUALITY_CHECK(Pg.LocalTimestamp)-PG_HAS_EQUALITY_CHECK(Pg.UTCTimestamp)-PG_HAS_EQUALITY_CHECK(Scientific)-PG_HAS_EQUALITY_CHECK(ByteString)-PG_HAS_EQUALITY_CHECK(BL.ByteString)-PG_HAS_EQUALITY_CHECK(V.Vector a)-PG_HAS_EQUALITY_CHECK(CI T.Text)-PG_HAS_EQUALITY_CHECK(CI TL.Text)--instance HasSqlEqualityCheck PgExpressionSyntax a =>- HasSqlEqualityCheck PgExpressionSyntax (Tagged t a)-instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax a =>- HasSqlQuantifiedEqualityCheck PgExpressionSyntax (Tagged t a)
Database/Beam/Postgres/Types.hs view
@@ -11,7 +11,11 @@ ( Postgres(..) ) where import Database.Beam-import Database.Beam.Backend.SQL+import Database.Beam.Backend+import Database.Beam.Migrate.Generics+import Database.Beam.Migrate.SQL (BeamMigrateOnlySqlBackend)+import Database.Beam.Postgres.Syntax+import Database.Beam.Query.SQL92 import qualified Database.PostgreSQL.Simple.FromField as Pg import qualified Database.PostgreSQL.Simple.HStore as Pg (HStoreMap, HStoreList)@@ -26,9 +30,10 @@ import Data.Int import Data.Ratio (Ratio) import Data.Scientific (Scientific, toBoundedInteger)+import Data.Tagged import Data.Text (Text) import qualified Data.Text.Lazy as TL-import Data.Time (UTCTime, Day, TimeOfDay, LocalTime, ZonedTime(..))+import Data.Time (UTCTime, Day, TimeOfDay, LocalTime, NominalDiffTime, ZonedTime(..)) import Data.UUID.Types (UUID) import Data.Vector (Vector) import Data.Word@@ -52,21 +57,18 @@ sciVal <- fmap (toBoundedInteger =<<) peekField case sciVal of Just sciVal' -> do- -- If the parse succeeded, consume the field- _ <- parseOneField @Postgres @Scientific pure sciVal' Nothing -> fromIntegral <$> fromBackendRow @Postgres @Integer -- | Deserialize integral fields, possibly downcasting from a larger integral -- type, but only if we won't lose data fromPgIntegral :: forall a- . (Pg.FromField a, Integral a)+ . (Pg.FromField a, Integral a, Typeable a) => FromBackendRowM Postgres a fromPgIntegral = do val <- peekField case val of Just val' -> do- _ <- parseOneField @Postgres @a pure val' Nothing -> do val' <- parseOneField @Postgres @Integer@@ -112,7 +114,7 @@ fromBackendRow = peekField >>= \case- Just (_ :: LocalTime) -> parseOneField+ Just (x :: LocalTime) -> pure x -- Also accept 'TIMESTAMP WITH TIME ZONE'. Considered as -- 'LocalTime', because postgres always returns times in the@@ -120,7 +122,7 @@ Nothing -> peekField >>= \case- Just (_ :: ZonedTime) -> zonedTimeToLocalTime <$> parseOneField+ Just (x :: ZonedTime) -> pure (zonedTimeToLocalTime x) Nothing -> fail "'TIMESTAMP WITH TIME ZONE' or 'TIMESTAMP WITHOUT TIME ZONE' required for LocalTime" instance FromBackendRow Postgres TimeOfDay instance FromBackendRow Postgres Day@@ -137,7 +139,7 @@ instance FromBackendRow Postgres (CI Text) instance FromBackendRow Postgres (CI TL.Text) instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Vector a) where- fromBackendRow = do+ fromBackendRow = do isNull <- peekField case isNull of Just SqlNull -> pure mempty@@ -146,7 +148,79 @@ instance FromBackendRow Postgres (Pg.Binary ByteString) instance FromBackendRow Postgres (Pg.Binary BL.ByteString) instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Pg.PGRange a)-instance (Pg.FromField a, Pg.FromField b) => FromBackendRow Postgres (Either a b)+instance (Pg.FromField a, Pg.FromField b, Typeable a, Typeable b) => FromBackendRow Postgres (Either a b) instance BeamSqlBackend Postgres-instance BeamSql92Backend Postgres+instance BeamMigrateOnlySqlBackend Postgres+type instance BeamSqlBackendSyntax Postgres = PgCommandSyntax++instance BeamSqlBackendIsString Postgres String+instance BeamSqlBackendIsString Postgres Text++instance HasQBuilder Postgres where+ buildSqlQuery = buildSql92Query' True++-- * Instances for 'HasDefaultSqlDataType'++instance HasDefaultSqlDataType Postgres ByteString where+ defaultSqlDataType _ _ _ = pgByteaType++instance HasDefaultSqlDataType Postgres LocalTime where+ defaultSqlDataType _ _ _ = timestampType Nothing False++instance HasDefaultSqlDataType Postgres (SqlSerial Int) where+ defaultSqlDataType _ _ False = pgSerialType+ defaultSqlDataType _ _ _ = intType++instance HasDefaultSqlDataType Postgres UUID where+ defaultSqlDataType _ _ _ = pgUuidType++-- * Instances for 'HasSqlEqualityCheck'++#define PG_HAS_EQUALITY_CHECK(ty) \+ instance HasSqlEqualityCheck Postgres (ty); \+ instance HasSqlQuantifiedEqualityCheck Postgres (ty);++PG_HAS_EQUALITY_CHECK(Bool)+PG_HAS_EQUALITY_CHECK(Double)+PG_HAS_EQUALITY_CHECK(Float)+PG_HAS_EQUALITY_CHECK(Int)+PG_HAS_EQUALITY_CHECK(Int8)+PG_HAS_EQUALITY_CHECK(Int16)+PG_HAS_EQUALITY_CHECK(Int32)+PG_HAS_EQUALITY_CHECK(Int64)+PG_HAS_EQUALITY_CHECK(Integer)+PG_HAS_EQUALITY_CHECK(Word)+PG_HAS_EQUALITY_CHECK(Word8)+PG_HAS_EQUALITY_CHECK(Word16)+PG_HAS_EQUALITY_CHECK(Word32)+PG_HAS_EQUALITY_CHECK(Word64)+PG_HAS_EQUALITY_CHECK(Text)+PG_HAS_EQUALITY_CHECK(TL.Text)+PG_HAS_EQUALITY_CHECK(UTCTime)+PG_HAS_EQUALITY_CHECK(Value)+PG_HAS_EQUALITY_CHECK(Pg.Oid)+PG_HAS_EQUALITY_CHECK(LocalTime)+PG_HAS_EQUALITY_CHECK(ZonedTime)+PG_HAS_EQUALITY_CHECK(TimeOfDay)+PG_HAS_EQUALITY_CHECK(NominalDiffTime)+PG_HAS_EQUALITY_CHECK(Day)+PG_HAS_EQUALITY_CHECK(UUID)+PG_HAS_EQUALITY_CHECK([Char])+PG_HAS_EQUALITY_CHECK(Pg.HStoreMap)+PG_HAS_EQUALITY_CHECK(Pg.HStoreList)+PG_HAS_EQUALITY_CHECK(Pg.Date)+PG_HAS_EQUALITY_CHECK(Pg.ZonedTimestamp)+PG_HAS_EQUALITY_CHECK(Pg.LocalTimestamp)+PG_HAS_EQUALITY_CHECK(Pg.UTCTimestamp)+PG_HAS_EQUALITY_CHECK(Scientific)+PG_HAS_EQUALITY_CHECK(ByteString)+PG_HAS_EQUALITY_CHECK(BL.ByteString)+PG_HAS_EQUALITY_CHECK(Vector a)+PG_HAS_EQUALITY_CHECK(CI Text)+PG_HAS_EQUALITY_CHECK(CI TL.Text)++instance HasSqlEqualityCheck Postgres a =>+ HasSqlEqualityCheck Postgres (Tagged t a)+instance HasSqlQuantifiedEqualityCheck Postgres a =>+ HasSqlQuantifiedEqualityCheck Postgres (Tagged t a)
beam-postgres.cabal view
@@ -1,5 +1,5 @@ name: beam-postgres-version: 0.3.2.3+version: 0.4.0.0 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@@ -18,17 +18,20 @@ Database.Beam.Postgres.Migrate Database.Beam.Postgres.PgCrypto Database.Beam.Postgres.Syntax+ Database.Beam.Postgres.CustomTypes Database.Beam.Postgres.Conduit Database.Beam.Postgres.Full - other-modules: Database.Beam.Postgres.Types- Database.Beam.Postgres.Connection- Database.Beam.Postgres.PgSpecific+ other-modules: Database.Beam.Postgres.Connection+ Database.Beam.Postgres.Debug Database.Beam.Postgres.Extensions+ Database.Beam.Postgres.PgSpecific+ Database.Beam.Postgres.Types+ build-depends: base >=4.7 && <5.0,- beam-core >=0.7 && <0.8,- beam-migrate >=0.3 && <0.4,+ beam-core >=0.8 && <0.9,+ beam-migrate >=0.4 && <0.5, postgresql-libpq >=0.8 && <0.10, postgresql-simple >=0.5 && <0.7,@@ -36,6 +39,7 @@ text >=1.0 && <1.3, bytestring >=0.10 && <0.11, + attoparsec >=0.13 && <0.14, hashable >=1.1 && <1.3, lifted-base >=0.2 && <0.3, free >=4.12 && <5.2,@@ -52,7 +56,7 @@ unordered-containers >= 0.2 && <0.3, tagged >=0.8 && <0.9, - haskell-src-exts >=1.18 && <1.21+ haskell-src-exts >=1.18 && <1.22 default-language: Haskell2010 default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances, DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings,@@ -60,6 +64,22 @@ ghc-options: -Wall if flag(werror) ghc-options: -Werror++test-suite beam-postgres-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Database.Beam.Postgres.Test,+ Database.Beam.Postgres.Test.Marshal,+ Database.Beam.Postgres.Test.Select,+ Database.Beam.Postgres.Test.DataTypes,+ Database.Beam.Postgres.Test.Migrate+ build-depends: base, beam-core, beam-migrate, beam-postgres, text, bytestring, tasty, tasty-hunit,+ postgresql-simple, process, temporary, hedgehog, uuid, filepath, directory+ default-language: Haskell2010+ default-extensions: OverloadedStrings, FlexibleInstances, FlexibleContexts, TypeFamilies,+ ScopedTypeVariables, MultiParamTypeClasses, TypeApplications, DeriveGeneric,+ DeriveAnyClass, RankNTypes flag werror description: Enable -Werror during development
+ test/Database/Beam/Postgres/Test.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP #-}+module Database.Beam.Postgres.Test where++#if MIN_VERSION_base(4,12,0)+import Prelude hiding (fail)+#endif++import qualified Database.PostgreSQL.Simple as Pg++import Control.Exception (SomeException(..), bracket, catch)+import Control.Concurrent (threadDelay)++import Control.Monad (void)+#if MIN_VERSION_base(4,12,0)+import Control.Monad.Fail (MonadFail(..))+#endif++import Data.ByteString (ByteString)+import Data.Semigroup+import Data.String++import qualified Hedgehog++import System.IO.Temp+import System.Process+import System.Exit+import System.FilePath+import System.Directory++withTestPostgres :: String -> IO ByteString -> (Pg.Connection -> IO a) -> IO a+withTestPostgres dbName getConnStr action = do+ connStr <- getConnStr++ let connStrTemplate1 = connStr <> " dbname=template1"+ connStrDb = connStr <> " dbname=" <> fromString dbName++ withTemplate1 :: (Pg.Connection -> IO b) -> IO b+ withTemplate1 = bracket (Pg.connectPostgreSQL connStrTemplate1) Pg.close++ createDatabase = withTemplate1 $ \c -> do+ Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName))++ Pg.connectPostgreSQL connStrDb+ dropDatabase c = do+ Pg.close c+ withTemplate1 $ \c' -> do+ Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName))+ pure ()++ bracket createDatabase dropDatabase action++startTempPostgres :: IO (ByteString, IO ())+startTempPostgres = do+ tmpDir <- getCanonicalTemporaryDirectory+ pgDataDir <- createTempDirectory tmpDir "postgres-data"++ callProcess "pg_ctl" [ "init", "-D", pgDataDir ]++ -- Use 'D' because otherwise, the path is too long on OS X+ pgHdl <- spawnProcess "postgres"+ [ "-D", pgDataDir+ , "-k", pgDataDir, "-h", "" ]++ putStrLn ("Using " ++ pgDataDir ++ " as postgres host")++ let waitForPort 10 = fail "Could not connect to postgres"+ waitForPort n = do+ (code, stdout, stderr) <- readProcessWithExitCode "pg_ctl" [ "status", "-D", pgDataDir ] ""+ case code of+ ExitSuccess -> waitForSocket 0+ ExitFailure _ -> threadDelay 1000000 >> waitForPort (n + 1)++ waitForSocket 10 = fail "Could not connect to postgres (waitForSocket)"+ waitForSocket n = do+ skExists <- doesFileExist (pgDataDir </> ".s.PGSQL.5432")+ if skExists then pure () else threadDelay 1000000 >> waitForSocket (n + 1)++ waitForPort 0+ putStrLn "Completed waiting for postgres"++ pure ( fromString ("host=" ++ pgDataDir)+ , void (callProcess "pg_ctl" [ "stop", "-D", pgDataDir ]))++#if MIN_VERSION_base(4,12,0)+-- TODO orphan instances are bad+instance Monad m => MonadFail (Hedgehog.PropertyT m) where+ fail _ = Hedgehog.failure+#endif
+ test/Database/Beam/Postgres/Test/DataTypes.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-}++module Database.Beam.Postgres.Test.DataTypes where++import Database.Beam+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate+import Database.Beam.Postgres.Test+import Database.Beam.Migrate+import Database.Beam.Backend.SQL.BeamExtensions++import Control.Exception (SomeException(..), handle)++import Data.ByteString (ByteString)+import Data.Text (Text)++import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests postgresConn =+ testGroup "Data-type unit tests"+ [ jsonNulTest postgresConn+ , errorOnSchemaMismatch postgresConn ]++data JsonT f+ = JsonT+ { _key :: C f Int+ , _field1 :: C f (PgJSON String) }+ deriving (Generic, Beamable)++instance Table JsonT where+ data PrimaryKey JsonT f = JsonKey (C f Int)+ deriving (Generic, Beamable)+ primaryKey = JsonKey <$> _key++data JsonDb entity+ = JsonDb+ { jsonTable :: entity (TableEntity JsonT) }+ deriving (Generic, Database Postgres)++-- | Regression test for <https://github.com/tathougies/beam/issues/297 #297>+jsonNulTest :: IO ByteString -> TestTree+jsonNulTest pgConn =+ testCase "JSON NUL handling (#297)" $+ withTestPostgres "db_jsonnul" pgConn $ \conn -> do+ readback <-+ runBeamPostgres conn $ do+ db <- fmap unCheckDatabase $+ executeMigration runNoReturn+ (JsonDb <$> createTable "json_test"+ (JsonT (field "key" int notNull)+ (field "value" json notNull)))++ runInsert $ insert (jsonTable db) $+ insertValues [ JsonT 1 (PgJSON "hello\0world") ]+ runInsert $ insert (jsonTable db) $+ insertValues [ JsonT 2 (PgJSON "\0\0\0") ]+ runInsert $ insert (jsonTable db) $+ insertValues [ JsonT 3 (PgJSON "\0hello") ]+ runInsert $ insert (jsonTable db) $+ insertValues [ JsonT 4 (PgJSON "hello\0") ]+ runInsert $ insert (jsonTable db) $+ insertValues [ JsonT 5 (PgJSON "\0hello\0") ]+ runInsert $ insert (jsonTable db) $+ insertValues [ JsonT 6 (PgJSON "\0he\0\0llo\0") ]++ fmap (fmap (\(PgJSON v) -> v)) $+ runSelectReturningList $ select $+ fmap (\(JsonT _ v) -> v) $+ orderBy_ (\(JsonT pk _) -> asc_ pk) $+ all_ (jsonTable db)++ readback @?= [ "hello\0world"+ , "\0\0\0"+ , "\0hello"+ , "hello\0"+ , "\0hello\0"+ , "\0he\0\0llo\0" ]++ return ()++data TblT f+ = Tbl { _tblKey :: C f Int, _tblValue :: C f Text }+ deriving (Generic, Beamable)++deriving instance Show (TblT Identity)+deriving instance Eq (TblT Identity)++instance Table TblT where+ data PrimaryKey TblT f = TblKey (C f Int)+ deriving (Generic, Beamable)+ primaryKey = TblKey <$> _tblKey++data WrongTblT f+ = WrongTbl { _wrongTblKey :: C f Int, _wrongTblValue :: C f Int }+ deriving (Generic, Beamable)++instance Table WrongTblT where+ data PrimaryKey WrongTblT f = WrongTblKey (C f Int)+ deriving (Generic, Beamable)+ primaryKey = WrongTblKey <$> _wrongTblKey++data RealDb entity+ = RealDb { _realTbl :: entity (TableEntity TblT) }+ deriving (Generic, Database Postgres)++data WrongDb entity+ = WrongDb { _wrongTbl :: entity (TableEntity WrongTblT) }+ deriving (Generic, Database Postgres)++-- | Regression test for <https://github.com/tathougies/beam/issues/112>+errorOnSchemaMismatch :: IO ByteString -> TestTree+errorOnSchemaMismatch pgConn =+ testCase "runInsertReturningList should error on schema mismatch (#112)" $+ withTestPostgres "db_failures" pgConn $ \conn -> do+ vs <-+ runBeamPostgres conn $ do+ realDb <- fmap unCheckDatabase $ executeMigration runNoReturn+ (RealDb <$> createTable "tbl1" (Tbl (field "key" int notNull)+ (field "value" (varchar Nothing) notNull)))++ runInsertReturningList $ insert (_realTbl realDb) $ insertValues [ Tbl 1 "hello", Tbl 2 "world", Tbl 3 "foo" ]++ vs @?= [ Tbl 1 "hello", Tbl 2 "world", Tbl 3 "foo" ]++ let wrongDb = unCheckDatabase $+ runMigrationSilenced (WrongDb <$> createTable "tbl1"+ (WrongTbl (field "key" int notNull)+ (field "value" int notNull)))++ didFail <- handle (\(e :: SomeException) -> pure True) $+ runBeamPostgres conn $ do+ _ <- runInsertReturningList $ insert (_wrongTbl wrongDb) $ insertValues [ WrongTbl 4 23, WrongTbl 5 24, WrongTbl 6 24 ]+ pure False++ assertBool "runInsertReturningList succeeded" didFail+ didFail @?= True
+ test/Database/Beam/Postgres/Test/Marshal.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+module Database.Beam.Postgres.Test.Marshal where++import Database.Beam+import Database.Beam.Backend.SQL+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test+import qualified Database.PostgreSQL.Simple as Pg++import Data.ByteString (ByteString)+import Data.Functor.Classes+import Data.Int+import Data.Proxy (Proxy(..))+import Data.Semigroup+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Typeable+import Data.UUID (UUID, fromWords)+import Data.Word++import qualified Hedgehog+import Hedgehog ((===))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Test.Tasty+import Test.Tasty.HUnit++import Unsafe.Coerce++uuidGen :: Hedgehog.Gen UUID+uuidGen = fromWords <$> Gen.integral Range.constantBounded+ <*> Gen.integral Range.constantBounded+ <*> Gen.integral Range.constantBounded+ <*> Gen.integral Range.constantBounded++pointGen :: Hedgehog.Gen PgPoint+pointGen = PgPoint <$> Gen.double (Range.constant 0 1000)+ <*> Gen.double (Range.constant 0 1000)++boxGen :: Hedgehog.Gen PgBox+boxGen = do PgPoint x1 y1 <- pointGen+ PgPoint x2 y2 <- pointGen+ pure (PgBox (PgPoint (min x1 x2) (min y1 y2))+ (PgPoint (max x1 x2) (max y1 y2)))++boxCmp :: PgBox -> PgBox -> Bool+boxCmp (PgBox a1 b1) (PgBox a2 b2) =+ (a1 `ptCmp` a2 && b1 `ptCmp` b2) ||+ (a1 `ptCmp` b2 && b1 `ptCmp` a2)++ptCmp :: PgPoint -> PgPoint -> Bool+ptCmp (PgPoint x1 y1) (PgPoint x2 y2) =+ x1 `dblCmp` x2 && y1 `dblCmp` y2++dblCmp :: Double -> Double -> Bool+dblCmp x y =+ let ulp = abs ((unsafeCoerce x :: Int64) - (unsafeCoerce y :: Int64))+ in ulp < 50++tests :: IO ByteString -> TestTree+tests postgresConn =+ testGroup "Postgres Marshaling tests"+ [ marshalTest Gen.bool postgresConn+ , marshalTest (Gen.integral (Range.constantBounded @Int16)) postgresConn+ , marshalTest (Gen.integral (Range.constantBounded @Int32)) postgresConn+ , marshalTest (Gen.integral (Range.constantBounded @Int64)) postgresConn+ , marshalTest (Gen.integral (Range.constantBounded @Word16)) postgresConn+ , marshalTest (Gen.integral (Range.constantBounded @Word32)) postgresConn+ , marshalTest (Gen.integral (Range.constantBounded @Word64)) postgresConn+ , marshalTest (Gen.text (Range.constant 0 1000) Gen.unicode) postgresConn+ , marshalTest uuidGen postgresConn++ , marshalTest' (\a b -> Hedgehog.assert (ptCmp a b)) pointGen postgresConn+ , marshalTest' (\a b -> Hedgehog.assert (boxCmp a b)) boxGen postgresConn++ , marshalTest (Gen.maybe Gen.bool) postgresConn+ , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Int16))) postgresConn+ , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Int32))) postgresConn+ , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Int64))) postgresConn+ , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word16))) postgresConn+ , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word32))) postgresConn+ , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word64))) postgresConn+ , marshalTest (Gen.maybe (Gen.text (Range.constant 0 1000) Gen.unicode)) postgresConn+ , marshalTest (Gen.maybe uuidGen) postgresConn++ , marshalTest' (\a b -> Hedgehog.assert (liftEq ptCmp a b)) (Gen.maybe pointGen) postgresConn+ , marshalTest' (\a b -> Hedgehog.assert (liftEq boxCmp a b)) (Gen.maybe boxGen) postgresConn++-- , marshalTest (Gen.double (Range.exponentialFloat 0 1e40)) postgresConn+-- , marshalTest (Gen.integral (Range.constantBounded @Word)) postgresConn+-- , marshalTest (Gen.integral (Range.constantBounded @Int)) postgresConn++-- , marshalTest @Int8 postgresConn+-- , marshalTest @Integer postgresConn+-- , marshalTest @Word8 postgresConn+-- , marshalTest @TL.Text postgresConn+ -- TODO MORE!!!!+ ]++data MarshalTable a f+ = MarshalTable+ { _marshalTableId :: C f (SqlSerial Int)+ , _marshalTableEntry :: C f a+ } deriving (Generic)+instance Beamable (MarshalTable a)++instance Typeable a => Table (MarshalTable a) where+ data PrimaryKey (MarshalTable a) f = MarshalTableKey (C f (SqlSerial Int))+ deriving (Generic, Beamable)+ primaryKey = MarshalTableKey . _marshalTableId++data MarshalDb a entity+ = MarshalDb+ { _marshalTbl :: entity (TableEntity (MarshalTable a))+ } deriving (Generic)+instance Typeable a => Database Postgres (MarshalDb a)++marshalTest :: forall a+ . ( Typeable a, Eq a, Show a+ , BeamSqlBackendSupportsDataType Postgres a+ , HasDefaultSqlDataType Postgres a+ , HasNullableConstraint (NullableStatus a) Postgres )+ => Hedgehog.Gen a -> IO ByteString -> TestTree+marshalTest = marshalTest' (===)++marshalTest' :: forall a+ . ( Typeable a, Show a+ , BeamSqlBackendSupportsDataType Postgres a+ , HasDefaultSqlDataType Postgres a+ , HasNullableConstraint (NullableStatus a) Postgres )+ => (forall m. (Hedgehog.MonadTest m, HasCallStack) => a -> a -> m ()) -> Hedgehog.Gen a -> IO ByteString -> TestTree+marshalTest' cmp gen postgresConn =+ testCase ("Can marshal " ++ show (typeRep (Proxy @a))) $+ withTestPostgres ("db_marshal_" <> show (typeRepFingerprint (typeRep (Proxy @a))))+ postgresConn $ \conn -> do+ let marshalDbSettings = defaultMigratableDbSettings @Postgres @(MarshalDb a)+ marshalDb = unCheckDatabase marshalDbSettings++ runBeamPostgres conn $ do+ autoMigrate migrationBackend marshalDbSettings++ putStrLn "\n"++ passes <- Hedgehog.check . Hedgehog.property $ do+ a <- Hedgehog.forAll gen++ [MarshalTable rowId v] <-+ liftIO . runBeamPostgres conn $+ runInsertReturningList $ insert (_marshalTbl marshalDb) $ insertExpressions [ MarshalTable default_ (val_ a) ]+ v `cmp` a++ Just (MarshalTable _ v') <-+ liftIO . runBeamPostgres conn $+ runSelectReturningOne (lookup_ (_marshalTbl marshalDb) (MarshalTableKey rowId))+ v' `cmp` a++ assertBool "Hedgehog test failed" passes+
+ test/Database/Beam/Postgres/Test/Migrate.hs view
@@ -0,0 +1,72 @@+module Database.Beam.Postgres.Test.Migrate where++import Database.Beam+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate+import Database.Beam.Postgres.Test+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple++import Data.ByteString (ByteString)+import Data.Text (Text)++import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests postgresConn =+ testGroup "Migration tests"+ [ charWidthVerification postgresConn "VARCHAR" varchar+ , charNoWidthVerification postgresConn "VARCHAR" varchar+ , charWidthVerification postgresConn "CHAR" char+ , charNoWidthVerification postgresConn "CHAR" char+ ]++data CharT f+ = CharT { vcKey :: C f Text }+ deriving (Generic, Beamable)++instance Table CharT where+ data PrimaryKey CharT f = VcKey (C f Text)+ deriving (Generic, Beamable)++ primaryKey = VcKey . vcKey++data CharDb entity+ = CharDb+ { vcTbl :: entity (TableEntity CharT) }+ deriving (Generic, Database Postgres)++-- | Verifies that 'verifySchema' correctly checks the width of+-- @VARCHAR@ or @CHAR@ columns.+charWidthVerification :: IO ByteString -> String -> (Maybe Word -> DataType Postgres Text) -> TestTree+charWidthVerification pgConn tyName charTy =+ testCase ("verifySchema correctly checks width of " ++ tyName ++ "(n) columns (#274)") $ do+ withTestPostgres "db_char_width" pgConn $ \conn -> do+ runBeamPostgres conn $ do+ db <- executeMigration runNoReturn+ (CharDb <$> createTable "char_test"+ (CharT (field "key" (charTy (Just 10)) notNull)))++ res <- verifySchema migrationBackend db++ case res of+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)++-- | Verifies that 'verifySchema' correctly checks the width of+-- @VARCHAR@ or @CHAR@ columns without any max width+charNoWidthVerification :: IO ByteString -> String -> (Maybe Word -> DataType Postgres Text) -> TestTree+charNoWidthVerification pgConn tyName charTy =+ testCase ("verifySchema correctly checks width of " ++ tyName ++ " columns (#274)") $ do+ withTestPostgres "db_char_no_width" pgConn $ \conn -> do+ runBeamPostgres conn $ do+ db <- executeMigration runNoReturn+ (CharDb <$> createTable "char_test"+ (CharT (field "key" (charTy Nothing) notNull)))++ res <- verifySchema migrationBackend db++ case res of+ VerificationSucceeded -> return ()+ VerificationFailed failures -> fail ("Verification failed: " ++ show failures)
+ test/Database/Beam/Postgres/Test/Select.hs view
@@ -0,0 +1,36 @@+module Database.Beam.Postgres.Test.Select where++import Database.Beam+import Database.Beam.Backend.SQL+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test+import qualified Database.PostgreSQL.Simple as Pg++import Data.ByteString (ByteString)+import Data.Functor.Classes+import Data.Int+import Data.Proxy (Proxy(..))+import Data.Semigroup+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Typeable+import Data.UUID (UUID, fromWords)+import Data.Word++import qualified Hedgehog+import Hedgehog ((===))+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Test.Tasty+import Test.Tasty.HUnit++import Unsafe.Coerce++tests :: IO ByteString -> TestTree+tests postgresConn =+ testGroup "Postgres Select Tests" []
+ test/Main.hs view
@@ -0,0 +1,17 @@+module Main where++import Test.Tasty++import Database.Beam.Postgres.Test (startTempPostgres)+import qualified Database.Beam.Postgres.Test.Select as Select+import qualified Database.Beam.Postgres.Test.Marshal as Marshal+import qualified Database.Beam.Postgres.Test.DataTypes as DataType+import qualified Database.Beam.Postgres.Test.Migrate as Migrate++main :: IO ()+main = defaultMain (withResource startTempPostgres snd $ \getConnStr ->+ testGroup "beam-postgres tests"+ [ Marshal.tests (fst <$> getConnStr)+ , Select.tests (fst <$> getConnStr)+ , DataType.tests (fst <$> getConnStr)+ , Migrate.tests (fst <$> getConnStr) ])