Merge pull request #1321 from whittle/insert400

Add insert400 and insert400_

yesod-persistent/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.1.0
+
+* add `insert400` and `insert400_`
+
 ## 1.4.0.6
 
 * persistent-2.6

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,46 @@ 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.
+--
+-- @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
+        Just unique ->
+            badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique
+        Nothing -> insert datum
+
+-- | Same as 'insert400', but doesn’t return a key.
+--
+-- @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
 -- 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

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'

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 <michael@snoyman.com>