beam-postgres (empty) → 0.3.0.0
raw patch · 13 files changed
+4362/−0 lines, 13 filesdep +aesondep +basedep +beam-core
Dependencies added: aeson, base, beam-core, beam-migrate, bytestring, case-insensitive, conduit, free, hashable, haskell-src-exts, lifted-base, monad-control, mtl, network-uri, postgresql-libpq, postgresql-simple, scientific, text, time, unordered-containers, uuid, vector
Files
- ChangeLog.md +3/−0
- Database/Beam/Postgres.hs +79/−0
- Database/Beam/Postgres/Conduit.hs +180/−0
- Database/Beam/Postgres/Connection.hs +346/−0
- Database/Beam/Postgres/Extensions.hs +192/−0
- Database/Beam/Postgres/Full.hs +397/−0
- Database/Beam/Postgres/Migrate.hs +364/−0
- Database/Beam/Postgres/PgCrypto.hs +178/−0
- Database/Beam/Postgres/PgSpecific.hs +1017/−0
- Database/Beam/Postgres/Syntax.hs +1374/−0
- Database/Beam/Postgres/Types.hs +152/−0
- LICENSE +8/−0
- beam-postgres.cabal +72/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# 0.3.0.0++Initial hackage beam-postgres
+ Database/Beam/Postgres.hs view
@@ -0,0 +1,79 @@+-- | Postgres is a popular, open-source RDBMS. It is fairly standards compliant+-- and supports many advanced features and data types.+--+-- The @beam-postgres@ module is built atop of @postgresql-simple@, which is+-- used for connection management, transaction support, serialization, and+-- deserialization.+--+-- @beam-postgres@ supports most beam features as well as many postgres-specific+-- features. For example, @beam-postgres@ provides support for full-text search,+-- @DISTINCT ON@, JSON handling, postgres @ARRAY@s, and the @MONEY@ type.+--+-- The documentation for @beam-postgres@ functionality below indicates which+-- postgres function each function or type wraps. Postgres maintains its own+-- in-depth documentation. Please refer to that for more detailed information on+-- <https://www.postgresql.org/docs/current/static/index.html behavior>.+--+-- For examples on how to use @beam-postgres@ usage, see+-- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ its manual>.++module Database.Beam.Postgres+ (+ -- * @beam-postgres@ errors+ -- @beam-postgres@ query and data manipulation functions may throw any error+ -- thrown by @postgresql-simple@ as well as the following two beam-specific+ -- errors.+ PgRowReadError(..), PgError(..)++ -- * Beam Postgres backend+ , Postgres(..), Pg++ -- ** Postgres syntax+ , PgCommandSyntax, PgSyntax+ , PgSelectSyntax, PgInsertSyntax+ , PgUpdateSyntax, PgDeleteSyntax++ -- * Beam URI support+ , postgresUriSyntax++ -- * Postgres-specific features+ -- ** Postgres-specific data types++ , json, jsonb, uuid, money+ , tsquery, tsvector, text, bytea+ , unboundedArray++ -- *** @SERIAL@ support+ , smallserial, serial, bigserial++ , module Database.Beam.Postgres.PgSpecific++ -- ** Postgres extension support+ , PgExtensionEntity, IsPgExtension(..)+ , pgCreateExtension, pgDropExtension+ , getPgExtension++ -- * @postgresql-simple@ re-exports++ , Pg.ResultError(..), Pg.SqlError(..)++ , Pg.Connection, Pg.ConnectInfo(..)+ , Pg.defaultConnectInfo++ , Pg.connectPostgreSQL, Pg.connect+ , Pg.close++ ) where++import Database.Beam.Postgres.Connection+import Database.Beam.Postgres.Syntax hiding (PostgresInaccessible)+import Database.Beam.Postgres.Types+import Database.Beam.Postgres.PgSpecific+import Database.Beam.Postgres.Migrate ( tsquery, tsvector, text, bytea, unboundedArray+ , json, jsonb, uuid, money, smallserial, serial+ , bigserial)+import Database.Beam.Postgres.Extensions ( PgExtensionEntity, IsPgExtension(..)+ , pgCreateExtension, pgDropExtension+ , getPgExtension )++import qualified Database.PostgreSQL.Simple as Pg
+ Database/Beam/Postgres/Conduit.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE LambdaCase #-}++-- | More efficient query execution functions for @beam-postgres@. These+-- functions use the @conduit@ package, to execute @beam-postgres@ statements in+-- an arbitrary 'MonadIO'. These functions may be more efficient for streaming+-- operations than 'MonadBeam'.+module Database.Beam.Postgres.Conduit where++import Database.Beam+import Database.Beam.Postgres.Connection+import Database.Beam.Postgres.Full+import Database.Beam.Postgres.Syntax+import Database.Beam.Postgres.Types++import Control.Exception.Lifted (finally)+import Control.Monad.Trans.Control (MonadBaseControl)++import qualified Database.PostgreSQL.LibPQ as Pg hiding+ (Connection, escapeStringConn, escapeIdentifier, escapeByteaConn, exec)+import qualified Database.PostgreSQL.Simple as Pg+import qualified Database.PostgreSQL.Simple.Internal as Pg (withConnection)+import qualified Database.PostgreSQL.Simple.Types as Pg (Query(..))++import qualified Data.Conduit as C+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))++-- * @SELECT@++-- | Run a PostgreSQL @SELECT@ statement in any 'MonadIO'.+runSelect :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a )+ => Pg.Connection -> SqlSelect PgSelectSyntax a+ -> (C.ConduitT () a m () -> m b) -> m b+runSelect conn (SqlSelect (PgSelectSyntax syntax)) withSrc =+ runQueryReturning conn syntax withSrc++-- * @INSERT@++-- | Run a PostgreSQL @INSERT@ statement in any 'MonadIO'. Returns the number of+-- rows affected.+runInsert :: MonadIO m+ => Pg.Connection -> SqlInsert PgInsertSyntax -> m Int64+runInsert _ SqlInsertNoRows = pure 0+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)+ => Pg.Connection+ -> PgInsertReturning a+ -> (C.ConduitT () a m () -> m b)+ -> m b+runInsertReturning _ PgInsertReturningEmpty withSrc = withSrc (pure ())+runInsertReturning conn (PgInsertReturning i) withSrc =+ runQueryReturning conn i withSrc++-- * @UPDATE@++-- | Run a PostgreSQL @UPDATE@ statement in any 'MonadIO'. Returns the number of+-- rows affected.+runUpdate :: MonadIO m+ => Pg.Connection -> SqlUpdate PgUpdateSyntax tbl -> m Int64+runUpdate _ SqlIdentityUpdate = pure 0+runUpdate conn (SqlUpdate (PgUpdateSyntax i)) =+ executeStatement conn i++-- | Run a PostgreSQL @UPDATE ... RETURNING ...@ statement in any 'MonadIO' and+-- get a 'C.Source' of the newly updated rows.+runUpdateReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a)+ => Pg.Connection+ -> PgUpdateReturning a+ -> (C.ConduitT () a m () -> m b)+ -> m b+runUpdateReturning _ PgUpdateReturningEmpty withSrc = withSrc (pure ())+runUpdateReturning conn (PgUpdateReturning u) withSrc =+ runQueryReturning conn u withSrc++-- * @DELETE@++-- | Run a PostgreSQL @DELETE@ statement in any 'MonadIO'. Returns the number of+-- rows affected.+runDelete :: MonadIO m+ => Pg.Connection -> SqlDelete PgDeleteSyntax tbl+ -> m Int64+runDelete conn (SqlDelete (PgDeleteSyntax d)) =+ executeStatement conn d++-- | Run a PostgreSQl @DELETE ... RETURNING ...@ statement in any+-- 'MonadIO' and get a 'C.Source' of the deleted rows.+runDeleteReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a )+ => Pg.Connection -> PgDeleteReturning a+ -> (C.ConduitT () a m () -> m b) -> m b+runDeleteReturning conn (PgDeleteReturning d) withSrc =+ runQueryReturning conn d withSrc++-- * Convenience functions++-- | Run any DML statement. Return the number of rows affected+executeStatement :: MonadIO m => Pg.Connection -> PgSyntax -> m Int64+executeStatement conn x =+ liftIO $ do+ syntax <- pgRenderSyntax conn x+ Pg.execute_ conn (Pg.Query syntax)++-- | Runs any query that returns a set of values+runQueryReturning+ :: ( MonadIO m, MonadBaseControl IO m, Functor m, FromBackendRow Postgres r )+ => Pg.Connection -> PgSyntax+ -> (C.ConduitT () r m () -> m b)+ -> m b+runQueryReturning conn x withSrc = do+ success <- liftIO $ do+ syntax <- pgRenderSyntax conn x++ Pg.withConnection conn (\conn' -> Pg.sendQuery conn' syntax)++ if success+ then do+ singleRowModeSet <- liftIO (Pg.withConnection conn Pg.setSingleRowMode)+ if singleRowModeSet+ then withSrc (streamResults Nothing) `finally` gracefulShutdown+ else fail "Could not enable single row mode"+ else do+ errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.withConnection conn Pg.errorMessage)+ fail (show errMsg)++ where+ streamResults fields = do+ nextRow <- liftIO (Pg.withConnection conn Pg.getResult)+ case nextRow of+ Nothing -> pure ()+ Just row ->+ liftIO (Pg.resultStatus row) >>=+ \case+ Pg.SingleTuple ->+ do fields' <- liftIO (maybe (getFields row) pure fields)+ parsedRow <- liftIO (runPgRowReader conn 0 row fields' fromBackendRow)+ case parsedRow of+ Left err -> liftIO (bailEarly row ("Could not read row: " <> show err))+ Right parsedRow' ->+ do C.yield parsedRow'+ streamResults (Just fields')+ Pg.TuplesOk -> liftIO (Pg.withConnection conn finishQuery)+ Pg.EmptyQuery -> fail "No query"+ Pg.CommandOk -> pure ()+ _ -> do errMsg <- liftIO (Pg.resultErrorMessage row)+ fail ("Postgres error: " <> show errMsg)++ bailEarly row errorString = do+ Pg.unsafeFreeResult row+ Pg.withConnection conn $ cancelQuery+ fail errorString++ cancelQuery conn' = do+ cancel <- Pg.getCancel conn'+ case cancel of+ Nothing -> pure ()+ Just cancel' -> do+ res <- Pg.cancel cancel'+ case res of+ Right () -> liftIO (finishQuery conn')+ Left err -> fail ("Could not cancel: " <> show err)++ finishQuery conn' = do+ nextRow <- Pg.getResult conn'+ case nextRow of+ Nothing -> pure ()+ Just _ -> finishQuery conn'++ gracefulShutdown =+ liftIO . Pg.withConnection conn $ \conn' ->+ do sts <- Pg.transactionStatus conn'+ case sts of+ Pg.TransIdle -> pure ()+ Pg.TransInTrans -> pure ()+ Pg.TransInError -> pure ()+ Pg.TransUnknown -> pure ()+ Pg.TransActive -> cancelQuery conn'
+ Database/Beam/Postgres/Connection.hs view
@@ -0,0 +1,346 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Beam.Postgres.Connection+ ( PgRowReadError(..), PgError(..)+ , Pg(..), PgF(..)++ , pgRenderSyntax, runPgRowReader, getFields++ , withPgDebug++ , postgresUriSyntax ) where++import Control.Exception (Exception, 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.URI+import Database.Beam.Query.Types (QGenExpr(..))++import Database.Beam.Postgres.Syntax+import Database.Beam.Postgres.Full+import Database.Beam.Postgres.Types++import qualified Database.PostgreSQL.LibPQ as Pg hiding+ (Connection, escapeStringConn, escapeIdentifier, escapeByteaConn, exec)+import qualified Database.PostgreSQL.Simple as Pg+import qualified Database.PostgreSQL.Simple.FromField as Pg+import qualified Database.PostgreSQL.Simple.Internal as Pg+ ( Field(..), RowParser(..)+ , escapeStringConn, escapeIdentifier, escapeByteaConn+ , 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 Control.Monad.Reader+import Control.Monad.State++import Data.ByteString (ByteString)+import Data.ByteString.Builder (toLazyByteString, byteString)+import qualified Data.ByteString.Lazy as BL+import Data.Monoid+import Data.Proxy+import Data.String+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)++import Foreign.C.Types++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)+ | 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+ -> BeamURIOpeners c+postgresUriSyntax =+ mkUriOpener "postgresql:"+ (\uri -> do+ let pgConnStr = fromString (uriToString id uri "")+ hdl <- Pg.connectPostgreSQL pgConnStr+ pure (hdl, Pg.close hdl))++-- * Syntax rendering++pgRenderSyntax ::+ Pg.Connection -> PgSyntax -> IO ByteString+pgRenderSyntax conn (PgSyntax mkQuery) =+ renderBuilder <$> runF mkQuery finish step mempty+ where+ renderBuilder = BL.toStrict . toLazyByteString++ step (EmitBuilder b next) a = next (a <> b)+ step (EmitByteString b next) a = next (a <> byteString b)+ step (EscapeString b next) a = do+ res <- wrapError "EscapeString" (Pg.escapeStringConn conn b)+ next (a <> byteString res)+ step (EscapeBytea b next) a = do+ res <- wrapError "EscapeBytea" (Pg.escapeByteaConn conn b)+ next (a <> byteString res)+ step (EscapeIdentifier b next) a = do+ res <- wrapError "EscapeIdentifier" (Pg.escapeIdentifier conn b)+ next (a <> byteString res)++ finish _ = pure++ wrapError step' go = do+ res <- go+ case res of+ Right res' -> pure res'+ Left res' -> fail (step' <> ": " <> show res')++-- * 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++ let getField col =+ Pg.Field res (Pg.Col col) <$> Pg.ftype res (Pg.Col col)++ 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.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:_) =+ 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)++ 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++ 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++ finish x _ _ _ = pure (Right x)++withPgDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO (Either PgError a)+withPgDebug dbg conn (Pg action) =+ let finish x = pure (Right x)+ step (PgLiftIO io next) = io >>= next+ step (PgLiftWithHandle withConn next) = withConn conn >>= next+ step (PgFetchNext next) = next Nothing+ step (PgRunReturning (PgCommandSyntax PgCommandTypeQuery syntax)+ (mkProcess :: Pg (Maybe x) -> Pg a')+ next) =+ do query <- pgRenderSyntax conn syntax+ let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))+ dbg (T.unpack (decodeUtf8 query))+ action' <- runF process finishProcess stepProcess Nothing+ case action' of+ PgStreamDone (Right x) -> Pg.execute_ conn (Pg.Query query) >> next x+ PgStreamDone (Left err) -> pure (Left err)+ PgStreamContinue nextStream ->+ let finishUp (PgStreamDone (Right x)) = next x+ finishUp (PgStreamDone (Left err)) = pure (Left err)+ finishUp (PgStreamContinue next') = next' Nothing >>= finishUp++ columnCount = fromIntegral $ valuesNeeded (Proxy @Postgres) (Proxy @x)+ in Pg.foldWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) (PgStreamContinue nextStream) runConsumer >>= finishUp+ step (PgRunReturning (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) =+ do query <- pgRenderSyntax conn syntax+ dbg (T.unpack (decodeUtf8 query))++ res <- Pg.exec conn query+ sts <- Pg.resultStatus res+ case sts of+ Pg.TuplesOk -> do+ let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))+ runF process (\x _ -> Pg.unsafeFreeResult res >> next x) (stepReturningList res) 0+ _ -> Pg.throwResultError "No tuples returned to Postgres update/insert returning"+ res sts+ step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) =+ do query <- pgRenderSyntax conn syntax+ dbg (T.unpack (decodeUtf8 query))+ _ <- Pg.execute_ conn (Pg.Query query)++ 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 (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"))++ stepReturningList :: forall a. Pg.Result -> PgF (CInt -> IO (Either PgError a)) -> CInt -> IO (Either PgError a)+ stepReturningList _ (PgLiftIO action' next) rowIdx = action' >>= \x -> next x rowIdx+ stepReturningList res (PgFetchNext next) rowIdx =+ do fields <- getFields res+ Pg.Row rowCount <- Pg.ntuples res+ if rowIdx >= rowCount+ then next Nothing rowIdx+ else runPgRowReader conn (Pg.Row rowIdx) res fields fromBackendRow >>= \case+ Left err -> pure (Left (PgRowParseError 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"))++ finishProcess :: forall a. a -> Maybe PgI.Row -> IO (PgStream a)+ finishProcess x _ = pure (PgStreamDone (Right x))++ stepProcess :: forall a. PgF (Maybe PgI.Row -> IO (PgStream a)) -> Maybe PgI.Row -> IO (PgStream a)+ stepProcess (PgLiftIO action' next) row = action' >>= flip next row+ stepProcess (PgFetchNext next) Nothing =+ pure . PgStreamContinue $ \res ->+ case res of+ Nothing -> next Nothing Nothing+ Just (PgI.Row rowIdx res') ->+ getFields res' >>= \fields ->+ runPgRowReader conn rowIdx res' fields fromBackendRow >>= \case+ Left err -> pure (PgStreamDone (Left (PgRowParseError err)))+ Right r -> next 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)))+ 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")))++ runConsumer :: forall a. PgStream a -> PgI.Row -> IO (PgStream a)+ runConsumer s@(PgStreamDone {}) _ = pure s+ runConsumer (PgStreamContinue next) row = next (Just row)+ in runF action finish step++-- * Beam Monad class++data PgF next where+ PgLiftIO :: IO a -> (a -> next) -> PgF next+ PgRunReturning ::+ FromBackendRow Postgres x =>+ PgCommandSyntax -> (Pg (Maybe x) -> Pg a) -> (a -> next) -> PgF next+ PgFetchNext ::+ FromBackendRow Postgres x =>+ (Maybe x -> next) -> PgF next+ PgLiftWithHandle :: (Pg.Connection -> IO a) -> (a -> next) -> PgF next+deriving instance Functor PgF++-- | 'MonadBeam' in which we can run Postgres commands. See the documentation+-- for 'MonadBeam' on examples of how to use.+--+-- @beam-postgres@ also provides functions that let you run queries without+-- 'MonadBeam'. These functions may be more efficient and offer a conduit+-- API. See "Database.Beam.Postgres.Conduit" for more information.+newtype Pg a = Pg { runPg :: F PgF a }+ deriving (Monad, Applicative, Functor, MonadFree PgF)++instance MonadIO Pg where+ liftIO x = liftF (PgLiftIO x id)++instance MonadBeam PgCommandSyntax Postgres Pg.Connection Pg where+ withDatabase conn action =+ withPgDebug (\_ -> pure ()) conn action >>= either throwIO pure+ withDatabaseDebug dbg conn action =+ withPgDebug dbg conn action >>= either throwIO pure++ 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)))++ -- Make savepoint+ case insertReturningCmd' of+ PgInsertReturningEmpty ->+ pure []+ 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))++ case updateReturningCmd' of+ PgUpdateReturningEmpty ->+ pure []+ 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))++ runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning deleteReturningCmd)
+ Database/Beam/Postgres/Extensions.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Postgres extensions are run-time loadable plugins that can extend Postgres+-- functionality. Extensions are part of the database schema.+--+-- Beam fully supports including Postgres extensions in Beam databases. The+-- 'PgExtensionEntity' type constructor can be used to declare the existence of+-- the extension in a particular backend. @beam-postgres@ provides predicates+-- and checks for @beam-migrate@ which allow extensions to be included as+-- regular parts of beam migrations.+module Database.Beam.Postgres.Extensions where++import Database.Beam+import Database.Beam.Schema.Tables++import Database.Beam.Postgres.Types+import Database.Beam.Postgres.Syntax++import Database.Beam.Migrate++import Control.Monad++import Data.Aeson+import qualified Data.HashSet as HS+import Data.Hashable (Hashable)+import Data.Monoid+import Data.Proxy+import Data.Text (Text)++-- *** Embedding extensions in databases++-- | Represents an extension in a database.+--+-- For example, to include the "Database.Beam.Postgres.PgCrypto" extension in a+-- database,+--+-- @+-- import Database.Beam.Migrate.PgCrypto+--+-- data MyDatabase entity+-- = MyDatabase+-- { _table1 :: entity (TableEntity Table1)+-- , _cryptoExtension :: entity (PgExtensionEntity PgCrypto)+-- }+--+-- migratableDbSettings :: CheckedDatabaseSettings Postgres MyDatabase+-- migratableDbSettings = defaultMigratableDbSettings+--+-- dbSettings :: DatabaseSettings Postgres MyDatabase+-- dbSettings = unCheckDatabase migratableDbSettings+-- @+--+-- Note that our database now only works in the 'Postgres' backend.+--+-- Extensions are implemented as records of functions and values that expose+-- extension functionality. For example, the @pgcrypto@ extension (implemented+-- by 'PgCrypto') provides cryptographic functions. Thus, 'PgCrypto' is a record+-- of functions over 'QGenExpr' which wrap the underlying postgres+-- functionality.+--+-- You get access to these functions by retrieving them from the entity in the+-- database.+--+-- For example, to use the @pgcrypto@ extension in the database above:+--+-- @+-- let PgCrypto { pgCryptoDigestText = digestText+-- , pgCryptoCrypt = crypt } = getPgExtension (_cryptoExtension dbSettings)+-- in fmap_ (\tbl -> (tbl, crypt (_field1 tbl) (_salt tbl))) (all_ (table1 dbSettings))+-- @+--+-- To implement your own extension, create a record type, and implement the+-- 'IsPgExtension' type class.+data PgExtensionEntity extension++-- | Type class implemented by any Postgresql extension+class IsPgExtension extension where+ -- | Return the name of this extension. This should be the string that is+ -- passed to @CREATE EXTENSION@. For example, 'PgCrypto' returns @"pgcrypto"@.+ pgExtensionName :: Proxy extension -> Text++ -- | Return a value of this extension type. This should fill in all fields in+ -- the record. For example, 'PgCrypto' builds a record where each function+ -- wraps the underlying Postgres one.+ pgExtensionBuild :: extension++-- | There are no fields to rename when defining entities+instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor Postgres (PgExtensionEntity e))) where+ renamingFields _ = FieldRenamer id++instance IsDatabaseEntity Postgres (PgExtensionEntity extension) where++ data DatabaseEntityDescriptor Postgres (PgExtensionEntity extension) where+ PgDatabaseExtension :: IsPgExtension extension+ => Text+ -> extension+ -> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)+ type DatabaseEntityDefaultRequirements Postgres (PgExtensionEntity extension) =+ ( IsPgExtension extension )+ type DatabaseEntityRegularRequirements Postgres (PgExtensionEntity extension) =+ ( IsPgExtension extension )++ dbEntityName f (PgDatabaseExtension nm ext) = fmap (\nm' -> PgDatabaseExtension nm' ext) (f nm)+ 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 =+ DatabaseEntityRegularRequirements Postgres (PgExtensionEntity extension)++ unCheck (CheckedPgExtension ext) = ext+ collectEntityChecks (CheckedPgExtension (PgDatabaseExtension {})) =+ [ SomeDatabasePredicate (PgHasExtension (pgExtensionName (Proxy @extension))) ]+ checkedDbEntityAuto _ = CheckedPgExtension . dbEntityAuto++-- | Get the extension record from a database entity. See the documentation for+-- 'PgExtensionEntity'.+getPgExtension :: DatabaseEntity Postgres db (PgExtensionEntity extension)+ -> extension+getPgExtension (DatabaseEntity (PgDatabaseExtension _ ext)) = ext++-- *** Migrations support for extensions++-- | 'Migration' representing the Postgres @CREATE EXTENSION@ command. Because+-- the extension name is statically known by the extension type and+-- 'IsPgExtension' type class, this simply produces the checked extension+-- entity.+--+-- If you need to use the extension in subsequent migration steps, use+-- 'getPgExtension' and 'unCheck' to get access to the underlying+-- 'DatabaseEntity'.+pgCreateExtension :: forall extension db+ . IsPgExtension extension+ => Migration PgCommandSyntax (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension))+pgCreateExtension =+ let entity = checkedDbEntityAuto (Proxy @PgCommandSyntax) ""+ extName = pgExtensionName (Proxy @extension)+ in upDown (pgCreateExtensionSyntax extName) Nothing >>+ pure (CheckedDatabaseEntity entity (collectEntityChecks entity))++-- | 'Migration' representing the Postgres @DROP EXTENSION@. After this+-- executes, you should expect any further uses of the extension to fail.+-- Unfortunately, without linear types, we cannot check this.+pgDropExtension :: forall extension+ . CheckedDatabaseEntityDescriptor Postgres (PgExtensionEntity extension)+ -> Migration PgCommandSyntax ()+pgDropExtension (CheckedPgExtension (PgDatabaseExtension {})) =+ upDown (pgDropExtensionSyntax (pgExtensionName (Proxy @extension))) Nothing+++-- | Postgres-specific database predicate asserting the existence of an+-- extension in the database. The 'pgExtensionActionProvider' properly provides+-- @CREATE EXTENSION@ and @DROP EXTENSION@ statements to the migration finder.+newtype PgHasExtension = PgHasExtension Text {- Extension Name -}+ deriving (Show, Eq, Generic, Hashable)+instance DatabasePredicate PgHasExtension where+ englishDescription (PgHasExtension extName) =+ "Postgres extension " ++ show extName ++ " is loaded"++ predicateSpecificity _ = PredicateSpecificityOnlyBackend "postgres"+ serializePredicate (PgHasExtension nm) =+ object [ "has-postgres-extension" .= nm ]++pgExtensionActionProvider :: ActionProvider PgCommandSyntax+pgExtensionActionProvider = pgCreateExtensionProvider <> pgDropExtensionProvider++pgCreateExtensionProvider, pgDropExtensionProvider :: ActionProvider PgCommandSyntax++pgCreateExtensionProvider =+ ActionProvider $ \findPre findPost ->+ do extP@(PgHasExtension ext) <- findPost+ ensuringNot_ $+ do PgHasExtension ext' <- findPre+ guard (ext == ext')++ let cmd = pgCreateExtensionSyntax ext+ pure (PotentialAction mempty (HS.fromList [p extP])+ (pure (MigrationCommand cmd MigrationKeepsData))+ ("Load the postgres extension " <> ext) 1)++pgDropExtensionProvider =+ ActionProvider $ \findPre findPost ->+ do extP@(PgHasExtension ext) <- findPre+ ensuringNot_ $+ do PgHasExtension ext' <- findPost+ guard (ext == ext')++ let cmd = pgDropExtensionSyntax ext+ pure (PotentialAction (HS.fromList [p extP]) mempty+ (pure (MigrationCommand cmd MigrationKeepsData))+ ("Unload the postgres extension " <> ext) 1)
+ Database/Beam/Postgres/Full.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++-- | Module providing (almost) full support for Postgres query and data+-- manipulation statements. These functions shadow the functions in+-- "Database.Beam.Query" and provide a strict superset of functionality. They+-- map 1-to-1 with the underlying Postgres support.+module Database.Beam.Postgres.Full+ ( -- * Additional @SELECT@ features++ -- ** @SELECT@ Locking clause+ PgWithLocking, PgLockedTables+ , PgSelectLockingStrength(..), PgSelectLockingOptions(..)+ , lockingAllTablesFor_, lockingFor_++ , locked_, lockAll_, withLocks_++ -- * @INSERT@ and @INSERT RETURNING@+ , insert, insertReturning++ , PgInsertReturning(..)++ -- ** Specifying conflict actions++ , PgInsertOnConflict(..), PgInsertOnConflictTarget(..)+ , PgConflictAction(..)++ , onConflictDefault, onConflict, anyConflict, conflictingFields+ , conflictingFieldsWhere, conflictingConstraint+ , onConflictDoNothing, onConflictUpdateSet+ , onConflictUpdateSetWhere, onConflictUpdateInstead+ , onConflictSetAll++ -- * @UPDATE RETURNING@+ , PgUpdateReturning(..)+ , updateReturning++ -- * @DELETE RETURNING@+ , PgDeleteReturning(..)+ , deleteReturning+ ) where++import Database.Beam hiding (insert, insertValues)+import Database.Beam.Query.Internal+import Database.Beam.Backend.SQL+import Database.Beam.Schema.Tables++import Database.Beam.Postgres.Types+import Database.Beam.Postgres.Syntax++import Control.Monad.Free.Church++import Data.Monoid ((<>))+import qualified Data.Text as T++-- * @SELECT@++-- | An explicit lock against some tables. You can create a value of this type using the 'locked_'+-- function. You can combine these values monoidally to combine multiple locks for use with the+-- 'withLocks_' function.+newtype PgLockedTables s = PgLockedTables [ T.Text ]+instance Monoid (PgLockedTables s) where+ mempty = PgLockedTables []+ mappend (PgLockedTables a) (PgLockedTables b) = PgLockedTables (a <> b)++-- | 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++-- | Use with 'lockingFor_' to lock all tables mentioned in the query+lockAll_ :: a -> PgWithLocking s a+lockAll_ = PgWithLocking mempty++-- | Return and lock the given tables. Typically used as an infix operator. See the+-- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ the user guide> for usage+-- examples+withLocks_ :: a -> PgLockedTables s -> PgWithLocking s a+withLocks_ = flip PgWithLocking++-- | 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+ => 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))+ pure (PgLockedTables [nm], joined)++-- | Lock some tables during the execution of a query. This is rather complicated, and there are+-- several usage examples in+-- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ the user guide>+--+-- The Postgres locking clause is rather complex, and beam currently does not check several+-- pre-conditions. It is assumed you kinda know what you're doing.+--+-- Things which postgres doesn't like, but beam will do+--+-- * Using aggregates within a query that has a locking clause+-- * Using @UNION@, @INTERSECT@, or @EXCEPT@+--+-- See <https://www.postgresql.org/docs/10/static/sql-select.html#SQL-FOR-UPDATE-SHARE here> for+-- more details.+--+-- This function accepts a locking strength (@UPDATE@, @SHARE@, @KEY SHARE@, etc), an optional+-- locking option (@NOWAIT@ or @SKIP LOCKED@), and a query whose rows to lock. The query should+-- return its result wrapped in 'PgWithLocking', via the `withLocks_` or `lockAll_` function.+--+-- 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 )+ => PgSelectLockingStrength+ -> Maybe PgSelectLockingOptions+ -> Q PgSelectSyntax db (QNested s) (PgWithLocking (QNested s) a)+ -> Q PgSelectSyntax db 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)))++-- | 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 )+ => PgSelectLockingStrength+ -> Maybe PgSelectLockingOptions+ -> Q PgSelectSyntax db (QNested s) a+ -> Q PgSelectSyntax db s a+lockingAllTablesFor_ lockStrength mLockOptions q =+ lockingFor_ lockStrength mLockOptions (lockAll_ <$> q)++-- * @INSERT@++-- | 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+ -> PgInsertOnConflict table+ -> SqlInsert PgInsertSyntax+insert tbl values onConflict_ =+ case insertReturning tbl values onConflict_+ (Nothing :: Maybe (table (QExpr PgExpressionSyntax PostgresInaccessible) -> QExpr PgExpressionSyntax PostgresInaccessible Int)) of+ PgInsertReturning a ->+ SqlInsert (PgInsertSyntax a)+ PgInsertReturningEmpty ->+ SqlInsertNoRows++-- | The most general kind of @INSERT@ that postgres can perform+data PgInsertReturning a+ = PgInsertReturning PgSyntax+ | PgInsertReturningEmpty++-- | The full Postgres @INSERT@ syntax, supporting conflict actions and the+-- @RETURNING CLAUSE@. See 'PgInsertOnConflict' for how to specify a conflict+-- action or provide 'onConflictDefault' to preserve the behavior without any+-- @ON CONFLICT@ clause. The last argument takes a newly inserted row and+-- 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+ => DatabaseEntity Postgres be (TableEntity table)+ -> SqlInsertValues PgInsertValuesSyntax (table (QExpr PgExpressionSyntax s))+ -> PgInsertOnConflict table+ -> Maybe (table (QExpr PgExpressionSyntax PostgresInaccessible) -> a)+ -> PgInsertReturning (QExprToIdentity a)++insertReturning _ SqlInsertValuesEmpty _ _ = PgInsertReturningEmpty+insertReturning (DatabaseEntity (DatabaseTable tblNm tblSettings))+ (SqlInsertValues (PgInsertValuesSyntax insertValues_))+ (PgInsertOnConflict mkOnConflict)+ returning =+ PgInsertReturning $+ emit "INSERT INTO " <> pgQuotedIdentifier tblNm <>+ emit "(" <> pgSepBy (emit ", ") (allBeamValues (\(Columnar' f) -> pgQuotedIdentifier (_fieldName f)) tblSettings) <> emit ") " <>+ insertValues_ <> emit " " <> fromPgInsertOnConflict (mkOnConflict tblFields) <>+ (case returning of+ Nothing -> mempty+ Just mkProjection ->+ emit " RETURNING "<>+ pgSepBy (emit ", ") (map fromPgExpression (project (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++-- ** @ON CONFLICT@ clause++-- | What to do when an @INSERT@ statement inserts a row into the table @tbl@+-- that violates a constraint.+newtype PgInsertOnConflict (tbl :: (* -> *) -> *) =+ PgInsertOnConflict (tbl (QField PostgresInaccessible) -> PgInsertOnConflictSyntax)++-- | Specifies the kind of constraint that must be violated for the action to occur+newtype PgInsertOnConflictTarget (tbl :: (* -> *) -> *) =+ PgInsertOnConflictTarget (tbl (QExpr PgExpressionSyntax PostgresInaccessible) -> PgInsertOnConflictTargetSyntax)++-- | A description of what to do when a constraint or index is violated.+newtype PgConflictAction (tbl :: (* -> *) -> *) =+ PgConflictAction (tbl (QField PostgresInaccessible) -> PgConflictActionSyntax)++-- | By default, Postgres will throw an error when a conflict is detected. This+-- preserves that functionality.+onConflictDefault :: PgInsertOnConflict tbl+onConflictDefault = PgInsertOnConflict (\_ -> PgInsertOnConflictSyntax mempty)++-- | Tells postgres what to do on an @INSERT@ conflict. The first argument is+-- the type of conflict to provide an action for. For example, to only provide+-- an action for certain fields, use 'conflictingFields'. Or to only provide an+-- action over certain fields where a particular condition is met, use+-- 'conflictingFields'. If you have a particular constraint violation in mind,+-- use 'conflictingConstraint'. To perform an action on any conflict, use+-- 'anyConflict'.+--+-- See the+-- <https://www.postgresql.org/docs/current/static/sql-insert.html Postgres documentation>.+onConflict :: Beamable tbl+ => PgInsertOnConflictTarget tbl+ -> PgConflictAction tbl+ -> PgInsertOnConflict tbl+onConflict (PgInsertOnConflictTarget tgt) (PgConflictAction update_) =+ PgInsertOnConflict $ \tbl ->+ let exprTbl = changeBeamRep (\(Columnar' (QField _ _ nm)) ->+ Columnar' (QExpr (\_ -> fieldE (unqualifiedField nm))))+ tbl+ in PgInsertOnConflictSyntax $+ emit "ON CONFLICT " <> fromPgInsertOnConflictTarget (tgt exprTbl)+ <> fromPgConflictAction (update_ tbl)++-- | Perform the conflict action when any constraint or index conflict occurs.+-- Syntactically, this is the @ON CONFLICT@ clause, without any /conflict target/.+anyConflict :: PgInsertOnConflictTarget tbl+anyConflict = PgInsertOnConflictTarget (\_ -> PgInsertOnConflictTargetSyntax mempty)++-- | 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)+ -> PgInsertOnConflictTarget tbl+conflictingFields makeProjection =+ PgInsertOnConflictTarget $ \tbl ->+ PgInsertOnConflictTargetSyntax $+ pgParens (pgSepBy (emit ", ") (map fromPgExpression (project (makeProjection tbl) "t"))) <> emit " "++-- | Like 'conflictingFields', but only perform the action if the condition+-- given in the second argument is met. See the postgres+-- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for+-- more information.+conflictingFieldsWhere :: Projectible PgExpressionSyntax proj+ => (tbl (QExpr PgExpressionSyntax PostgresInaccessible) -> proj)+ -> (tbl (QExpr PgExpressionSyntax PostgresInaccessible) ->+ QExpr PgExpressionSyntax PostgresInaccessible Bool)+ -> PgInsertOnConflictTarget tbl+conflictingFieldsWhere makeProjection makeWhere =+ PgInsertOnConflictTarget $ \tbl ->+ PgInsertOnConflictTargetSyntax $+ pgParens (pgSepBy (emit ", ") (map fromPgExpression (project (makeProjection tbl) "t"))) <>+ emit " WHERE " <>+ pgParens (let QExpr mkE = makeWhere tbl+ PgExpressionSyntax e = mkE "t"+ in e) <>+ emit " "++-- | Perform the action only if the given named constraint is violated+conflictingConstraint :: T.Text -> PgInsertOnConflictTarget tbl+conflictingConstraint nm =+ PgInsertOnConflictTarget $ \_ ->+ PgInsertOnConflictTargetSyntax $+ emit "ON CONSTRAINT " <> pgQuotedIdentifier nm <> emit " "++-- | The Postgres @DO NOTHING@ action+onConflictDoNothing :: PgConflictAction tbl+onConflictDoNothing = PgConflictAction $ \_ -> PgConflictActionSyntax (emit "DO NOTHING")++-- | The Postgres @DO UPDATE SET@ action, without the @WHERE@ clause. The+-- argument takes an updatable row (like the one used in 'update') and the+-- conflicting row. Use 'current_' on the first argument to get the current+-- value of the row in the database.+onConflictUpdateSet :: Beamable tbl+ => (tbl (QField PostgresInaccessible) ->+ tbl (QExpr PgExpressionSyntax PostgresInaccessible) ->+ [ QAssignment PgFieldNameSyntax PgExpressionSyntax PostgresInaccessible ])+ -> PgConflictAction tbl+onConflictUpdateSet mkAssignments =+ PgConflictAction $ \tbl ->+ let 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))+ in PgConflictActionSyntax $+ emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes++-- | The Postgres @DO UPDATE SET@ action, with the @WHERE@ clause. This is like+-- 'onConflictUpdateSet', but only rows satisfying the given condition are+-- updated. Sometimes this results in more efficient locking. See the Postgres+-- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for+-- more information.+onConflictUpdateSetWhere :: Beamable tbl+ => (tbl (QField PostgresInaccessible) ->+ tbl (QExpr PgExpressionSyntax PostgresInaccessible) ->+ [ QAssignment PgFieldNameSyntax PgExpressionSyntax PostgresInaccessible ])+ -> (tbl (QExpr PgExpressionSyntax PostgresInaccessible) -> QExpr PgExpressionSyntax PostgresInaccessible Bool)+ -> PgConflictAction tbl+onConflictUpdateSetWhere mkAssignments where_ =+ PgConflictAction $ \tbl ->+ let 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))+ 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)+ -> PgConflictAction tbl+onConflictUpdateInstead mkProj =+ onConflictUpdateSet $ \tbl _ ->+ let tblFields = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> nm))) tbl+ proj = project (mkProj tblFields) "t"++ in map (\fieldNm -> QAssignment [ (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)))+ => PgConflictAction tbl+onConflictSetAll = onConflictUpdateInstead id++-- * @UPDATE@++-- | The most general kind of @UPDATE@ that postgres can perform+data PgUpdateReturning a+ = PgUpdateReturning PgSyntax+ | PgUpdateReturningEmpty++-- | 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+ => 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)+ -> PgUpdateReturning (QExprToIdentity a)+updateReturning table@(DatabaseEntity (DatabaseTable _ tblSettings))+ mkAssignments+ mkWhere+ mkProjection =+ case update table mkAssignments mkWhere of+ SqlUpdate pgUpdate ->+ PgUpdateReturning $+ fromPgUpdate pgUpdate <>+ emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (mkProjection tblQ) "t"))++ SqlIdentityUpdate -> PgUpdateReturningEmpty+ where+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings++-- * @DELETE@++-- | The most general kind of @DELETE@ that postgres can perform+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+ => DatabaseEntity Postgres be (TableEntity table)+ -> (forall s. table (QExpr PgExpressionSyntax s) -> QExpr PgExpressionSyntax s Bool)+ -> (table (QExpr PgExpressionSyntax PostgresInaccessible) -> a)+ -> PgDeleteReturning (QExprToIdentity a)+deleteReturning table@(DatabaseEntity (DatabaseTable _ tblSettings))+ mkWhere+ mkProjection =+ PgDeleteReturning $+ fromPgDelete pgDelete <>+ emit " RETURNING " <>+ pgSepBy (emit ", ") (map fromPgExpression (project (mkProjection tblQ) "t"))+ where+ SqlDelete pgDelete = delete table mkWhere+ tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (pure (fieldE (unqualifiedField (_fieldName f)))))) tblSettings
+ Database/Beam/Postgres/Migrate.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-type-defaults #-}++-- | Migrations support for beam-postgres. See "Database.Beam.Migrate" for more+-- information on beam migrations.+module Database.Beam.Postgres.Migrate+ ( migrationBackend+ , postgresDataTypeDeserializers+ , pgPredConverter+ , getDbConstraints+ , pgTypeToHs+ , migrateScript+ , writeMigrationScript++ -- * Postgres data types+ , tsquery, tsvector, text, bytea+ , unboundedArray, uuid, money+ , json, jsonb+ , smallserial, serial, bigserial+ ) 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 qualified Database.Beam.Migrate.Serialization as Db+import qualified Database.Beam.Migrate.Types as Db++import Database.Beam.Postgres.Connection+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++import qualified Database.PostgreSQL.Simple as Pg+import qualified Database.PostgreSQL.Simple.Types as Pg+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg++import Control.Arrow+import Control.Exception (bracket)+import Control.Monad+import Control.Monad.Free.Church (liftF)++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.Monoid+import Data.String+import Data.Int+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V+import Data.UUID (UUID)+import Data.Typeable++-- | Top-level migration backend for use by @beam-migrate@ tools+migrationBackend :: Tool.BeamMigrationBackend PgCommandSyntax Postgres Pg.Connection 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"+ , ""+ , "For example, 'host=localhost port=5432 dbname=mydb connect_timeout=10' or 'dbname=mydb'"+ , ""+ , "Or use URIs, for which the general form is:"+ , " postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]"+ , ""+ , "See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> for more information" ])+ (BL.concat . migrateScript)+ (liftF (PgLiftWithHandle getDbConstraints id))+ (Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <>+ Db.sql2008BigIntDataTypeDeserializers <>+ postgresDataTypeDeserializers <>+ Db.beamCheckDeserializers)+ (BCL.unpack . (<> ";") . pgRenderSyntaxScript . fromPgCommand) "postgres.sql"+ pgPredConverter (defaultActionProvider <> pgExtensionActionProvider)+ (\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++-- | 'BeamDeserializers' for postgres-specific types:+--+-- * 'bytea'+-- * 'smallserial'+-- * 'serial'+-- * 'bigserial'+-- * 'tsvector'+-- * 'tsquery'+-- * 'text'+-- * 'json'+-- * 'jsonb'+-- * 'uuid'+-- * 'money'+--+postgresDataTypeDeserializers+ :: Db.BeamDeserializers PgCommandSyntax+postgresDataTypeDeserializers =+ Db.beamDeserializer $ \_ v ->+ case v of+ "bytea" -> pure pgByteaType+ "smallserial" -> pure pgSmallSerialType+ "serial" -> pure pgSerialType+ "bigserial" -> pure pgBigSerialType+ "tsquery" -> pure pgTsQueryType+ "tsvector" -> pure pgTsVectorType+ "text" -> pure pgTextType+ "json" -> pure pgJsonType+ "jsonb" -> pure pgJsonbType+ "uuid" -> pure pgUuidType+ "money" -> pure pgMoneyType+ _ -> 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 <>+ Tool.hsPredicateConverter pgHasColumnConstraint+ where+ pgHasColumnConstraint (Db.TableColumnHasConstraint tblNm colNm c :: Db.TableColumnHasConstraint PgColumnSchemaSyntax)+ | c == Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing =+ Just (Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tblNm colNm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint HsColumnSchema))+ | otherwise = Nothing++-- | Turn a 'PgDataTypeSyntax' into the corresponding 'HsDataType'. This is a+-- best effort guess, and may fail on more exotic types. Feel free to send PRs+-- to make this function more robust!+pgTypeToHs :: PgDataTypeSyntax -> Maybe HsDataType+pgTypeToHs (PgDataTypeSyntax tyDescr _ _) =+ case tyDescr of+ PgDataTypeDescrOid oid width+ | Pg.typoid Pg.int2 == oid -> Just smallIntType+ | Pg.typoid Pg.int4 == oid -> Just intType+ | Pg.typoid Pg.int8 == oid -> Just bigIntType++ | Pg.typoid Pg.bpchar == oid -> Just (charType (fromIntegral <$> width) Nothing)+ | Pg.typoid Pg.varchar == oid -> Just (varCharType (fromIntegral <$> width) Nothing)+ | Pg.typoid Pg.bit == oid -> Just (bitType (fromIntegral <$> width))+ | Pg.typoid Pg.varbit == oid -> Just (varBitType (fromIntegral <$> width))++ | Pg.typoid Pg.numeric == oid ->+ let decimals = fromMaybe 0 width .&. 0xFFFF+ prec = (fromMaybe 0 width `shiftR` 16) .&. 0xFFFF+ in Just (numericType (Just (fromIntegral prec, Just (fromIntegral decimals))))++ | Pg.typoid Pg.float4 == oid -> Just (floatType (fromIntegral <$> width))+ | Pg.typoid Pg.float8 == oid -> Just doubleType++ | Pg.typoid Pg.date == oid -> Just dateType++ -- We prefer using the standard beam names+ | Pg.typoid Pg.text == oid -> Just characterLargeObjectType+ | Pg.typoid Pg.bytea == oid -> Just binaryLargeObjectType+ | Pg.typoid Pg.bool == oid -> Just booleanType++ -- TODO timestamp prec+ | Pg.typoid Pg.time == oid -> Just (timeType Nothing False)+ | Pg.typoid Pg.timestamp == oid -> Just (timestampType Nothing False)+ | Pg.typoid Pg.timestamptz == oid -> Just (timestampType Nothing True)++ -- Postgres specific datatypes, haskell versions+ | Pg.typoid Pg.uuid == oid ->+ Just $ HsDataType (hsVarFrom "uuid" "Database.Beam.Postgres")+ (HsType (tyConNamed "UUID")+ (importSome "Data.UUID" [importTyNamed "UUID"]))+ (pgDataTypeSerialized pgUuidType)+ | Pg.typoid Pg.money == oid ->+ Just $ HsDataType (hsVarFrom "money" "Database.Beam.Postgres")+ (HsType (tyConNamed "PgMoney")+ (importSome "Database.Beam.Postgres" [importTyNamed "PgMoney"]))+ (pgDataTypeSerialized pgMoneyType)+ | Pg.typoid Pg.json == oid ->+ Just $ HsDataType (hsVarFrom "json" "Database.Beam.Postgres")+ (HsType (tyApp (tyConNamed "PgJSON") [ tyConNamed "Value" ])+ (importSome "Data.Aeson" [importTyNamed "Value"] <>+ importSome "Database.Beam.Postgres" [importTyNamed "PgJSON"]))+ (pgDataTypeSerialized pgJsonType)+ | Pg.typoid Pg.jsonb == oid ->+ Just $ HsDataType (hsVarFrom "jsonb" "Database.Beam.Postgres")+ (HsType (tyApp (tyConNamed "PgJSONB") [ tyConNamed "Value" ])+ (importSome "Data.Aeson" [importTyNamed "Value"] <>+ importSome "Database.Beam.Postgres" [importTyNamed "PgJSONB"]))+ (pgDataTypeSerialized pgJsonType)+ | Pg.typoid pgTsVectorTypeInfo == oid ->+ Just $ HsDataType (hsVarFrom "tsvector" "Database.Beam.Postgres")+ (HsType (tyConNamed "TsVector")+ (importSome "Database.Beam.Postgres" [importTyNamed "TsVector"]))+ (pgDataTypeSerialized pgTsVectorType)+ | Pg.typoid pgTsQueryTypeInfo == oid ->+ Just $ HsDataType (hsVarFrom "tsquery" "Database.Beam.Postgres")+ (HsType (tyConNamed "TsQuery")+ (importSome "Database.Beam.Postgres" [importTyNamed "TsQuery"]))+ (pgDataTypeSerialized pgTsQueryType)++ _ -> 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 steps =+ "-- CAUTION: beam-postgres currently escapes postgres string literals somewhat\n" :+ "-- haphazardly when generating scripts (but not when generating commands)\n" :+ "-- This is due to technical limitations in libPq that require a Postgres\n" :+ "-- Connection in order to correctly escape strings. Please verify that the\n" :+ "-- generated migration script is correct before running it on your database.\n" :+ "-- If you feel so called, please contribute better escaping support to beam-postgres\n" :+ "\n" :+ "-- Set connection encoding to UTF-8\n" :+ "SET client_encoding = 'UTF8';\n" :+ "SET standard_conforming_strings = off;\n\n" :+ appEndo (Db.migrateScript renderHeader renderCommand steps) []+ where+ renderHeader nm =+ Endo (("-- " <> BL.fromStrict (TE.encodeUtf8 nm) <> "\n"):)+ renderCommand command =+ Endo ((pgRenderSyntaxScript (fromPgCommand command) <> ";\n"):)++-- | Write the migration given by the 'Db.MigrationSteps' to a file.+writeMigrationScript :: FilePath -> Db.MigrationSteps PgCommandSyntax () 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 pg) = pg++pgDataTypeFromAtt :: ByteString -> Pg.Oid -> Maybe Int32 -> 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+ -- 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.numeric == oid =+ let precAndDecimal =+ case pgMod of+ Nothing -> Nothing+ Just pgMod' ->+ 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))++-- * Create constraints from a connection++getDbConstraints :: Pg.Connection -> IO [ Db.SomeDatabasePredicate ]+getDbConstraints conn =+ do tbls <- Pg.query_ conn "SELECT oid, relname FROM pg_catalog.pg_class where relnamespace=(select oid from pg_catalog.pg_namespace where nspname='public') and relkind='r'"+ let tblsExist = map (\(_, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate tbl)) tbls++ 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"+ (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+ notNullChecks = concatMap (\(nm, _, _, isNotNull, _) ->+ if isNotNull then+ [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint tbl nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing)+ :: Db.TableColumnHasConstraint PgColumnSchemaSyntax)]+ else [] ) columns++ pure (columnChecks ++ notNullChecks)++ primaryKeys <-+ map (\(relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey 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)"+ , "JOIN pg_attribute a ON a.attnum=k.attid AND a.attrelid=i.indrelid"+ , "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)++-- * Postgres-specific data types++-- | 'Db.DataType' for @tsquery@. See 'TsQuery' for more information+tsquery :: Db.DataType PgDataTypeSyntax TsQuery+tsquery = Db.DataType pgTsQueryType++-- | 'Db.DataType' for @tsvector@. See 'TsVector' for more information+tsvector :: Db.DataType PgDataTypeSyntax 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 pgTextType++-- | 'Db.DataType' for Postgres @BYTEA@. 'binaryLargeObject' is also mapped to+-- this data type+bytea :: Db.DataType PgDataTypeSyntax 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)+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 = Db.DataType pgJsonType++-- | 'Db.DataType' for @JSONB@. See 'PgJSON' for more information+jsonb :: (ToJSON a, FromJSON a) => Db.DataType PgDataTypeSyntax (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 pgUuidType++-- | 'Db.DataType' for @MONEY@ columns.+money :: Db.DataType PgDataTypeSyntax PgMoney+money = Db.DataType pgMoneyType++-- * 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 = 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+ field' _ _ nm ty _ collation constraints PgHasDefault =+ Db.field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints++instance IsBeamSerialColumnSchemaSyntax PgColumnSchemaSyntax where+ genericSerial nm = Db.field nm serial PgHasDefault
+ Database/Beam/Postgres/PgCrypto.hs view
@@ -0,0 +1,178 @@+-- | The @pgcrypto@ extension provides several cryptographic functions to+-- Postgres. This module provides a @beam-postgres@ extension to access this+-- functionality. For an example of usage, see the documentation for+-- 'PgExtensionEntity'.+module Database.Beam.Postgres.PgCrypto+ ( PgCrypto(..) ) where++import Database.Beam+import Database.Beam.Backend.SQL++import Database.Beam.Postgres.Syntax+import Database.Beam.Postgres.Extensions++import Data.Text (Text)+import Data.ByteString (ByteString)+import Data.Vector (Vector)+import Data.UUID (UUID)++type PgExpr ctxt s = QGenExpr ctxt PgExpressionSyntax s++type family LiftPg ctxt s fn where+ LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b+ LiftPg ctxt s (a -> b) = PgExpr ctxt s a -> LiftPg ctxt s b+ LiftPg ctxt s a = PgExpr ctxt s a++-- | Data type representing definitions contained in the @pgcrypto@ extension+--+-- Each field maps closely to the underlying @pgcrypto@ function, which are+-- described in further detail in the+-- <https://www.postgresql.org/docs/current/static/pgcrypto.html pgcrypto manual>.+data PgCrypto+ = PgCrypto+ { pgCryptoDigestText ::+ forall ctxt s. LiftPg ctxt s (Text -> Text -> ByteString)+ , pgCryptoDigestBytes ::+ forall ctxt s. LiftPg ctxt s (ByteString -> Text -> ByteString)+ , pgCryptoHmacText ::+ forall ctxt s. LiftPg ctxt s (Text -> Text -> Text -> ByteString)+ , pgCryptoHmacBytes ::+ forall ctxt s. LiftPg ctxt s (ByteString -> Text -> Text -> ByteString)+ , pgCryptoCrypt ::+ forall ctxt s. LiftPg ctxt s (Text -> Text -> Text)+ , pgCryptoGenSalt ::+ forall ctxt s. LiftPg ctxt s (Text -> Maybe Int -> Text)++ -- Pgp functions+ , pgCryptoPgpSymEncrypt ::+ forall ctxt s. LiftPg ctxt s (Text -> Text -> Maybe Text -> ByteString)+ , pgCryptoPgpSymEncryptBytea ::+ forall ctxt s. LiftPg ctxt s (ByteString -> Text -> Maybe Text -> ByteString)++ , pgCryptoPgpSymDecrypt ::+ forall ctxt s. LiftPg ctxt s (ByteString -> Text -> Maybe Text -> Text)+ , pgCryptoPgpSymDecryptBytea ::+ forall ctxt s. LiftPg ctxt s (ByteString -> Text -> Maybe Text -> ByteString)++ , pgCryptoPgpPubEncrypt ::+ forall ctxt s. LiftPg ctxt s (Text -> ByteString -> Maybe Text -> ByteString)+ , pgCryptoPgpPubEncryptBytea ::+ forall ctxt s. LiftPg ctxt s (ByteString -> ByteString -> Maybe Text -> ByteString)++ , pgCryptoPgpPubDecrypt ::+ forall ctxt s. LiftPg ctxt s (ByteString -> ByteString -> Maybe Text -> Maybe Text -> Text)+ , pgCryptoPgpPubDecryptBytea ::+ forall ctxt s. LiftPg ctxt s (ByteString -> ByteString -> Maybe Text -> Maybe Text -> ByteString)++ , pgCryptoPgpKeyId ::+ forall ctxt s. LiftPg ctxt s (ByteString -> Text)++ , pgCryptoArmor ::+ forall ctxt s. PgExpr ctxt s ByteString ->+ Maybe (PgExpr ctxt s (Vector Text), PgExpr ctxt s (Vector Text)) ->+ PgExpr ctxt s Text+ , pgCryptoDearmor ::+ forall ctxt s. LiftPg ctxt s (Text -> ByteString)++-- TODO setof+-- , pgCryptoPgpArmorHeaders ::+-- forall ctxt s. LiftPg ctxt s (Text -> )++ , pgCryptoGenRandomBytes ::+ forall ctxt s i. Integral i => PgExpr ctxt s i -> PgExpr ctxt s ByteString+ , pgCryptoGenRandomUUID ::+ forall ctxt s. PgExpr ctxt s UUID+ }++funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr+funcE nm args = functionCallE (fieldE (unqualifiedField nm)) args++instance IsPgExtension PgCrypto where+ pgExtensionName _ = "pgcrypto"+ pgExtensionBuild = PgCrypto {+ pgCryptoDigestText =+ \(QExpr data_) (QExpr type_) -> QExpr (funcE "digest" <$> sequenceA [data_, type_]),+ pgCryptoDigestBytes =+ \(QExpr data_) (QExpr type_) -> QExpr (funcE "digest" <$> sequenceA [data_, type_]),+ pgCryptoHmacText =+ \(QExpr data_) (QExpr key) (QExpr type_) -> QExpr (funcE "hmac" <$> sequenceA [data_, key, type_]),+ pgCryptoHmacBytes =+ \(QExpr data_) (QExpr key) (QExpr type_) -> QExpr (funcE "hmac" <$> sequenceA [data_, key, type_]),++ pgCryptoCrypt =+ \(QExpr pw) (QExpr salt) ->+ QExpr (funcE "crypt" <$> sequenceA [pw, salt]),+ pgCryptoGenSalt =+ \(QExpr text) iterCount ->+ QExpr (funcE "gen_salt" <$> sequenceA ([text] ++ maybe [] (\(QExpr iterCount') -> [iterCount']) iterCount)),++ pgCryptoPgpSymEncrypt =+ \(QExpr data_) (QExpr pw) options ->+ QExpr (funcE "pgp_sym_encrypt" <$> sequenceA ([data_, pw] ++ maybe [] (\(QExpr options') -> [options']) options)),+ pgCryptoPgpSymEncryptBytea =+ \(QExpr data_) (QExpr pw) options ->+ QExpr (funcE "pgp_sym_encrypt_bytea" <$> sequenceA ([data_, pw] ++ maybe [] (\(QExpr options') -> [options']) options)),++ pgCryptoPgpSymDecrypt =+ \(QExpr data_) (QExpr pw) options ->+ QExpr+ (funcE "pgp_sym_decrypt" <$> sequenceA ([data_, pw] ++ maybe [] (\(QExpr options') -> [options']) options)),+ pgCryptoPgpSymDecryptBytea =+ \(QExpr data_) (QExpr pw) options ->+ QExpr+ (funcE "pgp_sym_decrypt_bytea" <$> sequenceA ([data_, pw] ++ maybe [] (\(QExpr options') -> [options']) options)),++ pgCryptoPgpPubEncrypt =+ \(QExpr data_) (QExpr key) options ->+ QExpr+ (funcE "pgp_pub_encrypt" <$> sequenceA ([data_, key] ++ maybe [] (\(QExpr options') -> [options']) options)),+ pgCryptoPgpPubEncryptBytea =+ \(QExpr data_) (QExpr key) options ->+ QExpr+ (funcE "pgp_pub_encrypt_bytea" <$> sequenceA ([data_, key] ++ maybe [] (\(QExpr options') -> [options']) options)),++ pgCryptoPgpPubDecrypt =+ \(QExpr msg) (QExpr key) pw options ->+ QExpr+ (funcE "pgp_pub_decrypt" <$>+ sequenceA+ ( [msg, key] +++ case (pw, options) of+ (Nothing, Nothing) -> []+ (Just (QExpr pw'), Nothing) -> [pw']+ (Nothing, Just (QExpr options')) -> [ \_ -> valueE (sqlValueSyntax ("" :: String))+ , options' ]+ (Just (QExpr pw'), Just (QExpr options')) -> [pw', options'] )),+ pgCryptoPgpPubDecryptBytea =+ \(QExpr msg) (QExpr key) pw options ->+ QExpr $+ (funcE "pgp_pub_decrypt_bytea" <$>+ sequenceA+ ( [msg, key] +++ case (pw, options) of+ (Nothing, Nothing) -> []+ (Just (QExpr pw'), Nothing) -> [pw']+ (Nothing, Just (QExpr options')) -> [ \_ -> valueE (sqlValueSyntax ("" :: String))+ , options' ]+ (Just (QExpr pw'), Just (QExpr options')) -> [pw', options'] )),++ pgCryptoPgpKeyId =+ \(QExpr data_) -> QExpr (funcE "pgp_key_id" <$> sequenceA [data_]),++ pgCryptoArmor =+ \(QExpr data_) keysData ->+ QExpr (funcE "armor" <$> sequenceA+ ([data_] +++ case keysData of+ Nothing -> []+ Just (QExpr keys, QExpr values) ->+ [keys, values])),+ pgCryptoDearmor =+ \(QExpr data_) -> QExpr (funcE "dearmor" <$> sequenceA [data_]),++ pgCryptoGenRandomBytes =+ \(QExpr count) ->+ QExpr (funcE "gen_random_bytes" <$> sequenceA [count]),+ pgCryptoGenRandomUUID =+ QExpr (\_ -> funcE "gen_random_uuid" [])+ }
+ Database/Beam/Postgres/PgSpecific.hs view
@@ -0,0 +1,1017 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PolyKinds #-}++-- | Postgres-specific types, functions, and operators+module Database.Beam.Postgres.PgSpecific+ ( -- ** Full-text search+ -- $full-text-search++ -- *** @TSVECTOR@ data type+ TsVectorConfig, TsVector(..)+ , toTsVector, english++ -- *** @TSQUERY@ data type+ , TsQuery(..), (@@)++ -- ** @JSON@ and @JSONB@ data types+ -- $json+ , PgJSON(..), PgJSONB(..)+ , IsPgJSON(..)+ , PgJSONEach(..), PgJSONKey(..), PgJSONElement(..)++ , (@>), (<@), (->#), (->$)+ , (->>#), (->>$), (#>), (#>>)+ , (?), (?|), (?&)++ , withoutKey, withoutIdx+ , withoutKeys++ , pgJsonArrayLength+ , pgJsonbUpdate, pgJsonbSet+ , pgJsonbPretty++ -- ** @MONEY@ data type+ , PgMoney(..), pgMoney++ , pgScaleMoney_+ , pgDivideMoney_, pgDivideMoneys_++ , pgAddMoney_, pgSubtractMoney_+ , pgSumMoneyOver_, pgAvgMoneyOver_+ , pgSumMoney_, pgAvgMoney_++ -- ** Set-valued functions+ -- $set-valued-funs+ , PgSetOf, pgUnnest+ , pgUnnestArray, pgUnnestArrayWithOrdinality++ -- ** @ARRAY@ types+ -- $arrays+ , PgArrayValueContext, PgIsArrayContext++ -- *** Building @ARRAY@s+ , array_, arrayOf_, (++.)+ , pgArrayAgg, pgArrayAggOver++ -- *** Array operators and functions+ , (!.), arrayDims_+ , arrayUpper_, arrayLower_+ , arrayUpperUnsafe_, arrayLowerUnsafe_+ , arrayLength_, arrayLengthUnsafe_++ , isSupersetOf_, isSubsetOf_++ -- ** Postgres functions and aggregates+ , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver++ , pgNubBy_++ , now_, ilike_+ )+where++import Database.Beam+import Database.Beam.Backend.SQL+import Database.Beam.Migrate ( HasDefaultSqlDataType(..)+ , HasDefaultSqlDataTypeConstraints(..) )+import Database.Beam.Postgres.Syntax+import Database.Beam.Postgres.Types+import Database.Beam.Query.Internal+import Database.Beam.Schema.Tables++import Control.Monad.Free+import Control.Monad.State.Strict (evalState, put, get)++import Data.Aeson+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 Data.Monoid+import Data.Proxy+import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed))+import Data.String+import qualified Data.Text as T+import Data.Time (LocalTime)+import Data.Type.Bool+import qualified Data.Vector as V++import qualified Database.PostgreSQL.Simple.FromField as Pg+import qualified Database.PostgreSQL.Simple.ToField as Pg+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg++import GHC.TypeLits+import GHC.Exts hiding (toList)++-- ** Postgres-specific functions++-- | Postgres @NOW()@ function. Returns the server's timestamp+now_ :: QExpr PgExpressionSyntax 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_ (QExpr a) (QExpr b) = QExpr (pgBinOp "ILIKE" <$> a <*> b)++-- ** TsVector type++-- | The type of a document preprocessed for full-text search. The contained+-- 'ByteString' is the Postgres representation of the @TSVECTOR@ type. Use+-- 'toTsVector' to construct these on-the-fly from strings.+--+-- When this field is embedded in a beam table, 'defaultMigratableDbSettings'+-- will give the column the postgres @TSVECTOR@ type.+newtype TsVector = TsVector ByteString+ deriving (Show, Eq, Ord)++-- | The identifier of a Postgres text search configuration.+--+-- Use the 'IsString' instance to construct new values of this type+newtype TsVectorConfig = TsVectorConfig ByteString+ deriving (Show, Eq, Ord, IsString)++instance Pg.FromField TsVector where+ fromField field d =+ if Pg.typeOid field /= Pg.typoid pgTsVectorTypeInfo+ then Pg.returnError Pg.Incompatible field ""+ else case d of+ Just d' -> pure (TsVector d')+ Nothing -> Pg.returnError Pg.UnexpectedNull field ""++instance Pg.ToField TsVector where+ toField (TsVector d) =+ Pg.Many [ Pg.Plain "($$"+ , Pg.Plain (byteString d)+ , Pg.Plain "$$::tsvector)" ]++instance FromBackendRow Postgres TsVector++instance HasSqlEqualityCheck PgExpressionSyntax TsVectorConfig+instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsVectorConfig++instance HasSqlEqualityCheck PgExpressionSyntax TsVector+instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsVector++-- | A full-text search configuration with sensible defaults for english+english :: TsVectorConfig+english = TsVectorConfig "english"++-- | 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 Nothing (QExpr x) =+ QExpr (fmap (\(PgExpressionSyntax x') ->+ PgExpressionSyntax $+ emit "to_tsquery(" <> x' <> emit ")") x)+toTsVector (Just (TsVectorConfig configNm)) (QExpr x) =+ QExpr (fmap (\(PgExpressionSyntax x') -> PgExpressionSyntax $+ emit "to_tsquery('" <> escapeString configNm <> emit "', " <> x' <> emit ")") x)++-- | Determine if the given @TSQUERY@ matches the document represented by the+-- @TSVECTOR@. Behaves exactly like the similarly-named operator in postgres.+(@@) :: QGenExpr context PgExpressionSyntax s TsVector+ -> QGenExpr context PgExpressionSyntax s TsQuery+ -> QGenExpr context PgExpressionSyntax s Bool+QExpr vec @@ QExpr q =+ QExpr (pgBinOp "@@" <$> vec <*> q)++-- ** TsQuery type++-- | A query that can be run against a document contained in a 'TsVector'.+--+-- When this field is embedded in a beam table, 'defaultMigratableDbSettings'+-- will give the column the postgres @TSVECTOR@ type+newtype TsQuery = TsQuery ByteString+ deriving (Show, Eq, Ord)++instance HasSqlEqualityCheck PgExpressionSyntax TsQuery+instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsQuery++instance Pg.FromField TsQuery where+ fromField field d =+ if Pg.typeOid field /= Pg.typoid pgTsQueryTypeInfo+ then Pg.returnError Pg.Incompatible field ""+ else case d of+ Just d' -> pure (TsQuery d')+ Nothing -> Pg.returnError Pg.UnexpectedNull field ""++instance FromBackendRow Postgres TsQuery++-- ** Array operators++-- TODO this should be robust to slices++-- | Index into the given array. This translates to the @<array>[<index>]@+-- 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+QExpr v !. QExpr ix =+ QExpr (index <$> v <*> ix)+ where+ index (PgExpressionSyntax v') (PgExpressionSyntax ix') =+ PgExpressionSyntax (emit "(" <> v' <> emit ")[" <> ix' <> emit "]")++-- | 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_ (QExpr v) = QExpr (fmap (\(PgExpressionSyntax v') -> PgExpressionSyntax (emit "array_dims(" <> v' <> emit ")")) v)++type family CountDims (v :: *) :: Nat where+ CountDims (V.Vector a) = 1 + CountDims a+ CountDims a = 0+type family WithinBounds (dim :: Nat) (v :: *) :: Constraint where+ WithinBounds dim v =+ If ((dim <=? CountDims v) && (1 <=? dim))+ (() :: Constraint)+ (TypeError ( ('Text "Dimension " ':<>: 'ShowType dim ':<>: 'Text " is out of bounds.") ':$$:+ ('Text "The type " ':<>: 'ShowType v ':<>: 'Text " has " ':<>: 'ShowType (CountDims v) ':<>: 'Text " dimension(s).") ':$$:+ ('Text "Hint: The dimension should be a natural between 1 and " ':<>: 'ShowType (CountDims v)) ))++-- | Return the upper or lower bound of the given array at the given dimension+-- (statically supplied as a type application on a 'GHC.TypeLits.Nat'). Note+-- that beam will attempt to statically determine if the dimension is in range.+-- GHC errors will be thrown if this cannot be proved.+--+-- For example, to get the upper bound of the 2nd-dimension of an array:+--+-- @+-- arrayUpper_ @2 vectorValuedExpression+-- @+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+arrayUpper_ v =+ unsafeRetype (arrayUpperUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context PgExpressionSyntax s (Maybe Integer))+arrayLower_ v =+ unsafeRetype (arrayLowerUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context PgExpressionSyntax 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+-- unsafe because they may cause query processing to fail at runtime, even if+-- 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)+arrayUpperUnsafe_ (QExpr v) (QExpr dim) =+ QExpr (fmap (PgExpressionSyntax . mconcat) . sequenceA $+ [ pure (emit "array_upper(")+ , fromPgExpression <$> v+ , pure (emit ", ")+ , fromPgExpression <$> dim+ , pure (emit ")") ])+arrayLowerUnsafe_ (QExpr v) (QExpr dim) =+ QExpr (fmap (PgExpressionSyntax . mconcat) . sequenceA $+ [ pure (emit "array_lower(")+ , fromPgExpression <$> v+ , pure (emit ", ")+ , fromPgExpression <$> dim+ , pure (emit ")") ])++-- | Get the size of the array at the given (statically known) dimension,+-- provided as a type-level 'Nat'. Like the 'arrayUpper_' and 'arrayLower_'+-- functions,throws a compile-time error if the dimension is out of bounds.+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+arrayLength_ v =+ unsafeRetype (arrayLengthUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr ctxt PgExpressionSyntax 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)+arrayLengthUnsafe_ (QExpr a) (QExpr dim) =+ QExpr $ fmap (PgExpressionSyntax . mconcat) $ sequenceA $+ [ pure (emit "array_length(")+ , fromPgExpression <$> a+ , pure (emit ", ")+ , fromPgExpression <$> dim+ , pure (emit ")") ]++-- | 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_ (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_ (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)+QExpr a ++. QExpr b =+ QExpr (pgBinOp "||" <$> a <*> b)++-- ** Array expressions++-- | An expression context that determines which types of expressions can be put+-- inside an array element. Any scalar, aggregate, or window expression can be+-- placed within an array.+data PgArrayValueContext++-- | If you are extending beam-postgres and provide another expression context+-- that can be represented in an array, provide an empty instance of this class.+class PgIsArrayContext ctxt where+ mkArraySyntax :: Proxy ctxt -> PgSyntax -> PgSyntax+ mkArraySyntax _ s = emit "ARRAY" <> s+instance PgIsArrayContext PgArrayValueContext where+ mkArraySyntax _ = id+instance PgIsArrayContext QValueContext+instance PgIsArrayContext QAggregateContext+instance PgIsArrayContext QWindowingContext++-- | Build a 1-dimensional postgres array from an arbitrary 'Foldable'+-- containing expressions.+array_ :: forall context f s a.+ (PgIsArrayContext context, Foldable f)+ => f (QGenExpr PgArrayValueContext PgExpressionSyntax s a)+ -> QGenExpr context PgExpressionSyntax s (V.Vector a)+array_ vs =+ QExpr $ fmap (PgExpressionSyntax . mkArraySyntax (Proxy @context) . mconcat) $+ sequenceA [ pure (emit "[")+ , pgSepBy (emit ", ") <$> mapM (\(QExpr e) -> fromPgExpression <$> e) (toList vs)+ , 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 =+ let QExpr sub = subquery_ q+ in QExpr (\t -> let PgExpressionSyntax sub' = sub t+ in PgExpressionSyntax (emit "ARRAY(" <> sub' <> emit ")"))++-- ** JSON++-- | The Postgres @JSON@ type, which stores textual values that represent JSON+-- objects. The type parameter indicates the Haskell type which the JSON+-- encodes. This type must be a member of 'FromJSON' and 'ToJSON' in order for+-- deserialization and serialization to work as expected.+--+-- The 'defaultMigratableDbSettings' function automatically assigns the postgres+-- @JSON@ type to fields with this type.+newtype PgJSON a = PgJSON a+ deriving ( Show, Eq, Ord, Hashable, Monoid )++instance HasSqlEqualityCheck PgExpressionSyntax (PgJSON a)+instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSON a)++instance (Typeable x, FromJSON x) => Pg.FromField (PgJSON x) where+ fromField field d =+ if Pg.typeOid field /= Pg.typoid Pg.json+ then Pg.returnError Pg.Incompatible field ""+ else case decodeStrict =<< d of+ Just d' -> pure (PgJSON d')+ Nothing -> Pg.returnError Pg.UnexpectedNull field ""++instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSON a)+instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSON a) where+ sqlValueSyntax (PgJSON a) =+ PgValueSyntax $+ emit "'" <> escapeString (BL.toStrict (encode a)) <> emit "'::json"++-- | The Postgres @JSONB@ type, which stores JSON-encoded data in a+-- postgres-specific binary format. Like 'PgJSON', the type parameter indicates+-- the Hgaskell type which the JSON encodes.+--+-- Fields with this type are automatically given the Postgres @JSONB@ type+newtype PgJSONB a = PgJSONB a+ deriving ( Show, Eq, Ord, Hashable, Monoid )++instance HasSqlEqualityCheck PgExpressionSyntax (PgJSONB a)+instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSONB a)++instance (Typeable x, FromJSON x) => Pg.FromField (PgJSONB x) where+ fromField field d =+ if Pg.typeOid field /= Pg.typoid Pg.jsonb+ then Pg.returnError Pg.Incompatible field ""+ else case decodeStrict =<< d of+ Just d' -> pure (PgJSONB d')+ Nothing -> Pg.returnError Pg.UnexpectedNull field ""++instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSONB a)+instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSONB a) where+ sqlValueSyntax (PgJSONB a) =+ PgValueSyntax $+ emit "'" <> escapeString (BL.toStrict (encode a)) <> emit "'::jsonb"++-- | Key-value pair, used as output of 'pgJsonEachText' and 'pgJsonEach'+data PgJSONEach valType f+ = PgJSONEach+ { pgJsonEachKey :: C f T.Text+ , pgJsonEachValue :: C f valType+ } deriving Generic+instance Beamable (PgJSONEach valType)++-- | Output row of 'pgJsonKeys'+data PgJSONKey f = PgJSONKey { pgJsonKey :: C f T.Text }+ deriving Generic+instance Beamable PgJSONKey++-- | Output row of 'pgJsonArrayElements' and 'pgJsonArrayElementsText'+data PgJSONElement a f = PgJSONElement { pgJsonElement :: C f a }+ deriving Generic+instance Beamable (PgJSONElement a)++-- | Postgres provides separate @json_@ and @jsonb_@ functions. However, we know+-- what we're dealing with based on the type of data, so we can be less obtuse.+--+-- For more information on how these functions behave, see the Postgres manual+-- section on+-- <https://www.postgresql.org/docs/current/static/functions-json.html JSON>.+--+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)))++ -- | Like 'pgJsonEach', but returning text values instead+ pgJsonEachText :: QGenExpr ctxt PgExpressionSyntax s (json a)+ -> QGenExpr ctxt PgExpressionSyntax 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)++ -- | 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)))++ -- | Like 'pgJsonArrayElements', but returning the values as 'T.Text'+ pgJsonArrayElementsText :: QGenExpr ctxt PgExpressionSyntax s (json a)+ -> QGenExpr ctxt PgExpressionSyntax 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++ -- | The @json_strip_nulls@ or @jsonb_strip_nulls@ function.+ pgJsonStripNulls :: QGenExpr ctxt PgExpressionSyntax s (json a) -> QGenExpr ctxt PgExpressionSyntax s (json b)++ -- | The @json_agg@ or @jsonb_agg@ aggregate.+ pgJsonAgg :: QExpr PgExpressionSyntax s a -> QAgg PgExpressionSyntax 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)++instance IsPgJSON PgJSON where+ pgJsonEach (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_each") . pgParens . fromPgExpression) a++ pgJsonEachText (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_each_text") . pgParens . fromPgExpression) a++ pgJsonKeys (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_object_keys") . pgParens . fromPgExpression) a++ pgJsonArrayElements (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_array_elements") . pgParens . fromPgExpression) a++ pgJsonArrayElementsText (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_array_elements_text") . pgParens . fromPgExpression) a++ pgJsonTypeOf (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_typeof") . pgParens . fromPgExpression) a++ pgJsonStripNulls (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_strip_nulls") . pgParens . fromPgExpression) a++ pgJsonAgg (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_agg") . pgParens . fromPgExpression) a++ pgJsonObjectAgg (QExpr keys) (QExpr values) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_object_agg") . pgParens . mconcat) $+ sequenceA $ [ fromPgExpression <$> keys, pure (emit ", ")+ , fromPgExpression <$> values ]++instance IsPgJSON PgJSONB where+ pgJsonEach (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_each") . pgParens . fromPgExpression) a++ pgJsonEachText (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_each_text") . pgParens . fromPgExpression) a++ pgJsonKeys (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_object_keys") . pgParens . fromPgExpression) a++ pgJsonArrayElements (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_array_elements") . pgParens . fromPgExpression) a++ pgJsonArrayElementsText (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_array_elements_text") . pgParens . fromPgExpression) a++ pgJsonTypeOf (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_typeof") . pgParens . fromPgExpression) a++ pgJsonStripNulls (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_strip_nulls") . pgParens . fromPgExpression) a++ pgJsonAgg (QExpr a) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_agg") . pgParens . fromPgExpression) a++ pgJsonObjectAgg (QExpr keys) (QExpr values) =+ QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_object_agg") . pgParens . mconcat) $+ sequenceA $ [ fromPgExpression <$> keys, pure (emit ", ")+ , fromPgExpression <$> values ]++-- | Postgres @@>@ and @<@@ operators for JSON. Return true if the+-- 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+QExpr a @> QExpr b =+ QExpr (pgBinOp "@>" <$> a <*> b)+QExpr a <@ QExpr b =+ QExpr (pgBinOp "<@" <$> a <*> b)++-- | 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)+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)+QExpr a ->$ QExpr b =+ QExpr (pgBinOp "->" <$> a <*> b)++-- | Access a JSON array by index, returning the embedded object as a string.+-- 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+QExpr a ->># QExpr b =+ QExpr (pgBinOp "->>" <$> a <*> b)++-- | Access a JSON object by key, returning the embedded object as a string.+-- 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+QExpr a ->>$ QExpr b =+ QExpr (pgBinOp "->>" <$> a <*> b)++-- | Access a deeply nested JSON object. The first argument is the JSON object+-- to look within, the second is the path of keys from the first argument to the+-- target. Returns the result as a new json value. Note that the postgres+-- 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)+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+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+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+QExpr a ?| QExpr b =+ QExpr (pgBinOp "?|" <$> a <*> b)+QExpr a ?& QExpr b =+ QExpr (pgBinOp "?&" <$> a <*> b)++-- | Postgres @-@ operator on json objects. Returns the supplied json object+-- 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)+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)+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)+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 (QExpr a) =+ QExpr $ \tbl ->+ PgExpressionSyntax (emit "json_array_length(" <> fromPgExpression (a tbl) <> emit ")")++-- | The postgres @jsonb_set@ function. 'pgJsonUpdate' expects the value+-- specified by the path in the second argument to exist. If it does not, the+-- first argument is not modified. 'pgJsonbSet' will create any intermediate+-- 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)+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 ]+pgJsonbSet (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, pure (emit ", true") ]++-- | Postgres @jsonb_pretty@ function+pgJsonbPretty :: QGenExpr ctxt PgExpressionSyntax s (PgJSONB a)+ -> QGenExpr ctxt PgExpressionSyntax s T.Text+pgJsonbPretty (QExpr a) =+ QExpr (\tbl -> PgExpressionSyntax (emit "jsonb_pretty" <> pgParens (fromPgExpression (a tbl))))++-- ** Postgresql aggregates++-- | 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 = 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)+pgArrayAggOver quantifier (QExpr a) =+ QExpr $ \tbl ->+ PgExpressionSyntax $+ emit "array_agg" <>+ pgParens ( maybe mempty (\q -> fromPgAggregationSetQuantifier q <> emit " ") quantifier <>+ 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 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 a) =+ QExpr $ \tbl -> PgExpressionSyntax $+ emit "bool_and" <> pgParens (fromPgExpression (a tbl))++-- *** String aggregations++-- | 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 = 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+ => Maybe PgAggregationSetQuantifierSyntax+ -> QExpr PgExpressionSyntax s str+ -> QExpr PgExpressionSyntax s str+ -> QAgg PgExpressionSyntax s (Maybe str)+pgStringAggOver quantifier (QExpr v) (QExpr delim) =+ QExpr $ \tbl -> PgExpressionSyntax $+ emit "string_agg" <>+ pgParens ( maybe mempty (\q -> fromPgAggregationSetQuantifier q <> emit " ") quantifier <>+ fromPgExpression (v tbl) <> emit ", " <>+ fromPgExpression (delim tbl))++-- ** Postgresql SELECT DISTINCT ON++-- | 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 )+ => (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)++-- ** PostgreSql @MONEY@ data type++-- | Postgres @MONEY@ data type. A simple wrapper over 'ByteString', because+-- Postgres money format is locale-dependent, and we don't handle currency+-- symbol placement, digit grouping, or decimal separation.+--+-- The 'pgMoney' function can be used to convert a number to 'PgMoney'.+newtype PgMoney = PgMoney { fromPgMoney :: ByteString }+ deriving (Show, Read, Eq, Ord)++instance Pg.FromField PgMoney where+ fromField field Nothing = Pg.returnError Pg.UnexpectedNull field ""+ fromField field (Just d) =+ if Pg.typeOid field /= Pg.typoid Pg.money+ then Pg.returnError Pg.Incompatible field ""+ else pure (PgMoney d)+instance Pg.ToField PgMoney where+ toField (PgMoney a) = Pg.toField a++instance HasSqlEqualityCheck PgExpressionSyntax PgMoney+instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax PgMoney++instance FromBackendRow Postgres PgMoney+instance HasSqlValueSyntax PgValueSyntax PgMoney where+ sqlValueSyntax (PgMoney a) = sqlValueSyntax a++-- | Attempt to pack a floating point value as a 'PgMoney' value, paying no+-- attention to the locale-dependent currency symbol, digit grouping, or decimal+-- point. This will use the @.@ symbol as the decimal separator.+pgMoney :: Real a => a -> PgMoney+pgMoney val = PgMoney (BC.pack (formatScientific Fixed Nothing exactVal))+ where+ exactVal = fromRational (toRational val) :: Scientific++-- | 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+pgScaleMoney_ (QExpr scale) (QExpr v) =+ QExpr (pgBinOp "*" <$> scale <*> v)++-- | Divide a @MONEY@ value by a numeric value. Corresponds to Postgres @/@+-- where the numerator has type @MONEY@ and the denominator is a number. If you+-- 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+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+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+pgAddMoney_ (QExpr a) (QExpr b) =+ QExpr (pgBinOp "+" <$> a <*> b)+pgSubtractMoney_ (QExpr a) (QExpr b) =+ QExpr (pgBinOp "-" <$> a <*> b)++-- | The Postgres @MONEY@ type can be summed or averaged in an aggregation.+-- These functions provide the quantified aggregations. See 'pgSumMoney_' and+-- 'pgAvgMoney_' for the unquantified versions.+pgSumMoneyOver_, pgAvgMoneyOver_+ :: Maybe PgAggregationSetQuantifierSyntax+ -> QExpr PgExpressionSyntax s PgMoney -> QExpr PgExpressionSyntax 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_ = pgSumMoneyOver_ allInGroup_+pgAvgMoney_ = pgAvgMoneyOver_ allInGroup_++-- ** Set-valued functions++data PgSetOf (tbl :: (* -> *) -> *)++pgUnnest' :: forall tbl db s+ . Beamable tbl+ => (TablePrefix -> PgSyntax)+ -> Q PgSelectSyntax db s (QExprTable PgExpressionSyntax 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))+ ])+ tblFields+ (\_ -> Nothing) snd))+ where+ tblFields :: TableSettings tbl+ tblFields =+ evalState (zipBeamFieldsM (\_ _ ->+ do i <- get+ put (i + 1)+ pure (Columnar' (TableField (fromString ("r" ++ show i)))))+ tblSkeleton tblSkeleton) (0 :: Int)++pgUnnest :: forall tbl db s+ . Beamable tbl+ => QExpr PgExpressionSyntax s (PgSetOf tbl)+ -> Q PgSelectSyntax db s (QExprTable PgExpressionSyntax s tbl)+pgUnnest (QExpr q) =+ pgUnnest' (\t -> pgParens (fromPgExpression (q t)))++data PgUnnestArrayTbl a f = PgUnnestArrayTbl (C f a)+ deriving Generic+instance Beamable (PgUnnestArrayTbl a)++pgUnnestArray :: QExpr PgExpressionSyntax s (V.Vector a)+ -> Q PgSelectSyntax db s (QExpr PgExpressionSyntax s a)+pgUnnestArray (QExpr q) =+ fmap (\(PgUnnestArrayTbl x) -> x) $+ pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t)))++data PgUnnestArrayWithOrdinalityTbl a f = PgUnnestArrayWithOrdinalityTbl (C f Int) (C f a)+ 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 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 PgDataTypeSyntax TsVector where+ defaultSqlDataType _ _ = pgTsVectorType+instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax TsVector++instance HasDefaultSqlDataType PgDataTypeSyntax (PgJSON a) where+ defaultSqlDataType _ _ = pgJsonType+instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (PgJSON a)++instance HasDefaultSqlDataType PgDataTypeSyntax (PgJSONB a) where+ defaultSqlDataType _ _ = pgJsonbType+instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (PgJSONB a)++instance HasDefaultSqlDataType PgDataTypeSyntax PgMoney where+ defaultSqlDataType _ _ = pgMoneyType+instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax PgMoney++instance HasDefaultSqlDataType PgDataTypeSyntax a => HasDefaultSqlDataType PgDataTypeSyntax (V.Vector a) where+ defaultSqlDataType _ embedded = pgUnboundedArrayType (defaultSqlDataType (Proxy :: Proxy a) embedded)+instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (V.Vector a)++-- $full-text-search+--+-- Postgres has comprehensive, and thus complicated, support for full text+-- search. The types and functions in this section map closely to the underlying+-- Postgres API, which is described in the+-- <https://www.postgresql.org/docs/current/static/textsearch-intro.html documentation>.+--++-- $arrays+--+-- The functions and types in this section map Postgres @ARRAY@ types to+-- Haskell. An array is serialized and deserialized to a 'Data.Vector.Vector'+-- object. This type most closely matches the semantics of Postgres @ARRAY@s. In+-- general, the names of functions in this section closely match names of the+-- native Postgres functions they map to. As with most beam expression+-- functions, names are suffixed with an underscore and CamelCased.+--+-- Note that Postgres supports arbitrary nesting of vectors. For example, two,+-- three, or higher dimensional arrays can be expressed, manipulated, and stored+-- in tables. Beam fully supports this use case. A two-dimensional postgres+-- array is represented as @Vector (Vector a)@. Simply nest another 'Vector' for+-- higher dimensions. Some functions that return data on arrays expect a+-- dimension number as a parameter. Since beam can check the dimension at+-- compile time, these functions expect a type-level 'Nat' in the expression+-- DSL. The unsafe versions of these functions are also provided with the+-- @Unsafe_@ suffix. The safe versions are guaranteed not to fail at run-time+-- due to dimension mismatches, the unsafe ones may.+--+-- For more information on Postgres array support, refer to the postgres+-- <https://www.postgresql.org/docs/current/static/functions-array.html manual>.++-- $json+--+-- Postgres supports storing JSON in columns, as either a text-based type+-- (@JSON@) or a specialized binary encoding (@JSONB@). @beam-postgres@+-- accordingly provides the 'PgJSON' and 'PgJSONB' data types. Each of these+-- types takes a type parameter indicating the Haskell object represented by the+-- JSON object stored in the column. In order for serialization to work, be sure+-- to provide 'FromJSON' and 'ToJSON' instances for this type. If you do not+-- know the shape of the data stored, substitute 'Value' for this type+-- parameter.+--+-- For more information on Psotgres json support see the postgres+-- <https://www.postgresql.org/docs/current/static/functions-json.html manual>.+++-- $set-valued-funs+--+-- Postgres supports functions that returns /sets/. We can join directly against+-- these sets or arrays. @beam-postgres@ supports this feature via the+-- 'pgUnnest' and 'pgUnnestArray' functions.+--+-- Any function that returns a set can be typed as an expression returning+-- 'PgSetOf'. This polymorphic type takes one argument, which is a 'Beamable'+-- type that represents the shape of the data in the rows. For example, the+-- @json_each@ function returns a key and a value, so the corresponding+-- @beam-postgres@ function ('pgJsonEach') returns a value of type 'PgSetOf+-- (PgJSONEach Value)', which represents a set containing 'PgJSONEach'+-- rows. 'PgJSONEach' is a table with a column for keys ('pgJsonEachKey') and+-- one for values ('pgJsonEachValue').+--+-- Any 'PgSetOf' value can be introduced into the 'Q' monad using the 'pgUnnest'+-- function.+--+-- Postgres arrays (represented by the 'V.Vector' type) can also be joined+-- against using the 'pgUnnestArray' function. This directly corresponds to the+-- SQL @UNNEST@ keyword. Unlike sets, arrays have a sense of order. The+-- 'pgUnnestArrayWithOrdinality' function allows you to join against the+-- elements of an array along with its index. This corresponds to the+-- @UNNEST .. WITH ORDINALITY@ clause.+
+ Database/Beam/Postgres/Syntax.hs view
@@ -0,0 +1,1374 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-name-shadowing #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}++-- | Data types for Postgres syntax. Access is given mainly for extension+-- modules. The types and definitions here are likely to change.+module Database.Beam.Postgres.Syntax+ ( PgSyntaxF(..), PgSyntaxM+ , PgSyntax(..)++ , emit, emitBuilder, escapeString+ , escapeBytea, escapeIdentifier+ , pgParens++ , nextSyntaxStep++ , PgCommandSyntax(..), PgCommandType(..)+ , PgSelectSyntax(..), PgSelectSetQuantifierSyntax(..)+ , PgInsertSyntax(..)+ , PgDeleteSyntax(..)+ , PgUpdateSyntax(..)++ , PgExpressionSyntax(..), PgFromSyntax(..)+ , PgComparisonQuantifierSyntax(..)+ , PgExtractFieldSyntax(..)+ , PgProjectionSyntax(..), PgGroupingSyntax(..)+ , PgOrderingSyntax(..), PgValueSyntax(..)+ , PgTableSourceSyntax(..), PgFieldNameSyntax(..)+ , PgAggregationSetQuantifierSyntax(..)+ , PgInsertValuesSyntax(..), PgInsertOnConflictSyntax(..)+ , PgInsertOnConflictTargetSyntax(..), PgConflictActionSyntax(..)+ , PgCreateTableSyntax(..), PgTableOptionsSyntax(..), PgColumnSchemaSyntax(..)+ , PgDataTypeSyntax(..), PgColumnConstraintDefinitionSyntax(..), PgColumnConstraintSyntax(..)+ , PgTableConstraintSyntax(..), PgMatchTypeSyntax(..), PgReferentialActionSyntax(..)++ , PgAlterTableSyntax(..), PgAlterTableActionSyntax(..), PgAlterColumnActionSyntax(..)++ , PgWindowFrameSyntax(..), PgWindowFrameBoundsSyntax(..), PgWindowFrameBoundSyntax(..)++ , PgSelectLockingClauseSyntax(..)+ , PgSelectLockingStrength(..)+ , PgSelectLockingOptions(..)+ , fromPgSelectLockingClause+ , pgSelectStmt++ , PgDataTypeDescr(..)++ , pgCreateExtensionSyntax, pgDropExtensionSyntax++ , insertDefaults+ , pgSimpleMatchSyntax++ , pgSelectSetQuantifierDistinctOn++ , pgDataTypeJSON++ , pgTsQueryType, pgTsVectorType+ , pgJsonType, pgJsonbType, pgUuidType+ , pgMoneyType+ , pgTsQueryTypeInfo, pgTsVectorTypeInfo++ , pgByteaType, pgTextType, pgUnboundedArrayType+ , pgSerialType, pgSmallSerialType, pgBigSerialType++ , pgQuotedIdentifier, pgSepBy, pgDebugRenderSyntax+ , pgRenderSyntaxScript, pgBuildAction++ , pgBinOp, pgCompOp, pgUnOp, pgPostFix++ , pgTestSyntax++ , PostgresInaccessible ) where++import Database.Beam hiding (insert)+import Database.Beam.Backend.SQL+import Database.Beam.Query.SQL92++import Database.Beam.Migrate.SQL+import Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes)+import Database.Beam.Migrate.Serialization++import Database.Beam.Migrate.Generics++import Control.Monad.Free+import Control.Monad.Free.Church++import Data.Aeson (Value, object, (.=))+import Data.Bits+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder, byteString, char8, toLazyByteString)+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Lazy.Char8 (toStrict)+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Data.Coerce+import Data.Functor.Classes+import Data.Hashable+import Data.Int+import Data.Maybe+import Data.Monoid+import Data.Scientific (Scientific)+import Data.String (IsString(..), fromString)+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.UUID (UUID)+import qualified Data.Vector as V+import Data.Word++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.HStore as Pg (HStoreList, HStoreMap, HStoreBuilder)++data PostgresInaccessible++-- TODO This probably shouldn't be a free monad... oh well.+data PgSyntaxF f where+ EmitByteString :: ByteString -> f -> PgSyntaxF f+ EmitBuilder :: Builder -> f -> PgSyntaxF f++ EscapeString :: ByteString -> f -> PgSyntaxF f+ EscapeBytea :: ByteString -> f -> PgSyntaxF f+ EscapeIdentifier :: ByteString -> f -> PgSyntaxF f+deriving instance Functor PgSyntaxF++instance Eq1 PgSyntaxF where+ liftEq eq (EmitByteString b1 next1) (EmitByteString b2 next2) =+ b1 == b2 && next1 `eq` next2+ liftEq eq (EmitBuilder b1 next1) (EmitBuilder b2 next2) =+ toLazyByteString b1 == toLazyByteString b2 && next1 `eq` next2+ liftEq eq (EscapeString b1 next1) (EscapeString b2 next2) =+ b1 == b2 && next1 `eq` next2+ liftEq eq (EscapeBytea b1 next1) (EscapeBytea b2 next2) =+ b1 == b2 && next1 `eq` next2+ liftEq eq (EscapeIdentifier b1 next1) (EscapeIdentifier b2 next2) =+ b1 == b2 && next1 `eq` next2+ liftEq _ _ _ = False++instance Eq f => Eq (PgSyntaxF f) where+ (==) = eq1++instance Hashable PgSyntax where+ hashWithSalt salt (PgSyntax s) = runF s finish step salt+ where+ finish _ salt = hashWithSalt salt ()+ step (EmitByteString b hashRest) salt = hashRest (hashWithSalt salt (0 :: Int, b))+ step (EmitBuilder b hashRest) salt = hashRest (hashWithSalt salt (1 :: Int, toLazyByteString b))+ step (EscapeString b hashRest) salt = hashRest (hashWithSalt salt (2 :: Int, b))+ step (EscapeBytea b hashRest) salt = hashRest (hashWithSalt salt (3 :: Int, b))+ step (EscapeIdentifier b hashRest) salt = hashRest (hashWithSalt salt (4 :: Int, b))++instance Sql92DisplaySyntax PgSyntax where+ displaySyntax = BL.unpack . pgRenderSyntaxScript++type PgSyntaxM = F PgSyntaxF++-- | A piece of Postgres SQL syntax, which may contain embedded escaped byte and+-- text sequences. 'PgSyntax' composes monoidally, and may be created with+-- 'emit', 'emitBuilder', 'escapeString', 'escapBytea', and 'escapeIdentifier'.+newtype PgSyntax+ = PgSyntax { buildPgSyntax :: PgSyntaxM () }++instance Monoid PgSyntax where+ mempty = PgSyntax (pure ())+ mappend a b = PgSyntax (buildPgSyntax a >> buildPgSyntax b)++instance Eq PgSyntax where+ PgSyntax x == PgSyntax y = (fromF x :: Free PgSyntaxF ()) == fromF y++instance Show PgSyntax where+ showsPrec prec s =+ showParen (prec > 10) $+ showString "PgSyntax <" .+ shows (pgTestSyntax s) .+ showString ">"++emit :: ByteString -> PgSyntax+emit bs = PgSyntax (liftF (EmitByteString bs ()))++emitBuilder :: Builder -> PgSyntax+emitBuilder b = PgSyntax (liftF (EmitBuilder b ()))++escapeString, escapeBytea, escapeIdentifier :: ByteString -> PgSyntax+escapeString bs = PgSyntax (liftF (EscapeString bs ()))+escapeBytea bin = PgSyntax (liftF (EscapeBytea bin ()))+escapeIdentifier id = PgSyntax (liftF (EscapeIdentifier id ()))++nextSyntaxStep :: PgSyntaxF f -> f+nextSyntaxStep (EmitByteString _ next) = next+nextSyntaxStep (EmitBuilder _ next) = next+nextSyntaxStep (EscapeString _ next) = next+nextSyntaxStep (EscapeBytea _ next) = next+nextSyntaxStep (EscapeIdentifier _ next) = next++-- * Syntax types++data PgCommandType+ = PgCommandTypeQuery+ | PgCommandTypeDdl+ | PgCommandTypeDataUpdate+ | PgCommandTypeDataUpdateReturning+ deriving Show++-- | Representation of an arbitrary Postgres command. This is the combination of+-- the command syntax (repesented by 'PgSyntax'), as well as the type of command+-- (represented by 'PgCommandType'). The command type is necessary for us to+-- know how to retrieve results from the database.+data PgCommandSyntax+ = PgCommandSyntax+ { pgCommandType :: PgCommandType+ , fromPgCommand :: PgSyntax }++-- | 'IsSql92SelectSyntax' for Postgres+newtype PgSelectSyntax = PgSelectSyntax { fromPgSelect :: PgSyntax }+instance HasQBuilder PgSelectSyntax where+ buildSqlQuery = buildSql92Query' True++newtype PgSelectTableSyntax = PgSelectTableSyntax { fromPgSelectTable :: PgSyntax }++-- | 'IsSql92InsertSyntax' for Postgres+newtype PgInsertSyntax = PgInsertSyntax { fromPgInsert :: PgSyntax }++-- | 'IsSql92DeleteSyntax' for Postgres+newtype PgDeleteSyntax = PgDeleteSyntax { fromPgDelete :: PgSyntax }++-- | 'IsSql92UpdateSyntax' for Postgres+newtype PgUpdateSyntax = PgUpdateSyntax { fromPgUpdate :: PgSyntax }++newtype PgExpressionSyntax = PgExpressionSyntax { fromPgExpression :: PgSyntax } deriving Eq+newtype PgAggregationSetQuantifierSyntax = PgAggregationSetQuantifierSyntax { fromPgAggregationSetQuantifier :: PgSyntax }+newtype PgSelectSetQuantifierSyntax = PgSelectSetQuantifierSyntax { fromPgSelectSetQuantifier :: PgSyntax }+newtype PgFromSyntax = PgFromSyntax { fromPgFrom :: PgSyntax }+newtype PgComparisonQuantifierSyntax = PgComparisonQuantifierSyntax { fromPgComparisonQuantifier :: PgSyntax }+newtype PgExtractFieldSyntax = PgExtractFieldSyntax { fromPgExtractField :: PgSyntax }+newtype PgProjectionSyntax = PgProjectionSyntax { fromPgProjection :: PgSyntax }+newtype PgGroupingSyntax = PgGroupingSyntax { fromPgGrouping :: PgSyntax }+newtype PgValueSyntax = PgValueSyntax { fromPgValue :: PgSyntax }+newtype PgTableSourceSyntax = PgTableSourceSyntax { fromPgTableSource :: PgSyntax }+newtype PgFieldNameSyntax = PgFieldNameSyntax { fromPgFieldName :: PgSyntax }+newtype PgInsertValuesSyntax = PgInsertValuesSyntax { fromPgInsertValues :: PgSyntax }+newtype PgInsertOnConflictSyntax = PgInsertOnConflictSyntax { fromPgInsertOnConflict :: PgSyntax }+newtype PgInsertOnConflictTargetSyntax = PgInsertOnConflictTargetSyntax { fromPgInsertOnConflictTarget :: PgSyntax }+newtype PgInsertOnConflictUpdateSyntax = PgInsertOnConflictUpdateSyntax { fromPgInsertOnConflictUpdate :: PgSyntax }+newtype PgConflictActionSyntax = PgConflictActionSyntax { fromPgConflictAction :: PgSyntax }+data PgOrderingSyntax = PgOrderingSyntax { pgOrderingSyntax :: PgSyntax, pgOrderingNullOrdering :: Maybe PgNullOrdering }+data PgSelectLockingClauseSyntax = PgSelectLockingClauseSyntax { pgSelectLockingClauseStrength :: PgSelectLockingStrength+ , pgSelectLockingTables :: [T.Text]+ , pgSelectLockingClauseOptions :: Maybe PgSelectLockingOptions }++fromPgOrdering :: PgOrderingSyntax -> PgSyntax+fromPgOrdering (PgOrderingSyntax s Nothing) = s+fromPgOrdering (PgOrderingSyntax s (Just PgNullOrderingNullsFirst)) = s <> emit " NULLS FIRST"+fromPgOrdering (PgOrderingSyntax s (Just PgNullOrderingNullsLast)) = s <> emit " NULLS LAST"++data PgNullOrdering+ = PgNullOrderingNullsFirst+ | PgNullOrderingNullsLast+ deriving (Show, Eq, Generic)++fromPgSelectLockingClause :: PgSelectLockingClauseSyntax -> PgSyntax+fromPgSelectLockingClause s =+ emit " FOR " <>+ (case pgSelectLockingClauseStrength s of+ PgSelectLockingStrengthUpdate -> emit "UPDATE"+ PgSelectLockingStrengthNoKeyUpdate -> emit "NO KEY UPDATE"+ PgSelectLockingStrengthShare -> emit "SHARE"+ PgSelectLockingStrengthKeyShare -> emit "KEY SHARE") <>+ emitTables <>+ (maybe mempty emitOptions $ pgSelectLockingClauseOptions s)+ where+ emitTables = case pgSelectLockingTables s of+ [] -> mempty+ tableNames -> emit " OF " <> (pgSepBy (emit ", ") (map pgQuotedIdentifier tableNames))++ emitOptions PgSelectLockingOptionsNoWait = emit " NOWAIT"+ emitOptions PgSelectLockingOptionsSkipLocked = emit " SKIP LOCKED"++-- | Specifies the level of lock that will be taken against a row. See+-- <https://www.postgresql.org/docs/current/static/explicit-locking.html#LOCKING-ROWS the manual section>+-- for more information.+data PgSelectLockingStrength+ = PgSelectLockingStrengthUpdate+ -- ^ @UPDATE@+ | PgSelectLockingStrengthNoKeyUpdate+ -- ^ @NO KEY UPDATE@+ | PgSelectLockingStrengthShare+ -- ^ @SHARE@+ | PgSelectLockingStrengthKeyShare+ -- ^ @KEY SHARE@+ deriving (Show, Eq, Generic)++-- | Specifies how we should handle lock conflicts.+--+-- See+-- <https://www.postgresql.org/docs/9.5/static/sql-select.html#SQL-FOR-UPDATE-SHARE the manual section>+-- for more information+data PgSelectLockingOptions+ = PgSelectLockingOptionsNoWait+ -- ^ @NOWAIT@. Report an error rather than waiting for the lock+ | PgSelectLockingOptionsSkipLocked+ -- ^ @SKIP LOCKED@. Rather than wait for a lock, skip the row instead+ deriving (Show, Eq, Generic)++data PgDataTypeDescr+ = PgDataTypeDescrOid Pg.Oid (Maybe Int32)+ | PgDataTypeDescrDomain T.Text+ deriving (Show, Eq, Generic)+instance Hashable PgDataTypeDescr where+ hashWithSalt salt (PgDataTypeDescrOid (Pg.Oid oid) dim) =+ hashWithSalt salt (0 :: Int, fromIntegral oid :: Word32, dim)+ hashWithSalt salt (PgDataTypeDescrDomain t) =+ hashWithSalt salt (1 :: Int, t)++newtype PgCreateTableSyntax = PgCreateTableSyntax { fromPgCreateTable :: PgSyntax }+data PgTableOptionsSyntax = PgTableOptionsSyntax PgSyntax PgSyntax+newtype PgColumnSchemaSyntax = PgColumnSchemaSyntax { fromPgColumnSchema :: PgSyntax } deriving (Show, Eq)+instance Sql92DisplaySyntax PgColumnSchemaSyntax where+ displaySyntax = displaySyntax . fromPgColumnSchema++data PgDataTypeSyntax+ = PgDataTypeSyntax+ { pgDataTypeDescr :: PgDataTypeDescr+ , fromPgDataType :: PgSyntax+ , pgDataTypeSerialized :: BeamSerializedDataType+ } deriving Show+instance Sql92DisplaySyntax PgDataTypeSyntax where+ displaySyntax = displaySyntax . fromPgDataType++data PgColumnConstraintDefinitionSyntax+ = PgColumnConstraintDefinitionSyntax+ { fromPgColumnConstraintDefinition :: PgSyntax+ , pgColumnConstraintDefinitionSerialized :: BeamSerializedConstraintDefinition+ } deriving Show+instance Sql92DisplaySyntax PgColumnConstraintDefinitionSyntax where+ displaySyntax = displaySyntax . fromPgColumnConstraintDefinition++data PgColumnConstraintSyntax+ = PgColumnConstraintSyntax+ { fromPgColumnConstraint :: PgSyntax+ , pgColumnConstraintSerialized :: BeamSerializedConstraint+ }+newtype PgTableConstraintSyntax = PgTableConstraintSyntax { fromPgTableConstraint :: PgSyntax }+data PgMatchTypeSyntax+ = PgMatchTypeSyntax+ { fromPgMatchType :: PgSyntax+ , pgMatchTypeSerialized :: BeamSerializedMatchType+ }+data PgReferentialActionSyntax+ = PgReferentialActionSyntax+ { fromPgReferentialAction :: PgSyntax+ , pgReferentialActionSerialized :: BeamSerializedReferentialAction+ }+newtype PgDropTableSyntax = PgDropTableSyntax { fromPgDropTable :: PgSyntax }+newtype PgAlterTableSyntax = PgAlterTableSyntax { fromPgAlterTable :: PgSyntax }+newtype PgAlterTableActionSyntax = PgAlterTableActionSyntax { fromPgAlterTableAction :: PgSyntax }+newtype PgAlterColumnActionSyntax = PgAlterColumnActionSyntax { fromPgAlterColumnAction :: PgSyntax }+newtype PgWindowFrameSyntax = PgWindowFrameSyntax { fromPgWindowFrame :: PgSyntax }+newtype PgWindowFrameBoundsSyntax = PgWindowFrameBoundsSyntax { fromPgWindowFrameBounds :: PgSyntax }+newtype PgWindowFrameBoundSyntax = PgWindowFrameBoundSyntax { fromPgWindowFrameBound :: ByteString -> PgSyntax }++instance Hashable PgDataTypeSyntax where+ hashWithSalt salt (PgDataTypeSyntax a _ _) = hashWithSalt salt a+instance Eq PgDataTypeSyntax where+ PgDataTypeSyntax a _ _ == PgDataTypeSyntax b _ _ = a == b++instance Eq PgColumnConstraintDefinitionSyntax where+ PgColumnConstraintDefinitionSyntax a _ ==+ PgColumnConstraintDefinitionSyntax b _ =+ a == b++instance IsSql92Syntax PgCommandSyntax where+ type Sql92SelectSyntax PgCommandSyntax = PgSelectSyntax+ type Sql92InsertSyntax PgCommandSyntax = PgInsertSyntax+ type Sql92UpdateSyntax PgCommandSyntax = PgUpdateSyntax+ type Sql92DeleteSyntax PgCommandSyntax = PgDeleteSyntax++ selectCmd = PgCommandSyntax PgCommandTypeQuery . coerce+ insertCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce+ deleteCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce+ updateCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce++instance IsSql92DdlCommandSyntax PgCommandSyntax where+ type Sql92DdlCommandCreateTableSyntax PgCommandSyntax = PgCreateTableSyntax+ type Sql92DdlCommandDropTableSyntax PgCommandSyntax = PgDropTableSyntax+ type Sql92DdlCommandAlterTableSyntax PgCommandSyntax = PgAlterTableSyntax++ createTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce+ dropTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce+ alterTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce++instance IsSql92UpdateSyntax PgUpdateSyntax where+ type Sql92UpdateFieldNameSyntax PgUpdateSyntax = PgFieldNameSyntax+ type Sql92UpdateExpressionSyntax PgUpdateSyntax = PgExpressionSyntax++ updateStmt tbl fields where_ =+ PgUpdateSyntax $+ emit "UPDATE " <> pgQuotedIdentifier tbl <>+ (case fields of+ [] -> mempty+ fields ->+ emit " SET " <>+ pgSepBy (emit ", ") (map (\(field, val) -> fromPgFieldName field <> emit "=" <> fromPgExpression val) fields)) <>+ maybe mempty (\where_ -> emit " WHERE " <> fromPgExpression where_) where_++instance IsSql92DeleteSyntax PgDeleteSyntax where+ type Sql92DeleteExpressionSyntax PgDeleteSyntax = PgExpressionSyntax++ deleteStmt tbl where_ =+ PgDeleteSyntax $+ emit "DELETE FROM " <> pgQuotedIdentifier tbl <>+ maybe mempty (\where_ -> emit " WHERE " <> fromPgExpression where_) where_++instance IsSql92SelectSyntax PgSelectSyntax where+ type Sql92SelectSelectTableSyntax PgSelectSyntax = PgSelectTableSyntax+ type Sql92SelectOrderingSyntax PgSelectSyntax = PgOrderingSyntax++ selectStmt tbl ordering limit offset =+ pgSelectStmt tbl ordering limit offset Nothing++instance IsSql92SelectTableSyntax PgSelectTableSyntax where+ type Sql92SelectTableSelectSyntax PgSelectTableSyntax = PgSelectSyntax+ type Sql92SelectTableExpressionSyntax PgSelectTableSyntax = PgExpressionSyntax+ type Sql92SelectTableProjectionSyntax PgSelectTableSyntax = PgProjectionSyntax+ type Sql92SelectTableFromSyntax PgSelectTableSyntax = PgFromSyntax+ type Sql92SelectTableGroupingSyntax PgSelectTableSyntax = PgGroupingSyntax+ type Sql92SelectTableSetQuantifierSyntax PgSelectTableSyntax = PgSelectSetQuantifierSyntax++ selectTableStmt setQuantifier proj from where_ grouping having =+ PgSelectTableSyntax $+ emit "SELECT " <>+ maybe mempty (\setQuantifier' -> fromPgSelectSetQuantifier setQuantifier' <> emit " ") setQuantifier <>+ fromPgProjection proj <>+ (maybe mempty (emit " FROM " <> ) (coerce from)) <>+ (maybe mempty (emit " WHERE " <>) (coerce where_)) <>+ (maybe mempty (emit " GROUP BY " <>) (coerce grouping)) <>+ (maybe mempty (emit " HAVING " <>) (coerce having))++ unionTables all = pgTableOp (if all then "UNION ALL" else "UNION")+ intersectTables all = pgTableOp (if all then "INTERSECT ALL" else "INTERSECT")+ exceptTable all = pgTableOp (if all then "EXCEPT ALL" else "EXCEPT")++instance IsSql92GroupingSyntax PgGroupingSyntax where+ type Sql92GroupingExpressionSyntax PgGroupingSyntax = PgExpressionSyntax++ groupByExpressions es =+ PgGroupingSyntax $+ pgSepBy (emit ", ") (map fromPgExpression es)++instance IsSql92FromSyntax PgFromSyntax where+ type Sql92FromExpressionSyntax PgFromSyntax = PgExpressionSyntax+ type Sql92FromTableSourceSyntax PgFromSyntax = PgTableSourceSyntax++ fromTable tableSrc Nothing = coerce tableSrc+ fromTable tableSrc (Just nm) =+ PgFromSyntax $+ coerce tableSrc <> emit " AS " <> pgQuotedIdentifier nm++ innerJoin a b Nothing = PgFromSyntax (fromPgFrom a <> emit " CROSS JOIN " <> fromPgFrom b)+ innerJoin a b (Just e) = pgJoin "INNER JOIN" a b (Just e)++ leftJoin = pgJoin "LEFT JOIN"+ rightJoin = pgJoin "RIGHT JOIN"++instance IsSql92FromOuterJoinSyntax PgFromSyntax where+ outerJoin = pgJoin "FULL OUTER JOIN"++instance IsSql92OrderingSyntax PgOrderingSyntax where+ type Sql92OrderingExpressionSyntax PgOrderingSyntax = PgExpressionSyntax++ ascOrdering e = PgOrderingSyntax (fromPgExpression e <> emit " ASC") Nothing+ descOrdering e = PgOrderingSyntax (fromPgExpression e <> emit " DESC") Nothing++instance IsSql2003OrderingElementaryOLAPOperationsSyntax PgOrderingSyntax where+ nullsFirstOrdering o = o { pgOrderingNullOrdering = Just PgNullOrderingNullsFirst }+ nullsLastOrdering o = o { pgOrderingNullOrdering = Just PgNullOrderingNullsLast }++instance IsSql92DataTypeSyntax PgDataTypeSyntax where+ domainType nm = PgDataTypeSyntax (PgDataTypeDescrDomain nm) (pgQuotedIdentifier nm)+ (domainType nm)++ charType prec charSet = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bpchar) (fmap fromIntegral prec))+ (emit "CHAR" <> pgOptPrec prec <> pgOptCharSet charSet)+ (charType prec charSet)+ varCharType prec charSet = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.varchar) (fmap fromIntegral prec))+ (emit "VARCHAR" <> pgOptPrec prec <> pgOptCharSet charSet)+ (varCharType prec charSet)+ nationalCharType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bpchar) (fmap fromIntegral prec))+ (emit "NATIONAL CHAR" <> pgOptPrec prec)+ (nationalCharType prec)+ nationalVarCharType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.varchar) (fmap fromIntegral prec))+ (emit "NATIONAL CHARACTER VARYING" <> pgOptPrec prec)+ (nationalVarCharType prec)++ bitType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bit) (fmap fromIntegral prec))+ (emit "BIT" <> pgOptPrec prec)+ (bitType prec)+ varBitType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.varbit) (fmap fromIntegral prec))+ (emit "BIT VARYING" <> pgOptPrec prec)+ (varBitType prec)++ numericType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.numeric) (mkNumericPrec prec))+ (emit "NUMERIC" <> pgOptNumericPrec prec)+ (numericType prec)+ decimalType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.numeric) (mkNumericPrec prec))+ (emit "DOUBLE" <> pgOptNumericPrec prec)+ (decimalType prec)++ intType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int4) Nothing) (emit "INT") intType+ smallIntType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int2) Nothing) (emit "SMALLINT") smallIntType++ floatType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.float4) Nothing) (emit "FLOAT" <> pgOptPrec prec)+ (floatType prec)+ doubleType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.float8) Nothing) (emit "DOUBLE PRECISION") doubleType+ realType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.float4) Nothing) (emit "REAL") realType+ dateType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.date) Nothing) (emit "DATE") dateType+ timeType prec withTz = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.time) Nothing)+ (emit "TIME" <> pgOptPrec prec <> if withTz then emit " WITH TIME ZONE" else mempty)+ (timeType prec withTz)+ timestampType prec withTz = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid (if withTz then Pg.timestamptz else Pg.timestamp)) Nothing)+ (emit "TIMESTAMP" <> pgOptPrec prec <> if withTz then emit " WITH TIME ZONE" else mempty)+ (timestampType prec withTz)++instance IsSql99DataTypeSyntax PgDataTypeSyntax where+ characterLargeObjectType = pgTextType { pgDataTypeSerialized = characterLargeObjectType }+ binaryLargeObjectType = pgByteaType { pgDataTypeSerialized = binaryLargeObjectType }+ booleanType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bool) Nothing) (emit "BOOLEAN")+ booleanType+ arrayType (PgDataTypeSyntax _ syntax serialized) sz =+ PgDataTypeSyntax (error "TODO: array migrations")+ (syntax <> emit "[" <> emit (fromString (show sz)) <> emit "]")+ (arrayType serialized sz)+ rowType = error "rowType"++instance IsSql2008BigIntDataTypeSyntax PgDataTypeSyntax where+ bigIntType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGINT") bigIntType++instance Sql92SerializableDataTypeSyntax PgDataTypeSyntax where+ serializeDataType = fromBeamSerializedDataType . pgDataTypeSerialized++pgOptPrec :: Maybe Word -> PgSyntax+pgOptPrec Nothing = mempty+pgOptPrec (Just x) = emit "(" <> emit (fromString (show x)) <> emit ")"++pgOptCharSet :: Maybe T.Text -> PgSyntax+pgOptCharSet Nothing = mempty+pgOptCharSet (Just cs) = emit " CHARACTER SET " <> emit (TE.encodeUtf8 cs)++pgOptNumericPrec :: Maybe (Word, Maybe Word) -> PgSyntax+pgOptNumericPrec Nothing = mempty+pgOptNumericPrec (Just (prec, Nothing)) = pgOptPrec (Just prec)+pgOptNumericPrec (Just (prec, Just dec)) = emit "(" <> emit (fromString (show prec)) <> emit ", " <> emit (fromString (show dec)) <> emit ")"++pgDataTypeJSON :: Value -> BeamSerializedDataType+pgDataTypeJSON v = BeamSerializedDataType (beamSerializeJSON "postgres" v)++pgByteaType :: PgDataTypeSyntax+pgByteaType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.bytea) Nothing) (emit "BYTEA")+ (pgDataTypeJSON "bytea")++pgSmallSerialType, pgSerialType, pgBigSerialType :: PgDataTypeSyntax+pgSmallSerialType = PgDataTypeSyntax (pgDataTypeDescr smallIntType) (emit "SMALLSERIAL") (pgDataTypeJSON "smallserial")+pgSerialType = PgDataTypeSyntax (pgDataTypeDescr intType) (emit "SERIAL") (pgDataTypeJSON "serial")+pgBigSerialType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int8) Nothing) (emit "BIGSERIAL") (pgDataTypeJSON "bigserial")++pgUnboundedArrayType :: PgDataTypeSyntax -> PgDataTypeSyntax+pgUnboundedArrayType (PgDataTypeSyntax _ syntax serialized) =+ PgDataTypeSyntax (error "Can't do array migrations yet")+ (syntax <> emit "[]")+ (pgDataTypeJSON (object [ "unbounded-array" .= fromBeamSerializedDataType serialized ]))++pgTsQueryTypeInfo :: Pg.TypeInfo+pgTsQueryTypeInfo = Pg.Basic (Pg.Oid 3615) 'U' ',' "tsquery"++pgTsQueryType :: PgDataTypeSyntax+pgTsQueryType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid pgTsQueryTypeInfo) Nothing)+ (emit "TSQUERY") (pgDataTypeJSON "tsquery")++-- | Postgres TypeInfo for tsvector+-- TODO Is the Oid stable from postgres instance to postgres instance?+pgTsVectorTypeInfo :: Pg.TypeInfo+pgTsVectorTypeInfo = Pg.Basic (Pg.Oid 3614) 'U' ',' "tsvector"++pgTsVectorType :: PgDataTypeSyntax+pgTsVectorType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid pgTsVectorTypeInfo) Nothing)+ (emit "TSVECTOR")+ (pgDataTypeJSON "tsvector")++pgTextType :: PgDataTypeSyntax+pgTextType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.text) Nothing) (emit "TEXT")+ (pgDataTypeJSON "text")++pgJsonType, pgJsonbType :: PgDataTypeSyntax+pgJsonType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.json) Nothing) (emit "JSON") (pgDataTypeJSON "json")+pgJsonbType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.jsonb) Nothing) (emit "JSONB") (pgDataTypeJSON "jsonb")++pgUuidType :: PgDataTypeSyntax+pgUuidType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.uuid) Nothing) (emit "UUID") (pgDataTypeJSON "uuid")++pgMoneyType :: PgDataTypeSyntax+pgMoneyType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.money) Nothing) (emit "MONEY") (pgDataTypeJSON "money")++mkNumericPrec :: Maybe (Word, Maybe Word) -> Maybe Int32+mkNumericPrec Nothing = Nothing+mkNumericPrec (Just (whole, dec)) = Just $ (fromIntegral whole `shiftL` 16) .|. (fromIntegral (fromMaybe 0 dec) .&. 0xFFFF)++instance IsCustomSqlSyntax PgExpressionSyntax where+ newtype CustomSqlSyntax PgExpressionSyntax =+ PgCustomExpressionSyntax { fromPgCustomExpression :: PgSyntax }+ deriving Monoid+ customExprSyntax = PgExpressionSyntax . fromPgCustomExpression+ renderSyntax = PgCustomExpressionSyntax . pgParens . fromPgExpression++instance IsString (CustomSqlSyntax PgExpressionSyntax) where+ fromString = PgCustomExpressionSyntax . emit . fromString++instance IsSql92QuantifierSyntax PgComparisonQuantifierSyntax where+ quantifyOverAll = PgComparisonQuantifierSyntax (emit "ALL")+ quantifyOverAny = PgComparisonQuantifierSyntax (emit "ANY")++instance IsSql92ExpressionSyntax PgExpressionSyntax where+ type Sql92ExpressionValueSyntax PgExpressionSyntax = PgValueSyntax+ type Sql92ExpressionSelectSyntax PgExpressionSyntax = PgSelectSyntax+ type Sql92ExpressionFieldNameSyntax PgExpressionSyntax = PgFieldNameSyntax+ type Sql92ExpressionQuantifierSyntax PgExpressionSyntax = PgComparisonQuantifierSyntax+ type Sql92ExpressionCastTargetSyntax PgExpressionSyntax = PgDataTypeSyntax+ type Sql92ExpressionExtractFieldSyntax PgExpressionSyntax = PgExtractFieldSyntax++ addE = pgBinOp "+"+ subE = pgBinOp "-"+ mulE = pgBinOp "*"+ divE = pgBinOp "/"+ modE = pgBinOp "%"+ orE = pgBinOp "OR"+ andE = pgBinOp "AND"+ likeE = pgBinOp "LIKE"+ overlapsE = pgBinOp "OVERLAPS"+ eqE = pgCompOp "="+ neqE = pgCompOp "<>"+ eqMaybeE a b _ = pgBinOp "IS NOT DISTINCT FROM" a b+ neqMaybeE a b _ = pgBinOp "IS DISTINCT FROM" a b+ ltE = pgCompOp "<"+ gtE = pgCompOp ">"+ leE = pgCompOp "<="+ geE = pgCompOp ">="+ negateE = pgUnOp "-"+ notE = pgUnOp "NOT"+ existsE select = PgExpressionSyntax (emit "EXISTS (" <> fromPgSelect select <> emit ")")+ uniqueE select = PgExpressionSyntax (emit "UNIQUE (" <> fromPgSelect select <> emit ")")+ isNotNullE = pgPostFix "IS NOT NULL"+ isNullE = pgPostFix "IS NULL"+ isTrueE = pgPostFix "IS TRUE"+ isFalseE = pgPostFix "IS FALSE"+ isNotTrueE = pgPostFix "IS NOT TRUE"+ isNotFalseE = pgPostFix "IS NOT FALSE"+ isUnknownE = pgPostFix "IS UNKNOWN"+ isNotUnknownE = pgPostFix "IS NOT UNKNOWN"+ betweenE a b c = PgExpressionSyntax (emit "(" <> fromPgExpression a <> emit ") BETWEEN (" <>+ fromPgExpression b <> emit ") AND (" <> fromPgExpression c <> emit ")")+ valueE = coerce+ rowE vs = PgExpressionSyntax $+ emit "(" <>+ pgSepBy (emit ", ") (coerce vs) <>+ emit ")"+ quantifierListE vs =+ PgExpressionSyntax $+ emit "(VALUES " <> pgSepBy (emit ", ") (fmap (pgParens . fromPgExpression) vs) <> emit ")"+ fieldE = coerce+ subqueryE s = PgExpressionSyntax (emit "(" <> fromPgSelect s <> emit ")")+ positionE needle haystack =+ PgExpressionSyntax $+ emit "POSITION((" <> fromPgExpression needle <> emit ") IN (" <> fromPgExpression haystack <> emit "))"+ nullIfE a b = PgExpressionSyntax (emit "NULLIF(" <> fromPgExpression a <> emit ", " <> fromPgExpression b <> emit ")")+ absE x = PgExpressionSyntax (emit "ABS(" <> fromPgExpression x <> emit ")")+ bitLengthE x = PgExpressionSyntax (emit "BIT_LENGTH(" <> fromPgExpression x <> emit ")")+ charLengthE x = PgExpressionSyntax (emit "CHAR_LENGTH(" <> fromPgExpression x <> emit ")")+ octetLengthE x = PgExpressionSyntax (emit "OCTET_LENGTH(" <> fromPgExpression x <> emit ")")+ lowerE x = PgExpressionSyntax (emit "LOWER(" <> fromPgExpression x <> emit ")")+ upperE x = PgExpressionSyntax (emit "UPPER(" <> fromPgExpression x <> emit ")")+ trimE x = PgExpressionSyntax (emit "TRIM(" <> fromPgExpression x <> emit ")")+ coalesceE es = PgExpressionSyntax (emit "COALESCE(" <> pgSepBy (emit ", ") (map fromPgExpression es) <> emit ")")+ extractE field from = PgExpressionSyntax (emit "EXTRACT(" <> fromPgExtractField field <> emit " FROM (" <> fromPgExpression from <> emit "))")+ castE e to = PgExpressionSyntax (emit "CAST((" <> fromPgExpression e <> emit ") AS " <> fromPgDataType to <> emit ")")+ caseE cases else_ =+ PgExpressionSyntax $+ emit "CASE " <>+ foldMap (\(cond, res) -> emit "WHEN " <> fromPgExpression cond <> emit " THEN " <> fromPgExpression res <> emit " ") cases <>+ emit "ELSE " <> fromPgExpression else_ <> emit " END"++ currentTimestampE = PgExpressionSyntax $ emit "CURRENT_TIMESTAMP"++ defaultE = PgExpressionSyntax $ emit "DEFAULT"++ 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"++ functionCallE name args =+ PgExpressionSyntax $+ fromPgExpression name <>+ pgParens (pgSepBy (emit ", ") (map fromPgExpression args))++ instanceFieldE i nm =+ PgExpressionSyntax $+ pgParens (fromPgExpression i) <> emit "." <> escapeIdentifier (TE.encodeUtf8 nm)++ refFieldE i nm =+ PgExpressionSyntax $+ pgParens (fromPgExpression i) <> emit "->" <> escapeIdentifier (TE.encodeUtf8 nm)++instance IsSql99ConcatExpressionSyntax PgExpressionSyntax where+ concatE [] = valueE (sqlValueSyntax ("" :: T.Text))+ concatE [x] = x+ concatE es =+ PgExpressionSyntax $+ emit "CONCAT" <> pgParens (pgSepBy (emit ", ") (map fromPgExpression es))++instance IsSql2003ExpressionSyntax PgExpressionSyntax where+ type Sql2003ExpressionWindowFrameSyntax PgExpressionSyntax =+ PgWindowFrameSyntax++ overE expr frame =+ PgExpressionSyntax $+ fromPgExpression expr <> emit " " <> fromPgWindowFrame frame++instance IsSql2003EnhancedNumericFunctionsExpressionSyntax PgExpressionSyntax where+ lnE x = PgExpressionSyntax (emit "LN(" <> fromPgExpression x <> emit ")")+ expE x = PgExpressionSyntax (emit "EXP(" <> fromPgExpression x <> emit ")")+ sqrtE x = PgExpressionSyntax (emit "SQRT(" <> fromPgExpression x <> emit ")")+ ceilE x = PgExpressionSyntax (emit "CEIL(" <> fromPgExpression x <> emit ")")+ floorE x = PgExpressionSyntax (emit "FLOOR(" <> fromPgExpression x <> emit ")")+ powerE x y = PgExpressionSyntax (emit "POWER(" <> fromPgExpression x <> emit ", " <> fromPgExpression y <> emit ")")++instance IsSql2003ExpressionAdvancedOLAPOperationsSyntax PgExpressionSyntax where+ denseRankAggE = PgExpressionSyntax $ emit "DENSE_RANK()"+ percentRankAggE = PgExpressionSyntax $ emit "PERCENT_RANK()"+ cumeDistAggE = PgExpressionSyntax $ emit "CUME_DIST()"++instance IsSql2003ExpressionElementaryOLAPOperationsSyntax PgExpressionSyntax where+ rankAggE = PgExpressionSyntax $ emit "RANK()"+ filterAggE agg filter =+ PgExpressionSyntax $+ fromPgExpression agg <> emit " FILTER (WHERE " <> fromPgExpression filter <> emit ")"++instance IsSql2003EnhancedNumericFunctionsAggregationExpressionSyntax PgExpressionSyntax where+ stddevPopE = pgUnAgg "STDDEV_POP"+ stddevSampE = pgUnAgg "STDDEV_SAMP"+ varPopE = pgUnAgg "VAR_POP"+ varSampE = pgUnAgg "VAR_SAMP"++ covarPopE = pgBinAgg "COVAR_POP"+ covarSampE = pgBinAgg "COVAR_SAMP"+ corrE = pgBinAgg "CORR"+ regrSlopeE = pgBinAgg "REGR_SLOPE"+ regrInterceptE = pgBinAgg "REGR_INTERCEPT"+ regrCountE = pgBinAgg "REGR_COUNT"+ regrRSquaredE = pgBinAgg "REGR_R2"+ regrAvgXE = pgBinAgg "REGR_AVGX"+ regrAvgYE = pgBinAgg "REGR_AVGY"+ regrSXXE = pgBinAgg "REGR_SXX"+ regrSYYE = pgBinAgg "REGR_SYY"+ regrSXYE = pgBinAgg "REGR_SXY"++instance IsSql2003NtileExpressionSyntax PgExpressionSyntax where+ ntileE x = PgExpressionSyntax (emit "NTILE(" <> fromPgExpression x <> emit ")")++instance IsSql2003LeadAndLagExpressionSyntax PgExpressionSyntax where+ leadE x Nothing Nothing =+ PgExpressionSyntax (emit "LEAD(" <> fromPgExpression x <> emit ")")+ leadE x (Just n) Nothing =+ PgExpressionSyntax (emit "LEAD(" <> fromPgExpression x <> emit ", " <> fromPgExpression n <> emit ")")+ leadE x (Just n) (Just def) =+ PgExpressionSyntax (emit "LEAD(" <> fromPgExpression x <> emit ", " <> fromPgExpression n <> emit ", " <> fromPgExpression def <> emit ")")+ leadE x Nothing (Just def) =+ PgExpressionSyntax (emit "LEAD(" <> fromPgExpression x <> emit ", 1, " <> fromPgExpression def <> emit ")")++ lagE x Nothing Nothing =+ PgExpressionSyntax (emit "LAG(" <> fromPgExpression x <> emit ")")+ lagE x (Just n) Nothing =+ PgExpressionSyntax (emit "LAG(" <> fromPgExpression x <> emit ", " <> fromPgExpression n <> emit ")")+ lagE x (Just n) (Just def) =+ PgExpressionSyntax (emit "LAG(" <> fromPgExpression x <> emit ", " <> fromPgExpression n <> emit ", " <> fromPgExpression def <> emit ")")+ lagE x Nothing (Just def) =+ PgExpressionSyntax (emit "LAG(" <> fromPgExpression x <> emit ", 1, " <> fromPgExpression def <> emit ")")++instance IsSql2003FirstValueAndLastValueExpressionSyntax PgExpressionSyntax where+ firstValueE x = PgExpressionSyntax (emit "FIRST_VALUE(" <> fromPgExpression x <> emit ")")+ lastValueE x = PgExpressionSyntax (emit "LAST_VALUE(" <> fromPgExpression x <> emit ")")++instance IsSql2003NthValueExpressionSyntax PgExpressionSyntax where+ nthValueE x n = PgExpressionSyntax (emit "NTH_VALUE(" <> fromPgExpression x <> emit ", " <> fromPgExpression n <> emit ")")++instance IsSql2003WindowFrameSyntax PgWindowFrameSyntax where+ type Sql2003WindowFrameExpressionSyntax PgWindowFrameSyntax = PgExpressionSyntax+ type Sql2003WindowFrameOrderingSyntax PgWindowFrameSyntax = PgOrderingSyntax+ type Sql2003WindowFrameBoundsSyntax PgWindowFrameSyntax = PgWindowFrameBoundsSyntax++ frameSyntax partition_ ordering_ bounds_ =+ PgWindowFrameSyntax $+ emit "OVER " <>+ pgParens+ (+ maybe mempty (\p -> emit "PARTITION BY " <> pgSepBy (emit ", ") (map fromPgExpression p)) partition_ <>+ maybe mempty (\o -> emit " ORDER BY " <> pgSepBy (emit ", ") (map fromPgOrdering o)) ordering_ <>+ maybe mempty (\b -> emit " ROWS " <> fromPgWindowFrameBounds b) bounds_+ )++instance IsSql2003WindowFrameBoundsSyntax PgWindowFrameBoundsSyntax where+ type Sql2003WindowFrameBoundsBoundSyntax PgWindowFrameBoundsSyntax = PgWindowFrameBoundSyntax++ fromToBoundSyntax from Nothing =+ PgWindowFrameBoundsSyntax (fromPgWindowFrameBound from "PRECEDING")+ fromToBoundSyntax from (Just to) =+ PgWindowFrameBoundsSyntax $+ emit "BETWEEN " <> fromPgWindowFrameBound from "PRECEDING" <> emit " AND " <> fromPgWindowFrameBound to "FOLLOWING"++instance IsSql2003WindowFrameBoundSyntax PgWindowFrameBoundSyntax where+ unboundedSyntax = PgWindowFrameBoundSyntax $ \where_ -> emit "UNBOUNDED " <> emit where_+ nrowsBoundSyntax 0 = PgWindowFrameBoundSyntax $ \_ -> emit "CURRENT ROW"+ nrowsBoundSyntax n = PgWindowFrameBoundSyntax $ \where_ -> emit (fromString (show n)) <> emit " " <> emit where_++instance IsSql92AggregationExpressionSyntax PgExpressionSyntax where+ type Sql92AggregationSetQuantifierSyntax PgExpressionSyntax = PgAggregationSetQuantifierSyntax++ countAllE = PgExpressionSyntax (emit "COUNT(*)")+ countE = pgUnAgg "COUNT"+ avgE = pgUnAgg "AVG"+ sumE = pgUnAgg "SUM"+ minE = pgUnAgg "MIN"+ maxE = pgUnAgg "MAX"++instance IsSql99AggregationExpressionSyntax PgExpressionSyntax where+ everyE = pgUnAgg "EVERY"++ -- According to the note at <https://www.postgresql.org/docs/9.2/static/functions-aggregate.html>+ -- the following functions are equivalent.+ someE = pgUnAgg "BOOL_ANY"+ anyE = pgUnAgg "BOOL_ANY"++instance IsSql92AggregationSetQuantifierSyntax PgAggregationSetQuantifierSyntax where+ setQuantifierDistinct = PgAggregationSetQuantifierSyntax $ emit "DISTINCT"+ setQuantifierAll = PgAggregationSetQuantifierSyntax $ emit "ALL"++instance IsSql92AggregationSetQuantifierSyntax PgSelectSetQuantifierSyntax where+ setQuantifierDistinct = PgSelectSetQuantifierSyntax $ emit "DISTINCT"+ setQuantifierAll = PgSelectSetQuantifierSyntax $ emit "ALL"++pgSelectSetQuantifierDistinctOn :: [PgExpressionSyntax] -> PgSelectSetQuantifierSyntax+pgSelectSetQuantifierDistinctOn exprs =+ PgSelectSetQuantifierSyntax $+ emit "DISTINCT ON " <> pgParens (pgSepBy (emit ", ") (fromPgExpression <$> exprs))++pgUnAgg :: ByteString -> Maybe PgAggregationSetQuantifierSyntax -> PgExpressionSyntax -> PgExpressionSyntax+pgUnAgg fn q e =+ PgExpressionSyntax $+ emit fn <> emit "(" <> maybe mempty (\q -> fromPgAggregationSetQuantifier q <> emit " ") q <> fromPgExpression e <> emit ")"++pgBinAgg :: ByteString -> Maybe PgAggregationSetQuantifierSyntax -> PgExpressionSyntax -> PgExpressionSyntax+ -> PgExpressionSyntax+pgBinAgg fn q x y =+ PgExpressionSyntax $+ emit fn <> emit "(" <> maybe mempty (\q -> fromPgAggregationSetQuantifier q <> emit " ") q+ <> fromPgExpression x <> emit ", " <> fromPgExpression y <> emit ")"++instance IsSql92FieldNameSyntax PgFieldNameSyntax where+ qualifiedField a b =+ PgFieldNameSyntax $+ pgQuotedIdentifier a <> emit "." <> pgQuotedIdentifier b+ unqualifiedField = PgFieldNameSyntax . pgQuotedIdentifier++instance IsSql92TableSourceSyntax PgTableSourceSyntax where+ type Sql92TableSourceSelectSyntax PgTableSourceSyntax = PgSelectSyntax+ tableNamed = PgTableSourceSyntax . pgQuotedIdentifier+ tableFromSubSelect s = PgTableSourceSyntax $ emit "(" <> fromPgSelect s <> emit ")"++instance IsSql92ProjectionSyntax PgProjectionSyntax where+ type Sql92ProjectionExpressionSyntax PgProjectionSyntax = PgExpressionSyntax++ projExprs exprs =+ PgProjectionSyntax $+ pgSepBy (emit ", ")+ (map (\(expr, nm) -> fromPgExpression expr <>+ maybe mempty (\nm -> emit " AS " <> pgQuotedIdentifier nm) nm) exprs)++instance IsSql92InsertSyntax PgInsertSyntax where+ type Sql92InsertValuesSyntax PgInsertSyntax = PgInsertValuesSyntax++ insertStmt tblName fields values =+ PgInsertSyntax $+ emit "INSERT INTO " <> pgQuotedIdentifier tblName <> emit "(" <>+ pgSepBy (emit ", ") (map pgQuotedIdentifier fields) <>+ emit ") " <> fromPgInsertValues values++instance IsSql92InsertValuesSyntax PgInsertValuesSyntax where+ type Sql92InsertValuesExpressionSyntax PgInsertValuesSyntax = PgExpressionSyntax+ type Sql92InsertValuesSelectSyntax PgInsertValuesSyntax = PgSelectSyntax++ insertSqlExpressions es =+ PgInsertValuesSyntax $+ emit "VALUES " <>+ pgSepBy (emit ", ")+ (map (\es -> emit "(" <> pgSepBy (emit ", ") (coerce es) <> emit ")")+ es)+ insertFromSql (PgSelectSyntax a) = PgInsertValuesSyntax a++insertDefaults :: SqlInsertValues PgInsertValuesSyntax tbl+insertDefaults = SqlInsertValues (PgInsertValuesSyntax (emit "DEFAULT VALUES"))++instance IsSql92DropTableSyntax PgDropTableSyntax where+ dropTableSyntax tblNm =+ PgDropTableSyntax $+ emit "DROP TABLE " <> pgQuotedIdentifier tblNm++instance IsSql92AlterTableSyntax PgAlterTableSyntax where+ type Sql92AlterTableAlterTableActionSyntax PgAlterTableSyntax = PgAlterTableActionSyntax++ alterTableSyntax tblNm action =+ PgAlterTableSyntax $+ emit "ALTER TABLE " <> pgQuotedIdentifier tblNm <> emit " " <> fromPgAlterTableAction action++instance IsSql92AlterTableActionSyntax PgAlterTableActionSyntax where+ type Sql92AlterTableAlterColumnActionSyntax PgAlterTableActionSyntax = PgAlterColumnActionSyntax+ type Sql92AlterTableColumnSchemaSyntax PgAlterTableActionSyntax = PgColumnSchemaSyntax++ alterColumnSyntax colNm action =+ PgAlterTableActionSyntax $+ emit "ALTER COLUMN " <> pgQuotedIdentifier colNm <> emit " " <> fromPgAlterColumnAction action++ addColumnSyntax colNm schema =+ PgAlterTableActionSyntax $+ emit "ADD COLUMN " <> pgQuotedIdentifier colNm <> emit " " <> fromPgColumnSchema schema++ dropColumnSyntax colNm =+ PgAlterTableActionSyntax $+ emit "DROP COLUMN " <> pgQuotedIdentifier colNm++ renameTableToSyntax newNm =+ PgAlterTableActionSyntax $+ emit "RENAME TO " <> pgQuotedIdentifier newNm++ renameColumnToSyntax oldNm newNm =+ PgAlterTableActionSyntax $+ emit "RENAME COLUMN " <> pgQuotedIdentifier oldNm <> emit " TO " <> pgQuotedIdentifier newNm++instance IsSql92AlterColumnActionSyntax PgAlterColumnActionSyntax where+ setNullSyntax = PgAlterColumnActionSyntax (emit "DROP NOT NULL")+ setNotNullSyntax = PgAlterColumnActionSyntax (emit "SET NOT NULL")++instance IsSql92CreateTableSyntax PgCreateTableSyntax where+ type Sql92CreateTableColumnSchemaSyntax PgCreateTableSyntax = PgColumnSchemaSyntax+ type Sql92CreateTableTableConstraintSyntax PgCreateTableSyntax = PgTableConstraintSyntax+ type Sql92CreateTableOptionsSyntax PgCreateTableSyntax = PgTableOptionsSyntax++ createTableSyntax options tblNm fieldTypes constraints =+ let (beforeOptions, afterOptions) =+ case options of+ Nothing -> (emit " ", emit " ")+ Just (PgTableOptionsSyntax before after) ->+ ( emit " " <> before <> emit " "+ , emit " " <> after <> emit " " )+ in PgCreateTableSyntax $+ emit "CREATE" <> beforeOptions <> emit "TABLE " <> pgQuotedIdentifier tblNm <>+ emit " (" <>+ pgSepBy (emit ", ")+ (map (\(nm, type_) -> pgQuotedIdentifier nm <> emit " " <> fromPgColumnSchema type_) fieldTypes <>+ map fromPgTableConstraint constraints)+ <> emit ")" <> afterOptions++instance IsSql92TableConstraintSyntax PgTableConstraintSyntax where+ primaryKeyConstraintSyntax fieldNames =+ PgTableConstraintSyntax $+ emit "PRIMARY KEY(" <> pgSepBy (emit ", ") (map pgQuotedIdentifier fieldNames) <> emit ")"++instance Hashable PgColumnSchemaSyntax where+ hashWithSalt salt = hashWithSalt salt . fromPgColumnSchema+instance IsSql92ColumnSchemaSyntax PgColumnSchemaSyntax where+ type Sql92ColumnSchemaColumnTypeSyntax PgColumnSchemaSyntax = PgDataTypeSyntax+ type Sql92ColumnSchemaExpressionSyntax PgColumnSchemaSyntax = PgExpressionSyntax+ type Sql92ColumnSchemaColumnConstraintDefinitionSyntax PgColumnSchemaSyntax = PgColumnConstraintDefinitionSyntax++ columnSchemaSyntax colType defaultClause constraints collation =+ PgColumnSchemaSyntax syntax+ where+ syntax =+ fromPgDataType colType <>+ maybe mempty (\d -> emit " DEFAULT " <> fromPgExpression d) defaultClause <>+ (case constraints of+ [] -> mempty+ _ -> foldMap (\c -> emit " " <> fromPgColumnConstraintDefinition c) constraints) <>+ maybe mempty (\nm -> emit " COLLATE " <> pgQuotedIdentifier nm) collation++instance IsSql92MatchTypeSyntax PgMatchTypeSyntax where+ fullMatchSyntax = PgMatchTypeSyntax (emit "FULL") fullMatchSyntax+ partialMatchSyntax = PgMatchTypeSyntax (emit "PARTIAL") partialMatchSyntax++pgMatchTypeJSON :: Value -> BeamSerializedMatchType+pgMatchTypeJSON v = BeamSerializedMatchType (beamSerializeJSON "postgres" v)++pgSimpleMatchSyntax :: PgMatchTypeSyntax+pgSimpleMatchSyntax = PgMatchTypeSyntax (emit "SIMPLE") (pgMatchTypeJSON "simple")++instance IsSql92ReferentialActionSyntax PgReferentialActionSyntax where+ referentialActionCascadeSyntax = PgReferentialActionSyntax (emit "CASCADE") referentialActionCascadeSyntax+ referentialActionNoActionSyntax = PgReferentialActionSyntax (emit "NO ACTION") referentialActionNoActionSyntax+ referentialActionSetDefaultSyntax = PgReferentialActionSyntax (emit "SET DEFAULT") referentialActionSetDefaultSyntax+ referentialActionSetNullSyntax = PgReferentialActionSyntax (emit "SET NULL") referentialActionSetNullSyntax++fromSqlConstraintAttributes :: SqlConstraintAttributesBuilder -> PgSyntax+fromSqlConstraintAttributes (SqlConstraintAttributesBuilder timing deferrable) =+ maybe mempty timingBuilder timing <> maybe mempty deferrableBuilder deferrable+ where timingBuilder InitiallyDeferred = emit "INITIALLY DEFERRED"+ timingBuilder InitiallyImmediate = emit "INITIALLY IMMEDIATE"+ deferrableBuilder False = emit "NOT DEFERRABLE"+ deferrableBuilder True = emit "DEFERRABLE"++instance Hashable PgColumnConstraintDefinitionSyntax where+ hashWithSalt salt = hashWithSalt salt . fromPgColumnConstraintDefinition++instance IsSql92ColumnConstraintDefinitionSyntax PgColumnConstraintDefinitionSyntax where+ type Sql92ColumnConstraintDefinitionConstraintSyntax PgColumnConstraintDefinitionSyntax = PgColumnConstraintSyntax+ type Sql92ColumnConstraintDefinitionAttributesSyntax PgColumnConstraintDefinitionSyntax = SqlConstraintAttributesBuilder++ constraintDefinitionSyntax nm constraint attrs =+ PgColumnConstraintDefinitionSyntax syntax+ (constraintDefinitionSyntax nm (pgColumnConstraintSerialized constraint) (fmap sqlConstraintAttributesSerialized attrs))+ where+ syntax =+ maybe mempty (\nm -> emit "CONSTRAINT " <> pgQuotedIdentifier nm <> emit " " ) nm <>+ fromPgColumnConstraint constraint <>+ maybe mempty (\a -> emit " " <> fromSqlConstraintAttributes a) attrs++instance Sql92SerializableConstraintDefinitionSyntax PgColumnConstraintDefinitionSyntax where+ serializeConstraint = fromBeamSerializedConstraintDefinition . pgColumnConstraintDefinitionSerialized++instance IsSql92ColumnConstraintSyntax PgColumnConstraintSyntax where+ type Sql92ColumnConstraintMatchTypeSyntax PgColumnConstraintSyntax = PgMatchTypeSyntax+ type Sql92ColumnConstraintReferentialActionSyntax PgColumnConstraintSyntax = PgReferentialActionSyntax+ type Sql92ColumnConstraintExpressionSyntax PgColumnConstraintSyntax = PgExpressionSyntax++ notNullConstraintSyntax = PgColumnConstraintSyntax (emit "NOT NULL") notNullConstraintSyntax+ uniqueColumnConstraintSyntax = PgColumnConstraintSyntax (emit "UNIQUE") uniqueColumnConstraintSyntax+ primaryKeyColumnConstraintSyntax = PgColumnConstraintSyntax (emit "PRIMARY KEY") primaryKeyColumnConstraintSyntax+ checkColumnConstraintSyntax expr =+ PgColumnConstraintSyntax (emit "CHECK(" <> fromPgExpression expr <> emit ")")+ (checkColumnConstraintSyntax . BeamSerializedExpression . TE.decodeUtf8 .+ toStrict . pgRenderSyntaxScript . fromPgExpression $ expr)+ referencesConstraintSyntax tbl fields matchType onUpdate onDelete =+ PgColumnConstraintSyntax syntax+ (referencesConstraintSyntax tbl fields (fmap pgMatchTypeSerialized matchType)+ (fmap pgReferentialActionSerialized onUpdate)+ (fmap pgReferentialActionSerialized onDelete))+ where+ syntax =+ emit "REFERENCES " <> pgQuotedIdentifier tbl <> emit "("+ <> pgSepBy (emit ", ") (map pgQuotedIdentifier fields) <> emit ")" <>+ maybe mempty (\m -> emit " " <> fromPgMatchType m) matchType <>+ maybe mempty (\a -> emit " ON UPDATE " <> fromPgReferentialAction a) onUpdate <>+ maybe mempty (\a -> emit " ON DELETE " <> fromPgReferentialAction a) onDelete++defaultPgValueSyntax :: Pg.ToField a => a -> PgValueSyntax+defaultPgValueSyntax =+ PgValueSyntax . pgBuildAction . pure . Pg.toField++#define DEFAULT_SQL_SYNTAX(ty) \+ instance HasSqlValueSyntax PgValueSyntax ty where \+ sqlValueSyntax = defaultPgValueSyntax++DEFAULT_SQL_SYNTAX(Bool)+DEFAULT_SQL_SYNTAX(Double)+DEFAULT_SQL_SYNTAX(Float)+DEFAULT_SQL_SYNTAX(Int)+DEFAULT_SQL_SYNTAX(Int8)+DEFAULT_SQL_SYNTAX(Int16)+DEFAULT_SQL_SYNTAX(Int32)+DEFAULT_SQL_SYNTAX(Int64)+DEFAULT_SQL_SYNTAX(Integer)+DEFAULT_SQL_SYNTAX(Word)+DEFAULT_SQL_SYNTAX(Word8)+DEFAULT_SQL_SYNTAX(Word16)+DEFAULT_SQL_SYNTAX(Word32)+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(TimeOfDay)+DEFAULT_SQL_SYNTAX(NominalDiffTime)+DEFAULT_SQL_SYNTAX(Day)+DEFAULT_SQL_SYNTAX(UUID)+DEFAULT_SQL_SYNTAX([Char])+DEFAULT_SQL_SYNTAX(Pg.HStoreMap)+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)++instance HasSqlValueSyntax PgValueSyntax (CI T.Text) where+ sqlValueSyntax = sqlValueSyntax . CI.original+instance HasSqlValueSyntax PgValueSyntax (CI TL.Text) where+ sqlValueSyntax = sqlValueSyntax . CI.original++instance HasSqlValueSyntax PgValueSyntax SqlNull where+ sqlValueSyntax _ = defaultPgValueSyntax Pg.Null++instance HasSqlValueSyntax PgValueSyntax x => HasSqlValueSyntax PgValueSyntax (Maybe x) where+ sqlValueSyntax Nothing = sqlValueSyntax SqlNull+ sqlValueSyntax (Just x) = sqlValueSyntax x++instance HasSqlValueSyntax PgValueSyntax B.ByteString where+ sqlValueSyntax = defaultPgValueSyntax . Pg.Binary++instance HasSqlValueSyntax PgValueSyntax BL.ByteString where+ sqlValueSyntax = defaultPgValueSyntax . Pg.Binary++pgQuotedIdentifier :: T.Text -> PgSyntax+pgQuotedIdentifier t =+ escapeIdentifier (TE.encodeUtf8 t)++pgParens :: PgSyntax -> PgSyntax+pgParens a = emit "(" <> a <> emit ")"++pgTableOp :: ByteString -> PgSelectTableSyntax -> PgSelectTableSyntax+ -> PgSelectTableSyntax+pgTableOp op tbl1 tbl2 =+ PgSelectTableSyntax $+ emit "(" <> fromPgSelectTable tbl1 <> emit ") " <> emit op <>+ emit " (" <> fromPgSelectTable tbl2 <> emit ")"++pgCompOp :: ByteString -> Maybe PgComparisonQuantifierSyntax+ -> PgExpressionSyntax -> PgExpressionSyntax -> PgExpressionSyntax+pgCompOp op quantifier a b =+ PgExpressionSyntax $+ emit "(" <> fromPgExpression a <>+ emit (") " <> op) <>+ maybe (emit " (" <> fromPgExpression b <> emit ")")+ (\q -> emit " " <> fromPgComparisonQuantifier q <> emit " " <> fromPgExpression b)+ quantifier++pgBinOp :: ByteString -> PgExpressionSyntax -> PgExpressionSyntax -> PgExpressionSyntax+pgBinOp op a b =+ PgExpressionSyntax $+ emit "(" <> fromPgExpression a <> emit (") " <> op <> " (") <> fromPgExpression b <> emit ")"++pgPostFix, pgUnOp :: ByteString -> PgExpressionSyntax -> PgExpressionSyntax+pgPostFix op a =+ PgExpressionSyntax $+ emit "(" <> fromPgExpression a <> emit ") " <> emit op+pgUnOp op a =+ PgExpressionSyntax $+ emit (op <> "(") <> fromPgExpression a <> emit ")"++pgJoin :: ByteString -> PgFromSyntax -> PgFromSyntax -> Maybe PgExpressionSyntax -> PgFromSyntax+pgJoin joinType a b Nothing =+ PgFromSyntax $+ fromPgFrom a <> emit (" " <> joinType <> " ") <> fromPgFrom b <> emit " ON TRUE"+pgJoin joinType a b (Just on) =+ PgFromSyntax $+ fromPgFrom a <> emit (" " <> joinType <> " ") <> fromPgFrom b <>+ emit " ON " <> fromPgExpression on++pgSepBy :: PgSyntax -> [PgSyntax] -> PgSyntax+pgSepBy _ [] = mempty+pgSepBy _ [x] = x+pgSepBy sep (x:xs) = x <> sep <> pgSepBy sep xs++pgDebugRenderSyntax :: PgSyntax -> IO ()+pgDebugRenderSyntax (PgSyntax p) = go p Nothing+ where go :: PgSyntaxM () -> Maybe (PgSyntaxF ()) -> IO ()+ go p = runF p finish step+ step x lastBs =+ case (x, lastBs) of+ (EmitBuilder s next, lastBs) ->+ step (EmitByteString (toStrict (toLazyByteString s)) next) lastBs+ (x, Nothing) ->+ nextSyntaxStep x (Just (fmap (const ()) x))+ (EmitByteString x next, Just (EmitByteString before _)) ->+ next (Just (EmitByteString (before <> x) ()))+ (EscapeString x next, Just (EscapeString before _)) ->+ next (Just (EscapeString (before <> x) ()))+ (EscapeBytea x next, Just (EscapeBytea before _)) ->+ next (Just (EscapeBytea (before <> x) ()))+ (EscapeIdentifier x next, Just (EscapeIdentifier before _)) ->+ next (Just (EscapeIdentifier (before <> x) ()))+ (s, Just e) ->+ renderStep e >>+ nextSyntaxStep s (Just (fmap (const ()) s))++ renderStep (EmitByteString x _) = putStrLn ("EmitByteString " <> show x)+ renderStep (EmitBuilder x _) = putStrLn ("EmitBuilder " <> show (toLazyByteString x))+ renderStep (EscapeString x _) = putStrLn ("EscapeString " <> show x)+ renderStep (EscapeBytea x _) = putStrLn ("EscapeBytea " <> show x)+ renderStep (EscapeIdentifier x _) = putStrLn ("EscapeIdentifier " <> show x)++ finish x Nothing = pure x+ finish x (Just s) = renderStep s >> pure x++pgBuildAction :: [ Pg.Action ] -> PgSyntax+pgBuildAction =+ foldMap $ \action ->+ case action of+ Pg.Plain x -> emitBuilder x+ Pg.Escape str -> emit "'" <> escapeString str <> emit "'"+ Pg.EscapeByteA bin -> emit "'" <> escapeBytea bin <> emit "'"+ Pg.EscapeIdentifier id -> escapeIdentifier id+ Pg.Many as -> pgBuildAction as++-- * Postgres-specific extensions++-- * Postgres specific commands++pgSelectStmt :: PgSelectTableSyntax+ -> [PgOrderingSyntax]+ -> Maybe Integer {-^ LIMIT -}+ -> Maybe Integer {-^ OFFSET -}+ -> Maybe PgSelectLockingClauseSyntax+ -> PgSelectSyntax+pgSelectStmt tbl ordering limit offset locking =+ PgSelectSyntax $+ mconcat [ coerce tbl+ , case ordering of+ [] -> mempty+ ordering -> emit " ORDER BY " <> pgSepBy (emit ", ") (map fromPgOrdering ordering)+ , maybe mempty (emit . fromString . (" LIMIT " <>) . show) limit+ , maybe mempty (emit . fromString . (" OFFSET " <>) . show) offset+ , maybe mempty fromPgSelectLockingClause locking ]++pgCreateExtensionSyntax :: T.Text -> PgCommandSyntax+pgCreateExtensionSyntax extName =+ PgCommandSyntax PgCommandTypeDdl $ emit "CREATE EXTENSION " <> pgQuotedIdentifier extName++pgDropExtensionSyntax :: T.Text -> PgCommandSyntax+pgDropExtensionSyntax extName =+ PgCommandSyntax PgCommandTypeDdl $ emit "DROP EXTENSION " <> pgQuotedIdentifier extName++-- -- * Pg-specific Q monad+++data PgEscapeType = PgEscapeString | PgEscapeBytea | PgEscapeIdentifier+ deriving (Show, Eq, Ord, Enum, Bounded)+data PgSyntaxPrim = PgSyntaxPrim (Maybe PgEscapeType) BL.ByteString deriving Show++instance IsString PgSyntaxPrim where+ fromString = PgSyntaxPrim Nothing . fromString++pgTestSyntax :: PgSyntax -> [ PgSyntaxPrim ]+pgTestSyntax (PgSyntax syntax) = runF syntax finish step Nothing mempty id+ where+ finish _ escapeType curBuilder a =+ let chunk = toLazyByteString curBuilder+ in if BL.null chunk then a []+ else a [ PgSyntaxPrim escapeType chunk ]++ go next curType nextType curBuilder nextBuilder a+ | curType == nextType = next curType (curBuilder <> nextBuilder) a+ | otherwise = next nextType mempty (a . (PgSyntaxPrim curType (toLazyByteString curBuilder):))++ step (EmitByteString bs next) curType curBuilder a =+ go next curType Nothing curBuilder (byteString bs) a+ step (EmitBuilder bs next) curType curBuilder a =+ go next curType Nothing curBuilder bs a+ step (EscapeString s next) curType curBuilder a =+ go next curType (Just PgEscapeString) curBuilder (byteString s) a+ step (EscapeBytea s next) curType curBuilder a =+ go next curType (Just PgEscapeBytea) curBuilder (byteString s) a+ step (EscapeIdentifier s next) curType curBuilder a =+ go next curType (Just PgEscapeIdentifier) curBuilder (byteString s) a++pgRenderSyntaxScript :: PgSyntax -> BL.ByteString+pgRenderSyntaxScript (PgSyntax mkQuery) =+ toLazyByteString (runF mkQuery finish step)+ where+ finish _ = mempty+ step (EmitBuilder b next) = b <> next+ step (EmitByteString b next) = byteString b <> next+ step (EscapeString b next) = escapePgString b <> next+ step (EscapeBytea b next) = escapePgBytea b <> next+ step (EscapeIdentifier b next) = escapePgIdentifier b <> next++ escapePgString b = byteString (B.concatMap (\w -> if w == '\'' then "''" else B.singleton w) b)+ escapePgBytea _ = error "escapePgBytea: no connection"+ escapePgIdentifier bs = char8 '"' <> foldMap quoteIdentifierChar (B.unpack bs) <> char8 '"'+ where+ 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)
+ Database/Beam/Postgres/Types.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Beam.Postgres.Types+ ( Postgres(..) ) where++import Database.Beam+import Database.Beam.Backend.SQL++import qualified Database.PostgreSQL.Simple.FromField as Pg+import qualified Database.PostgreSQL.Simple.HStore as Pg (HStoreMap, HStoreList)+import qualified Database.PostgreSQL.Simple.Types as Pg+import qualified Database.PostgreSQL.Simple.Range as Pg (PGRange)+import qualified Database.PostgreSQL.Simple.Time as Pg (Date, UTCTimestamp, ZonedTimestamp, LocalTimestamp)++import Data.Aeson (Value)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL+import Data.CaseInsensitive (CI)+import Data.Int+import Data.Ratio (Ratio)+import Data.Scientific (Scientific, toBoundedInteger)+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Data.Time (UTCTime, Day, TimeOfDay, LocalTime, ZonedTime(..))+import Data.UUID (UUID)+import Data.Vector (Vector)+import Data.Word++-- | The Postgres backend type, used to parameterize 'MonadBeam'. See the+-- definitions there for more information. The corresponding query monad is+-- 'Pg'. See documentation for 'MonadBeam' and the+-- <https://tathougies.github/beam/ user guide> for more information on using+-- this backend.+data Postgres+ = Postgres++instance BeamBackend Postgres where+ type BackendFromField Postgres = Pg.FromField++instance Pg.FromField SqlNull where+ fromField field d = fmap (\Pg.Null -> SqlNull) (Pg.fromField field d)++fromScientificOrIntegral :: (Bounded a, Integral a) => FromBackendRowM Postgres a+fromScientificOrIntegral = do+ 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)+ => FromBackendRowM Postgres a+fromPgIntegral = do+ val <- peekField+ case val of+ Just val' -> do+ _ <- parseOneField @Postgres @a+ pure val'+ Nothing -> do+ val' <- parseOneField @Postgres @Integer+ let val'' = fromIntegral val'+ if fromIntegral val'' == val'+ then pure val''+ else fail (concat [ "Data loss while downsizing Integral type. "+ , "Make sure your Haskell types are wide enough for your data" ])++-- Default FromBackendRow instances for all postgresql-simple FromField instances+instance FromBackendRow Postgres SqlNull+instance FromBackendRow Postgres Bool+instance FromBackendRow Postgres Char+instance FromBackendRow Postgres Double+instance FromBackendRow Postgres Int where+ fromBackendRow = fromPgIntegral+instance FromBackendRow Postgres Int16 where+ fromBackendRow = fromPgIntegral+instance FromBackendRow Postgres Int32 where+ fromBackendRow = fromPgIntegral+instance FromBackendRow Postgres Int64 where+ fromBackendRow = fromPgIntegral+-- Word values are serialized as SQL @NUMBER@ types to guarantee full domain coverage.+-- However, we wan them te be serialized/deserialized as whichever type makes sense+instance FromBackendRow Postgres Word where+ fromBackendRow = fromScientificOrIntegral+instance FromBackendRow Postgres Word16 where+ fromBackendRow = fromScientificOrIntegral+instance FromBackendRow Postgres Word32 where+ fromBackendRow = fromScientificOrIntegral+instance FromBackendRow Postgres Word64 where+ fromBackendRow = fromScientificOrIntegral+instance FromBackendRow Postgres Integer+instance FromBackendRow Postgres ByteString+instance FromBackendRow Postgres Scientific+instance FromBackendRow Postgres BL.ByteString+instance FromBackendRow Postgres Text+instance FromBackendRow Postgres UTCTime+instance FromBackendRow Postgres Value+instance FromBackendRow Postgres TL.Text+instance FromBackendRow Postgres Pg.Oid+instance FromBackendRow Postgres LocalTime where+ fromBackendRow =+ peekField >>=+ \case+ Just (_ :: LocalTime) -> parseOneField++ -- Also accept 'TIMESTAMP WITH TIME ZONE'. Considered as+ -- 'LocalTime', because postgres always returns times in the+ -- server timezone, regardless of type.+ Nothing ->+ peekField >>=+ \case+ Just (_ :: ZonedTime) -> zonedTimeToLocalTime <$> parseOneField+ Nothing -> fail "'TIMESTAMP WITH TIME ZONE' or 'TIMESTAMP WITHOUT TIME ZONE' required for LocalTime"+instance FromBackendRow Postgres TimeOfDay+instance FromBackendRow Postgres Day+instance FromBackendRow Postgres UUID+instance FromBackendRow Postgres Pg.Null+instance FromBackendRow Postgres Pg.Date+instance FromBackendRow Postgres Pg.ZonedTimestamp+instance FromBackendRow Postgres Pg.UTCTimestamp+instance FromBackendRow Postgres Pg.LocalTimestamp+instance FromBackendRow Postgres Pg.HStoreMap+instance FromBackendRow Postgres Pg.HStoreList+instance FromBackendRow Postgres [Char]+instance FromBackendRow Postgres (Ratio Integer)+instance FromBackendRow Postgres (CI Text)+instance FromBackendRow Postgres (CI TL.Text)+instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Vector a) where+ fromBackendRow = do+ isNull <- peekField+ case isNull of+ Just SqlNull -> pure mempty+ Nothing -> parseOneField @Postgres @(Vector a)+instance (Pg.FromField a, Typeable a) => FromBackendRow Postgres (Pg.PGArray a)+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 BeamSqlBackend Postgres+instance BeamSql92Backend Postgres
+ LICENSE view
@@ -0,0 +1,8 @@+The MIT License (MIT)+Copyright (c) 2017-2018 Travis Athougies and the Beam Authors++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ beam-postgres.cabal view
@@ -0,0 +1,72 @@+name: beam-postgres+version: 0.3.0.0+synopsis: Connection layer between beam and postgres+description: Beam driver for <https://www.postgresql.org/ PostgreSQL>, an advanced open-source RDBMS+homepage: http://tathougies.github.io/beam/user-guide/backends/beam-postgres+license: MIT+license-file: LICENSE+author: Travis Athougies+maintainer: travis@athougies.net+category: Database+build-type: Simple+cabal-version: 1.18+extra-doc-files: ChangeLog.md+bug-reports: https://github.com/tathougies/beam/issues++library+ exposed-modules: Database.Beam.Postgres+ Database.Beam.Postgres.Migrate+ Database.Beam.Postgres.PgCrypto+ Database.Beam.Postgres.Syntax++ Database.Beam.Postgres.Conduit+ Database.Beam.Postgres.Full++ other-modules: Database.Beam.Postgres.Types+ Database.Beam.Postgres.Connection+ Database.Beam.Postgres.PgSpecific+ Database.Beam.Postgres.Extensions+ build-depends: base >=4.7 && <5.0,+ beam-core >=0.7 && <0.8,+ beam-migrate >=0.3 && <0.4,++ postgresql-libpq >=0.8 && <0.10,+ postgresql-simple >=0.5 && <0.6,++ text >=1.0 && <1.3,+ bytestring >=0.10 && <0.11,++ hashable >=1.1 && <1.3,+ lifted-base >=0.2 && <0.3,+ free >=4.12 && <5.1,+ time >=1.6 && <1.10,+ monad-control >=1.0 && <1.1,+ mtl >=2.1 && <2.3,+ conduit >=1.2 && <1.4,+ aeson >=0.11 && <1.3,+ uuid >=1.2 && <1.4,+ case-insensitive >=1.2 && <1.3,+ scientific >=0.3 && <0.4,+ vector >=0.11 && <0.13,+ network-uri >=2.6 && <2.7,+ unordered-containers >= 0.2 && <0.3,++ haskell-src-exts >=1.18 && <1.21+ default-language: Haskell2010+ default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances,+ DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings,+ CPP, TypeApplications, FlexibleContexts+ ghc-options: -Wall+ if flag(werror)+ ghc-options: -Werror++flag werror+ description: Enable -Werror during development+ default: False+ manual: True++source-repository head+ type: git+ location: https://github.com/tathougies/beam.git+ subdir: beam-postgres+