haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Conditional support for persistent2 branch.

Browse Source 
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.
This commit is contained in:
Michael Snoyman 2014-08-27 11:16:08 +03:00
parent 1539753562
commit 8b2297adf4
7 changed files with 141 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
yesod-auth/Yesod/Auth.hs
View File

@ -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.

4
yesod-auth/yesod-auth.cabal
View File

@ -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

26
yesod-form/Yesod/Form/Fields.hs
View File

@ -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)

2
yesod-form/yesod-form.cabal
View File

@ -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

47
yesod-persistent/Yesod/Persist/Core.hs
View File

@ -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

3
yesod-persistent/test/Yesod/PersistSpec.hs
View File

@ -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

4
yesod-persistent/yesod-persistent.cabal
View File

@ -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