Add insert400 and insert400_, which check for violated uniqueness constraints.

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

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'