diff --git a/Database/Beam/Postgres.hs b/Database/Beam/Postgres.hs --- a/Database/Beam/Postgres.hs +++ b/Database/Beam/Postgres.hs @@ -18,15 +18,8 @@ -- . 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 diff --git a/Database/Beam/Postgres/Conduit.hs b/Database/Beam/Postgres/Conduit.hs --- a/Database/Beam/Postgres/Conduit.hs +++ b/Database/Beam/Postgres/Conduit.hs @@ -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 diff --git a/Database/Beam/Postgres/Connection.hs b/Database/Beam/Postgres/Connection.hs --- a/Database/Beam/Postgres/Connection.hs +++ b/Database/Beam/Postgres/Connection.hs @@ -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) diff --git a/Database/Beam/Postgres/CustomTypes.hs b/Database/Beam/Postgres/CustomTypes.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Postgres/CustomTypes.hs @@ -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 diff --git a/Database/Beam/Postgres/Debug.hs b/Database/Beam/Postgres/Debug.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Postgres/Debug.hs @@ -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) + diff --git a/Database/Beam/Postgres/Extensions.hs b/Database/Beam/Postgres/Extensions.hs --- a/Database/Beam/Postgres/Extensions.hs +++ b/Database/Beam/Postgres/Extensions.hs @@ -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 -> diff --git a/Database/Beam/Postgres/Full.hs b/Database/Beam/Postgres/Full.hs --- a/Database/Beam/Postgres/Full.hs +++ b/Database/Beam/Postgres/Full.hs @@ -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 -- 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 diff --git a/Database/Beam/Postgres/Migrate.hs b/Database/Beam/Postgres/Migrate.hs --- a/Database/Beam/Postgres/Migrate.hs +++ b/Database/Beam/Postgres/Migrate.hs @@ -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 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 diff --git a/Database/Beam/Postgres/PgCrypto.hs b/Database/Beam/Postgres/PgCrypto.hs --- a/Database/Beam/Postgres/PgCrypto.hs +++ b/Database/Beam/Postgres/PgCrypto.hs @@ -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 diff --git a/Database/Beam/Postgres/PgSpecific.hs b/Database/Beam/Postgres/PgSpecific.hs --- a/Database/Beam/Postgres/PgSpecific.hs +++ b/Database/Beam/Postgres/PgSpecific.hs @@ -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 -- diff --git a/Database/Beam/Postgres/Syntax.hs b/Database/Beam/Postgres/Syntax.hs --- a/Database/Beam/Postgres/Syntax.hs +++ b/Database/Beam/Postgres/Syntax.hs @@ -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) diff --git a/Database/Beam/Postgres/Types.hs b/Database/Beam/Postgres/Types.hs --- a/Database/Beam/Postgres/Types.hs +++ b/Database/Beam/Postgres/Types.hs @@ -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) diff --git a/beam-postgres.cabal b/beam-postgres.cabal --- a/beam-postgres.cabal +++ b/beam-postgres.cabal @@ -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 , 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 diff --git a/test/Database/Beam/Postgres/Test.hs b/test/Database/Beam/Postgres/Test.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test.hs @@ -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 diff --git a/test/Database/Beam/Postgres/Test/DataTypes.hs b/test/Database/Beam/Postgres/Test/DataTypes.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/DataTypes.hs @@ -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 +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 +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 diff --git a/test/Database/Beam/Postgres/Test/Marshal.hs b/test/Database/Beam/Postgres/Test/Marshal.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/Marshal.hs @@ -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 + diff --git a/test/Database/Beam/Postgres/Test/Migrate.hs b/test/Database/Beam/Postgres/Test/Migrate.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/Migrate.hs @@ -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) diff --git a/test/Database/Beam/Postgres/Test/Select.hs b/test/Database/Beam/Postgres/Test/Select.hs new file mode 100644 --- /dev/null +++ b/test/Database/Beam/Postgres/Test/Select.hs @@ -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" [] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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) ])