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

persistent2

Browse Source
This commit is contained in:
Michael Snoyman 2014-01-16 08:23:50 +02:00
parent 1a43658455
commit db096471ca
7 changed files with 178 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -156,6 +156,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
@ -167,6 +179,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
@ -191,6 +204,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
@ -201,6 +226,7 @@ defaultMaybeAuthId
, YesodPersist master
, Typeable val
) => HandlerT master IO (Maybe (AuthId master))
#endif
defaultMaybeAuthId = do
ms <- lookupSession credsKey
case ms of
@ -210,6 +236,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
@ -219,6 +256,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
@ -363,6 +401,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
@ -372,6 +421,7 @@ maybeAuth :: ( YesodAuth master
, YesodPersist master
, Typeable val
) => HandlerT master IO (Maybe (Entity val))
#endif
maybeAuth = runMaybeT $ do
aid <- MaybeT maybeAuthId
MaybeT $ cachedAuth aid
@ -385,6 +435,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))
@ -395,6 +457,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.:

49
yesod-auth/Yesod/Auth/HashDB.hs
View File

@ -134,6 +134,18 @@ setPassword pwd u = do salt <- randomSalt
-- | Given a user ID and password in plaintext, validate them against
-- the database values.
#if MIN_VERSION_persistent(2, 0, 0)
validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod
, b ~ PersistEntityBackend user
, PersistUnique b
, PersistEntity user
, HashDBUser user
) =>
Unique user -- ^ User unique identifier
-> Text -- ^ Password in plaint-text
-> HandlerT yesod IO Bool
#else
validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod
, PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user
@ -144,6 +156,7 @@ validateUser :: ( YesodPersist yesod
Unique user -- ^ User unique identifier
-> Text -- ^ Password in plaint-text
-> HandlerT yesod IO Bool
#endif
validateUser userID passwd = do
-- Checks that hash and password match
let validate u = do hash <- userPasswordHash u
@ -160,6 +173,16 @@ login = PluginR "hashdb" ["login"]
-- | Handle the login form. First parameter is function which maps
-- username (whatever it might be) to unique user ID.
#if MIN_VERSION_persistent(2, 0, 0)
postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser user, PersistEntity user
, b ~ YesodPersistBackend y
, b ~ PersistEntityBackend user
, PersistUnique b
)
=> (Text -> Maybe (Unique user))
-> HandlerT Auth (HandlerT y IO) ()
#else
postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser user, PersistEntity user
, b ~ YesodPersistBackend y
@ -168,6 +191,7 @@ postLoginR :: ( YesodAuth y, YesodPersist y
)
=> (Text -> Maybe (Unique user))
-> HandlerT Auth (HandlerT y IO) ()
#endif
postLoginR uniq = do
(mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username"
@ -184,6 +208,19 @@ postLoginR uniq = do
-- | A drop in for the getAuthId method of your YesodAuth instance which
-- can be used if authHashDB is the only plugin in use.
#if MIN_VERSION_persistent(2, 0, 0)
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user
, Key user ~ AuthId master
, b ~ YesodPersistBackend master
, b ~ PersistEntityBackend user
, PersistUnique b
)
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
-> (Text -> Maybe (Unique user)) -- ^ gets user ID
-> Creds master -- ^ the creds argument
-> HandlerT master IO (Maybe (AuthId master))
#else
getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user
, Key user ~ AuthId master
@ -195,6 +232,7 @@ getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
-> (Text -> Maybe (Unique user)) -- ^ gets user ID
-> Creds master -- ^ the creds argument
-> HandlerT master IO (Maybe (AuthId master))
#endif
getAuthIdHashDB authR uniq creds = do
muid <- maybeAuthId
case muid of
@ -211,6 +249,16 @@ getAuthIdHashDB authR uniq creds = do
-- | Prompt for username and password, validate that against a database
-- which holds the username and a hash of the password
#if MIN_VERSION_persistent(2, 0, 0)
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user
, PersistEntity user
, b ~ YesodPersistBackend m
, b ~ PersistEntityBackend user
, PersistUnique b
)
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
#else
authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user
, PersistEntity user
@ -218,6 +266,7 @@ authHashDB :: ( YesodAuth m, YesodPersist m
, PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user
, PersistUnique (b (HandlerT m IO)))
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
#endif
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
$newline never
<div id="header">

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

@ -34,8 +34,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
, SHA >= 1.4.1.3
, http-conduit >= 1.5
, aeson >= 0.5

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

@ -73,7 +73,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
@ -525,12 +529,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 (YesodDB site)
, PathPiece (Key a)
, PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)
, RenderMessage site msg
)
#endif
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
@ -548,6 +561,16 @@ 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
@ -555,6 +578,7 @@ optionsPersistKey
, PathPiece (Key a)
, RenderMessage site msg
, PersistEntityBackend a ~ PersistMonadBackend (YesodDB site))
#endif
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)

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

@ -20,7 +20,7 @@ library
, hamlet >= 1.1 && < 1.2
, shakespeare-css >= 1.0 && < 1.1
, shakespeare-js >= 1.0.2 && < 1.3
, persistent >= 1.2 && < 1.4
, persistent >= 1.2 && < 2.1
, template-haskell
, transformers >= 0.2.2
, data-default

39
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
@ -32,10 +35,24 @@ 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 :: (* -> *) -> * -> *
#endif
runDB :: YesodDB site a -> HandlerT site IO a
-- | Helper for creating 'runDB'.
@ -78,7 +95,11 @@ newtype DBRunner site = DBRunner
-- | 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
@ -123,6 +144,11 @@ respondSourceDB :: YesodPersistRunner site
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)
@ -131,6 +157,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
@ -139,6 +166,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
@ -147,6 +179,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
@ -158,8 +191,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

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 && < 0.4
, blaze-builder
, conduit