yesod-persistent 1.2.3 → 1.6.0.9
raw patch · 5 files changed
Files
- ChangeLog.md +63/−0
- README.md +3/−0
- Yesod/Persist/Core.hs +100/−40
- test/Yesod/PersistSpec.hs +33/−8
- yesod-persistent.cabal +12/−9
+ ChangeLog.md view
@@ -0,0 +1,63 @@+# ChangeLog for yesod-persistent++## 1.6.0.9++* Support `yesod-core` 1.7++## 1.6.0.8++* Add support for `persistent-2.14` [#1706](https://github.com/yesodweb/yesod/pull/1760)++## 1.6.0.7++* Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723)++## 1.6.0.6++* Add support for persistent 2.12++## 1.6.0.5++* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)++## 1.6.0.4++* Fix test suite to be compatible with latest `persistent-template`+* See https://github.com/yesodweb/persistent/pull/1002+* [#1649](https://github.com/yesodweb/yesod/pull/1649/files)++## 1.6.0.3++* Replace call to `connPrepare` with `getStmtConn`. [#1635](https://github.com/yesodweb/yesod/issues/1635)++## 1.6.0.2++* Add support for persistent 2.10++## 1.6.0.1++* Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)++## 1.6.0++* Upgrade to yesod-core 1.6.0++## 1.4.3++* Fix overly powerful constraints on get404 and getBy404.++## 1.4.2++* Fix warnings++## 1.4.1.1++* Fix build failure with older persistent versions [#1324](https://github.com/yesodweb/yesod/issues/1324)++## 1.4.1.0++* add `insert400` and `insert400_`++## 1.4.0.6++* persistent-2.6
+ README.md view
@@ -0,0 +1,3 @@+## yesod-persistent++Some helpers for using Persistent from Yesod.
Yesod/Persist/Core.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | Defines the core functionality of this package. This package is -- distinguished from Yesod.Persist in that the latter additionally exports the -- persistent modules themselves.@@ -16,11 +20,12 @@ , YesodDB , get404 , getBy404+ , insert400+ , insert400_ ) where import Database.Persist-import Database.Persist.Sql (SqlPersistT, unSqlPersistT)-import Control.Monad.Trans.Reader (runReaderT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Yesod.Core import Data.Conduit@@ -30,21 +35,37 @@ import Control.Exception (throwIO) import Yesod.Core.Types (HandlerContents (HCError)) import qualified Database.Persist.Sql as SQL+#if MIN_VERSION_persistent(2,13,0)+import Data.List.NonEmpty (toList)+import qualified Database.Persist.SqlBackend.Internal as SQL+#endif -type YesodDB site = YesodPersistBackend site (HandlerT site IO)+unSqlPersistT :: a -> a+unSqlPersistT = id -class Monad (YesodPersistBackend site (HandlerT site IO)) => YesodPersist site where- type YesodPersistBackend site :: (* -> *) -> * -> *- runDB :: YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a+type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerFor site) +class Monad (YesodDB site) => YesodPersist site where+ type YesodPersistBackend site+ -- | Allows you to execute database actions within Yesod Handlers. For databases that support it, code inside the action will run as an atomic transaction.+ --+ --+ -- ==== __Example Usage__+ --+ -- > userId <- runDB $ do+ -- > userId <- insert $ User "username" "email@example.com"+ -- > insert_ $ UserPreferences userId True+ -- > pure userId+ runDB :: YesodDB site a -> HandlerFor site a+ -- | Helper for creating 'runDB'. -- -- Since 1.2.0 defaultRunDB :: PersistConfig c => (site -> c) -> (site -> PersistConfigPool c)- -> PersistConfigBackend c (HandlerT site IO) a- -> HandlerT site IO a+ -> PersistConfigBackend c (HandlerFor site) a+ -> HandlerFor site a defaultRunDB getConfig getPool f = do master <- getYesod Database.Persist.runPool@@ -68,25 +89,29 @@ -- least, a rollback will be used instead. -- -- Since 1.2.0- getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())+ getDBRunner :: HandlerFor site (DBRunner site, HandlerFor site ()) newtype DBRunner site = DBRunner- { runDBRunner :: forall a. YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a+ { runDBRunner :: forall a. YesodDB site a -> HandlerFor site a } -- | Helper for implementing 'getDBRunner'. -- -- Since 1.2.0-defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT- => (site -> Pool SQL.Connection)- -> HandlerT site IO (DBRunner site, HandlerT site IO ())+defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)+ => (site -> Pool backend)+ -> HandlerFor site (DBRunner site, HandlerFor site ()) defaultGetDBRunner getPool = do pool <- fmap getPool getYesod- let withPrep conn f = f conn (SQL.connPrepare conn)+ let withPrep conn f = f (persistBackend conn) (SQL.getStmtConn $ persistBackend conn) (relKey, (conn, local)) <- allocate (do (conn, local) <- takeResource pool+#if MIN_VERSION_persistent(2,9,0)+ withPrep conn (\c f -> SQL.connBegin c f Nothing)+#else withPrep conn SQL.connBegin+#endif return (conn, local) ) (\(conn, local) -> do@@ -106,8 +131,8 @@ -- -- Since 1.2.0 runDBSource :: YesodPersistRunner site- => Source (YesodPersistBackend site (HandlerT site IO)) a- -> Source (HandlerT site IO) a+ => ConduitT () a (YesodDB site) ()+ -> ConduitT () a (HandlerFor site) () runDBSource src = do (dbrunner, cleanup) <- lift getDBRunner transPipe (runDBRunner dbrunner) src@@ -116,19 +141,14 @@ -- | Extends 'respondSource' to create a streaming database response body. respondSourceDB :: YesodPersistRunner site => ContentType- -> Source (YesodPersistBackend site (HandlerT site IO)) (Flush Builder)- -> HandlerT site IO TypedContent+ -> ConduitT () (Flush Builder) (YesodDB site) ()+ -> HandlerFor site TypedContent respondSourceDB ctype = respondSource ctype . runDBSource -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.-get404 :: ( PersistStore (t m)- , PersistEntity val- , Monad (t m)- , m ~ HandlerT site IO- , MonadTrans t- , PersistMonadBackend (t m) ~ PersistEntityBackend val- )- => Key val -> t m val+get404 :: (MonadIO m, PersistStoreRead backend, PersistRecordBackend val backend)+ => Key val+ -> ReaderT backend m val get404 key = do mres <- get key case mres of@@ -137,27 +157,67 @@ -- | Get the given entity by unique key, or return a 404 not found if it doesn't -- exist.-getBy404 :: ( PersistUnique (t m)- , PersistEntity val- , m ~ HandlerT site IO- , Monad (t m)- , MonadTrans t- , PersistEntityBackend val ~ PersistMonadBackend (t m)- )- => Unique val -> t m (Entity val)+getBy404 :: (PersistUniqueRead backend, PersistRecordBackend val backend, MonadIO m)+ => Unique val+ -> ReaderT backend m (Entity val) getBy404 key = do mres <- getBy key case mres of 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+insert400+ :: ( MonadIO m+ , PersistUniqueWrite backend+ , PersistRecordBackend val backend+#if MIN_VERSION_persistent(2,14,0)+ , SafeToInsert val+#endif+ )+ => val+ -> ReaderT backend m (Key val)+insert400 datum = do+ conflict <- checkUnique datum+ case conflict of+ Just unique ->+ badRequest' $ map (getName . fst) $ mkList $ persistUniqueToFieldNames unique+ Nothing -> insert datum+ where+#if MIN_VERSION_persistent(2,12,0)+ getName = unFieldNameHS+#else+ getName = unHaskellName+#endif+#if MIN_VERSION_persistent(2,13,0)+ mkList = toList+#else+ mkList = id+#endif++-- | Same as 'insert400', but doesn’t return a key.+--+-- @since 1.4.1+insert400_ :: ( MonadIO m+ , PersistUniqueWrite backend+ , PersistRecordBackend val backend+#if MIN_VERSION_persistent(2,14,0)+ , SafeToInsert val+#endif+ )+ => val+ -> 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 -instance MonadHandler m => MonadHandler (SqlPersistT m) where- type HandlerSite (SqlPersistT m) = HandlerSite m- liftHandlerT = lift . liftHandlerT-instance MonadWidget m => MonadWidget (SqlPersistT m) where- liftWidgetT = lift . liftWidgetT+-- | Constructed like 'notFound'', and for the same reasons.+badRequest' :: MonadIO m => Texts -> m a+badRequest' = liftIO . throwIO . HCError . InvalidArgs
test/Yesod/PersistSpec.hs view
@@ -1,5 +1,19 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}-{-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+ module Yesod.PersistSpec where import Test.Hspec@@ -14,6 +28,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Person name Text+ UniquePerson name |] data App = App@@ -23,11 +38,12 @@ mkYesod "App" [parseRoutes| / HomeR GET+/ins InsertR GET |] instance Yesod App instance YesodPersist App where- type YesodPersistBackend App = SqlPersistT+ type YesodPersistBackend App = SqlBackend runDB = defaultRunDB appConfig appPool instance YesodPersistRunner App where getDBRunner = defaultGetDBRunner appPool@@ -40,13 +56,16 @@ insert_ $ Person "Charlie" insert_ $ Person "Alice" insert_ $ Person "Bob"- respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder+ respondSourceDB typePlain $ selectSource [] [Asc PersonName] .| awaitForever toBuilder where toBuilder (Entity _ (Person name)) = do yield $ Chunk $ fromText name 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@@ -55,7 +74,13 @@ 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.cabal view
@@ -1,5 +1,6 @@+cabal-version: >= 1.10 name: yesod-persistent-version: 1.2.3+version: 1.6.0.9 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -7,16 +8,17 @@ synopsis: Some helpers for using Persistent from Yesod. category: Web, Yesod, Database stability: Stable-cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/-description: Some helpers for using Persistent from Yesod.+description: API docs and the README are available at <http://www.stackage.org/package/yesod-persistent>+extra-source-files: README.md ChangeLog.md library- build-depends: base >= 4 && < 5- , yesod-core >= 1.2.2 && < 1.3- , persistent >= 1.2 && < 1.4- , persistent-template >= 1.2 && < 1.4+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5+ , yesod-core >= 1.6 && < 1.8+ , persistent >= 2.8+ , persistent-template >= 2.1 , transformers >= 0.2.2 , blaze-builder , conduit@@ -27,16 +29,17 @@ ghc-options: -Wall test-suite test+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test other-modules: Yesod.PersistSpec+ build-tool-depends: hspec-discover:hspec-discover build-depends: base , hspec- , wai-test , wai-extra , yesod-core- , persistent-sqlite+ , persistent-sqlite >= 2.8 , yesod-persistent , conduit , blaze-builder