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

persistent 2.0 support (stolen from yesod-1.4 branch)

Browse Source
This commit is contained in:
Michael Snoyman 2014-06-09 11:44:05 +03:00
parent 4c2b8eec33
commit 7b8b7e00d4
7 changed files with 137 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
@ -161,6 +162,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
@ -172,6 +185,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
@ -193,6 +207,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
@ -203,6 +229,7 @@ defaultMaybeAuthId
, YesodPersist master
, Typeable val
) => HandlerT master IO (Maybe (AuthId master))
#endif
defaultMaybeAuthId = do
ms <- lookupSession credsKey
case ms of
@ -212,6 +239,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
@ -221,6 +259,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
@ -373,6 +412,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
@ -382,6 +432,7 @@ maybeAuth :: ( YesodAuth master
, YesodPersist master
, Typeable val
) => HandlerT master IO (Maybe (Entity val))
#endif
maybeAuth = runMaybeT $ do
aid <- MaybeT maybeAuthId
MaybeT $ cachedAuth aid
@ -395,6 +446,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))
@ -405,6 +468,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.:

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

@ -41,8 +41,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.5
, 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

@ -21,7 +21,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

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

@ -27,7 +27,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

6
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
@ -36,7 +36,7 @@ test-suite test
, wai-test
, wai-extra
, yesod-core
, persistent-sqlite
, persistent-sqlite >= 2.0
, yesod-persistent
, conduit
, blaze-builder