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

Everything compiles

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-14 09:28:51 +02:00
parent 3df45ac1c7
commit 9c4cd573b4
26 changed files with 352 additions and 315 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -25,6 +25,8 @@ module Yesod.Auth
, requireAuth , requireAuth
-- * Exception -- * Exception
, AuthException (..) , AuthException (..)
-- * Helper
, AuthHandler
) where ) where
import Control.Monad (when) import Control.Monad (when)
@ -39,8 +41,6 @@ import qualified Data.Text as T
import qualified Data.HashMap.Lazy as Map import qualified Data.HashMap.Lazy as Map
import Network.HTTP.Conduit (Manager) import Network.HTTP.Conduit (Manager)
import Language.Haskell.TH.Syntax hiding (lift)
import qualified Network.Wai as W import qualified Network.Wai as W
import Text.Hamlet (shamlet) import Text.Hamlet (shamlet)
@ -51,10 +51,11 @@ import qualified Yesod.Auth.Message as Msg
import Yesod.Form (FormMessage) import Yesod.Form (FormMessage)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad.Trans.Class
type AuthRoute = Route Auth type AuthRoute = Route Auth
type AuthHandler master a = YesodAuth master => HandlerT Auth (GHandler master) a type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a
type Method = Text type Method = Text
type Piece = Text type Piece = Text
@ -62,7 +63,7 @@ type Piece = Text
data AuthPlugin master = AuthPlugin data AuthPlugin master = AuthPlugin
{ apName :: Text { apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master () , apDispatch :: Method -> [Piece] -> AuthHandler master ()
, apLogin :: (Route Auth -> Text) -> GWidget master () , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
} }
getAuth :: a -> Auth getAuth :: a -> Auth
@ -87,7 +88,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
logoutDest :: master -> Route master logoutDest :: master -> Route master
-- | Determine the ID associated with the set of credentials. -- | Determine the ID associated with the set of credentials.
getAuthId :: Creds master -> GHandler master (Maybe (AuthId master)) getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
-- | Which authentication backends to use. -- | Which authentication backends to use.
authPlugins :: master -> [AuthPlugin master] authPlugins :: master -> [AuthPlugin master]
@ -95,16 +96,17 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | What to show on the login page. -- | What to show on the login page.
loginHandler :: AuthHandler master RepHtml loginHandler :: AuthHandler master RepHtml
loginHandler = do loginHandler = do
render <- getUrlRender tp <- getRouteToParent
lift $ defaultLayout $ do lift $ defaultLayout $ do
setTitleI Msg.LoginTitle setTitleI Msg.LoginTitle
master <- lift getYesod master <- getYesod
mapM_ (flip apLogin render) (authPlugins master) mapM_ (flip apLogin tp) (authPlugins master)
-- | Used for i18n of messages provided by this package. -- | Used for i18n of messages provided by this package.
renderAuthMessage :: master renderAuthMessage :: master
-> [Text] -- ^ languages -> [Text] -- ^ languages
-> AuthMessage -> Text -> AuthMessage
-> Text
renderAuthMessage _ _ = defaultMessage renderAuthMessage _ _ = defaultMessage
-- | After login and logout, redirect to the referring page, instead of -- | After login and logout, redirect to the referring page, instead of
@ -120,11 +122,11 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | Called on a successful login. By default, calls -- | Called on a successful login. By default, calls
-- @setMessageI NowLoggedIn@. -- @setMessageI NowLoggedIn@.
onLogin :: GHandler master () onLogin :: HandlerT master IO ()
onLogin = setMessageI Msg.NowLoggedIn onLogin = setMessageI Msg.NowLoggedIn
-- | Called on logout. By default, does nothing -- | Called on logout. By default, does nothing
onLogout :: GHandler master () onLogout :: HandlerT master IO ()
onLogout = return () onLogout = return ()
-- | Retrieves user credentials, if user is authenticated. -- | Retrieves user credentials, if user is authenticated.
@ -136,7 +138,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- other than a browser. -- other than a browser.
-- --
-- Since 1.1.2 -- Since 1.1.2
maybeAuthId :: GHandler master (Maybe (AuthId master)) maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId maybeAuthId = defaultMaybeAuthId
credsKey :: Text credsKey :: Text
@ -146,15 +148,15 @@ credsKey = "_ID"
-- --
-- Since 1.1.2 -- Since 1.1.2
defaultMaybeAuthId :: YesodAuth master defaultMaybeAuthId :: YesodAuth master
=> GHandler master (Maybe (AuthId master)) => HandlerT master IO (Maybe (AuthId master))
defaultMaybeAuthId = do defaultMaybeAuthId = do
ms <- lookupSession credsKey ms <- lookupSession credsKey
case ms of case ms of
Nothing -> return Nothing Nothing -> return Nothing
Just s -> return $ fromPathPiece s Just s -> return $ fromPathPiece s
setCreds :: Bool -> Creds master -> AuthHandler master () setCreds :: YesodAuth master => Bool -> Creds master -> HandlerT master IO ()
setCreds doRedirects creds = lift $ do setCreds doRedirects creds = do
y <- getYesod y <- getYesod
maid <- getAuthId creds maid <- getAuthId creds
case maid of case maid of
@ -233,14 +235,14 @@ handlePluginR plugin pieces = do
ap:_ -> apDispatch ap method pieces ap:_ -> apDispatch ap method pieces
maybeAuth :: ( YesodAuth master maybeAuth :: ( YesodAuth master
, PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend val , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
, b ~ YesodPersistBackend master , b ~ YesodPersistBackend master
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistStore (b (GHandler master)) , PersistStore (b (HandlerT master IO))
, PersistEntity val , PersistEntity val
, YesodPersist master , YesodPersist master
, Typeable val , Typeable val
) => GHandler master (Maybe (Entity val)) ) => HandlerT master IO (Maybe (Entity val))
maybeAuth = runMaybeT $ do maybeAuth = runMaybeT $ do
aid <- MaybeT $ maybeAuthId aid <- MaybeT $ maybeAuthId
a <- MaybeT a <- MaybeT
@ -254,21 +256,21 @@ maybeAuth = runMaybeT $ do
newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
deriving Typeable deriving Typeable
requireAuthId :: YesodAuth master => GHandler master (AuthId master) requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)
requireAuthId = maybeAuthId >>= maybe redirectLogin return requireAuthId = maybeAuthId >>= maybe redirectLogin return
requireAuth :: ( YesodAuth master requireAuth :: ( YesodAuth master
, b ~ YesodPersistBackend master , b ~ YesodPersistBackend master
, PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend val , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistStore (b (GHandler master)) , PersistStore (b (HandlerT master IO))
, PersistEntity val , PersistEntity val
, YesodPersist master , YesodPersist master
, Typeable val , Typeable val
) => GHandler master (Entity val) ) => HandlerT master IO (Entity val)
requireAuth = maybeAuth >>= maybe redirectLogin return requireAuth = maybeAuth >>= maybe redirectLogin return
redirectLogin :: Yesod master => GHandler master a redirectLogin :: Yesod master => HandlerT master IO a
redirectLogin = do redirectLogin = do
y <- getYesod y <- getYesod
setUltDestCurrent setUltDestCurrent
@ -284,5 +286,5 @@ data AuthException = InvalidBrowserIDAssertion
deriving (Show, Typeable) deriving (Show, Typeable)
instance Exception AuthException instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (GHandler master) where instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)

15
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -22,6 +22,7 @@ import Data.Aeson (toJSON)
import Network.URI (uriPath, parseURI) import Network.URI (uriPath, parseURI)
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Control.Monad.Trans.Class
pid :: Text pid :: Text
pid = "browserid" pid = "browserid"
@ -59,7 +60,7 @@ helper maudience = AuthPlugin
memail <- lift $ checkAssertion audience assertion (authHttpManager master) memail <- lift $ checkAssertion audience assertion (authHttpManager master)
case memail of case memail of
Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion
Just email -> setCreds True Creds Just email -> lift $ setCreds True Creds
{ credsPlugin = pid { credsPlugin = pid
, credsIdent = email , credsIdent = email
, credsExtra = [] , credsExtra = []
@ -73,7 +74,7 @@ helper maudience = AuthPlugin
, apLogin = \toMaster -> do , apLogin = \toMaster -> do
onclick <- createOnClick toMaster onclick <- createOnClick toMaster
autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin" autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
when autologin $ toWidget [julius| when autologin $ toWidget [julius|
#{rawJS onclick}(); #{rawJS onclick}();
|] |]
@ -82,7 +83,7 @@ helper maudience = AuthPlugin
$newline never $newline never
<p> <p>
<a href="javascript:#{onclick}()"> <a href="javascript:#{onclick}()">
<img src=#{toMaster loginIcon}> <img src=@{toMaster loginIcon}>
|] |]
} }
where where
@ -91,18 +92,18 @@ $newline never
-- | Generates a function to handle on-click events, and returns that function -- | Generates a function to handle on-click events, and returns that function
-- name. -- name.
createOnClick :: (Route Auth -> Text) -> GWidget master Text createOnClick :: (Route Auth -> Route master) -> WidgetT master IO Text
createOnClick toMaster = do createOnClick toMaster = do
addScriptRemote browserIdJs addScriptRemote browserIdJs
onclick <- newIdent onclick <- newIdent
render <- getUrlRender render <- getUrlRender
let login = toJSON $ getPath $ toMaster LoginR let login = toJSON $ getPath $ render $ toMaster LoginR
toWidget [julius| toWidget [julius|
function #{rawJS onclick}() { function #{rawJS onclick}() {
navigator.id.watch({ navigator.id.watch({
onlogin: function (assertion) { onlogin: function (assertion) {
if (assertion) { if (assertion) {
document.location = #{toJSON $ toMaster complete} + "/" + assertion; document.location = "@{toMaster complete}" + "/" + assertion;
} }
}, },
onlogout: function () {} onlogout: function () {}
@ -113,7 +114,7 @@ createOnClick toMaster = do
} }
|] |]
autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin" autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
when autologin $ toWidget [julius|#{rawJS onclick}();|] when autologin $ toWidget [julius|#{rawJS onclick}();|]
return onclick return onclick
where where

5
yesod-auth/Yesod/Auth/Dummy.hs
View File

@ -11,6 +11,7 @@ import Yesod.Auth
import Yesod.Form (runInputPost, textField, ireq) import Yesod.Form (runInputPost, textField, ireq)
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Yesod.Core import Yesod.Core
import Control.Monad.Trans.Class
authDummy :: YesodAuth m => AuthPlugin m authDummy :: YesodAuth m => AuthPlugin m
authDummy = authDummy =
@ -18,13 +19,13 @@ authDummy =
where where
dispatch "POST" [] = do dispatch "POST" [] = do
ident <- lift $ runInputPost $ ireq textField "ident" ident <- lift $ runInputPost $ ireq textField "ident"
setCreds True $ Creds "dummy" ident [] lift $ setCreds True $ Creds "dummy" ident []
dispatch _ _ = notFound dispatch _ _ = notFound
url = PluginR "dummy" [] url = PluginR "dummy" []
login authToMaster = login authToMaster =
toWidget [hamlet| toWidget [hamlet|
$newline never $newline never
<form method="post" action="#{authToMaster url}"> <form method="post" action="@{authToMaster url}">
Your new identifier is: # Your new identifier is: #
<input type="text" name="ident"> <input type="text" name="ident">
<input type="submit" value="Dummy Login"> <input type="submit" value="Dummy Login">

83
yesod-auth/Yesod/Auth/Email.hs
View File

@ -27,6 +27,7 @@ import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Text (Text) import Data.Text (Text)
import qualified Crypto.PasswordStore as PS import qualified Crypto.PasswordStore as PS
import qualified Data.Text.Encoding as DTE import qualified Data.Text.Encoding as DTE
import Control.Monad.Trans.Class
import Yesod.Form import Yesod.Form
import Yesod.Core import Yesod.Core
@ -55,21 +56,21 @@ data EmailCreds m = EmailCreds
, emailCredsVerkey :: Maybe VerKey , emailCredsVerkey :: Maybe VerKey
} }
class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where
type AuthEmailId m type AuthEmailId site
addUnverified :: Email -> VerKey -> GHandler m (AuthEmailId m) addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)
sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler m () sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO ()
getVerifyKey :: AuthEmailId m -> GHandler m (Maybe VerKey) getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey)
setVerifyKey :: AuthEmailId m -> VerKey -> GHandler m () setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
verifyAccount :: AuthEmailId m -> GHandler m (Maybe (AuthId m)) verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))
getPassword :: AuthId m -> GHandler m (Maybe SaltedPass) getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass)
setPassword :: AuthId m -> SaltedPass -> GHandler m () setPassword :: AuthId site -> SaltedPass -> HandlerT site IO ()
getEmailCreds :: Email -> GHandler m (Maybe (EmailCreds m)) getEmailCreds :: Email -> HandlerT site IO (Maybe (EmailCreds site))
getEmail :: AuthEmailId m -> GHandler m (Maybe Email) getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email)
-- | Generate a random alphanumeric string. -- | Generate a random alphanumeric string.
randomKey :: m -> IO Text randomKey :: site -> IO Text
randomKey _ = do randomKey _ = do
stdgen <- newStdGen stdgen <- newStdGen
return $ TS.pack $ fst $ randomString 10 stdgen return $ TS.pack $ fst $ randomString 10 stdgen
@ -79,7 +80,7 @@ authEmail =
AuthPlugin "email" dispatch $ \tm -> AuthPlugin "email" dispatch $ \tm ->
[whamlet| [whamlet|
$newline never $newline never
<form method="post" action="#{tm loginR}"> <form method="post" action="@{tm loginR}">
<table> <table>
<tr> <tr>
<th>_{Msg.Email} <th>_{Msg.Email}
@ -92,7 +93,7 @@ $newline never
<tr> <tr>
<td colspan="2"> <td colspan="2">
<input type="submit" value=_{Msg.LoginViaEmail}> <input type="submit" value=_{Msg.LoginViaEmail}>
<a href="#{tm registerR}">I don't have an account <a href="@{tm registerR}">I don't have an account
|] |]
where where
dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "GET" ["register"] = getRegisterR >>= sendResponse
@ -106,21 +107,21 @@ $newline never
dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
dispatch _ _ = notFound dispatch _ _ = notFound
getRegisterR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) RepHtml
getRegisterR = do getRegisterR = do
email <- newIdent email <- newIdent
mrender <- getMessageRender tp <- getRouteToParent
defaultLayoutT $ do lift $ defaultLayout $ do
setTitle $ toHtml $ mrender Msg.RegisterLong setTitleI Msg.RegisterLong
[whamlet| [whamlet|
<p>#{mrender Msg.EnterEmail} <p>_{Msg.EnterEmail}
<form method="post" action="@{registerR}"> <form method="post" action="@{tp registerR}">
<label for=#{email}>#{mrender Msg.Email} <label for=#{email}>_{Msg.Email}
<input ##{email} type="email" name="email" width="150"> <input ##{email} type="email" name="email" width="150">
<input type="submit" value=#{mrender Msg.Register}> <input type="submit" value=_{Msg.Register}>
|] |]
postRegisterR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml postRegisterR :: YesodAuthEmail master => AuthHandler master RepHtml
postRegisterR = do postRegisterR = do
y <- lift getYesod y <- lift getYesod
email <- lift $ runInputPost $ ireq emailField "email" email <- lift $ runInputPost $ ireq emailField "email"
@ -146,7 +147,7 @@ postRegisterR = do
getVerifyR :: YesodAuthEmail m getVerifyR :: YesodAuthEmail m
=> AuthEmailId m => AuthEmailId m
-> Text -> Text
-> HandlerT Auth (GHandler m) RepHtml -> HandlerT Auth (HandlerT m IO) RepHtml
getVerifyR lid key = do getVerifyR lid key = do
realKey <- lift $ getVerifyKey lid realKey <- lift $ getVerifyKey lid
memail <- lift $ getEmail lid memail <- lift $ getEmail lid
@ -156,16 +157,15 @@ getVerifyR lid key = do
case muid of case muid of
Nothing -> return () Nothing -> return ()
Just _uid -> do Just _uid -> do
setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid? lift $ setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?
mrender <- lift getMessageRender lift $ setMessageI Msg.AddressVerified
setMessage $ toHtml $ mrender Msg.AddressVerified
redirect setpassR redirect setpassR
_ -> return () _ -> return ()
lift $ defaultLayout $ do lift $ defaultLayout $ do
setTitleI Msg.InvalidKey setTitleI Msg.InvalidKey
[whamlet|<p>_{Msg.InvalidKey}|] [whamlet|<p>_{Msg.InvalidKey}|]
postLoginR :: YesodAuthEmail master => HandlerT Auth (GHandler master) () postLoginR :: YesodAuthEmail master => AuthHandler master ()
postLoginR = do postLoginR = do
(email, pass) <- lift $ runInputPost $ (,) (email, pass) <- lift $ runInputPost $ (,)
<$> ireq emailField "email" <$> ireq emailField "email"
@ -184,46 +184,45 @@ postLoginR = do
_ -> return Nothing _ -> return Nothing
case maid of case maid of
Just _aid -> Just _aid ->
setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? lift $ setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?
Nothing -> do Nothing -> do
mrender <- lift getMessageRender lift $ setMessageI Msg.InvalidEmailPass
setMessage $ toHtml $ mrender Msg.InvalidEmailPass
redirect LoginR redirect LoginR
getPasswordR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) RepHtml
getPasswordR = do getPasswordR = do
maid <- lift maybeAuthId maid <- lift maybeAuthId
pass1 <- newIdent pass1 <- newIdent
pass2 <- newIdent pass2 <- newIdent
mrender <- lift getMessageRender
case maid of case maid of
Just _ -> return () Just _ -> return ()
Nothing -> do Nothing -> do
setMessage $ toHtml $ mrender Msg.BadSetPass lift $ setMessageI Msg.BadSetPass
redirect LoginR redirect LoginR
defaultLayoutT $ do tp <- getRouteToParent
setTitle $ toHtml $ mrender Msg.SetPassTitle -- FIXME make setTitleI more intelligent lift $ defaultLayout $ do
setTitleI Msg.SetPassTitle
[whamlet| [whamlet|
$newline never $newline never
<h3>#{mrender Msg.SetPass} <h3>_{Msg.SetPass}
<form method="post" action="@{setpassR}"> <form method="post" action="@{tp setpassR}">
<table> <table>
<tr> <tr>
<th> <th>
<label for=#{pass1}>#{mrender Msg.NewPass} <label for=#{pass1}>_{Msg.NewPass}
<td> <td>
<input ##{pass1} type="password" name="new"> <input ##{pass1} type="password" name="new">
<tr> <tr>
<th> <th>
<label for=#{pass2}>#{mrender Msg.ConfirmPass} <label for=#{pass2}>_{Msg.ConfirmPass}
<td> <td>
<input ##{pass2} type="password" name="confirm"> <input ##{pass2} type="password" name="confirm">
<tr> <tr>
<td colspan="2"> <td colspan="2">
<input type="submit" value=#{mrender Msg.SetPassTitle}> <input type="submit" value=_{Msg.SetPassTitle}>
|] |]
postPasswordR :: YesodAuthEmail master => HandlerT Auth (GHandler master) () postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
postPasswordR = do postPasswordR = do
(new, confirm) <- lift $ runInputPost $ (,) (new, confirm) <- lift $ runInputPost $ (,)
<$> ireq textField "new" <$> ireq textField "new"

7
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -24,6 +24,7 @@ import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
import qualified Data.Text as T import qualified Data.Text as T
import Control.Exception.Lifted (try, SomeException) import Control.Exception.Lifted (try, SomeException)
import Control.Monad.Trans.Class
pid :: Text pid :: Text
pid = "googleemail" pid = "googleemail"
@ -40,7 +41,7 @@ authGoogleEmail =
where where
complete = PluginR pid ["complete"] complete = PluginR pid ["complete"]
login tm = login tm =
[whamlet|<a href=#{tm forwardUrl}>_{Msg.LoginGoogle}|] [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
render <- getUrlRender render <- getUrlRender
let complete' = render complete let complete' = render complete
@ -70,7 +71,7 @@ authGoogleEmail =
completeHelper posts completeHelper posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(Text, Text)] -> HandlerT Auth (GHandler m) () completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master ()
completeHelper gets' = do completeHelper gets' = do
master <- lift getYesod master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
@ -81,7 +82,7 @@ completeHelper gets' = do
let OpenId.Identifier ident = OpenId.oirOpLocal oir let OpenId.Identifier ident = OpenId.oirOpLocal oir
memail <- lookupGetParam "openid.ext1.value.email" memail <- lookupGetParam "openid.ext1.value.email"
case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
(Just email, True) -> setCreds True $ Creds pid email [] (Just email, True) -> lift $ setCreds True $ Creds pid email []
(_, False) -> do (_, False) -> do
setMessage "Only Google login is supported" setMessage "Only Google login is supported"
redirect LoginR redirect LoginR

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

@ -81,6 +81,7 @@ import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM) import Control.Monad (replicateM,liftM)
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (lift)
import qualified Data.ByteString.Lazy.Char8 as BS (pack) import qualified Data.ByteString.Lazy.Char8 as BS (pack)
import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Digest.Pure.SHA (sha1, showDigest)
@ -134,14 +135,14 @@ setPassword pwd u = do salt <- randomSalt
-- the database values. -- the database values.
validateUser :: ( YesodPersist yesod validateUser :: ( YesodPersist yesod
, b ~ YesodPersistBackend yesod , b ~ YesodPersistBackend yesod
, PersistMonadBackend (b (GHandler yesod)) ~ PersistEntityBackend user , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler yesod)) , PersistUnique (b (HandlerT yesod IO))
, PersistEntity user , PersistEntity user
, HashDBUser user , HashDBUser user
) => ) =>
Unique user -- ^ User unique identifier Unique user -- ^ User unique identifier
-> Text -- ^ Password in plaint-text -> Text -- ^ Password in plaint-text
-> GHandler yesod Bool -> HandlerT yesod IO Bool
validateUser userID passwd = do validateUser userID passwd = do
-- Checks that hash and password match -- Checks that hash and password match
let validate u = do hash <- userPasswordHash u let validate u = do hash <- userPasswordHash u
@ -161,11 +162,11 @@ login = PluginR "hashdb" ["login"]
postLoginR :: ( YesodAuth y, YesodPersist y postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser user, PersistEntity user , HashDBUser user, PersistEntity user
, b ~ YesodPersistBackend y , b ~ YesodPersistBackend y
, PersistMonadBackend (b (GHandler y)) ~ PersistEntityBackend user , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler y)) , PersistUnique (b (HandlerT y IO))
) )
=> (Text -> Maybe (Unique user)) => (Text -> Maybe (Unique user))
-> HandlerT Auth (GHandler y) () -> HandlerT Auth (HandlerT y IO) ()
postLoginR uniq = do postLoginR uniq = do
(mu,mp) <- lift $ runInputPost $ (,) (mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username" <$> iopt textField "username"
@ -174,7 +175,7 @@ postLoginR uniq = do
isValid <- lift $ fromMaybe (return False) isValid <- lift $ fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp) (validateUser <$> (uniq =<< mu) <*> mp)
if isValid if isValid
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do setMessage "Invalid username/password" else do setMessage "Invalid username/password"
redirect LoginR redirect LoginR
@ -185,13 +186,13 @@ getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user , HashDBUser user, PersistEntity user
, Key user ~ AuthId master , Key user ~ AuthId master
, b ~ YesodPersistBackend master , b ~ YesodPersistBackend master
, PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend user , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler master)) , PersistUnique (b (HandlerT master IO))
) )
=> (AuthRoute -> Route master) -- ^ your site's Auth Route => (AuthRoute -> Route master) -- ^ your site's Auth Route
-> (Text -> Maybe (Unique user)) -- ^ gets user ID -> (Text -> Maybe (Unique user)) -- ^ gets user ID
-> Creds master -- ^ the creds argument -> Creds master -- ^ the creds argument
-> GHandler master (Maybe (AuthId master)) -> HandlerT master IO (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do getAuthIdHashDB authR uniq creds = do
muid <- maybeAuthId muid <- maybeAuthId
case muid of case muid of
@ -214,8 +215,8 @@ authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user , HashDBUser user
, PersistEntity user , PersistEntity user
, b ~ YesodPersistBackend m , b ~ YesodPersistBackend m
, PersistMonadBackend (b (GHandler m)) ~ PersistEntityBackend user , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler m))) , PersistUnique (b (HandlerT m IO)))
=> (Text -> Maybe (Unique user)) -> AuthPlugin m => (Text -> Maybe (Unique user)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet| authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
$newline never $newline never
@ -223,7 +224,7 @@ $newline never
<h1>Login <h1>Login
<div id="login"> <div id="login">
<form method="post" action="#{tm login}"> <form method="post" action="@{tm login}">
<table> <table>
<tr> <tr>
<th>Username: <th>Username:

15
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -21,6 +21,7 @@ import Data.Text (Text, isPrefixOf)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
import Control.Exception.Lifted (SomeException, try) import Control.Exception.Lifted (SomeException, try)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Control.Monad.Trans.Class
forwardUrl :: AuthRoute forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"] forwardUrl = PluginR "openid" ["forward"]
@ -37,7 +38,7 @@ authOpenId idType extensionFields =
complete = PluginR "openid" ["complete"] complete = PluginR "openid" ["complete"]
name = "openid_identifier" name = "openid_identifier"
login tm = do login tm = do
ident <- lift newIdent ident <- newIdent
-- FIXME this is a hack to get GHC 7.6's type checker to allow the -- FIXME this is a hack to get GHC 7.6's type checker to allow the
-- code, but it shouldn't be necessary -- code, but it shouldn't be necessary
let y :: a -> [(Text, Text)] -> Text let y :: a -> [(Text, Text)] -> Text
@ -48,13 +49,13 @@ authOpenId idType extensionFields =
|] $ x `asTypeOf` y) |] $ x `asTypeOf` y)
[whamlet| [whamlet|
$newline never $newline never
<form method="get" action="#{tm forwardUrl}"> <form method="get" action="@{tm forwardUrl}">
<input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id"> <input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id">
<button .openid-google>_{Msg.LoginGoogle} <button .openid-google>_{Msg.LoginGoogle}
<form method="get" action="#{tm forwardUrl}"> <form method="get" action="@{tm forwardUrl}">
<input type="hidden" name="openid_identifier" value="http://me.yahoo.com"> <input type="hidden" name="openid_identifier" value="http://me.yahoo.com">
<button .openid-yahoo>_{Msg.LoginYahoo} <button .openid-yahoo>_{Msg.LoginYahoo}
<form method="get" action="#{tm forwardUrl}"> <form method="get" action="@{tm forwardUrl}">
<label for="#{ident}">OpenID: # <label for="#{ident}">OpenID: #
<input id="#{ident}" type="text" name="#{name}" value="http://"> <input id="#{ident}" type="text" name="#{name}" value="http://">
<input type="submit" value="_{Msg.LoginOpenID}"> <input type="submit" value="_{Msg.LoginOpenID}">
@ -73,7 +74,7 @@ $newline never
redirect LoginR redirect LoginR
Right x -> redirect x Right x -> redirect x
Nothing -> do Nothing -> do
setMessageI Msg.NoOpenID lift $ setMessageI Msg.NoOpenID
redirect LoginR redirect LoginR
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
dispatch "GET" ["complete"] = do dispatch "GET" ["complete"] = do
@ -85,7 +86,7 @@ $newline never
completeHelper idType posts completeHelper idType posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: YesodAuth master => IdentifierType -> [(Text, Text)] -> HandlerT Auth (GHandler master) () completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()
completeHelper idType gets' = do completeHelper idType gets' = do
master <- lift getYesod master <- lift getYesod
eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
@ -105,7 +106,7 @@ completeHelper idType gets' = do
case idType of case idType of
OPLocal -> OpenId.oirOpLocal oir OPLocal -> OpenId.oirOpLocal oir
Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
setCreds True $ Creds "openid" i gets'' lift $ setCreds True $ Creds "openid" i gets''
either onFailure onSuccess eres either onFailure onSuccess eres
-- | The main identifier provided by the OpenID authentication plugin is the -- | The main identifier provided by the OpenID authentication plugin is the

10
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -17,6 +17,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***)) import Control.Arrow ((***))
import Network.HTTP.Types (renderQuery) import Network.HTTP.Types (renderQuery)
import Control.Monad.Trans.Class
authRpxnow :: YesodAuth m authRpxnow :: YesodAuth m
=> String -- ^ app name => String -- ^ app name
@ -25,13 +26,10 @@ authRpxnow :: YesodAuth m
authRpxnow app apiKey = authRpxnow app apiKey =
AuthPlugin "rpxnow" dispatch login AuthPlugin "rpxnow" dispatch login
where where
login ::
forall master.
ToWidget master (GWidget master ())
=> (Route Auth -> Text) -> GWidget master ()
login tm = do login tm = do
render <- getUrlRender
let queryString = decodeUtf8With lenientDecode let queryString = decodeUtf8With lenientDecode
$ renderQuery True [("token_url", Just $ encodeUtf8 $ tm $ PluginR "rpxnow" [])] $ renderQuery True [("token_url", Just $ encodeUtf8 $ render $ tm $ PluginR "rpxnow" [])]
toWidget [hamlet| toWidget [hamlet|
$newline never $newline never
<iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> <iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
@ -51,7 +49,7 @@ $newline never
$ maybe id (\x -> (:) ("displayName", x)) $ maybe id (\x -> (:) ("displayName", x))
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[] []
setCreds True creds lift $ setCreds True creds
dispatch _ _ = notFound dispatch _ _ = notFound
-- | Get some form of a display name. -- | Get some form of a display name.

4
yesod-core/Yesod/Core.hs
View File

@ -51,6 +51,7 @@ module Yesod.Core
, HandlerReader (..) , HandlerReader (..)
, HandlerState (..) , HandlerState (..)
, HandlerError (..) , HandlerError (..)
, getRouteToParent
-- * Misc -- * Misc
, yesodVersion , yesodVersion
, yesodRender , yesodRender
@ -110,3 +111,6 @@ maybeAuthorized :: Yesod site
maybeAuthorized r isWrite = do maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing return $ if x == Authorized then Just r else Nothing
getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)
getRouteToParent = HandlerT $ return . handlerToParent

4
yesod-core/Yesod/Core/Handler.hs
View File

@ -862,7 +862,7 @@ data ProvidedRep m = ProvidedRep !ContentType !(m Content)
-- client. Should be used together with 'selectRep'. -- client. Should be used together with 'selectRep'.
-- --
-- Since 1.2.0 -- Since 1.2.0
provideRep :: (MonadIO m, HasContentType a) provideRep :: (Monad m, HasContentType a)
=> m a => m a
-> Writer.Writer (Endo [ProvidedRep m]) () -> Writer.Writer (Endo [ProvidedRep m]) ()
provideRep handler = provideRepType (getContentType handler) handler provideRep handler = provideRepType (getContentType handler) handler
@ -875,7 +875,7 @@ provideRep handler = provideRepType (getContentType handler) handler
-- > provideRepType "application/x-special-format" "This is the content" -- > provideRepType "application/x-special-format" "This is the content"
-- --
-- Since 1.2.0 -- Since 1.2.0
provideRepType :: (MonadIO m, ToContent a) provideRepType :: (Monad m, ToContent a)
=> ContentType => ContentType
-> m a -> m a
-> Writer.Writer (Endo [ProvidedRep m]) () -> Writer.Writer (Endo [ProvidedRep m]) ()

11
yesod-core/Yesod/Core/Widget.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
@ -42,6 +43,7 @@ module Yesod.Core.Widget
, addScriptEither , addScriptEither
-- * Subsites -- * Subsites
, liftWidget , liftWidget
, handlerToWidget
-- * Internal -- * Internal
, whamletFileWithSettings , whamletFileWithSettings
) where ) where
@ -221,13 +223,8 @@ tell w = WidgetT $ const $ return ((), w)
toUnique :: x -> UniqueList x toUnique :: x -> UniqueList x
toUnique = UniqueList . (:) toUnique = UniqueList . (:)
liftHandlerT :: MonadIO m handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a
=> HandlerT site IO a handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f
-> HandlerT site m a
liftHandlerT (HandlerT f) =
HandlerT $ liftIO . f . fixToParent
where
fixToParent hd = hd { handlerToParent = const () }
liftWidget :: MonadIO m liftWidget :: MonadIO m
=> WidgetT child IO a => WidgetT child IO a

6
yesod-form/Yesod/Form/Class.hs
View File

@ -14,7 +14,7 @@ import Yesod.Form.Functions (areq, aopt)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Time (Day, TimeOfDay) import Data.Time (Day, TimeOfDay)
import Data.Text (Text) import Data.Text (Text)
import Yesod.Core (RenderMessage) import Yesod.Core (RenderMessage, HandlerT)
{- {-
class ToForm a where class ToForm a where
@ -23,7 +23,9 @@ class ToForm a where
class ToField a master where class ToField a master where
toField :: RenderMessage master FormMessage toField :: RenderMessage master FormMessage
=> FieldSettings master -> Maybe a -> AForm master a => FieldSettings master
-> Maybe a
-> AForm (HandlerT master IO) a
{- FIXME {- FIXME
instance ToFormField String y where instance ToFormField String y where

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

@ -79,8 +79,9 @@ import qualified Data.ByteString.Lazy as L
import Data.Text (Text, unpack, pack) import Data.Text (Text, unpack, pack)
import qualified Data.Text.Read import qualified Data.Text.Read
import Control.Monad.Trans.Class
import qualified Data.Map as Map import qualified Data.Map as Map
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery) import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB)
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
import Control.Applicative ((<$>), (<|>)) import Control.Applicative ((<$>), (<|>))
@ -91,7 +92,7 @@ defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage defaultFormMessage = englishFormMessage
intField :: (Integral i, RenderMessage site FormMessage) => Field site i intField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i
intField = Field intField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->
case Data.Text.Read.signed Data.Text.Read.decimal s of case Data.Text.Read.signed Data.Text.Read.decimal s of
@ -108,7 +109,7 @@ $newline never
showVal = either id (pack . showI) showVal = either id (pack . showI)
showI x = show (fromIntegral x :: Integer) showI x = show (fromIntegral x :: Integer)
doubleField :: RenderMessage site FormMessage => Field site Double doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
doubleField = Field doubleField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->
case Data.Text.Read.double s of case Data.Text.Read.double s of
@ -123,7 +124,7 @@ $newline never
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
dayField :: RenderMessage site FormMessage => Field site Day dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day
dayField = Field dayField = Field
{ fieldParse = parseHelper $ parseDate . unpack { fieldParse = parseHelper $ parseDate . unpack
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -134,7 +135,7 @@ $newline never
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
timeField :: RenderMessage site FormMessage => Field site TimeOfDay timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField = Field timeField = Field
{ fieldParse = parseHelper parseTime { fieldParse = parseHelper parseTime
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -150,7 +151,7 @@ $newline never
where where
fullSec = fromInteger $ floor $ todSec tod fullSec = fromInteger $ floor $ todSec tod
htmlField :: RenderMessage site FormMessage => Field site Html htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html
htmlField = Field htmlField = Field
{ fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet| , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@ -179,7 +180,7 @@ instance ToHtml Textarea where
writeHtmlEscapedChar '\n' = writeByteString "<br>" writeHtmlEscapedChar '\n' = writeByteString "<br>"
writeHtmlEscapedChar c = B.writeHtmlEscapedChar c writeHtmlEscapedChar c = B.writeHtmlEscapedChar c
textareaField :: RenderMessage site FormMessage => Field site Textarea textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea
textareaField = Field textareaField = Field
{ fieldParse = parseHelper $ Right . Textarea { fieldParse = parseHelper $ Right . Textarea
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet| , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@ -189,8 +190,8 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
hiddenField :: (PathPiece p, RenderMessage site FormMessage) hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)
=> Field site p => Field m p
hiddenField = Field hiddenField = Field
{ fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece
, fieldView = \theId name attrs val _isReq -> toWidget [hamlet| , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|
@ -200,7 +201,7 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
textField :: RenderMessage site FormMessage => Field site Text textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
textField = Field textField = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> , fieldView = \theId name attrs val isReq ->
@ -211,7 +212,7 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
passwordField :: RenderMessage site FormMessage => Field site Text passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
passwordField = Field passwordField = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> toWidget [hamlet| , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
@ -282,7 +283,7 @@ timeParser = do
then fail $ show $ msg $ pack xy then fail $ show $ msg $ pack xy
else return $ fromIntegral (i :: Int) else return $ fromIntegral (i :: Int)
emailField :: RenderMessage site FormMessage => Field site Text emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
emailField = Field emailField = Field
{ fieldParse = parseHelper $ { fieldParse = parseHelper $
\s -> \s ->
@ -297,7 +298,7 @@ $newline never
} }
type AutoFocus = Bool type AutoFocus = Bool
searchField :: RenderMessage site FormMessage => AutoFocus -> Field site Text searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
searchField autoFocus = Field searchField autoFocus = Field
{ fieldParse = parseHelper Right { fieldParse = parseHelper Right
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do
@ -318,24 +319,25 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
urlField :: RenderMessage site FormMessage => Field site Text urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
urlField = Field urlField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->
case parseURI $ unpack s of case parseURI $ unpack s of
Nothing -> Left $ MsgInvalidUrl s Nothing -> Left $ MsgInvalidUrl s
Just _ -> Right s Just _ -> Right s
, fieldView = \theId name attrs val isReq -> , fieldView = \theId name attrs val isReq ->
[whamlet| [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>|]
$newline never
<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>
|]
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site a selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerT site IO) a
selectFieldList = selectField . optionsPairs selectFieldList = selectField . optionsPairs
selectField :: (Eq a, RenderMessage site FormMessage) => GHandler site (OptionList a) -> Field site a selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
selectField = selectFieldHelper selectField = selectFieldHelper
(\theId name attrs inside -> [whamlet| (\theId name attrs inside -> [whamlet|
$newline never $newline never
@ -350,12 +352,14 @@ $newline never
<option value=#{value} :isSel:selected>#{text} <option value=#{value} :isSel:selected>#{text}
|]) -- inside |]) -- inside
multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site [a] multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerT site IO) [a]
multiSelectFieldList = multiSelectField . optionsPairs multiSelectFieldList = multiSelectField . optionsPairs
multiSelectField :: (Eq a, RenderMessage site FormMessage) multiSelectField :: (Eq a, RenderMessage site FormMessage)
=> GHandler site (OptionList a) => HandlerT site IO (OptionList a)
-> Field site [a] -> Field (HandlerT site IO) [a]
multiSelectField ioptlist = multiSelectField ioptlist =
Field parse view UrlEncoded Field parse view UrlEncoded
where where
@ -367,10 +371,9 @@ multiSelectField ioptlist =
Just res -> return $ Right $ Just res Just res -> return $ Right $ Just res
view theId name attrs val isReq = do view theId name attrs val isReq = do
opts <- fmap olOptions $ lift ioptlist opts <- fmap olOptions $ handlerToWidget ioptlist
let selOpts = map (id &&& (optselected val)) opts let selOpts = map (id &&& (optselected val)) opts
[whamlet| [whamlet|
$newline never
<select ##{theId} name=#{name} :isReq:required multiple *{attrs}> <select ##{theId} name=#{name} :isReq:required multiple *{attrs}>
$forall (opt, optsel) <- selOpts $forall (opt, optsel) <- selOpts
<option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt} <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}
@ -379,10 +382,14 @@ $newline never
optselected (Left _) _ = False optselected (Left _) _ = False
optselected (Right vals) opt = (optionInternalValue opt) `elem` vals optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site a radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)]
-> Field (HandlerT site IO) a
radioFieldList = radioField . optionsPairs radioFieldList = radioField . optionsPairs
radioField :: (Eq a, RenderMessage site FormMessage) => GHandler site (OptionList a) -> Field site a radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
radioField = selectFieldHelper radioField = selectFieldHelper
(\theId _name _attrs inside -> [whamlet| (\theId _name _attrs inside -> [whamlet|
$newline never $newline never
@ -403,7 +410,7 @@ $newline never
\#{text} \#{text}
|]) |])
boolField :: RenderMessage site FormMessage => Field site Bool boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
boolField = Field boolField = Field
{ fieldParse = \e _ -> return $ boolParser e { fieldParse = \e _ -> return $ boolParser e
, fieldView = \theId name attrs val isReq -> [whamlet| , fieldView = \theId name attrs val isReq -> [whamlet|
@ -439,7 +446,7 @@ $newline never
-- --
-- Note that this makes the field always optional. -- Note that this makes the field always optional.
-- --
checkBoxField :: RenderMessage site FormMessage => Field site Bool checkBoxField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool
checkBoxField = Field checkBoxField = Field
{ fieldParse = \e _ -> return $ checkBoxParser e { fieldParse = \e _ -> return $ checkBoxParser e
, fieldView = \theId name attrs val _ -> [whamlet| , fieldView = \theId name attrs val _ -> [whamlet|
@ -475,7 +482,8 @@ data Option a = Option
, optionExternalValue :: Text , optionExternalValue :: Text
} }
optionsPairs :: RenderMessage site msg => [(msg, a)] -> GHandler site (OptionList a) optionsPairs :: (HandlerReader m, RenderMessage (HandlerSite m) msg)
=> [(msg, a)] -> m (OptionList a)
optionsPairs opts = do optionsPairs opts = do
mr <- getMessageRender mr <- getMessageRender
let mkOption external (display, internal) = let mkOption external (display, internal) =
@ -485,16 +493,19 @@ optionsPairs opts = do
} }
return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts)
optionsEnum :: (Show a, Enum a, Bounded a) => GHandler site (OptionList a) optionsEnum :: (HandlerReader m, Show a, Enum a, Bounded a) => m (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist site, PersistEntity a optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (YesodPersistBackend site (GHandler site)) , PersistQuery (YesodDB site)
, PathPiece (Key a) , PathPiece (Key a)
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (GHandler site)) , PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)
, RenderMessage site msg , RenderMessage site msg
) )
=> [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler site (OptionList (Entity a)) => [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerT site IO (OptionList (Entity a))
optionsPersist filts ords toDisplay = fmap mkOptionList $ do optionsPersist filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender mr <- getMessageRender
pairs <- runDB $ selectList filts ords pairs <- runDB $ selectList filts ords
@ -506,16 +517,17 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
selectFieldHelper selectFieldHelper
:: (Eq a, RenderMessage site FormMessage) :: (Eq a, RenderMessage site FormMessage)
=> (Text -> Text -> [(Text, Text)] -> GWidget site () -> GWidget site ()) => (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ())
-> (Text -> Text -> Bool -> GWidget site ()) -> (Text -> Text -> Bool -> WidgetT site IO ())
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget site ()) -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetT site IO ())
-> GHandler site (OptionList a) -> Field site a -> HandlerT site IO (OptionList a)
-> Field (HandlerT site IO) a
selectFieldHelper outside onOpt inside opts' = Field selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x _ -> do { fieldParse = \x _ -> do
opts <- opts' opts <- opts'
return $ selectParser opts x return $ selectParser opts x
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do
opts <- fmap olOptions $ lift opts' opts <- fmap olOptions $ handlerToWidget opts'
outside theId name attrs $ do outside theId name attrs $ do
unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts
flip mapM_ opts $ \opt -> inside flip mapM_ opts $ \opt -> inside
@ -538,7 +550,8 @@ selectFieldHelper outside onOpt inside opts' = Field
Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Nothing -> Left $ SomeMessage $ MsgInvalidEntry x
Just y -> Right $ Just y Just y -> Right $ Just y
fileField :: RenderMessage site FormMessage => Field site FileInfo fileField :: (Monad m, RenderMessage (HandlerSite m) FormMessage)
=> Field m FileInfo
fileField = Field fileField = Field
{ fieldParse = \_ files -> return $ { fieldParse = \_ files -> return $
case files of case files of
@ -550,7 +563,8 @@ fileField = Field
, fieldEnctype = Multipart , fieldEnctype = Multipart
} }
fileAFormReq :: RenderMessage site FormMessage => FieldSettings site -> AForm site FileInfo fileAFormReq :: (HandlerState m, RenderMessage (HandlerSite m) FormMessage)
=> FieldSettings (HandlerSite m) -> AForm m FileInfo
fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do
let (name, ints') = let (name, ints') =
case fsName fs of case fsName fs of
@ -581,7 +595,10 @@ $newline never
} }
return (res, (fv :), ints', Multipart) return (res, (fv :), ints', Multipart)
fileAFormOpt :: RenderMessage site FormMessage => FieldSettings site -> AForm site (Maybe FileInfo) fileAFormOpt :: HandlerState m
=> RenderMessage (HandlerSite m) FormMessage
=> FieldSettings (HandlerSite m)
-> AForm m (Maybe FileInfo)
fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do
let (name, ints') = let (name, ints') =
case fsName fs of case fsName fs of

182
yesod-form/Yesod/Form/Functions.hs
View File

@ -35,11 +35,9 @@ module Yesod.Form.Functions
, checkBool , checkBool
, checkM , checkM
, checkMMap , checkMMap
, checkMMod
, customErrorMessage , customErrorMessage
-- * Utilities -- * Utilities
, fieldSettingsLabel , fieldSettingsLabel
, aformM
, parseHelper , parseHelper
) where ) where
@ -48,6 +46,7 @@ import Yesod.Form.Types
import Data.Text (Text, pack) import Data.Text (Text, pack)
import Control.Arrow (second) import Control.Arrow (second)
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST) import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.Class
import Control.Monad (liftM, join) import Control.Monad (liftM, join)
import Crypto.Classes (constTimeEq) import Crypto.Classes (constTimeEq)
import Text.Blaze (Markup, toMarkup) import Text.Blaze (Markup, toMarkup)
@ -63,7 +62,7 @@ import qualified Data.Text.Encoding as TE
import Control.Arrow (first) import Control.Arrow (first)
-- | Get a unique identifier. -- | Get a unique identifier.
newFormIdent :: MForm site Text newFormIdent :: Monad m => MForm m Text
newFormIdent = do newFormIdent = do
i <- get i <- get
let i' = incrInts i let i' = incrInts i
@ -73,12 +72,16 @@ newFormIdent = do
incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is incrInts (IntCons i is) = (i + 1) `IntCons` is
formToAForm :: MForm site (FormResult a, [FieldView site]) -> AForm site a formToAForm :: (HandlerSite m ~ site, Monad m)
=> MForm m (FormResult a, [FieldView site])
-> AForm m a
formToAForm form = AForm $ \(site, langs) env ints -> do formToAForm form = AForm $ \(site, langs) env ints -> do
((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints ((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints
return (a, (++) xmls, ints', enc) return (a, (++) xmls, ints', enc)
aFormToForm :: AForm site a -> MForm site (FormResult a, [FieldView site] -> [FieldView site]) aFormToForm :: (Monad m, HandlerSite m ~ site)
=> AForm m a
-> MForm m (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm (AForm aform) = do aFormToForm (AForm aform) = do
ints <- get ints <- get
(env, site, langs) <- ask (env, site, langs) <- ask
@ -87,32 +90,38 @@ aFormToForm (AForm aform) = do
tell enc tell enc
return (a, xml) return (a, xml)
askParams :: MForm site (Maybe Env) askParams :: Monad m => MForm m (Maybe Env)
askParams = do askParams = do
(x, _, _) <- ask (x, _, _) <- ask
return $ liftM fst x return $ liftM fst x
askFiles :: MForm site (Maybe FileEnv) askFiles :: Monad m => MForm m (Maybe FileEnv)
askFiles = do askFiles = do
(x, _, _) <- ask (x, _, _) <- ask
return $ liftM snd x return $ liftM snd x
mreq :: RenderMessage site FormMessage mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, HandlerState m)
=> Field site a -> FieldSettings site -> Maybe a => Field m a
-> MForm site (FormResult a, FieldView site) -> FieldSettings site
-> Maybe a
-> MForm m (FormResult a, FieldView site)
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
mopt :: Field site a -> FieldSettings site -> Maybe (Maybe a) mopt :: (site ~ HandlerSite m, HandlerState m)
-> MForm site (FormResult (Maybe a), FieldView site) => Field m a
-> FieldSettings site
-> Maybe (Maybe a)
-> MForm m (FormResult (Maybe a), FieldView site)
mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
mhelper :: Field site a mhelper :: (site ~ HandlerSite m, HandlerState m)
=> Field m a
-> FieldSettings site -> FieldSettings site
-> Maybe a -> Maybe a
-> (site -> [Text] -> FormResult b) -- ^ on missing -> (site -> [Text] -> FormResult b) -- ^ on missing
-> (a -> FormResult b) -- ^ on success -> (a -> FormResult b) -- ^ on success
-> Bool -- ^ is it required? -> Bool -- ^ is it required?
-> MForm site (FormResult b, FieldView site) -> MForm m (FormResult b, FieldView site)
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
tell fieldEnctype tell fieldEnctype
@ -147,24 +156,27 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
, fvRequired = isReq , fvRequired = isReq
}) })
areq :: RenderMessage site FormMessage areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, HandlerState m)
=> Field site a -> FieldSettings site -> Maybe a => Field m a
-> AForm site a
areq a b = formToAForm . fmap (second return) . mreq a b
aopt :: Field site a
-> FieldSettings site -> FieldSettings site
-> Maybe (Maybe a) -> Maybe a
-> AForm site (Maybe a) -> AForm m a
aopt a b = formToAForm . fmap (second return) . mopt a b areq a b = formToAForm . liftM (second return) . mreq a b
runFormGeneric :: MonadHandler m aopt :: HandlerState m
=> MForm (HandlerSite m) a => Field m a
-> FieldSettings (HandlerSite m)
-> Maybe (Maybe a)
-> AForm m (Maybe a)
aopt a b = formToAForm . liftM (second return) . mopt a b
runFormGeneric :: Monad m
=> MForm m a
-> HandlerSite m -> HandlerSite m
-> [Text] -> [Text]
-> Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
-> m (a, Enctype) -> m (a, Enctype)
runFormGeneric form site langs env = liftHandler $ evalRWST form (env, site, langs) (IntSingle 1) runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 1)
-- | This function is used to both initially render a form and to later extract -- | This function is used to both initially render a form and to later extract
-- results from it. Note that, due to CSRF protection and a few other issues, -- results from it. Note that, due to CSRF protection and a few other issues,
@ -175,15 +187,15 @@ runFormGeneric form site langs env = liftHandler $ evalRWST form (env, site, lan
-- For example, a common case is displaying a form on a GET request and having -- For example, a common case is displaying a form on a GET request and having
-- the form submit to a POST page. In such a case, both the GET and POST -- the form submit to a POST page. In such a case, both the GET and POST
-- handlers should use 'runFormPost'. -- handlers should use 'runFormPost'.
runFormPost :: (HandlerSite m ~ site, RenderMessage site FormMessage, MonadResource m, MonadHandler m) runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, HandlerState m)
=> (Html -> MForm site (FormResult a, xml)) => (Html -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype) -> m ((FormResult a, xml), Enctype)
runFormPost form = do runFormPost form = do
env <- postEnv env <- postEnv
postHelper form env postHelper form env
postHelper :: (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m) postHelper :: (HandlerReader m, RenderMessage (HandlerSite m) FormMessage)
=> (Html -> MForm site (FormResult a, xml)) => (Html -> MForm m (FormResult a, xml))
-> Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
-> m ((FormResult a, xml), Enctype) -> m ((FormResult a, xml), Enctype)
postHelper form env = do postHelper form env = do
@ -212,8 +224,8 @@ postHelper form env = do
-- page will both receive and incoming form and produce a new, blank form. For -- page will both receive and incoming form and produce a new, blank form. For
-- general usage, you can stick with @runFormPost@. -- general usage, you can stick with @runFormPost@.
generateFormPost generateFormPost
:: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) :: (RenderMessage (HandlerSite m) FormMessage, HandlerReader m)
=> (Html -> MForm (HandlerSite m) (FormResult a, xml)) => (Html -> MForm m (FormResult a, xml))
-> m (xml, Enctype) -> m (xml, Enctype)
generateFormPost form = first snd `liftM` postHelper form Nothing generateFormPost form = first snd `liftM` postHelper form Nothing
@ -228,8 +240,8 @@ postEnv = do
let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f) return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f)
runFormPostNoToken :: (MonadHandler m) runFormPostNoToken :: (HandlerState m, MonadResource m)
=> (Html -> MForm (HandlerSite m) (FormResult a, xml)) => (Html -> MForm m (FormResult a, xml))
-> m ((FormResult a, xml), Enctype) -> m ((FormResult a, xml), Enctype)
runFormPostNoToken form = do runFormPostNoToken form = do
langs <- languages langs <- languages
@ -237,8 +249,8 @@ runFormPostNoToken form = do
env <- postEnv env <- postEnv
runFormGeneric (form mempty) m langs env runFormGeneric (form mempty) m langs env
runFormGet :: MonadHandler m runFormGet :: HandlerReader m
=> (Html -> MForm (HandlerSite m) a) => (Html -> MForm m a)
-> m (a, Enctype) -> m (a, Enctype)
runFormGet form = do runFormGet form = do
gets <- liftM reqGetParams getRequest gets <- liftM reqGetParams getRequest
@ -248,16 +260,16 @@ runFormGet form = do
Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty) Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
getHelper form env getHelper form env
generateFormGet :: MonadHandler m generateFormGet :: HandlerReader m
=> (Html -> MForm (HandlerSite m) a) => (Html -> MForm m a)
-> m (a, Enctype) -> m (a, Enctype)
generateFormGet form = getHelper form Nothing generateFormGet form = getHelper form Nothing
getKey :: Text getKey :: Text
getKey = "_hasdata" getKey = "_hasdata"
getHelper :: MonadHandler m getHelper :: HandlerReader m
=> (Html -> MForm (HandlerSite m) a) => (Html -> MForm m a)
-> Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
-> m (a, Enctype) -> m (a, Enctype)
getHelper form env = do getHelper form env = do
@ -266,12 +278,12 @@ getHelper form env = do
m <- getYesod m <- getYesod
runFormGeneric (form fragment) m langs env runFormGeneric (form fragment) m langs env
type FormRender site a = type FormRender m a =
AForm site a AForm m a
-> Html -> Html
-> MForm site (FormResult a, GWidget site ()) -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
renderTable, renderDivs, renderDivsNoLabels :: FormRender site a renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
renderTable aform fragment = do renderTable aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -296,7 +308,7 @@ renderDivs = renderDivsMaybeLabels True
-- | render a field inside a div, not displaying any label -- | render a field inside a div, not displaying any label
renderDivsNoLabels = renderDivsMaybeLabels False renderDivsNoLabels = renderDivsMaybeLabels False
renderDivsMaybeLabels :: Bool -> FormRender site a renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a
renderDivsMaybeLabels withLabels aform fragment = do renderDivsMaybeLabels withLabels aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -330,40 +342,42 @@ $forall view <- views
-- > ^{formWidget} -- > ^{formWidget}
-- > <div .form-actions> -- > <div .form-actions>
-- > <input .btn .primary type=submit value=_{MsgSubmit}> -- > <input .btn .primary type=submit value=_{MsgSubmit}>
renderBootstrap :: FormRender site a renderBootstrap :: Monad m => FormRender m a
renderBootstrap aform fragment = do renderBootstrap aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
has (Just _) = True has (Just _) = True
has Nothing = False has Nothing = False
let widget = [whamlet| let widget = [whamlet|
$newline never $newline never
\#{fragment} \#{fragment}
$forall view <- views $forall view <- views
<div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error> <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>
<label .control-label for=#{fvId view}>#{fvLabel view} <label .control-label for=#{fvId view}>#{fvLabel view}
<div .controls .input> <div .controls .input>
^{fvInput view} ^{fvInput view}
$maybe tt <- fvTooltip view $maybe tt <- fvTooltip view
<span .help-block>#{tt} <span .help-block>#{tt}
$maybe err <- fvErrors view $maybe err <- fvErrors view
<span .help-block>#{err} <span .help-block>#{err}
|] |]
return (res, widget) return (res, widget)
check :: RenderMessage site msg check :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> Either msg a) -> Field site a -> Field site a => (a -> Either msg a)
-> Field m a
-> Field m a
check f = checkM $ return . f check f = checkM $ return . f
-- | Return the given error message if the predicate is false. -- | Return the given error message if the predicate is false.
checkBool :: RenderMessage site msg checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> Bool) -> msg -> Field site a -> Field site a => (a -> Bool) -> msg -> Field m a -> Field m a
checkBool b s = check $ \x -> if b x then Right x else Left s checkBool b s = check $ \x -> if b x then Right x else Left s
checkM :: RenderMessage site msg checkM :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> GHandler site (Either msg a)) => (a -> m (Either msg a))
-> Field site a -> Field m a
-> Field site a -> Field m a
checkM f = checkMMap f id checkM f = checkMMap f id
-- | Same as 'checkM', but modifies the datatype. -- | Same as 'checkM', but modifies the datatype.
@ -372,47 +386,33 @@ checkM f = checkMMap f id
-- the new datatype to the old one (the second argument to this function). -- the new datatype to the old one (the second argument to this function).
-- --
-- Since 1.1.2 -- Since 1.1.2
checkMMap :: RenderMessage site msg checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> GHandler site (Either msg b)) => (a -> m (Either msg b))
-> (b -> a) -> (b -> a)
-> Field site a -> Field m a
-> Field site b -> Field m b
checkMMap f inv field = field checkMMap f inv field = field
{ fieldParse = \ts fs -> do { fieldParse = \ts fs -> do
e1 <- fieldParse field ts fs e1 <- fieldParse field ts fs
case e1 of case e1 of
Left msg -> return $ Left msg Left msg -> return $ Left msg
Right Nothing -> return $ Right Nothing Right Nothing -> return $ Right Nothing
Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a Right (Just a) -> liftM (either (Left . SomeMessage) (Right . Just)) $ f a
, fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req , fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req
} }
-- | Deprecated synonym for 'checkMMap'.
--
-- Since 1.1.1
checkMMod :: RenderMessage site msg
=> (a -> GHandler site (Either msg b))
-> (b -> a)
-> Field site a
-> Field site b
checkMMod = checkMMap
{-# DEPRECATED checkMMod "Please use checkMMap instead" #-}
-- | Allows you to overwrite the error message on parse error. -- | Allows you to overwrite the error message on parse error.
customErrorMessage :: SomeMessage site -> Field site a -> Field site a customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a
customErrorMessage msg field = field { fieldParse = \ts fs -> fmap (either customErrorMessage msg field = field
(const $ Left msg) Right) $ fieldParse field ts fs } { fieldParse = \ts fs ->
liftM (either (const $ Left msg) Right)
$ fieldParse field ts fs
}
-- | Generate a 'FieldSettings' from the given label. -- | Generate a 'FieldSettings' from the given label.
fieldSettingsLabel :: RenderMessage site msg => msg -> FieldSettings site fieldSettingsLabel :: RenderMessage site msg => msg -> FieldSettings site
fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing [] fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing []
-- | Generate an 'AForm' that gets its value from the given action.
aformM :: GHandler site a -> AForm site a
aformM action = AForm $ \_ _ ints -> do
value <- action
return (FormSuccess value, id, ints, mempty)
-- | A helper function for creating custom fields. -- | A helper function for creating custom fields.
-- --
-- This is intended to help with the common case where a single input value is -- This is intended to help with the common case where a single input value is

22
yesod-form/Yesod/Form/Input.hs
View File

@ -13,15 +13,16 @@ import Data.Text (Text)
import Control.Applicative (Applicative (..)) import Control.Applicative (Applicative (..))
import Yesod.Core import Yesod.Core
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.Trans.Resource
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Control.Arrow ((***)) import Control.Arrow ((***))
type DText = [Text] -> [Text] type DText = [Text] -> [Text]
newtype FormInput site a = FormInput { unFormInput :: site -> [Text] -> Env -> FileEnv -> GHandler site (Either DText a) } newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }
instance Functor (FormInput site) where instance Monad m => Functor (FormInput m) where
fmap a (FormInput f) = FormInput $ \c d e e' -> fmap (either Left (Right . a)) $ f c d e e' fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'
instance Applicative (FormInput site) where instance Monad m => Applicative (FormInput m) where
pure = FormInput . const . const . const . const . return . Right pure = FormInput . const . const . const . const . return . Right
(FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do (FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do
res1 <- f c d e e' res1 <- f c d e e'
@ -32,7 +33,8 @@ instance Applicative (FormInput site) where
(_, Left b) -> Left b (_, Left b) -> Left b
(Right a, Right b) -> Right $ a b (Right a, Right b) -> Right $ a b
ireq :: (RenderMessage site FormMessage) => Field site a -> Text -> FormInput site a ireq :: (Monad m, RenderMessage (HandlerSite m) FormMessage)
=> Field m a -> Text -> FormInput m a
ireq field name = FormInput $ \m l env fenv -> do ireq field name = FormInput $ \m l env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env let filteredEnv = fromMaybe [] $ Map.lookup name env
filteredFEnv = fromMaybe [] $ Map.lookup name fenv filteredFEnv = fromMaybe [] $ Map.lookup name fenv
@ -42,7 +44,7 @@ ireq field name = FormInput $ \m l env fenv -> do
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
Right (Just a) -> Right a Right (Just a) -> Right a
iopt :: Field site a -> Text -> FormInput site (Maybe a) iopt :: Monad m => Field m a -> Text -> FormInput m (Maybe a)
iopt field name = FormInput $ \m l env fenv -> do iopt field name = FormInput $ \m l env fenv -> do
let filteredEnv = fromMaybe [] $ Map.lookup name env let filteredEnv = fromMaybe [] $ Map.lookup name env
filteredFEnv = fromMaybe [] $ Map.lookup name fenv filteredFEnv = fromMaybe [] $ Map.lookup name fenv
@ -51,12 +53,12 @@ iopt field name = FormInput $ \m l env fenv -> do
Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e
Right x -> Right x Right x -> Right x
runInputGet :: MonadHandler m => FormInput (HandlerSite m) a -> m a runInputGet :: HandlerError m => FormInput m a -> m a
runInputGet (FormInput f) = do runInputGet (FormInput f) = do
env <- liftM (toMap . reqGetParams) getRequest env <- liftM (toMap . reqGetParams) getRequest
m <- getYesod m <- getYesod
l <- languages l <- languages
emx <- liftHandler $ f m l env Map.empty emx <- f m l env Map.empty
case emx of case emx of
Left errs -> invalidArgs $ errs [] Left errs -> invalidArgs $ errs []
Right x -> return x Right x -> return x
@ -64,12 +66,12 @@ runInputGet (FormInput f) = do
toMap :: [(Text, a)] -> Map.Map Text [a] toMap :: [(Text, a)] -> Map.Map Text [a]
toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y]) toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
runInputPost :: MonadHandler m => FormInput (HandlerSite m) a -> m a runInputPost :: (HandlerState m, HandlerError m, MonadResource m) => FormInput m a -> m a
runInputPost (FormInput f) = do runInputPost (FormInput f) = do
(env, fenv) <- liftM (toMap *** toMap) runRequestBody (env, fenv) <- liftM (toMap *** toMap) runRequestBody
m <- getYesod m <- getYesod
l <- languages l <- languages
emx <- liftHandler $ f m l env fenv emx <- f m l env fenv
case emx of case emx of
Left errs -> invalidArgs $ errs [] Left errs -> invalidArgs $ errs []
Right x -> return x Right x -> return x

12
yesod-form/Yesod/Form/Jquery.hs
View File

@ -53,7 +53,7 @@ class YesodJquery a where
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field site Day jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day
jqueryDayField jds = Field jqueryDayField jds = Field
{ fieldParse = parseHelper $ maybe { fieldParse = parseHelper $ maybe
(Left MsgInvalidDay) (Left MsgInvalidDay)
@ -98,7 +98,7 @@ $(function(){
] ]
jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site) jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
=> Route site -> Field site Text => Route site -> Field (HandlerT site IO) Text
jqueryAutocompleteField src = Field jqueryAutocompleteField src = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do
@ -115,14 +115,14 @@ $(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})});
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
addScript' :: (site -> Either (Route site) Text) -> GWidget site () addScript' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- getYesod
addScriptEither $ f y addScriptEither $ f y
addStylesheet' :: (site -> Either (Route site) Text) -> GWidget site () addStylesheet' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
addStylesheet' f = do addStylesheet' f = do
y <- lift getYesod y <- getYesod
addStylesheetEither $ f y addStylesheetEither $ f y
readMay :: Read a => String -> Maybe a readMay :: Read a => String -> Maybe a

21
yesod-form/Yesod/Form/MassInput.hs
View File

@ -22,8 +22,9 @@ import Data.Either (partitionEithers)
import Data.Traversable (sequenceA) import Data.Traversable (sequenceA)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import Control.Monad.Trans.Class
down :: Int -> MForm site () down :: Monad m => Int -> MForm m ()
down 0 = return () down 0 = return ()
down i | i < 0 = error "called down with a negative number" down i | i < 0 = error "called down with a negative number"
down i = do down i = do
@ -31,7 +32,7 @@ down i = do
put $ IntCons 0 is put $ IntCons 0 is
down $ i - 1 down $ i - 1
up :: Int -> MForm site () up :: Monad m => Int -> MForm m ()
up 0 = return () up 0 = return ()
up i | i < 0 = error "called down with a negative number" up i | i < 0 = error "called down with a negative number"
up i = do up i = do
@ -41,11 +42,11 @@ up i = do
IntCons _ is' -> put is' >> newFormIdent >> return () IntCons _ is' -> put is' >> newFormIdent >> return ()
up $ i - 1 up $ i - 1
inputList :: (m ~ GHandler site, xml ~ GWidget site (), RenderMessage site FormMessage) inputList :: (m ~ HandlerT site IO, xml ~ WidgetT site IO (), RenderMessage site FormMessage)
=> Html => Html
-> ([[FieldView site]] -> xml) -> ([[FieldView site]] -> xml)
-> (Maybe a -> AForm site a) -> (Maybe a -> AForm (HandlerT site IO) a)
-> (Maybe [a] -> AForm site [a]) -> (Maybe [a] -> AForm (HandlerT site IO) [a])
inputList label fixXml single mdef = formToAForm $ do inputList label fixXml single mdef = formToAForm $ do
theId <- lift newIdent theId <- lift newIdent
down 1 down 1
@ -85,9 +86,9 @@ $newline never
, fvRequired = False , fvRequired = False
}]) }])
withDelete :: (xml ~ GWidget site (), RenderMessage site FormMessage) withDelete :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage)
=> AForm site a => AForm (HandlerT site IO) a
-> MForm site (Either xml (FormResult a, [FieldView site])) -> MForm (HandlerT site IO) (Either xml (FormResult a, [FieldView site]))
withDelete af = do withDelete af = do
down 1 down 1
deleteName <- newFormIdent deleteName <- newFormIdent
@ -110,7 +111,7 @@ $newline never
up 1 up 1
return res return res
fixme :: (xml ~ GWidget site ()) fixme :: (xml ~ WidgetT site IO ())
=> [Either xml (FormResult a, [FieldView site])] => [Either xml (FormResult a, [FieldView site])]
-> (FormResult [a], [xml], [[FieldView site]]) -> (FormResult [a], [xml], [[FieldView site]])
fixme eithers = fixme eithers =
@ -121,7 +122,7 @@ fixme eithers =
massDivs, massTable massDivs, massTable
:: [[FieldView site]] :: [[FieldView site]]
-> GWidget site () -> WidgetT site IO ()
massDivs viewss = [whamlet| massDivs viewss = [whamlet|
$newline never $newline never
$forall views <- viewss $forall views <- viewss

8
yesod-form/Yesod/Form/Nic.hs
View File

@ -24,7 +24,7 @@ class Yesod a => YesodNic a where
urlNicEdit :: a -> Either (Route a) Text urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
nicHtmlField :: YesodNic site => Field site Html nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html
nicHtmlField = Field nicHtmlField = Field
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
, fieldView = \theId name attrs val _isReq -> do , fieldView = \theId name attrs val _isReq -> do
@ -33,7 +33,7 @@ $newline never
<textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val} <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val}
|] |]
addScript' urlNicEdit addScript' urlNicEdit
master <- lift getYesod master <- getYesod
toWidget $ toWidget $
case jsLoader master of case jsLoader master of
BottomOfHeadBlocking -> [julius| BottomOfHeadBlocking -> [julius|
@ -47,7 +47,7 @@ bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{ra
where where
showVal = either id (pack . renderHtml) showVal = either id (pack . renderHtml)
addScript' :: (site -> Either (Route site) Text) -> GWidget site () addScript' :: Monad m => (site -> Either (Route site) Text) -> WidgetT site m ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- getYesod
addScriptEither $ f y addScriptEither $ f y

39
yesod-form/Yesod/Form/Types.hs
View File

@ -31,8 +31,9 @@ import Text.Blaze (Markup, ToMarkup (toMarkup))
#define toHtml toMarkup #define toHtml toMarkup
import Control.Applicative ((<$>), Applicative (..)) import Control.Applicative ((<$>), Applicative (..))
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.Trans.Class
import Data.String (IsString (..)) import Data.String (IsString (..))
import Yesod.Core (GHandler, GWidget, SomeMessage, MonadLift (..)) import Yesod.Core
import qualified Data.Map as Map import qualified Data.Map as Map
-- | A form can produce three different results: there was no data available, -- | A form can produce three different results: there was no data available,
@ -79,27 +80,35 @@ instance Show Ints where
type Env = Map.Map Text [Text] type Env = Map.Map Text [Text]
type FileEnv = Map.Map Text [FileInfo] type FileEnv = Map.Map Text [FileInfo]
type Lang = Text type MForm m a = RWST
type MForm site a = RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (GHandler site) a (Maybe (Env, FileEnv), HandlerSite m, [Lang])
Enctype
Ints
m
a
newtype AForm site a = AForm newtype AForm m a = AForm
{ unAForm :: (site, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandler site (FormResult a, [FieldView site] -> [FieldView site], Ints, Enctype) { unAForm :: (HandlerSite m, [Text])
-> Maybe (Env, FileEnv)
-> Ints
-> m (FormResult a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints, Enctype)
} }
instance Functor (AForm site) where instance Monad m => Functor (AForm m) where
fmap f (AForm a) = fmap f (AForm a) =
AForm $ \x y z -> liftM go $ a x y z AForm $ \x y z -> liftM go $ a x y z
where where
go (w, x, y, z) = (fmap f w, x, y, z) go (w, x, y, z) = (fmap f w, x, y, z)
instance Applicative (AForm site) where instance Monad m => Applicative (AForm m) where
pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty) pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
(AForm f) <*> (AForm g) = AForm $ \mr env ints -> do (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
(a, b, ints', c) <- f mr env ints (a, b, ints', c) <- f mr env ints
(x, y, ints'', z) <- g mr env ints' (x, y, ints'', z) <- g mr env ints'
return (a <*> x, b `mappend` y, ints'', c `mappend` z) return (a <*> x, b `mappend` y, ints'', c `mappend` z)
instance Monoid a => Monoid (AForm site a) where instance (Monad m, Monoid a) => Monoid (AForm m a) where
mempty = pure mempty mempty = pure mempty
mappend a b = mappend <$> a <*> b mappend a b = mappend <$> a <*> b
instance MonadLift (GHandler site) (AForm site) where
instance MonadTrans AForm where
lift f = AForm $ \_ _ ints -> do lift f = AForm $ \_ _ ints -> do
x <- f x <- f
return (FormSuccess x, id, ints, mempty) return (FormSuccess x, id, ints, mempty)
@ -119,22 +128,22 @@ data FieldView site = FieldView
{ fvLabel :: Html { fvLabel :: Html
, fvTooltip :: Maybe Html , fvTooltip :: Maybe Html
, fvId :: Text , fvId :: Text
, fvInput :: GWidget site () , fvInput :: WidgetT site IO ()
, fvErrors :: Maybe Html , fvErrors :: Maybe Html
, fvRequired :: Bool , fvRequired :: Bool
} }
type FieldViewFunc site a type FieldViewFunc m a
= Text -- ^ ID = Text -- ^ ID
-> Text -- ^ Name -> Text -- ^ Name
-> [(Text, Text)] -- ^ Attributes -> [(Text, Text)] -- ^ Attributes
-> Either Text a -- ^ Either (invalid text) or (legitimate result) -> Either Text a -- ^ Either (invalid text) or (legitimate result)
-> Bool -- ^ Required? -> Bool -- ^ Required?
-> GWidget site () -> WidgetT (HandlerSite m) IO ()
data Field site a = Field data Field m a = Field
{ fieldParse :: [Text] -> [FileInfo] -> GHandler site (Either (SomeMessage site) (Maybe a)) { fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
, fieldView :: FieldViewFunc site a , fieldView :: FieldViewFunc m a
, fieldEnctype :: Enctype , fieldEnctype :: Enctype
} }

12
yesod-newsfeed/Yesod/AtomFeed.hs
View File

@ -42,7 +42,7 @@ instance HasContentType RepAtom where
instance ToTypedContent RepAtom where instance ToTypedContent RepAtom where
toTypedContent = TypedContent typeAtom . toContent toTypedContent = TypedContent typeAtom . toContent
atomFeed :: Feed (Route site) -> GHandler site RepAtom atomFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m RepAtom
atomFeed feed = do atomFeed feed = do
render <- getUrlRender render <- getUrlRender
return $ RepAtom $ toContent $ renderLBS def $ template feed render return $ RepAtom $ toContent $ renderLBS def $ template feed render
@ -75,10 +75,10 @@ entryTemplate FeedEntry {..} render = Element "entry" Map.empty $ map NodeElemen
] ]
-- | Generates a link tag in the head of a widget. -- | Generates a link tag in the head of a widget.
atomLink :: Route site atomLink :: Monad m
=> Route site
-> Text -- ^ title -> Text -- ^ title
-> GWidget site () -> WidgetT site m ()
atomLink r title = toWidgetHead [hamlet| atomLink r title = toWidgetHead [hamlet|
$newline never <link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}>
<link href=@{r} type=#{S8.unpack typeAtom} rel="alternate" title=#{title}> |]
|]

2
yesod-newsfeed/Yesod/Feed.hs
View File

@ -25,7 +25,7 @@ import Yesod.AtomFeed
import Yesod.RssFeed import Yesod.RssFeed
import Yesod.Core import Yesod.Core
newsFeed :: Feed (Route site) -> GHandler site TypedContent newsFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m TypedContent
newsFeed f = selectRep $ do newsFeed f = selectRep $ do
provideRep $ atomFeed f provideRep $ atomFeed f
provideRep $ rssFeed f provideRep $ rssFeed f

8
yesod-newsfeed/Yesod/RssFeed.hs
View File

@ -39,7 +39,7 @@ instance ToTypedContent RepRss where
toTypedContent = TypedContent typeRss . toContent toTypedContent = TypedContent typeRss . toContent
-- | Generate the feed -- | Generate the feed
rssFeed :: Feed (Route site) -> GHandler site RepRss rssFeed :: HandlerReader m => Feed (Route (HandlerSite m)) -> m RepRss
rssFeed feed = do rssFeed feed = do
render <- getUrlRender render <- getUrlRender
return $ RepRss $ toContent $ renderLBS def $ template feed render return $ RepRss $ toContent $ renderLBS def $ template feed render
@ -71,10 +71,10 @@ entryTemplate FeedEntry {..} render = Element "item" Map.empty $ map NodeElement
] ]
-- | Generates a link tag in the head of a widget. -- | Generates a link tag in the head of a widget.
rssLink :: Route site rssLink :: Monad m
=> Route site
-> Text -- ^ title -> Text -- ^ title
-> GWidget site () -> WidgetT site m ()
rssLink r title = toWidgetHead [hamlet| rssLink r title = toWidgetHead [hamlet|
$newline never
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}> <link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>
|] |]

10
yesod-persistent/Yesod/Persist.hs
View File

@ -12,21 +12,21 @@ module Yesod.Persist
import Database.Persist import Database.Persist
import Database.Persist.TH import Database.Persist.TH
import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Class (MonadTrans, lift)
import Yesod.Core import Yesod.Core
type YesodDB site = YesodPersistBackend site (GHandler site) type YesodDB site = YesodPersistBackend site (HandlerT site IO)
class YesodPersist site where class YesodPersist site where
type YesodPersistBackend site :: (* -> *) -> * -> * type YesodPersistBackend site :: (* -> *) -> * -> *
runDB :: YesodDB site a -> GHandler site a runDB :: YesodDB site a -> HandlerT site IO a
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist. -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
get404 :: ( PersistStore (t m) get404 :: ( PersistStore (t m)
, PersistEntity val , PersistEntity val
, Monad (t m) , Monad (t m)
, m ~ GHandler site , m ~ HandlerT site IO
, MonadTrans t , MonadTrans t
, PersistMonadBackend (t m) ~ PersistEntityBackend val , PersistMonadBackend (t m) ~ PersistEntityBackend val
) )
@ -41,7 +41,7 @@ get404 key = do
-- exist. -- exist.
getBy404 :: ( PersistUnique (t m) getBy404 :: ( PersistUnique (t m)
, PersistEntity val , PersistEntity val
, m ~ GHandler site , m ~ HandlerT site IO
, Monad (t m) , Monad (t m)
, MonadTrans t , MonadTrans t
, PersistEntityBackend val ~ PersistMonadBackend (t m) , PersistEntityBackend val ~ PersistMonadBackend (t m)

9
yesod-sitemap/Yesod/Sitemap.hs
View File

@ -24,7 +24,7 @@ module Yesod.Sitemap
, SitemapChangeFreq (..) , SitemapChangeFreq (..)
) where ) where
import Yesod.Core (RepXml (..), RepPlain (..), toContent, formatW3, Route, GHandler, getUrlRender) import Yesod.Core
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.Monoid (mappend) import Data.Monoid (mappend)
import Text.XML import Text.XML
@ -75,15 +75,16 @@ template urls render =
, Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority] , Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority]
] ]
sitemap :: [SitemapUrl (Route site)] -> GHandler site RepXml sitemap :: HandlerReader m => [SitemapUrl (Route (HandlerSite m))] -> m RepXml
sitemap urls = do sitemap urls = do
render <- getUrlRender render <- getUrlRender
let doc = template urls render let doc = template urls render
return $ RepXml $ toContent $ renderLBS def doc return $ RepXml $ toContent $ renderLBS def doc
-- | A basic robots file which just lists the "Sitemap: " line. -- | A basic robots file which just lists the "Sitemap: " line.
robots :: Route site -- ^ sitemap url robots :: HandlerReader m
-> GHandler site RepPlain => Route (HandlerSite m) -- ^ sitemap url
-> m RepPlain
robots smurl = do robots smurl = do
render <- getUrlRender render <- getUrlRender
return $ RepPlain $ toContent $ "Sitemap: " `mappend` render smurl return $ RepPlain $ toContent $ "Sitemap: " `mappend` render smurl

2
yesod-static/Yesod/Static.hs
View File

@ -52,7 +52,7 @@ import System.Directory
import Control.Monad import Control.Monad
import Data.FileEmbed (embedDir) import Data.FileEmbed (embedDir)
import Yesod.Core hiding (lift) import Yesod.Core
import Yesod.Core.Types import Yesod.Core.Types
import Data.List (intercalate) import Data.List (intercalate)

2
yesod/Yesod/Default/Util.hs
View File

@ -40,7 +40,7 @@ addStaticContentExternal
-> Text -- ^ filename extension -> Text -- ^ filename extension
-> Text -- ^ mime type -> Text -- ^ mime type
-> L.ByteString -- ^ file contents -> L.ByteString -- ^ file contents
-> GHandler master (Maybe (Either Text (Route master, [(Text, Text)]))) -> HandlerT master IO (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal minify hash staticDir toRoute ext' _ content = do addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
liftIO $ createDirectoryIfMissing True statictmp liftIO $ createDirectoryIfMissing True statictmp
exists <- liftIO $ doesFileExist fn' exists <- liftIO $ doesFileExist fn'