packages feed

yesod-persistent 1.1.0.1 → 1.2.0

raw patch · 4 files changed

+201/−35 lines, 4 filesdep +blaze-builderdep +conduitdep +hspecdep ~basedep ~persistentdep ~persistent-template

Dependencies added: blaze-builder, conduit, hspec, lifted-base, persistent-sqlite, pool-conduit, resourcet, text, wai-test, yesod-persistent

Dependency ranges changed: base, persistent, persistent-template, yesod-core

Files

Yesod/Persist.hs view
@@ -1,8 +1,15 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Persist     ( YesodPersist (..)+    , defaultRunDB+    , YesodPersistRunner (..)+    , defaultGetDBRunner+    , DBRunner (..)+    , runDBSource+    , respondSourceDB     , YesodDB     , get404     , getBy404@@ -12,35 +19,116 @@  import Database.Persist import Database.Persist.TH-import Control.Monad.Trans.Class (MonadTrans)+import Database.Persist.Sql (SqlPersistT, unSqlPersistT)+import Control.Monad.Trans.Reader (runReaderT) -import Yesod.Handler+import Yesod.Core+import Data.Conduit+import Blaze.ByteString.Builder (Builder)+import Data.IORef.Lifted+import Data.Conduit.Pool+import Control.Monad.Trans.Resource+import qualified Database.Persist.Sql as SQL -type YesodDB sub master = YesodPersistBackend master (GHandler sub master)+type YesodDB site = YesodPersistBackend site (HandlerT site IO) -class YesodPersist master where-    type YesodPersistBackend master :: (* -> *) -> * -> *-    runDB :: YesodDB sub master a -> GHandler sub master a+class Monad (YesodPersistBackend site (HandlerT site IO)) => YesodPersist site where+    type YesodPersistBackend site :: (* -> *) -> * -> *+    runDB :: YesodDB site a -> HandlerT site IO 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+defaultRunDB getConfig getPool f = do+    master <- getYesod+    Database.Persist.runPool+        (getConfig master)+        f+        (getPool master)++-- |+--+-- Since 1.2.0+class YesodPersist site => YesodPersistRunner site where+    -- | This function differs from 'runDB' in that it returns a database+    -- runner function, as opposed to simply running a single action. This will+    -- usually mean that a connection is taken from a pool and then reused for+    -- each invocation. This can be useful for creating streaming responses;+    -- see 'runDBSource'.+    --+    -- It additionally returns a cleanup function to free the connection.  If+    -- your code finishes successfully, you /must/ call this cleanup to+    -- indicate changes should be committed. Otherwise, for SQL backends at+    -- least, a rollback will be used instead.+    --+    -- Since 1.2.0+    getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())++newtype DBRunner site = DBRunner+    { runDBRunner :: forall a. YesodDB site a -> HandlerT site IO 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 getPool = do+    ididSucceed <- newIORef False++    pool <- fmap getPool getYesod+    managedConn <- takeResource pool+    let conn = mrValue managedConn++    let withPrep f = f conn (SQL.connPrepare conn)+    (finishTransaction, ()) <- allocate (withPrep SQL.connBegin) $ \() -> do+        didSucceed <- readIORef ididSucceed+        withPrep $ if didSucceed+            then SQL.connCommit+            else SQL.connRollback++    let cleanup = do+            writeIORef ididSucceed True+            release finishTransaction+            mrReuse managedConn True+            mrRelease managedConn++    return (DBRunner $ \x -> runReaderT (unSqlPersistT x) conn, cleanup)++-- | Like 'runDB', but transforms a @Source@. See 'respondSourceDB' for an+-- example, practical use case.+--+-- Since 1.2.0+runDBSource :: YesodPersistRunner site+            => Source (YesodDB site) a+            -> Source (HandlerT site IO) a+runDBSource src = do+    (dbrunner, cleanup) <- lift getDBRunner+    transPipe (runDBRunner dbrunner) src+    lift cleanup++-- | Extends 'respondSource' to create a streaming database response body.+respondSourceDB :: YesodPersistRunner site+                => ContentType+                -> Source (YesodDB site) (Flush Builder)+                -> HandlerT site IO TypedContent+respondSourceDB ctype = respondSource ctype . runDBSource+ -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.-#if MIN_VERSION_persistent(1, 1, 0) get404 :: ( PersistStore (t m)           , PersistEntity val           , Monad (t m)-          , m ~ GHandler sub master+          , m ~ HandlerT site IO           , MonadTrans t           , PersistMonadBackend (t m) ~ PersistEntityBackend val           )        => Key val -> t m val-#else-get404 :: ( PersistStore b m-          , PersistEntity val-          , Monad (b m)-          , m ~ GHandler sub master-          , MonadTrans b-          )-       => Key b val -> b m val-#endif get404 key = do     mres <- get key     case mres of@@ -49,27 +137,22 @@  -- | Get the given entity by unique key, or return a 404 not found if it doesn't --   exist.-#if MIN_VERSION_persistent(1, 1, 0) getBy404 :: ( PersistUnique (t m)             , PersistEntity val-            , m ~ GHandler sub master+            , m ~ HandlerT site IO             , Monad (t m)             , MonadTrans t             , PersistEntityBackend val ~ PersistMonadBackend (t m)             )          => Unique val -> t m (Entity val)-#else-getBy404 :: ( PersistUnique b m-            , PersistEntity val-            , m ~ GHandler sub master-            , Monad (b m)-            , MonadTrans b-            , PersistEntityBackend val ~ b-            )-         => Unique val b -> b m (Entity val)-#endif getBy404 key = do     mres <- getBy key     case mres of         Nothing -> lift notFound         Just res -> return res++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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Yesod/PersistSpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs #-}+module Yesod.PersistSpec where++import Test.Hspec+import Database.Persist.Sqlite+import Network.Wai.Test+import Yesod.Core+import Data.Conduit+import Blaze.ByteString.Builder.Char.Utf8 (fromText)+import Yesod.Persist+import Data.Text (Text)++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+Person+    name Text+|]++data App = App+    { appConfig :: SqliteConf+    , appPool   :: ConnectionPool+    }++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App+instance YesodPersist App where+    type YesodPersistBackend App = SqlPersistT+    runDB = defaultRunDB appConfig appPool+instance YesodPersistRunner App where+    getDBRunner = defaultGetDBRunner appPool++getHomeR :: Handler TypedContent+getHomeR = do+    runDB $ do+        runMigration migrateAll+        deleteWhere ([] :: [Filter Person])+        insert_ $ Person "Charlie"+        insert_ $ Person "Alice"+        insert_ $ Person "Bob"+    respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder+  where+    toBuilder (Entity _ (Person name)) = do+        yield $ Chunk $ fromText name+        yield $ Chunk $ fromText "\n"+        yield Flush++test :: String -> Session () -> Spec+test name session = it name $ do+    let config = SqliteConf ":memory:" 1+    pool <- createPoolConfig config+    app <- toWaiApp $ App config pool+    runSession session app++spec :: Spec+spec = test "streaming" $ do+    sres <- request defaultRequest+    assertBody "Alice\nBob\nCharlie\n" sres+    assertStatus 200 sres
yesod-persistent.cabal view
@@ -1,5 +1,5 @@ name:            yesod-persistent-version:         1.1.0.1+version:         1.2.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -7,19 +7,40 @@ synopsis:        Some helpers for using Persistent from Yesod. category:        Web, Yesod, Database stability:       Stable-cabal-version:   >= 1.6+cabal-version:   >= 1.8 build-type:      Simple homepage:        http://www.yesodweb.com/ description:     Some helpers for using Persistent from Yesod.  library     build-depends:   base                      >= 4        && < 5-                   , yesod-core                >= 1.1      && < 1.2-                   , persistent                >= 1.0      && < 1.2-                   , persistent-template       >= 1.0      && < 1.2+                   , yesod-core                >= 1.2      && < 1.3+                   , persistent                >= 1.2      && < 1.3+                   , persistent-template       >= 1.2      && < 1.3                    , transformers              >= 0.2.2    && < 0.4+                   , blaze-builder+                   , conduit+                   , lifted-base+                   , pool-conduit+                   , resourcet     exposed-modules: Yesod.Persist     ghc-options:     -Wall++test-suite test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    hs-source-dirs: test+    other-modules: Yesod.PersistSpec+    build-depends: base+                 , hspec+                 , wai-test+                 , yesod-core+                 , persistent-sqlite+                 , yesod-persistent+                 , conduit+                 , blaze-builder+                 , persistent+                 , text  source-repository head   type:     git