From c573f02d9de6f45380b53f2b4ba8e5b5636f7a48 Mon Sep 17 00:00:00 2001 From: Jason Whittle Date: Mon, 12 Dec 2016 01:54:27 -0500 Subject: [PATCH 1/3] Add insert400 and insert400_, which check for violated uniqueness constraints. --- yesod-persistent/Yesod/Persist/Core.hs | 25 ++++++++++++++++++++++ yesod-persistent/test/Yesod/PersistSpec.hs | 19 ++++++++++++---- 2 files changed, 40 insertions(+), 4 deletions(-) diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index 2b6904f6..3f8d6612 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -18,6 +18,8 @@ module Yesod.Persist.Core , YesodDB , get404 , getBy404 + , insert400 + , insert400_ ) where import Database.Persist @@ -163,7 +165,30 @@ getBy404 key = do Nothing -> notFound' Just res -> return res +-- | Create a new record in the database, returning an automatically +-- created key, or raise a 400 bad request if a uniqueness constraint +-- is violated. +insert400 :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) + => record + -> ReaderT backend m (Key record) +insert400 datum = do + conflict <- checkUnique datum + case conflict of + Just unique -> + badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique + Nothing -> insert datum + +-- | Same as 'insert400', but doesn’t return a key. +insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) + => record + -> ReaderT backend m () +insert400_ datum = insert400 datum >> return () + -- | Should be equivalent to @lift . notFound@, but there's an apparent bug in -- GHC 7.4.2 that leads to segfaults. This is a workaround. notFound' :: MonadIO m => m a notFound' = liftIO $ throwIO $ HCError NotFound + +-- | Constructed like 'notFound'', and for the same reasons. +badRequest' :: MonadIO m => Texts -> m a +badRequest' = liftIO . throwIO . HCError . InvalidArgs diff --git a/yesod-persistent/test/Yesod/PersistSpec.hs b/yesod-persistent/test/Yesod/PersistSpec.hs index 260b46c8..fa6a4986 100644 --- a/yesod-persistent/test/Yesod/PersistSpec.hs +++ b/yesod-persistent/test/Yesod/PersistSpec.hs @@ -17,6 +17,7 @@ import Data.Text (Text) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Person name Text + UniquePerson name |] data App = App @@ -26,6 +27,7 @@ data App = App mkYesod "App" [parseRoutes| / HomeR GET +/ins InsertR GET |] instance Yesod App @@ -50,6 +52,9 @@ getHomeR = do yield $ Chunk $ fromText "\n" yield Flush +getInsertR :: Handler () +getInsertR = runDB $ insert400_ $ Person "Alice" + test :: String -> Session () -> Spec test name session = it name $ do let config = SqliteConf ":memory:" 1 @@ -58,7 +63,13 @@ test name session = it name $ do runSession session app spec :: Spec -spec = test "streaming" $ do - sres <- request defaultRequest - assertBody "Alice\nBob\nCharlie\n" sres - assertStatus 200 sres +spec = do + test "streaming" $ do + sres <- request defaultRequest + assertBody "Alice\nBob\nCharlie\n" sres + assertStatus 200 sres + test "insert400" $ do + sres <- request defaultRequest + assertStatus 200 sres + sres' <- request $ defaultRequest `setPath` "/ins" + assertStatus 400 sres' From d526658c7b1a07050503183822ca36712a591c01 Mon Sep 17 00:00:00 2001 From: Jason Whittle Date: Mon, 12 Dec 2016 08:18:25 -0500 Subject: [PATCH 2/3] Implement the changes requested by @snoyberg. --- yesod-persistent/Yesod/Persist/Core.hs | 26 ++++++++++++++++++++----- yesod-persistent/yesod-persistent.cabal | 2 +- 2 files changed, 22 insertions(+), 6 deletions(-) diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index 3f8d6612..b7cfefce 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -168,9 +168,17 @@ getBy404 key = do -- | Create a new record in the database, returning an automatically -- created key, or raise a 400 bad request if a uniqueness constraint -- is violated. -insert400 :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) - => record - -> ReaderT backend m (Key record) +-- +-- @since 1.4.1 +#if MIN_VERSION_persistent(2,5,0) +insert400 :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend) + => val + -> ReaderT backend m (Key val) +#else +insert400 :: (MonadIO m, PersistUniqueWrite (PersistEntityBackend val), PersistEntity val) + => val + -> ReaderT (PersistEntityBackend val) m (Key val) +#endif insert400 datum = do conflict <- checkUnique datum case conflict of @@ -179,9 +187,17 @@ insert400 datum = do Nothing -> insert datum -- | Same as 'insert400', but doesn’t return a key. -insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) - => record +-- +-- @since 1.4.1 +#if MIN_VERSION_persistent(2,5,0) +insert400_ :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend val backend) + => val -> ReaderT backend m () +#else +insert400_ :: (MonadIO m, PersistUniqueWrite (PersistEntityBackend val), PersistEntity val) + => val + -> ReaderT (PersistEntityBackend val) m () +#endif insert400_ datum = insert400 datum >> return () -- | Should be equivalent to @lift . notFound@, but there's an apparent bug in diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index 4f9cc850..dd5eafc9 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -1,5 +1,5 @@ name: yesod-persistent -version: 1.4.0.6 +version: 1.4.1.0 license: MIT license-file: LICENSE author: Michael Snoyman From 2e284bbe64ee814dab004de55d250900143762ba Mon Sep 17 00:00:00 2001 From: Jason Whittle Date: Mon, 12 Dec 2016 08:23:16 -0500 Subject: [PATCH 3/3] Add notes to changelog for yesod-persistent 1.4.1.0. --- yesod-persistent/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-persistent/ChangeLog.md b/yesod-persistent/ChangeLog.md index b5aa45c8..91510491 100644 --- a/yesod-persistent/ChangeLog.md +++ b/yesod-persistent/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.1.0 + +* add `insert400` and `insert400_` + ## 1.4.0.6 * persistent-2.6