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 diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index 2b6904f6..b7cfefce 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,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 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' 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