diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -157,8 +157,8 @@ ```haskell select $ -from $ \(p `LeftOuterJoin`` mb) -> do -on (p ^. PersonId ==. mb ?. BlogPostAuthorId) +from $ \(p `LeftOuterJoin` mb) -> do +on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] return (p, mb) ``` diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ -Unreleased +3.1.1 ======== + +- @JoseD92 + - [#149](https://github.com/bitemyapp/esqueleto/pull/149): Added `upsert` support. + +- @parsonsmatt + - [#133](https://github.com/bitemyapp/esqueleto/pull/133): Added `renderQueryToText` and related functions. 3.1.0 ======= diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.1.0 +version: 3.1.1 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . @@ -53,7 +53,7 @@ , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 - , time >=1.5.0.1 && <=1.8.0.2 + , time >=1.5.0.1 && <=1.10 , transformers >=0.2 , unliftio , unordered-containers >=0.2 diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -86,6 +86,12 @@ , insertSelectCount , (<#) , (<&>) + -- ** Rendering Queries + , renderQueryToText + , renderQuerySelect + , renderQueryUpdate + , renderQueryDelete + , renderQueryInsertInto -- * Internal.Language , From -- * RDBMS-specific modules diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -730,8 +730,9 @@ -- Bar -- barNum Int -- Foo --- Id BarId +-- bar BarId -- fooNum Int +-- Primary bar -- @ -- -- For this example, declare: @@ -1262,6 +1263,7 @@ | InsertionFinalError | NewIdentForError | UnsafeSqlCaseError + | OperationNotSupported deriving (Show) data SqlBinOpCompositeError = @@ -1994,8 +1996,8 @@ -- -- Note: if you're curious about the SQL query being generated by -- @esqueleto@, instead of manually using this function (which is --- possible but tedious), you may just turn on query logging of --- @persistent@. +-- possible but tedious), see the 'renderQueryToText' function (along with +-- 'renderQuerySelect', 'renderQueryUpdate', etc). toRawSql :: (SqlSelect a r, BackendCompatible SqlBackend backend) => Mode -> (backend, IdentState) -> SqlQuery a -> (TLB.Builder, [PersistValue]) @@ -2031,6 +2033,90 @@ , makeLocking lockingClause ] +-- | Renders a 'SqlQuery' into a 'Text' value along with the list of +-- 'PersistValue's that would be supplied to the database for @?@ placeholders. +-- +-- You must ensure that the 'Mode' you pass to this function corresponds with +-- the actual 'SqlQuery'. If you pass a query that uses incompatible features +-- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird +-- result. +-- +-- @since 3.1.1 +renderQueryToText + :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) + => Mode + -- ^ Whether to render as an 'SELECT', 'DELETE', etc. + -> SqlQuery a + -- ^ The SQL query you want to render. + -> R.ReaderT backend m (T.Text, [PersistValue]) +renderQueryToText mode query = do + backend <- R.ask + let (builder, pvals) = toRawSql mode (backend, initialIdentState) query + pure (builderToText builder, pvals) + +-- | Renders a 'SqlQuery' into a 'Text' value along with the list of +-- 'PersistValue's that would be supplied to the database for @?@ placeholders. +-- +-- You must ensure that the 'Mode' you pass to this function corresponds with +-- the actual 'SqlQuery'. If you pass a query that uses incompatible features +-- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird +-- result. +-- +-- @since 3.1.1 +renderQuerySelect + :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) + => SqlQuery a + -- ^ The SQL query you want to render. + -> R.ReaderT backend m (T.Text, [PersistValue]) +renderQuerySelect = renderQueryToText SELECT + +-- | Renders a 'SqlQuery' into a 'Text' value along with the list of +-- 'PersistValue's that would be supplied to the database for @?@ placeholders. +-- +-- You must ensure that the 'Mode' you pass to this function corresponds with +-- the actual 'SqlQuery'. If you pass a query that uses incompatible features +-- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird +-- result. +-- +-- @since 3.1.1 +renderQueryDelete + :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) + => SqlQuery a + -- ^ The SQL query you want to render. + -> R.ReaderT backend m (T.Text, [PersistValue]) +renderQueryDelete = renderQueryToText DELETE + +-- | Renders a 'SqlQuery' into a 'Text' value along with the list of +-- 'PersistValue's that would be supplied to the database for @?@ placeholders. +-- +-- You must ensure that the 'Mode' you pass to this function corresponds with +-- the actual 'SqlQuery'. If you pass a query that uses incompatible features +-- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird +-- result. +-- +-- @since 3.1.1 +renderQueryUpdate + :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) + => SqlQuery a + -- ^ The SQL query you want to render. + -> R.ReaderT backend m (T.Text, [PersistValue]) +renderQueryUpdate = renderQueryToText UPDATE + +-- | Renders a 'SqlQuery' into a 'Text' value along with the list of +-- 'PersistValue's that would be supplied to the database for @?@ placeholders. +-- +-- You must ensure that the 'Mode' you pass to this function corresponds with +-- the actual 'SqlQuery'. If you pass a query that uses incompatible features +-- (like an @INSERT@ statement with a @SELECT@ mode) then you'll get a weird +-- result. +-- +-- @since 3.1.1 +renderQueryInsertInto + :: (SqlSelect a r, BackendCompatible SqlBackend backend, Monad m) + => SqlQuery a + -- ^ The SQL query you want to render. + -> R.ReaderT backend m (T.Text, [PersistValue]) +renderQueryInsertInto = renderQueryToText INSERT_INTO -- | (Internal) Mode of query being converted by 'toRawSql'. data Mode = diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -61,6 +61,11 @@ , veryUnsafeCoerceSqlExprValue , veryUnsafeCoerceSqlExprValueList -- * Helper functions + , renderQueryToText + , renderQuerySelect + , renderQueryUpdate + , renderQueryDelete + , renderQueryInsertInto , makeOrderByNoNewline , uncommas' , parens diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -18,6 +18,8 @@ , chr , now_ , random_ + , upsert + , upsertBy -- * Internal , unsafeSqlAggregateFunction ) where @@ -28,9 +30,18 @@ import qualified Data.Text.Internal.Builder as TLB import Data.Time.Clock (UTCTime) import Database.Esqueleto.Internal.Language hiding (random_) -import Database.Esqueleto.Internal.PersistentImport +import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Database.Esqueleto.Internal.Sql +import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), + UnexpectedCaseError(..), SetClause) +import Database.Persist.Class (OnlyOneUniqueKey) +import Data.List.NonEmpty ( NonEmpty( (:|) ) ) +import Control.Arrow ((***), first) +import Control.Exception (Exception, throw, throwIO) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Control.Monad.Trans.Reader as R + -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- @@ -152,3 +163,54 @@ now_ :: SqlExpr (Value UTCTime) now_ = unsafeSqlValue "NOW()" + +upsert :: (MonadIO m, + PersistEntity record, + OnlyOneUniqueKey record, + PersistRecordBackend record SqlBackend, + IsPersistBackend (PersistEntityBackend record)) + => record + -- ^ new record to insert + -> [SqlExpr (Update record)] + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Entity record) + -- ^ the record in the database after the operation +upsert record updates = do + uniqueKey <- onlyUnique record + upsertBy uniqueKey record updates + +upsertBy :: (MonadIO m, + PersistEntity record, + IsPersistBackend (PersistEntityBackend record)) + => Unique record + -- ^ uniqueness constraint to find by + -> record + -- ^ new record to insert + -> [SqlExpr (Update record)] + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Entity record) + -- ^ the record in the database after the operation +upsertBy uniqueKey record updates = do + sqlB <- R.ask + maybe + (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent + (handler sqlB) + (connUpsertSql sqlB) + where + addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey + entDef = entityDef (Just record) + uDef = head $ filter ((==) (persistUniqueToFieldNames uniqueKey) . uniqueFields) $ entityUniques entDef + updatesText conn = first builderToText $ renderUpdates conn updates + handler conn f = fmap head $ uncurry rawSql $ + (***) (f entDef (uDef :| [])) addVals $ updatesText conn + renderUpdates :: SqlBackend + -> [SqlExpr (Update val)] + -> (TLB.Builder, [PersistValue]) + renderUpdates conn = uncommas' . concatMap renderUpdate + where + mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] + mk (ERaw _ f) = [f info] + mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME + renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] + renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused + info = (projectBackend conn, initialIdentState) diff --git a/test/Common/Test.hs b/test/Common/Test.hs --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -25,11 +25,14 @@ , testAscRandom , testRandomMath , migrateAll + , migrateUnique , cleanDB + , cleanUniques , RunDbMonad , Run , p1, p2, p3, p4, p5 , l1, l2, l3 + , u1, u2, u3, u4 , insert' , EntityField (..) , Foo (..) @@ -48,6 +51,7 @@ , Point (..) , Circle (..) , Numbers (..) + , OneUnique(..) ) where import Control.Monad (forM_, replicateM, replicateM_, void) @@ -65,10 +69,12 @@ import Test.Hspec import UnliftIO +import Database.Persist (PersistValue(..)) import Data.Conduit (ConduitT, (.|), runConduit) import qualified Data.Conduit.List as CL import qualified Data.List as L import qualified Data.Set as S +import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Internal.Lazy as TL import qualified Database.Esqueleto.Internal.Sql as EI @@ -155,8 +161,14 @@ double Double |] - - +-- Unique Test schema +share [mkPersist sqlSettings, mkMigrate "migrateUnique"] [persistUpperCase| + OneUnique + name String + value Int + UniqueValue value + deriving Eq Show +|] -- | this could be achieved with S.fromList, but not all lists -- have Ord instances @@ -194,8 +206,18 @@ l3 :: Lord l3 = Lord "Chester" (Just 17) +u1 :: OneUnique +u1 = OneUnique "First" 0 +u2 :: OneUnique +u2 = OneUnique "Second" 1 +u3 :: OneUnique +u3 = OneUnique "Third" 0 + +u4 :: OneUnique +u4 = OneUnique "First" 2 + testSelect :: Run -> Spec testSelect run = do describe "select" $ do @@ -1437,7 +1459,26 @@ [Value n] <- select $ from $ return . countKind liftIO $ (n :: Int) `shouldBe` expected - +testRenderSql :: Run -> Spec +testRenderSql run = + describe "testRenderSql" $ do + it "works" $ do + (queryText, queryVals) <- run $ renderQuerySelect $ + from $ \p -> do + where_ $ p ^. PersonName ==. val "Johhny Depp" + pure (p ^. PersonName, p ^. PersonAge) + -- the different backends use different quote marks, so I filter them out + -- here instead of making a duplicate test + Text.filter (\c -> c `notElem` ['`', '"']) queryText + `shouldBe` + Text.unlines + [ "SELECT Person.name, Person.age" + , "FROM Person" + , "WHERE Person.name = ?" + ] + queryVals + `shouldBe` + [toPersistValue ("Johhny Depp" :: TL.Text)] @@ -1460,8 +1501,7 @@ testMathFunctions run testCase run testCountingRows run - - + testRenderSql run insert' :: ( Functor m @@ -1516,3 +1556,10 @@ delete $ from $ \(_ :: SqlExpr (Entity Point)) -> return () delete $ from $ \(_ :: SqlExpr (Entity Numbers)) -> return () + + +cleanUniques + :: (forall m. RunDbMonad m + => SqlPersistT (R.ResourceT m) ()) +cleanUniques = + delete $ from $ \(_ :: SqlExpr (Entity OneUnique)) -> return () diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -33,7 +33,7 @@ import Database.Esqueleto.PostgreSQL.JSON hiding ((?.), (-.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON import Database.Persist.Postgresql (withPostgresqlConn) -import Database.PostgreSQL.Simple (SqlError(..)) +import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..)) import System.Environment import Test.Hspec @@ -949,7 +949,35 @@ where_ $ v @>. jsonbVal (object []) where_ $ f v +testInsertUniqueViolation :: Spec +testInsertUniqueViolation = + describe "Unique Violation on Insert" $ + it "Unique throws exception" $ run (do + _ <- insert u1 + _ <- insert u2 + insert u3) `shouldThrow` (==) exception + where + exception = SqlError { + sqlState = "23505", + sqlExecStatus = FatalError, + sqlErrorMsg = "duplicate key value violates unique constraint \"UniqueValue\"", + sqlErrorDetail = "Key (value)=(0) already exists.", + sqlErrorHint = ""} +testUpsert :: Spec +testUpsert = + describe "Upsert test" $ do + it "Upsert can insert like normal" $ run $ do + u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] + liftIO $ entityVal u1e `shouldBe` u1 + it "Upsert performs update on collision" $ run $ do + u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] + liftIO $ entityVal u1e `shouldBe` u1 + u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"] + liftIO $ entityVal u2e `shouldBe` u2 + u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] + liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} + type JSONValue = Maybe (JSONB A.Value) createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO () @@ -1021,6 +1049,8 @@ testPostgresqlUpdate testPostgresqlCoalesce testPostgresqlTextFunctions + testInsertUniqueViolation + testUpsert describe "PostgreSQL JSON tests" $ do -- NOTE: We only clean the table once, so we -- can use its contents across all JSON tests @@ -1053,11 +1083,13 @@ migrateIt :: RunDbMonad m => SqlPersistT (R.ResourceT m) () migrateIt = do void $ runMigrationSilent migrateAll + void $ runMigrationSilent migrateUnique cleanDB + cleanUniques withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a withConn = - R.runResourceT . withPostgresqlConn "host=localhost port=5433 user=esqutest password=esqutest dbname=esqutest" + R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" -- | Show the SQL generated by a query showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend)