From 8b2297adf400e4287f904d6a6d31c25c787e0449 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 27 Aug 2014 11:16:08 +0300 Subject: [PATCH] Conditional support for persistent2 branch. Pinging @gregwebs. I've backported the relevant tweaks on the yesod-1.4 branch, to allow master to compile against persistent2. Whenever you're ready to release persistent2, we can: 1. Release persistent2. 2. Release new versions of yesod packages, which will work with persistent 1.3 and 2.0. 3. Add an upper bound in Stackage to avoid using the new persistent libraries until they're ready for primetime. 4. Release your blog post. yesod-1.4 should then remove the CPP here and only work with persistent2; the biggest "breaking change" in the 1.4 release will be remove backwards compatibility hacks for persistent, conduit, shakespeare, and wai. --- yesod-auth/Yesod/Auth.hs | 68 ++++++++++++++++++++++ yesod-auth/yesod-auth.cabal | 4 +- yesod-form/Yesod/Form/Fields.hs | 26 ++++++++- yesod-form/yesod-form.cabal | 2 +- yesod-persistent/Yesod/Persist/Core.hs | 47 +++++++++++++-- yesod-persistent/test/Yesod/PersistSpec.hs | 3 +- yesod-persistent/yesod-persistent.cabal | 4 +- 7 files changed, 141 insertions(+), 13 deletions(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 535137b4..3a0cb4af 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} @@ -160,6 +161,18 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- Since 1.2.0 maybeAuthId :: HandlerT master IO (Maybe (AuthId master)) +#if MIN_VERSION_persistent(2, 0, 0) + default maybeAuthId + :: ( YesodAuth master + , PersistEntityBackend val ~ YesodPersistBackend master + , Key val ~ AuthId master + , PersistStore (PersistEntityBackend val) + , PersistEntity val + , YesodPersist master + , Typeable val + ) + => HandlerT master IO (Maybe (AuthId master)) +#else default maybeAuthId :: ( YesodAuth master , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val @@ -171,6 +184,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage , Typeable val ) => HandlerT master IO (Maybe (AuthId master)) +#endif maybeAuthId = defaultMaybeAuthId -- | Called on login error for HTTP requests. By default, calls @@ -192,6 +206,18 @@ credsKey = "_ID" -- 'maybeAuthIdRaw' for more information. -- -- Since 1.1.2 +#if MIN_VERSION_persistent(2, 0, 0) +defaultMaybeAuthId + :: ( YesodAuth master + , b ~ YesodPersistBackend master + , b ~ PersistEntityBackend val + , Key val ~ AuthId master + , PersistStore b + , PersistEntity val + , YesodPersist master + , Typeable val + ) => HandlerT master IO (Maybe (AuthId master)) +#else defaultMaybeAuthId :: ( YesodAuth master , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val @@ -202,6 +228,7 @@ defaultMaybeAuthId , YesodPersist master , Typeable val ) => HandlerT master IO (Maybe (AuthId master)) +#endif defaultMaybeAuthId = do ms <- lookupSession credsKey case ms of @@ -211,6 +238,17 @@ defaultMaybeAuthId = do Nothing -> return Nothing Just aid -> fmap (fmap entityKey) $ cachedAuth aid +#if MIN_VERSION_persistent(2, 0, 0) +cachedAuth :: ( YesodAuth master + , b ~ YesodPersistBackend master + , b ~ PersistEntityBackend val + , Key val ~ AuthId master + , PersistStore b + , PersistEntity val + , YesodPersist master + , Typeable val + ) => AuthId master -> HandlerT master IO (Maybe (Entity val)) +#else cachedAuth :: ( YesodAuth master , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val , b ~ YesodPersistBackend master @@ -220,6 +258,7 @@ cachedAuth :: ( YesodAuth master , YesodPersist master , Typeable val ) => AuthId master -> HandlerT master IO (Maybe (Entity val)) +#endif cachedAuth aid = runMaybeT $ do a <- MaybeT $ fmap unCachedMaybeAuth $ cached @@ -372,6 +411,17 @@ handlePluginR plugin pieces = do -- assumes that you are using a Persistent database. -- -- Since 1.1.0 +#if MIN_VERSION_persistent(2, 0, 0) +maybeAuth :: ( YesodAuth master + , b ~ YesodPersistBackend master + , b ~ PersistEntityBackend val + , Key val ~ AuthId master + , PersistStore b + , PersistEntity val + , YesodPersist master + , Typeable val + ) => HandlerT master IO (Maybe (Entity val)) +#else maybeAuth :: ( YesodAuth master , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val , b ~ YesodPersistBackend master @@ -381,6 +431,7 @@ maybeAuth :: ( YesodAuth master , YesodPersist master , Typeable val ) => HandlerT master IO (Maybe (Entity val)) +#endif maybeAuth = runMaybeT $ do aid <- MaybeT maybeAuthId MaybeT $ cachedAuth aid @@ -394,6 +445,18 @@ newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } -- full informatin on a given user. -- -- Since 1.2.0 +#if MIN_VERSION_persistent(2, 0, 0) +type YesodAuthPersist master = + ( YesodAuth master + , YesodPersistBackend master + ~ PersistEntityBackend (AuthEntity master) + , Key (AuthEntity master) ~ AuthId master + , PersistStore (YesodPersistBackend master) + , PersistEntity (AuthEntity master) + , YesodPersist master + , Typeable (AuthEntity master) + ) +#else type YesodAuthPersist master = ( YesodAuth master , PersistMonadBackend (YesodPersistBackend master (HandlerT master IO)) @@ -404,6 +467,7 @@ type YesodAuthPersist master = , YesodPersist master , Typeable (AuthEntity master) ) +#endif -- | If the @AuthId@ for a given site is a persistent ID, this will give the -- value for that entity. E.g.: @@ -413,6 +477,10 @@ type YesodAuthPersist master = -- -- Since 1.2.0 type AuthEntity master = KeyEntity (AuthId master) +#if MIN_VERSION_persistent(2, 0, 0) +type family KeyEntity key +type instance KeyEntity (Key x) = x +#endif -- | Similar to 'maybeAuthId', but redirects to a login page if user is not -- authenticated. diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index cf8b2476..a5a40dd3 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -45,8 +45,8 @@ library , unordered-containers , yesod-form >= 1.3 && < 1.4 , transformers >= 0.2.2 - , persistent >= 1.2 && < 1.4 - , persistent-template >= 1.2 && < 1.4 + , persistent >= 1.2 && < 2.1 + , persistent-template >= 1.2 && < 2.1 , http-conduit >= 1.5 , aeson >= 0.7 , lifted-base >= 0.1 diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index f3861238..00f748b4 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -75,7 +75,11 @@ import Data.Maybe (listToMaybe, fromMaybe) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) import Blaze.ByteString.Builder.Internal.Write (fromWriteList) +#if MIN_VERSION_persistent(2, 0, 0) +import Database.Persist (PersistEntityBackend) +#else import Database.Persist (PersistMonadBackend, PersistEntityBackend) +#endif import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.ByteString as S @@ -555,12 +559,21 @@ optionsPairs opts = do optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] +#if MIN_VERSION_persistent(2, 0, 0) +optionsPersist :: ( YesodPersist site, PersistEntity a + , PersistQuery (PersistEntityBackend a) + , PathPiece (Key a) + , RenderMessage site msg + , YesodPersistBackend site ~ PersistEntityBackend a + ) +#else optionsPersist :: ( YesodPersist site, PersistEntity a , PersistQuery (YesodPersistBackend site (HandlerT site IO)) , PathPiece (Key a) , PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO)) , RenderMessage site msg ) +#endif => [Filter a] -> [SelectOpt a] -> (a -> msg) @@ -578,13 +591,24 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do -- the entire @Entity@. -- -- Since 1.3.2 +#if MIN_VERSION_persistent(2, 0, 0) +optionsPersistKey + :: (YesodPersist site + , PersistEntity a + , PersistQuery (PersistEntityBackend a) + , PathPiece (Key a) + , RenderMessage site msg + , YesodPersistBackend site ~ PersistEntityBackend a + ) +#else optionsPersistKey :: (YesodPersist site , PersistEntity a , PersistQuery (YesodPersistBackend site (HandlerT site IO)) , PathPiece (Key a) , RenderMessage site msg - , PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO))) + , PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)) +#endif => [Filter a] -> [SelectOpt a] -> (a -> msg) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 668e3c1a..ec6cd546 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -25,7 +25,7 @@ library , shakespeare , shakespeare-css >= 1.0 , shakespeare-js >= 1.0.2 - , persistent >= 1.2 && < 1.4 + , persistent >= 1.2 && < 2.1 , template-haskell , transformers >= 0.2.2 , data-default diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index 1a338f3f..7f9b6b05 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -19,8 +20,10 @@ module Yesod.Persist.Core ) where import Database.Persist +#if !MIN_VERSION_persistent(2, 0, 0) import Database.Persist.Sql (SqlPersistT, unSqlPersistT) -import Control.Monad.Trans.Reader (runReaderT) +#endif +import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Yesod.Core import Data.Conduit @@ -31,11 +34,25 @@ import Control.Exception (throwIO) import Yesod.Core.Types (HandlerContents (HCError)) import qualified Database.Persist.Sql as SQL -type YesodDB site = YesodPersistBackend site (HandlerT site IO) +#if MIN_VERSION_persistent(2, 0, 0) +unSqlPersistT :: a -> a +unSqlPersistT = id +#endif +#if MIN_VERSION_persistent(2, 0, 0) +type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerT site IO) +#else +type YesodDB site = YesodPersistBackend site (HandlerT site IO) +#endif + +#if MIN_VERSION_persistent(2, 0, 0) +class Monad (YesodDB site) => YesodPersist site where + type YesodPersistBackend site +#else class Monad (YesodPersistBackend site (HandlerT site IO)) => YesodPersist site where type YesodPersistBackend site :: (* -> *) -> * -> * - runDB :: YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a +#endif + runDB :: YesodDB site a -> HandlerT site IO a -- | Helper for creating 'runDB'. -- @@ -71,13 +88,17 @@ class YesodPersist site => YesodPersistRunner site where getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ()) newtype DBRunner site = DBRunner - { runDBRunner :: forall a. YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a + { runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a } -- | Helper for implementing 'getDBRunner'. -- -- Since 1.2.0 +#if MIN_VERSION_persistent(2, 0, 0) +defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend +#else defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT +#endif => (site -> Pool SQL.Connection) -> HandlerT site IO (DBRunner site, HandlerT site IO ()) defaultGetDBRunner getPool = do @@ -106,7 +127,7 @@ defaultGetDBRunner getPool = do -- -- Since 1.2.0 runDBSource :: YesodPersistRunner site - => Source (YesodPersistBackend site (HandlerT site IO)) a + => Source (YesodDB site) a -> Source (HandlerT site IO) a runDBSource src = do (dbrunner, cleanup) <- lift getDBRunner @@ -116,11 +137,16 @@ runDBSource src = do -- | Extends 'respondSource' to create a streaming database response body. respondSourceDB :: YesodPersistRunner site => ContentType - -> Source (YesodPersistBackend site (HandlerT site IO)) (Flush Builder) + -> 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(2, 0, 0) +get404 :: (MonadIO m, PersistStore (PersistEntityBackend val), PersistEntity val) + => Key val + -> ReaderT (PersistEntityBackend val) m val +#else get404 :: ( PersistStore (t m) , PersistEntity val , Monad (t m) @@ -129,6 +155,7 @@ get404 :: ( PersistStore (t m) , PersistMonadBackend (t m) ~ PersistEntityBackend val ) => Key val -> t m val +#endif get404 key = do mres <- get key case mres of @@ -137,6 +164,11 @@ get404 key = do -- | Get the given entity by unique key, or return a 404 not found if it doesn't -- exist. +#if MIN_VERSION_persistent(2, 0, 0) +getBy404 :: (PersistUnique (PersistEntityBackend val), PersistEntity val, MonadIO m) + => Unique val + -> ReaderT (PersistEntityBackend val) m (Entity val) +#else getBy404 :: ( PersistUnique (t m) , PersistEntity val , m ~ HandlerT site IO @@ -145,6 +177,7 @@ getBy404 :: ( PersistUnique (t m) , PersistEntityBackend val ~ PersistMonadBackend (t m) ) => Unique val -> t m (Entity val) +#endif getBy404 key = do mres <- getBy key case mres of @@ -156,8 +189,10 @@ getBy404 key = do notFound' :: MonadIO m => m a notFound' = liftIO $ throwIO $ HCError NotFound +#if !MIN_VERSION_persistent(2, 0, 0) 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 +#endif diff --git a/yesod-persistent/test/Yesod/PersistSpec.hs b/yesod-persistent/test/Yesod/PersistSpec.hs index bf29910c..58cdb2c4 100644 --- a/yesod-persistent/test/Yesod/PersistSpec.hs +++ b/yesod-persistent/test/Yesod/PersistSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-} {-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Yesod.PersistSpec where import Test.Hspec @@ -27,7 +28,7 @@ mkYesod "App" [parseRoutes| 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 diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index b44499b6..a6ce68f7 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -15,8 +15,8 @@ description: Some helpers for using Persistent from Yesod. library build-depends: base >= 4 && < 5 , yesod-core >= 1.2.2 && < 1.3 - , persistent >= 1.2 && < 1.4 - , persistent-template >= 1.2 && < 1.4 + , persistent >= 1.2 && < 2.1 + , persistent-template >= 1.2 && < 2.1 , transformers >= 0.2.2 , blaze-builder , conduit