diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +## yesod-persistent + +Some helpers for using Persistent from Yesod. diff --git a/Yesod/Persist/Core.hs b/Yesod/Persist/Core.hs --- a/Yesod/Persist/Core.hs +++ b/Yesod/Persist/Core.hs @@ -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 diff --git a/test/Yesod/PersistSpec.hs b/test/Yesod/PersistSpec.hs --- a/test/Yesod/PersistSpec.hs +++ b/test/Yesod/PersistSpec.hs @@ -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' diff --git a/yesod-persistent.cabal b/yesod-persistent.cabal --- a/yesod-persistent.cabal +++ b/yesod-persistent.cabal @@ -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 @@ -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 +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