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-13 13:35:11 +02:00
parent f063074ac4
commit 099b96f178
33 changed files with 427 additions and 429 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -27,9 +27,10 @@ module Yesod.Auth
, AuthException (..) , AuthException (..)
) where ) where
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Yesod.Auth.Routes
import Data.Aeson import Data.Aeson
import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
@ -51,17 +52,17 @@ import Yesod.Form (FormMessage)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Control.Exception (Exception) import Control.Exception (Exception)
data Auth = Auth
type AuthRoute = Route Auth type AuthRoute = Route Auth
type AuthHandler master a = YesodAuth master => HandlerT Auth (GHandler master) a
type Method = Text type Method = Text
type Piece = Text type Piece = Text
data AuthPlugin master = AuthPlugin data AuthPlugin master = AuthPlugin
{ apName :: Text { apName :: Text
, apDispatch :: Method -> [Piece] -> GHandler Auth master () , apDispatch :: Method -> [Piece] -> AuthHandler master ()
, apLogin :: forall sub. (Route Auth -> Route master) -> GWidget sub master () , apLogin :: (Route Auth -> Text) -> GWidget master ()
} }
getAuth :: a -> Auth getAuth :: a -> Auth
@ -86,18 +87,19 @@ 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 sub master (Maybe (AuthId master)) getAuthId :: Creds master -> GHandler master (Maybe (AuthId master))
-- | Which authentication backends to use. -- | Which authentication backends to use.
authPlugins :: master -> [AuthPlugin master] authPlugins :: master -> [AuthPlugin master]
-- | What to show on the login page. -- | What to show on the login page.
loginHandler :: GHandler Auth master RepHtml loginHandler :: AuthHandler master RepHtml
loginHandler = defaultLayout $ do loginHandler = do
setTitleI Msg.LoginTitle render <- getUrlRender
tm <- lift getRouteToMaster lift $ defaultLayout $ do
master <- lift getYesod setTitleI Msg.LoginTitle
mapM_ (flip apLogin tm) (authPlugins master) master <- lift getYesod
mapM_ (flip apLogin render) (authPlugins master)
-- | Used for i18n of messages provided by this package. -- | Used for i18n of messages provided by this package.
renderAuthMessage :: master renderAuthMessage :: master
@ -118,11 +120,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 sub master () onLogin :: GHandler master ()
onLogin = setMessageI Msg.NowLoggedIn onLogin = setMessageI Msg.NowLoggedIn
-- | Called on logout. By default, does nothing -- | Called on logout. By default, does nothing
onLogout :: GHandler sub master () onLogout :: GHandler master ()
onLogout = return () onLogout = return ()
-- | Retrieves user credentials, if user is authenticated. -- | Retrieves user credentials, if user is authenticated.
@ -134,7 +136,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 sub master (Maybe (AuthId master)) maybeAuthId :: GHandler master (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId maybeAuthId = defaultMaybeAuthId
credsKey :: Text credsKey :: Text
@ -144,29 +146,15 @@ credsKey = "_ID"
-- --
-- Since 1.1.2 -- Since 1.1.2
defaultMaybeAuthId :: YesodAuth master defaultMaybeAuthId :: YesodAuth master
=> GHandler sub master (Maybe (AuthId master)) => GHandler master (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
mkYesodSub "Auth" setCreds :: Bool -> Creds master -> AuthHandler master ()
[ ClassP ''YesodAuth [VarT $ mkName "master"] setCreds doRedirects creds = lift $ do
]
#define STRINGS *Texts
[parseRoutes|
/check CheckR GET
/login LoginR GET
/logout LogoutR GET POST
/page/#Text/STRINGS PluginR
|]
setCreds :: YesodAuth master
=> Bool
-> Creds master
-> GHandler sub master ()
setCreds doRedirects creds = do
y <- getYesod y <- getYesod
maid <- getAuthId creds maid <- getAuthId creds
case maid of case maid of
@ -196,8 +184,8 @@ setCreds doRedirects creds = do
provideRep $ return $ object ["message" .= ("Login Successful" :: Text)] provideRep $ return $ object ["message" .= ("Login Successful" :: Text)]
sendResponse res sendResponse res
getCheckR :: YesodAuth master => GHandler Auth master TypedContent getCheckR :: AuthHandler master TypedContent
getCheckR = do getCheckR = lift $ do
creds <- maybeAuthId creds <- maybeAuthId
defaultLayoutJson (do defaultLayoutJson (do
setTitle "Authentication Status" setTitle "Authentication Status"
@ -217,29 +205,27 @@ $nothing
[ (T.pack "logged_in", Bool $ maybe False (const True) creds) [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
] ]
setUltDestReferer' :: YesodAuth master => GHandler sub master () setUltDestReferer' :: AuthHandler master ()
setUltDestReferer' = do setUltDestReferer' = lift $ do
master <- getYesod master <- getYesod
when (redirectToReferer master) setUltDestReferer when (redirectToReferer master) setUltDestReferer
getLoginR :: YesodAuth master => GHandler Auth master RepHtml getLoginR :: AuthHandler master RepHtml
getLoginR = setUltDestReferer' >> loginHandler getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: YesodAuth master => GHandler Auth master () getLogoutR :: AuthHandler master ()
getLogoutR = do getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
tm <- getRouteToMaster
setUltDestReferer' >> redirectToPost (tm LogoutR)
postLogoutR :: YesodAuth master => GHandler Auth master () postLogoutR :: AuthHandler master ()
postLogoutR = do postLogoutR = lift $ do
y <- getYesod y <- getYesod
deleteSession credsKey deleteSession credsKey
onLogout onLogout
redirectUltDest $ logoutDest y redirectUltDest $ logoutDest y
handlePluginR :: YesodAuth master => Text -> [Text] -> GHandler Auth master () handlePluginR :: Text -> [Text] -> AuthHandler master ()
handlePluginR plugin pieces = do handlePluginR plugin pieces = do
master <- getYesod master <- lift getYesod
env <- waiRequest env <- waiRequest
let method = decodeUtf8With lenientDecode $ W.requestMethod env let method = decodeUtf8With lenientDecode $ W.requestMethod env
case filter (\x -> apName x == plugin) (authPlugins master) of case filter (\x -> apName x == plugin) (authPlugins master) of
@ -247,14 +233,14 @@ handlePluginR plugin pieces = do
ap:_ -> apDispatch ap method pieces ap:_ -> apDispatch ap method pieces
maybeAuth :: ( YesodAuth master maybeAuth :: ( YesodAuth master
, PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val , PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend val
, b ~ YesodPersistBackend master , b ~ YesodPersistBackend master
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistStore (b (GHandler sub master)) , PersistStore (b (GHandler master))
, PersistEntity val , PersistEntity val
, YesodPersist master , YesodPersist master
, Typeable val , Typeable val
) => GHandler sub master (Maybe (Entity val)) ) => GHandler master (Maybe (Entity val))
maybeAuth = runMaybeT $ do maybeAuth = runMaybeT $ do
aid <- MaybeT $ maybeAuthId aid <- MaybeT $ maybeAuthId
a <- MaybeT a <- MaybeT
@ -268,21 +254,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 sub master (AuthId master) requireAuthId :: YesodAuth master => GHandler master (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 sub master)) ~ PersistEntityBackend val , PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend val
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistStore (b (GHandler sub master)) , PersistStore (b (GHandler master))
, PersistEntity val , PersistEntity val
, YesodPersist master , YesodPersist master
, Typeable val , Typeable val
) => GHandler sub master (Entity val) ) => GHandler master (Entity val)
requireAuth = maybeAuth >>= maybe redirectLogin return requireAuth = maybeAuth >>= maybe redirectLogin return
redirectLogin :: Yesod master => GHandler sub master a redirectLogin :: Yesod master => GHandler master a
redirectLogin = do redirectLogin = do
y <- getYesod y <- getYesod
setUltDestCurrent setUltDestCurrent
@ -297,3 +283,6 @@ data AuthException = InvalidBrowserIDAssertion
| InvalidFacebookResponse | InvalidFacebookResponse
deriving (Show, Typeable) deriving (Show, Typeable)
instance Exception AuthException instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (GHandler master) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)

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

@ -49,14 +49,13 @@ helper maudience = AuthPlugin
, apDispatch = \m ps -> , apDispatch = \m ps ->
case (m, ps) of case (m, ps) of
("GET", [assertion]) -> do ("GET", [assertion]) -> do
master <- getYesod master <- lift getYesod
audience <- audience <-
case maudience of case maudience of
Just a -> return a Just a -> return a
Nothing -> do Nothing -> do
tm <- getRouteToMaster
r <- getUrlRender r <- getUrlRender
return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR
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
@ -83,7 +82,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
@ -92,18 +91,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 -> Route master) -> GWidget sub master Text createOnClick :: (Route Auth -> Text) -> GWidget master Text
createOnClick toMaster = do createOnClick toMaster = do
addScriptRemote browserIdJs addScriptRemote browserIdJs
onclick <- lift newIdent onclick <- newIdent
render <- lift getUrlRender render <- getUrlRender
let login = toJSON $ getPath $ render (toMaster LoginR) let login = toJSON $ getPath $ 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 = "@{toMaster complete}/" + assertion; document.location = #{toJSON $ toMaster complete} + "/" + assertion;
} }
}, },
onlogout: function () {} onlogout: function () {}

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

@ -9,23 +9,22 @@ module Yesod.Auth.Dummy
import Yesod.Auth import Yesod.Auth
import Yesod.Form (runInputPost, textField, ireq) import Yesod.Form (runInputPost, textField, ireq)
import Yesod.Handler (notFound)
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Yesod.Widget (toWidget) import Yesod.Core
authDummy :: YesodAuth m => AuthPlugin m authDummy :: YesodAuth m => AuthPlugin m
authDummy = authDummy =
AuthPlugin "dummy" dispatch login AuthPlugin "dummy" dispatch login
where where
dispatch "POST" [] = do dispatch "POST" [] = do
ident <- runInputPost $ ireq textField "ident" ident <- lift $ runInputPost $ ireq textField "ident"
setCreds True $ Creds "dummy" ident [] 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">

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

@ -17,6 +17,7 @@ module Yesod.Auth.Email
import Network.Mail.Mime (randomString) import Network.Mail.Mime (randomString)
import Yesod.Auth import Yesod.Auth
import System.Random import System.Random
import Text.Blaze.Html (toHtml)
import Control.Monad (when) import Control.Monad (when)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Data.Digest.Pure.MD5 import Data.Digest.Pure.MD5
@ -28,9 +29,7 @@ import qualified Crypto.PasswordStore as PS
import qualified Data.Text.Encoding as DTE import qualified Data.Text.Encoding as DTE
import Yesod.Form import Yesod.Form
import Yesod.Handler import Yesod.Core
import Yesod.Content
import Yesod.Core (PathPiece, fromPathPiece, whamlet, defaultLayout, setTitleI, toPathPiece)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
@ -59,15 +58,15 @@ data EmailCreds m = EmailCreds
class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where
type AuthEmailId m type AuthEmailId m
addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) addUnverified :: Email -> VerKey -> GHandler m (AuthEmailId m)
sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler m ()
getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) getVerifyKey :: AuthEmailId m -> GHandler m (Maybe VerKey)
setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () setVerifyKey :: AuthEmailId m -> VerKey -> GHandler m ()
verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) verifyAccount :: AuthEmailId m -> GHandler m (Maybe (AuthId m))
getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) getPassword :: AuthId m -> GHandler m (Maybe SaltedPass)
setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () setPassword :: AuthId m -> SaltedPass -> GHandler m ()
getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) getEmailCreds :: Email -> GHandler m (Maybe (EmailCreds m))
getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) getEmail :: AuthEmailId m -> GHandler m (Maybe Email)
-- | Generate a random alphanumeric string. -- | Generate a random alphanumeric string.
randomKey :: m -> IO Text randomKey :: m -> IO Text
@ -80,7 +79,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}
@ -93,7 +92,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
@ -107,81 +106,75 @@ $newline never
dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
dispatch _ _ = notFound dispatch _ _ = notFound
getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml getRegisterR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml
getRegisterR = do getRegisterR = do
toMaster <- getRouteToMaster
email <- newIdent email <- newIdent
defaultLayout $ do mrender <- getMessageRender
setTitleI Msg.RegisterLong defaultLayoutT $ do
setTitle $ toHtml $ mrender Msg.RegisterLong
[whamlet| [whamlet|
$newline never <p>#{mrender Msg.EnterEmail}
<p>_{Msg.EnterEmail} <form method="post" action="@{registerR}">
<form method="post" action="@{toMaster 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 => GHandler Auth master RepHtml postRegisterR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml
postRegisterR = do postRegisterR = do
y <- getYesod y <- lift getYesod
email <- runInputPost $ ireq emailField "email" email <- lift $ runInputPost $ ireq emailField "email"
mecreds <- getEmailCreds email mecreds <- lift $ getEmailCreds email
(lid, verKey) <- (lid, verKey) <-
case mecreds of case mecreds of
Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
Just (EmailCreds lid _ _ Nothing) -> do Just (EmailCreds lid _ _ Nothing) -> do
key <- liftIO $ randomKey y key <- liftIO $ randomKey y
setVerifyKey lid key lift $ setVerifyKey lid key
return (lid, key) return (lid, key)
Nothing -> do Nothing -> do
key <- liftIO $ randomKey y key <- liftIO $ randomKey y
lid <- addUnverified email key lid <- lift $ addUnverified email key
return (lid, key) return (lid, key)
render <- getUrlRender render <- getUrlRender
tm <- getRouteToMaster let verUrl = render $ verify (toPathPiece lid) verKey
let verUrl = render $ tm $ verify (toPathPiece lid) verKey lift $ sendVerifyEmail email verKey verUrl
sendVerifyEmail email verKey verUrl lift $ defaultLayout $ do
defaultLayout $ do
setTitleI Msg.ConfirmationEmailSentTitle setTitleI Msg.ConfirmationEmailSentTitle
[whamlet| [whamlet|<p>_{Msg.ConfirmationEmailSent email}|]
$newline never
<p>_{Msg.ConfirmationEmailSent email}
|]
getVerifyR :: YesodAuthEmail m getVerifyR :: YesodAuthEmail m
=> AuthEmailId m -> Text -> GHandler Auth m RepHtml => AuthEmailId m
-> Text
-> HandlerT Auth (GHandler m) RepHtml
getVerifyR lid key = do getVerifyR lid key = do
realKey <- getVerifyKey lid realKey <- lift $ getVerifyKey lid
memail <- getEmail lid memail <- lift $ getEmail lid
case (realKey == Just key, memail) of case (realKey == Just key, memail) of
(True, Just email) -> do (True, Just email) -> do
muid <- verifyAccount lid muid <- lift $ verifyAccount lid
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? setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?
toMaster <- getRouteToMaster mrender <- lift getMessageRender
setMessageI Msg.AddressVerified setMessage $ toHtml $ mrender Msg.AddressVerified
redirect $ toMaster setpassR redirect setpassR
_ -> return () _ -> return ()
defaultLayout $ do lift $ defaultLayout $ do
setTitleI Msg.InvalidKey setTitleI Msg.InvalidKey
[whamlet| [whamlet|<p>_{Msg.InvalidKey}|]
$newline never
<p>_{Msg.InvalidKey}
|]
postLoginR :: YesodAuthEmail master => GHandler Auth master () postLoginR :: YesodAuthEmail master => HandlerT Auth (GHandler master) ()
postLoginR = do postLoginR = do
(email, pass) <- runInputPost $ (,) (email, pass) <- lift $ runInputPost $ (,)
<$> ireq emailField "email" <$> ireq emailField "email"
<*> ireq textField "password" <*> ireq textField "password"
mecreds <- getEmailCreds email mecreds <- lift $ getEmailCreds email
maid <- maid <-
case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
(Just aid, Just True) -> do (Just aid, Just True) -> do
mrealpass <- getPassword aid mrealpass <- lift $ getPassword aid
case mrealpass of case mrealpass of
Nothing -> return Nothing Nothing -> return Nothing
Just realpass -> return $ Just realpass -> return $
@ -193,63 +186,63 @@ postLoginR = do
Just _aid -> Just _aid ->
setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?
Nothing -> do Nothing -> do
setMessageI Msg.InvalidEmailPass mrender <- lift getMessageRender
toMaster <- getRouteToMaster setMessage $ toHtml $ mrender Msg.InvalidEmailPass
redirect $ toMaster LoginR redirect LoginR
getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml getPasswordR :: YesodAuthEmail master => HandlerT Auth (GHandler master) RepHtml
getPasswordR = do getPasswordR = do
toMaster <- getRouteToMaster maid <- lift maybeAuthId
maid <- 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
setMessageI Msg.BadSetPass setMessage $ toHtml $ mrender Msg.BadSetPass
redirect $ toMaster LoginR redirect LoginR
defaultLayout $ do defaultLayoutT $ do
setTitleI Msg.SetPassTitle setTitle $ toHtml $ mrender Msg.SetPassTitle -- FIXME make setTitleI more intelligent
[whamlet| [whamlet|
$newline never $newline never
<h3>_{Msg.SetPass} <h3>#{mrender Msg.SetPass}
<form method="post" action="@{toMaster setpassR}"> <form method="post" action="@{setpassR}">
<table> <table>
<tr> <tr>
<th> <th>
<label for=#{pass1}>_{Msg.NewPass} <label for=#{pass1}>#{mrender Msg.NewPass}
<td> <td>
<input ##{pass1} type="password" name="new"> <input ##{pass1} type="password" name="new">
<tr> <tr>
<th> <th>
<label for=#{pass2}>_{Msg.ConfirmPass} <label for=#{pass2}>#{mrender 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="_{Msg.SetPassTitle}"> <input type="submit" value=#{mrender Msg.SetPassTitle}>
|] |]
postPasswordR :: YesodAuthEmail master => GHandler Auth master () postPasswordR :: YesodAuthEmail master => HandlerT Auth (GHandler master) ()
postPasswordR = do postPasswordR = do
(new, confirm) <- runInputPost $ (,) (new, confirm) <- lift $ runInputPost $ (,)
<$> ireq textField "new" <$> ireq textField "new"
<*> ireq textField "confirm" <*> ireq textField "confirm"
toMaster <- getRouteToMaster
y <- getYesod
when (new /= confirm) $ do when (new /= confirm) $ do
setMessageI Msg.PassMismatch lift $ setMessageI Msg.PassMismatch
redirect $ toMaster setpassR redirect setpassR
maid <- maybeAuthId maid <- lift maybeAuthId
aid <- case maid of aid <- case maid of
Nothing -> do Nothing -> do
setMessageI Msg.BadSetPass lift $ setMessageI Msg.BadSetPass
redirect $ toMaster LoginR redirect LoginR
Just aid -> return aid Just aid -> return aid
salted <- liftIO $ saltPass new salted <- liftIO $ saltPass new
setPassword aid salted lift $ do
setMessageI Msg.PassUpdated y <- getYesod
redirect $ loginDest y setPassword aid salted
setMessageI Msg.PassUpdated
redirect $ loginDest y
saltLength :: Int saltLength :: Int
saltLength = 5 saltLength = 5

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

@ -40,15 +40,11 @@ authGoogleEmail =
where where
complete = PluginR pid ["complete"] complete = PluginR pid ["complete"]
login tm = login tm =
[whamlet| [whamlet|<a href=#{tm forwardUrl}>_{Msg.LoginGoogle}|]
$newline never
<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}
|]
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
render <- getUrlRender render <- getUrlRender
toMaster <- getRouteToMaster let complete' = render complete
let complete' = render $ toMaster complete master <- lift getYesod
master <- getYesod
eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing
[ ("openid.ax.type.email", "http://schema.openid.net/contact/email") [ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
, ("openid.ns.ax", "http://openid.net/srv/ax/1.0") , ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
@ -60,7 +56,7 @@ $newline never
either either
(\err -> do (\err -> do
setMessage $ toHtml $ show (err :: SomeException) setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR redirect LoginR
) )
redirect redirect
eres eres
@ -74,14 +70,13 @@ $newline never
completeHelper posts completeHelper posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () completeHelper :: YesodAuth m => [(Text, Text)] -> HandlerT Auth (GHandler m) ()
completeHelper gets' = do completeHelper gets' = do
master <- getYesod master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
toMaster <- getRouteToMaster
let onFailure err = do let onFailure err = do
setMessage $ toHtml $ show (err :: SomeException) setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR redirect LoginR
let onSuccess oir = do let onSuccess oir = 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"
@ -89,8 +84,8 @@ completeHelper gets' = do
(Just email, True) -> setCreds True $ Creds pid email [] (Just email, True) -> setCreds True $ Creds pid email []
(_, False) -> do (_, False) -> do
setMessage "Only Google login is supported" setMessage "Only Google login is supported"
redirect $ toMaster LoginR redirect LoginR
(Nothing, _) -> do (Nothing, _) -> do
setMessage "No email address provided" setMessage "No email address provided"
redirect $ toMaster LoginR redirect LoginR
either onFailure onSuccess eres either onFailure onSuccess eres

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

@ -73,10 +73,9 @@ module Yesod.Auth.HashDB
) where ) where
import Yesod.Persist import Yesod.Persist
import Yesod.Handler
import Yesod.Form import Yesod.Form
import Yesod.Auth import Yesod.Auth
import Yesod.Widget (toWidget) import Yesod.Core
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
@ -135,14 +134,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 sub yesod)) ~ PersistEntityBackend user , PersistMonadBackend (b (GHandler yesod)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler sub yesod)) , PersistUnique (b (GHandler yesod))
, 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 sub yesod Bool -> GHandler yesod 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
@ -162,23 +161,22 @@ 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 Auth y)) ~ PersistEntityBackend user , PersistMonadBackend (b (GHandler y)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler Auth y)) , PersistUnique (b (GHandler y))
) )
=> (Text -> Maybe (Unique user)) => (Text -> Maybe (Unique user))
-> GHandler Auth y () -> HandlerT Auth (GHandler y) ()
postLoginR uniq = do postLoginR uniq = do
(mu,mp) <- runInputPost $ (,) (mu,mp) <- lift $ runInputPost $ (,)
<$> iopt textField "username" <$> iopt textField "username"
<*> iopt textField "password" <*> iopt textField "password"
isValid <- 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 setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do setMessage "Invalid username/password" else do setMessage "Invalid username/password"
toMaster <- getRouteToMaster redirect LoginR
redirect $ toMaster LoginR
-- | A drop in for the getAuthId method of your YesodAuth instance which -- | A drop in for the getAuthId method of your YesodAuth instance which
@ -187,13 +185,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 sub master)) ~ PersistEntityBackend user , PersistMonadBackend (b (GHandler master)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler sub master)) , PersistUnique (b (GHandler master))
) )
=> (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 sub master (Maybe (AuthId master)) -> GHandler master (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do getAuthIdHashDB authR uniq creds = do
muid <- maybeAuthId muid <- maybeAuthId
case muid of case muid of
@ -216,8 +214,8 @@ authHashDB :: ( YesodAuth m, YesodPersist m
, HashDBUser user , HashDBUser user
, PersistEntity user , PersistEntity user
, b ~ YesodPersistBackend m , b ~ YesodPersistBackend m
, PersistMonadBackend (b (GHandler Auth m)) ~ PersistEntityBackend user , PersistMonadBackend (b (GHandler m)) ~ PersistEntityBackend user
, PersistUnique (b (GHandler Auth m))) , PersistUnique (b (GHandler m)))
=> (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
@ -225,7 +223,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:

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

@ -48,35 +48,33 @@ 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}">
|] |]
dispatch "GET" ["forward"] = do dispatch "GET" ["forward"] = do
roid <- runInputGet $ iopt textField name roid <- lift $ runInputGet $ iopt textField name
case roid of case roid of
Just oid -> do Just oid -> do
render <- getUrlRender render <- getUrlRender
toMaster <- getRouteToMaster let complete' = render complete
let complete' = render $ toMaster complete master <- lift getYesod
master <- getYesod
eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
case eres of case eres of
Left err -> do Left err -> do
setMessage $ toHtml $ show (err :: SomeException) setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR redirect LoginR
Right x -> redirect x Right x -> redirect x
Nothing -> do Nothing -> do
toMaster <- getRouteToMaster
setMessageI Msg.NoOpenID setMessageI Msg.NoOpenID
redirect $ toMaster 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
rr <- getRequest rr <- getRequest
@ -87,14 +85,13 @@ $newline never
completeHelper idType posts completeHelper idType posts
dispatch _ _ = notFound dispatch _ _ = notFound
completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m () completeHelper :: YesodAuth master => IdentifierType -> [(Text, Text)] -> HandlerT Auth (GHandler master) ()
completeHelper idType gets' = do completeHelper idType gets' = do
master <- getYesod master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master) eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
toMaster <- getRouteToMaster
let onFailure err = do let onFailure err = do
setMessage $ toHtml $ show (err :: SomeException) setMessage $ toHtml $ show (err :: SomeException)
redirect $ toMaster LoginR redirect LoginR
let onSuccess oir = do let onSuccess oir = do
let claimed = let claimed =
case OpenId.oirClaimed oir of case OpenId.oirClaimed oir of

20
yesod-auth/Yesod/Auth/Routes.hs Normal file
View File

@ -0,0 +1,20 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Yesod.Auth.Routes where
import Yesod.Core
import Data.Text (Text)
data Auth = Auth
mkYesodSubData "Auth" [parseRoutes|
/check CheckR GET
/login LoginR GET
/logout LogoutR GET POST
/page/#Text/*Texts PluginR
|]

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

@ -12,7 +12,7 @@ import Control.Monad (mplus)
import Yesod.Core import Yesod.Core
import Text.Hamlet (hamlet) import Text.Hamlet (hamlet)
import Data.Text (pack, unpack) import Data.Text (pack, unpack, Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***)) import Control.Arrow ((***))
@ -26,13 +26,12 @@ authRpxnow app apiKey =
AuthPlugin "rpxnow" dispatch login AuthPlugin "rpxnow" dispatch login
where where
login :: login ::
forall sub master. forall master.
ToWidget sub master (GWidget sub master ()) ToWidget master (GWidget master ())
=> (Route Auth -> Route master) -> GWidget sub master () => (Route Auth -> Text) -> GWidget master ()
login tm = do login tm = do
render <- lift getUrlRender
let queryString = decodeUtf8With lenientDecode let queryString = decodeUtf8With lenientDecode
$ renderQuery True [("token_url", Just $ encodeUtf8 $ render $ tm $ PluginR "rpxnow" [])] $ renderQuery True [("token_url", Just $ encodeUtf8 $ 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">
@ -43,7 +42,7 @@ $newline never
token <- case token1 ++ token2 of token <- case token1 ++ token2 of
[] -> invalidArgs ["token: Value not supplied"] [] -> invalidArgs ["token: Value not supplied"]
x:_ -> return $ unpack x x:_ -> return $ unpack x
master <- getYesod master <- lift getYesod
Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master) Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
let creds = let creds =
Creds "rpxnow" ident Creds "rpxnow" ident

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

@ -54,6 +54,7 @@ library
Yesod.Auth.HashDB Yesod.Auth.HashDB
Yesod.Auth.Message Yesod.Auth.Message
Yesod.Auth.GoogleEmail Yesod.Auth.GoogleEmail
other-modules: Yesod.Auth.Routes
ghc-options: -Wall ghc-options: -Wall
source-repository head source-repository head

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

@ -50,6 +50,9 @@ module Yesod.Core
-- * Subsites -- * Subsites
, defaultLayoutT , defaultLayoutT
, MonadHandler (..) , MonadHandler (..)
, HandlerReader (..)
, HandlerState (..)
, HandlerError (..)
-- * Misc -- * Misc
, yesodVersion , yesodVersion
, yesodRender , yesodRender
@ -121,7 +124,7 @@ defaultLayoutT :: ( HandlerSite m ~ sub
defaultLayoutT (GWidget (GHandler f)) = do defaultLayoutT (GWidget (GHandler f)) = do
hd <- askHandlerData hd <- askHandlerData
((), gwdata) <- liftResourceT $ f hd ((), gwdata) <- liftResourceT $ f hd
liftHandler $ defaultLayout $ GWidget $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata) liftHandlerMaster $ defaultLayout $ GWidget $ return ((), renderGWData (rheRender $ handlerEnv hd) gwdata)
renderGWData :: (x -> [(Text, Text)] -> Text) -> GWData x -> GWData y renderGWData :: (x -> [(Text, Text)] -> Text) -> GWData x -> GWData y
renderGWData render gwd = GWData renderGWData render gwd = GWData

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

@ -19,6 +19,7 @@ class Monad m => HandlerReader m where
askYesodRequest :: m YesodRequest askYesodRequest :: m YesodRequest
askHandlerEnv :: m (RunHandlerEnv (HandlerSite m)) askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
askHandlerEnvMaster :: m (RunHandlerEnv (HandlerMaster m))
instance HandlerReader (GHandler site) where instance HandlerReader (GHandler site) where
type HandlerSite (GHandler site) = site type HandlerSite (GHandler site) = site
@ -26,6 +27,7 @@ instance HandlerReader (GHandler site) where
askYesodRequest = GHandler $ return . handlerRequest askYesodRequest = GHandler $ return . handlerRequest
askHandlerEnv = GHandler $ return . handlerEnv askHandlerEnv = GHandler $ return . handlerEnv
askHandlerEnvMaster = GHandler $ return . handlerEnv
instance HandlerReader m => HandlerReader (HandlerT site m) where instance HandlerReader m => HandlerReader (HandlerT site m) where
type HandlerSite (HandlerT site m) = site type HandlerSite (HandlerT site m) = site
@ -33,6 +35,7 @@ instance HandlerReader m => HandlerReader (HandlerT site m) where
askYesodRequest = HandlerT $ return . handlerRequest askYesodRequest = HandlerT $ return . handlerRequest
askHandlerEnv = HandlerT $ return . handlerEnv askHandlerEnv = HandlerT $ return . handlerEnv
askHandlerEnvMaster = lift askHandlerEnvMaster
instance HandlerReader (GWidget site) where instance HandlerReader (GWidget site) where
type HandlerSite (GWidget site) = site type HandlerSite (GWidget site) = site
@ -40,6 +43,7 @@ instance HandlerReader (GWidget site) where
askYesodRequest = lift askYesodRequest askYesodRequest = lift askYesodRequest
askHandlerEnv = lift askHandlerEnv askHandlerEnv = lift askHandlerEnv
askHandlerEnvMaster = lift askHandlerEnvMaster
class HandlerReader m => HandlerState m where class HandlerReader m => HandlerState m where
stateGHState :: (GHState -> (a, GHState)) -> m a stateGHState :: (GHState -> (a, GHState)) -> m a

10
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -562,12 +562,18 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
char = show . snd . loc_start char = show . snd . loc_start
class (MonadBaseControl IO m, HandlerState m, HandlerError m, MonadResource m, Yesod (HandlerMaster m)) => MonadHandler m where class (MonadBaseControl IO m, HandlerState m, HandlerError m, MonadResource m, Yesod (HandlerMaster m)) => MonadHandler m where
liftHandler :: GHandler (HandlerMaster m) a -> m a liftHandler :: GHandler (HandlerSite m) a -> m a
liftHandler (GHandler f) = do
hd <- askHandlerData
liftResourceT $ f hd
liftHandlerMaster :: GHandler (HandlerMaster m) a -> m a
askHandlerData :: m (HandlerData (HandlerSite m)) askHandlerData :: m (HandlerData (HandlerSite m))
instance Yesod site => MonadHandler (GHandler site) where instance Yesod site => MonadHandler (GHandler site) where
liftHandler = id liftHandler = id
liftHandlerMaster = id
askHandlerData = GHandler return askHandlerData = GHandler return
instance MonadHandler m => MonadHandler (HandlerT site m) where instance MonadHandler m => MonadHandler (HandlerT site m) where
liftHandler = lift . liftHandler liftHandlerMaster = lift . liftHandlerMaster
askHandlerData = HandlerT return askHandlerData = HandlerT return

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

@ -417,7 +417,7 @@ setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessageI :: (HandlerState m, RenderMessage (HandlerSite m) msg) setMessageI :: (HandlerState m, RenderMessage (HandlerMaster m) msg)
=> msg -> m () => msg -> m ()
setMessageI msg = do setMessageI msg = do
mr <- getMessageRender mr <- getMessageRender
@ -490,7 +490,7 @@ permissionDenied :: HandlerError m => Text -> m a
permissionDenied = hcError . PermissionDenied permissionDenied = hcError . PermissionDenied
-- | Return a 403 permission denied page. -- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, HandlerError m) permissionDeniedI :: (RenderMessage (HandlerMaster m) msg, HandlerError m)
=> msg => msg
-> m a -> m a
permissionDeniedI msg = do permissionDeniedI msg = do
@ -502,7 +502,7 @@ invalidArgs :: HandlerError m => [Text] -> m a
invalidArgs = hcError . InvalidArgs invalidArgs = hcError . InvalidArgs
-- | Return a 400 invalid arguments page. -- | Return a 400 invalid arguments page.
invalidArgsI :: (HandlerError m, RenderMessage (HandlerSite m) msg) => [msg] -> m a invalidArgsI :: (HandlerError m, RenderMessage (HandlerMaster m) msg) => [msg] -> m a
invalidArgsI msg = do invalidArgsI msg = do
mr <- getMessageRender mr <- getMessageRender
invalidArgs $ map mr msg invalidArgs $ map mr msg
@ -693,12 +693,12 @@ giveUrlRenderer f = do
waiRequest :: HandlerReader m => m W.Request waiRequest :: HandlerReader m => m W.Request
waiRequest = reqWaiRequest `liftM` getRequest waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (HandlerReader m, RenderMessage (HandlerSite m) message) getMessageRender :: (HandlerReader m, RenderMessage (HandlerMaster m) message)
=> m (message -> Text) => m (message -> Text)
getMessageRender = do getMessageRender = do
m <- getYesod env <- askHandlerEnvMaster
l <- reqLangs `liftM` getRequest l <- reqLangs `liftM` getRequest
return $ renderMessage m l return $ renderMessage (rheSite env) l
-- | Use a per-request cache to avoid performing the same action multiple -- | Use a per-request cache to avoid performing the same action multiple
-- times. Note that values are stored by their type. Therefore, you should use -- times. Note that values are stored by their type. Therefore, you should use

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

@ -95,6 +95,7 @@ library
Yesod.Core.Json Yesod.Core.Json
Yesod.Core.Widget Yesod.Core.Widget
Yesod.Core.Internal Yesod.Core.Internal
Yesod.Core.Types
other-modules: Yesod.Core.Internal.Session other-modules: Yesod.Core.Internal.Session
Yesod.Core.Internal.Request Yesod.Core.Internal.Request
Yesod.Core.Class.Handler Yesod.Core.Class.Handler
@ -105,7 +106,6 @@ library
Yesod.Core.Class.Yesod Yesod.Core.Class.Yesod
Yesod.Core.Class.Dispatch Yesod.Core.Class.Dispatch
Yesod.Core.Class.Breadcrumbs Yesod.Core.Class.Breadcrumbs
Yesod.Core.Types
Yesod.Core.Types.Orphan Yesod.Core.Types.Orphan
Paths_yesod_core Paths_yesod_core
ghc-options: -Wall ghc-options: -Wall

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

@ -23,7 +23,7 @@ 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 sub master a => FieldSettings master -> Maybe a -> AForm master a
{- FIXME {- FIXME
instance ToFormField String y where instance ToFormField String y where

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

@ -49,9 +49,7 @@ module Yesod.Form.Fields
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Form.I18n.English import Yesod.Form.I18n.English
import Yesod.Form.Functions (parseHelper) import Yesod.Form.Functions (parseHelper)
import Yesod.Handler (getMessageRender) import Yesod.Core
import Yesod.Widget (toWidget, whamlet, GWidget)
import Yesod.Core (RenderMessage (renderMessage), SomeMessage (..))
import Text.Hamlet import Text.Hamlet
import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString) import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString)
#define ToHtml ToMarkup #define ToHtml ToMarkup
@ -82,10 +80,6 @@ import Data.Text (Text, unpack, pack)
import qualified Data.Text.Read import qualified Data.Text.Read
import qualified Data.Map as Map import qualified Data.Map as Map
import Yesod.Core (newIdent, lift)
import Yesod.Core (FileInfo)
import Yesod.Core (toPathPiece, GHandler, PathPiece, fromPathPiece)
import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery) import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)
import Control.Arrow ((&&&)) import Control.Arrow ((&&&))
@ -97,7 +91,7 @@ defaultFormMessage :: FormMessage -> Text
defaultFormMessage = englishFormMessage defaultFormMessage = englishFormMessage
intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i intField :: (Integral i, RenderMessage site FormMessage) => Field site 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
@ -114,7 +108,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 master FormMessage => Field sub master Double doubleField :: RenderMessage site FormMessage => Field site 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
@ -129,7 +123,7 @@ $newline never
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
dayField :: RenderMessage master FormMessage => Field sub master Day dayField :: RenderMessage site FormMessage => Field site 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|
@ -140,7 +134,7 @@ $newline never
} }
where showVal = either id (pack . show) where showVal = either id (pack . show)
timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField :: RenderMessage site FormMessage => Field site 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|
@ -156,7 +150,7 @@ $newline never
where where
fullSec = fromInteger $ floor $ todSec tod fullSec = fromInteger $ floor $ todSec tod
htmlField :: RenderMessage master FormMessage => Field sub master Html htmlField :: RenderMessage site FormMessage => Field site 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|
@ -185,7 +179,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 master FormMessage => Field sub master Textarea textareaField :: RenderMessage site FormMessage => Field site 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|
@ -195,8 +189,8 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
hiddenField :: (PathPiece p, RenderMessage master FormMessage) hiddenField :: (PathPiece p, RenderMessage site FormMessage)
=> Field sub master p => Field site 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|
@ -206,7 +200,7 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
textField :: RenderMessage master FormMessage => Field sub master Text textField :: RenderMessage site FormMessage => Field site Text
textField = Field textField = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> , fieldView = \theId name attrs val isReq ->
@ -217,7 +211,7 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
passwordField :: RenderMessage master FormMessage => Field sub master Text passwordField :: RenderMessage site FormMessage => Field site 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|
@ -288,7 +282,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 master FormMessage => Field sub master Text emailField :: RenderMessage site FormMessage => Field site Text
emailField = Field emailField = Field
{ fieldParse = parseHelper $ { fieldParse = parseHelper $
\s -> \s ->
@ -303,7 +297,7 @@ $newline never
} }
type AutoFocus = Bool type AutoFocus = Bool
searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text searchField :: RenderMessage site FormMessage => AutoFocus -> Field site 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
@ -324,7 +318,7 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
urlField :: RenderMessage master FormMessage => Field sub master Text urlField :: RenderMessage site FormMessage => Field site Text
urlField = Field urlField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->
case parseURI $ unpack s of case parseURI $ unpack s of
@ -338,10 +332,10 @@ $newline never
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site a
selectFieldList = selectField . optionsPairs selectFieldList = selectField . optionsPairs
selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a selectField :: (Eq a, RenderMessage site FormMessage) => GHandler site (OptionList a) -> Field site a
selectField = selectFieldHelper selectField = selectFieldHelper
(\theId name attrs inside -> [whamlet| (\theId name attrs inside -> [whamlet|
$newline never $newline never
@ -356,12 +350,12 @@ $newline never
<option value=#{value} :isSel:selected>#{text} <option value=#{value} :isSel:selected>#{text}
|]) -- inside |]) -- inside
multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a] multiSelectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site [a]
multiSelectFieldList = multiSelectField . optionsPairs multiSelectFieldList = multiSelectField . optionsPairs
multiSelectField :: (Eq a, RenderMessage master FormMessage) multiSelectField :: (Eq a, RenderMessage site FormMessage)
=> GHandler sub master (OptionList a) => GHandler site (OptionList a)
-> Field sub master [a] -> Field site [a]
multiSelectField ioptlist = multiSelectField ioptlist =
Field parse view UrlEncoded Field parse view UrlEncoded
where where
@ -385,10 +379,10 @@ $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 master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] -> Field site a
radioFieldList = radioField . optionsPairs radioFieldList = radioField . optionsPairs
radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a radioField :: (Eq a, RenderMessage site FormMessage) => GHandler site (OptionList a) -> Field site a
radioField = selectFieldHelper radioField = selectFieldHelper
(\theId _name _attrs inside -> [whamlet| (\theId _name _attrs inside -> [whamlet|
$newline never $newline never
@ -409,7 +403,7 @@ $newline never
\#{text} \#{text}
|]) |])
boolField :: RenderMessage master FormMessage => Field sub master Bool boolField :: RenderMessage site FormMessage => Field site 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|
@ -445,7 +439,7 @@ $newline never
-- --
-- Note that this makes the field always optional. -- Note that this makes the field always optional.
-- --
checkBoxField :: RenderMessage m FormMessage => Field s m Bool checkBoxField :: RenderMessage site FormMessage => Field site 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|
@ -481,7 +475,7 @@ data Option a = Option
, optionExternalValue :: Text , optionExternalValue :: Text
} }
optionsPairs :: RenderMessage master msg => [(msg, a)] -> GHandler sub master (OptionList a) optionsPairs :: RenderMessage site msg => [(msg, a)] -> GHandler site (OptionList a)
optionsPairs opts = do optionsPairs opts = do
mr <- getMessageRender mr <- getMessageRender
let mkOption external (display, internal) = let mkOption external (display, internal) =
@ -491,16 +485,16 @@ 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 sub master (OptionList a) optionsEnum :: (Show a, Enum a, Bounded a) => GHandler site (OptionList a)
optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
optionsPersist :: ( YesodPersist master, PersistEntity a optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (YesodPersistBackend master (GHandler sub master)) , PersistQuery (YesodPersistBackend site (GHandler site))
, PathPiece (Key a) , PathPiece (Key a)
, PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend master (GHandler sub master)) , PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (GHandler site))
, RenderMessage master msg , RenderMessage site msg
) )
=> [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler sub master (OptionList (Entity a)) => [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler site (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
@ -511,11 +505,11 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
}) pairs }) pairs
selectFieldHelper selectFieldHelper
:: (Eq a, RenderMessage master FormMessage) :: (Eq a, RenderMessage site FormMessage)
=> (Text -> Text -> [(Text, Text)] -> GWidget sub master () -> GWidget sub master ()) => (Text -> Text -> [(Text, Text)] -> GWidget site () -> GWidget site ())
-> (Text -> Text -> Bool -> GWidget sub master ()) -> (Text -> Text -> Bool -> GWidget site ())
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget sub master ()) -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> GWidget site ())
-> GHandler sub master (OptionList a) -> Field sub master a -> GHandler site (OptionList a) -> Field site a
selectFieldHelper outside onOpt inside opts' = Field selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x _ -> do { fieldParse = \x _ -> do
opts <- opts' opts <- opts'
@ -544,7 +538,7 @@ 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 master FormMessage => Field sub master FileInfo fileField :: RenderMessage site FormMessage => Field site FileInfo
fileField = Field fileField = Field
{ fieldParse = \_ files -> return $ { fieldParse = \_ files -> return $
case files of case files of
@ -556,8 +550,8 @@ fileField = Field
, fieldEnctype = Multipart , fieldEnctype = Multipart
} }
fileAFormReq :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master FileInfo fileAFormReq :: RenderMessage site FormMessage => FieldSettings site -> AForm site FileInfo
fileAFormReq fs = AForm $ \(master, 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
Just x -> (x, ints) Just x -> (x, ints)
@ -572,11 +566,11 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do
case Map.lookup name fenv of case Map.lookup name fenv of
Just (fi:_) -> (FormSuccess fi, Nothing) Just (fi:_) -> (FormSuccess fi, Nothing)
_ -> _ ->
let t = renderMessage master langs MsgValueRequired let t = renderMessage site langs MsgValueRequired
in (FormFailure [t], Just $ toHtml t) in (FormFailure [t], Just $ toHtml t)
let fv = FieldView let fv = FieldView
{ fvLabel = toHtml $ renderMessage master langs $ fsLabel fs { fvLabel = toHtml $ renderMessage site langs $ fsLabel fs
, fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs
, fvId = id' , fvId = id'
, fvInput = [whamlet| , fvInput = [whamlet|
$newline never $newline never
@ -587,7 +581,7 @@ $newline never
} }
return (res, (fv :), ints', Multipart) return (res, (fv :), ints', Multipart)
fileAFormOpt :: RenderMessage master FormMessage => FieldSettings master -> AForm sub master (Maybe FileInfo) fileAFormOpt :: RenderMessage site FormMessage => FieldSettings site -> AForm site (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

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

@ -1,4 +1,5 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -42,33 +43,27 @@ module Yesod.Form.Functions
, parseHelper , parseHelper
) where ) where
import Control.Monad.Trans.Resource (MonadResource)
import Yesod.Form.Types 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 (lift)
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)
#define Html Markup #define Html Markup
#define toHtml toMarkup #define toHtml toMarkup
import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod) import Yesod.Core
import Yesod.Core (RenderMessage, SomeMessage (..))
import Yesod.Widget (GWidget, whamlet)
import Yesod.Core (reqToken, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod) import Network.Wai (requestMethod)
import Text.Hamlet (shamlet) import Text.Hamlet (shamlet)
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Data.Maybe (listToMaybe, fromMaybe) import Data.Maybe (listToMaybe, fromMaybe)
import Yesod.Core (RenderMessage (..))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import Control.Applicative ((<$>))
import Control.Arrow (first) import Control.Arrow (first)
import Yesod.Core (FileInfo)
-- | Get a unique identifier. -- | Get a unique identifier.
newFormIdent :: MForm sub master Text newFormIdent :: MForm site Text
newFormIdent = do newFormIdent = do
i <- get i <- get
let i' = incrInts i let i' = incrInts i
@ -78,54 +73,54 @@ 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 sub master (FormResult a, [FieldView sub master]) -> AForm sub master a formToAForm :: MForm site (FormResult a, [FieldView site]) -> AForm site a
formToAForm form = AForm $ \(master, langs) env ints -> do formToAForm form = AForm $ \(site, langs) env ints -> do
((a, xmls), ints', enc) <- runRWST form (env, master, langs) ints ((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints
return (a, (++) xmls, ints', enc) return (a, (++) xmls, ints', enc)
aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master]) aFormToForm :: AForm site a -> MForm site (FormResult a, [FieldView site] -> [FieldView site])
aFormToForm (AForm aform) = do aFormToForm (AForm aform) = do
ints <- get ints <- get
(env, master, langs) <- ask (env, site, langs) <- ask
(a, xml, ints', enc) <- lift $ aform (master, langs) env ints (a, xml, ints', enc) <- lift $ aform (site, langs) env ints
put ints' put ints'
tell enc tell enc
return (a, xml) return (a, xml)
askParams :: MForm sub master (Maybe Env) askParams :: MForm site (Maybe Env)
askParams = do askParams = do
(x, _, _) <- ask (x, _, _) <- ask
return $ liftM fst x return $ liftM fst x
askFiles :: MForm sub master (Maybe FileEnv) askFiles :: MForm site (Maybe FileEnv)
askFiles = do askFiles = do
(x, _, _) <- ask (x, _, _) <- ask
return $ liftM snd x return $ liftM snd x
mreq :: RenderMessage master FormMessage mreq :: RenderMessage site FormMessage
=> Field sub master a -> FieldSettings master -> Maybe a => Field site a -> FieldSettings site -> Maybe a
-> MForm sub master (FormResult a, FieldView sub master) -> MForm site (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 sub master a -> FieldSettings master -> Maybe (Maybe a) mopt :: Field site a -> FieldSettings site -> Maybe (Maybe a)
-> MForm sub master (FormResult (Maybe a), FieldView sub master) -> MForm site (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 sub master a mhelper :: Field site a
-> FieldSettings master -> FieldSettings site
-> Maybe a -> Maybe a
-> (master -> [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 sub master (FormResult b, FieldView sub master) -> MForm site (FormResult b, FieldView site)
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
tell fieldEnctype tell fieldEnctype
mp <- askParams mp <- askParams
name <- maybe newFormIdent return fsName name <- maybe newFormIdent return fsName
theId <- lift $ maybe newIdent return fsId theId <- lift $ maybe newIdent return fsId
(_, master, langs) <- ask (_, site, langs) <- ask
let mr2 = renderMessage master langs let mr2 = renderMessage site langs
(res, val) <- (res, val) <-
case mp of case mp of
Nothing -> return (FormMissing, maybe (Left "") Right mdef) Nothing -> return (FormMissing, maybe (Left "") Right mdef)
@ -135,10 +130,10 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
files = fromMaybe [] $ mfs >>= Map.lookup name files = fromMaybe [] $ mfs >>= Map.lookup name
emx <- lift $ fieldParse mvals files emx <- lift $ fieldParse mvals files
return $ case emx of return $ case emx of
Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals)) Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals))
Right mx -> Right mx ->
case mx of case mx of
Nothing -> (onMissing master langs, Left "") Nothing -> (onMissing site langs, Left "")
Just x -> (onFound x, Right x) Just x -> (onFound x, Right x)
return (res, FieldView return (res, FieldView
{ fvLabel = toHtml $ mr2 fsLabel { fvLabel = toHtml $ mr2 fsLabel
@ -152,19 +147,24 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
, fvRequired = isReq , fvRequired = isReq
}) })
areq :: RenderMessage master FormMessage areq :: RenderMessage site FormMessage
=> Field sub master a -> FieldSettings master -> Maybe a => Field site a -> FieldSettings site -> Maybe a
-> AForm sub master a -> AForm site a
areq a b = formToAForm . fmap (second return) . mreq a b areq a b = formToAForm . fmap (second return) . mreq a b
aopt :: Field sub master a aopt :: Field site a
-> FieldSettings master -> FieldSettings site
-> Maybe (Maybe a) -> Maybe (Maybe a)
-> AForm sub master (Maybe a) -> AForm site (Maybe a)
aopt a b = formToAForm . fmap (second return) . mopt a b aopt a b = formToAForm . fmap (second return) . mopt a b
runFormGeneric :: MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) runFormGeneric :: MonadHandler m
runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1) => MForm (HandlerSite m) a
-> HandlerSite m
-> [Text]
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
runFormGeneric form site langs env = liftHandler $ 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,27 +175,24 @@ runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSi
-- 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 :: RenderMessage master FormMessage runFormPost :: (HandlerSite m ~ site, RenderMessage site FormMessage, MonadResource m, MonadHandler m)
=> (Html -> MForm sub master (FormResult a, xml)) => (Html -> MForm site (FormResult a, xml))
-> GHandler sub master ((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 :: RenderMessage master FormMessage postHelper :: (site ~ HandlerSite m, RenderMessage site FormMessage, MonadHandler m)
=> (Html -> MForm sub master (FormResult a, xml)) => (Html -> MForm site (FormResult a, xml))
-> Maybe (Env, FileEnv) -> Maybe (Env, FileEnv)
-> GHandler sub master ((FormResult a, xml), Enctype) -> m ((FormResult a, xml), Enctype)
postHelper form env = do postHelper form env = do
req <- getRequest req <- getRequest
let tokenKey = "_token" let tokenKey = "_token"
let token = let token =
case reqToken req of case reqToken req of
Nothing -> mempty Nothing -> mempty
Just n -> [shamlet| Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|]
$newline never
<input type=hidden name=#{tokenKey} value=#{n}>
|]
m <- getYesod m <- getYesod
langs <- languages langs <- languages
((res, xml), enctype) <- runFormGeneric (form token) m langs env ((res, xml), enctype) <- runFormGeneric (form token) m langs env
@ -215,12 +212,13 @@ $newline never
-- 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
:: RenderMessage master FormMessage :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
=> (Html -> MForm sub master (FormResult a, xml)) => (Html -> MForm (HandlerSite m) (FormResult a, xml))
-> GHandler sub master (xml, Enctype) -> m (xml, Enctype)
generateFormPost form = first snd <$> postHelper form Nothing generateFormPost form = first snd `liftM` postHelper form Nothing
postEnv :: GHandler sub master (Maybe (Env, FileEnv)) postEnv :: (HandlerState m, MonadResource m)
=> m (Maybe (Env, FileEnv))
postEnv = do postEnv = do
req <- getRequest req <- getRequest
if requestMethod (reqWaiRequest req) == "GET" if requestMethod (reqWaiRequest req) == "GET"
@ -230,14 +228,18 @@ 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 :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) runFormPostNoToken :: (MonadHandler m)
=> (Html -> MForm (HandlerSite m) (FormResult a, xml))
-> m ((FormResult a, xml), Enctype)
runFormPostNoToken form = do runFormPostNoToken form = do
langs <- languages langs <- languages
m <- getYesod m <- getYesod
env <- postEnv env <- postEnv
runFormGeneric (form mempty) m langs env runFormGeneric (form mempty) m langs env
runFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype) runFormGet :: MonadHandler m
=> (Html -> MForm (HandlerSite m) a)
-> m (a, Enctype)
runFormGet form = do runFormGet form = do
gets <- liftM reqGetParams getRequest gets <- liftM reqGetParams getRequest
let env = let env =
@ -246,28 +248,30 @@ 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 :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype) generateFormGet :: MonadHandler m
=> (Html -> MForm (HandlerSite m) a)
-> m (a, Enctype)
generateFormGet form = getHelper form Nothing generateFormGet form = getHelper form Nothing
getKey :: Text getKey :: Text
getKey = "_hasdata" getKey = "_hasdata"
getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) getHelper :: MonadHandler m
=> (Html -> MForm (HandlerSite m) a)
-> Maybe (Env, FileEnv)
-> m (a, Enctype)
getHelper form env = do getHelper form env = do
let fragment = [shamlet| let fragment = [shamlet|<input type=hidden name=#{getKey}>|]
$newline never
<input type=hidden name=#{getKey}>
|]
langs <- languages langs <- languages
m <- getYesod m <- getYesod
runFormGeneric (form fragment) m langs env runFormGeneric (form fragment) m langs env
type FormRender sub master a = type FormRender site a =
AForm sub master a AForm site a
-> Html -> Html
-> MForm sub master (FormResult a, GWidget sub master ()) -> MForm site (FormResult a, GWidget site ())
renderTable, renderDivs, renderDivsNoLabels :: FormRender sub master a renderTable, renderDivs, renderDivsNoLabels :: FormRender site a
renderTable aform fragment = do renderTable aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -292,7 +296,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 sub master a renderDivsMaybeLabels :: Bool -> FormRender site 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' []
@ -326,7 +330,7 @@ $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 sub master a renderBootstrap :: FormRender site a
renderBootstrap aform fragment = do renderBootstrap aform fragment = do
(res, views') <- aFormToForm aform (res, views') <- aFormToForm aform
let views = views' [] let views = views' []
@ -347,19 +351,19 @@ $forall view <- views
|] |]
return (res, widget) return (res, widget)
check :: RenderMessage master msg check :: RenderMessage site msg
=> (a -> Either msg a) -> Field sub master a -> Field sub master a => (a -> Either msg a) -> Field site a -> Field site 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 master msg checkBool :: RenderMessage site msg
=> (a -> Bool) -> msg -> Field sub master a -> Field sub master a => (a -> Bool) -> msg -> Field site a -> Field site 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 master msg checkM :: RenderMessage site msg
=> (a -> GHandler sub master (Either msg a)) => (a -> GHandler site (Either msg a))
-> Field sub master a -> Field site a
-> Field sub master a -> Field site 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.
@ -368,11 +372,11 @@ 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 master msg checkMMap :: RenderMessage site msg
=> (a -> GHandler sub master (Either msg b)) => (a -> GHandler site (Either msg b))
-> (b -> a) -> (b -> a)
-> Field sub master a -> Field site a
-> Field sub master b -> Field site 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
@ -386,25 +390,25 @@ checkMMap f inv field = field
-- | Deprecated synonym for 'checkMMap'. -- | Deprecated synonym for 'checkMMap'.
-- --
-- Since 1.1.1 -- Since 1.1.1
checkMMod :: RenderMessage master msg checkMMod :: RenderMessage site msg
=> (a -> GHandler sub master (Either msg b)) => (a -> GHandler site (Either msg b))
-> (b -> a) -> (b -> a)
-> Field sub master a -> Field site a
-> Field sub master b -> Field site b
checkMMod = checkMMap checkMMod = checkMMap
{-# DEPRECATED checkMMod "Please use checkMMap instead" #-} {-# 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 master -> Field sub master a -> Field sub master a customErrorMessage :: SomeMessage site -> Field site a -> Field site a
customErrorMessage msg field = field { fieldParse = \ts fs -> fmap (either customErrorMessage msg field = field { fieldParse = \ts fs -> fmap (either
(const $ Left msg) Right) $ fieldParse field ts fs } (const $ Left msg) Right) $ fieldParse field ts fs }
-- | Generate a 'FieldSettings' from the given label. -- | Generate a 'FieldSettings' from the given label.
fieldSettingsLabel :: RenderMessage master msg => msg -> FieldSettings master 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. -- | Generate an 'AForm' that gets its value from the given action.
aformM :: GHandler sub master a -> AForm sub master a aformM :: GHandler site a -> AForm site a
aformM action = AForm $ \_ _ ints -> do aformM action = AForm $ \_ _ ints -> do
value <- action value <- action
return (FormSuccess value, id, ints, mempty) return (FormSuccess value, id, ints, mempty)
@ -415,9 +419,9 @@ aformM action = AForm $ \_ _ ints -> do
-- required, such as when parsing a text field. -- required, such as when parsing a text field.
-- --
-- Since 1.1 -- Since 1.1
parseHelper :: (Monad m, RenderMessage master FormMessage) parseHelper :: (Monad m, RenderMessage site FormMessage)
=> (Text -> Either FormMessage a) => (Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage master) (Maybe a)) -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper _ [] _ = return $ Right Nothing parseHelper _ [] _ = return $ Right Nothing
parseHelper _ ("":_) _ = return $ Right Nothing parseHelper _ ("":_) _ = return $ Right Nothing
parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x

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

@ -11,19 +11,17 @@ module Yesod.Form.Input
import Yesod.Form.Types import Yesod.Form.Types
import Data.Text (Text) import Data.Text (Text)
import Control.Applicative (Applicative (..)) import Control.Applicative (Applicative (..))
import Yesod.Handler (GHandler, invalidArgs, runRequestBody, getRequest, getYesod) import Yesod.Core
import Yesod.Core (reqGetParams, languages)
import Control.Monad (liftM) import Control.Monad (liftM)
import Yesod.Core (RenderMessage (..), SomeMessage (..))
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 sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> FileEnv -> GHandler sub master (Either DText a) } newtype FormInput site a = FormInput { unFormInput :: site -> [Text] -> Env -> FileEnv -> GHandler site (Either DText a) }
instance Functor (FormInput sub master) where instance Functor (FormInput site) 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' -> fmap (either Left (Right . a)) $ f c d e e'
instance Applicative (FormInput sub master) where instance Applicative (FormInput site) 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'
@ -34,7 +32,7 @@ instance Applicative (FormInput sub master) 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 master FormMessage) => Field sub master a -> Text -> FormInput sub master a ireq :: (RenderMessage site FormMessage) => Field site a -> Text -> FormInput site 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
@ -44,7 +42,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 sub master a -> Text -> FormInput sub master (Maybe a) iopt :: Field site a -> Text -> FormInput site (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
@ -53,12 +51,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 :: FormInput sub master a -> GHandler sub master a runInputGet :: MonadHandler m => FormInput (HandlerSite 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 <- f m l env Map.empty emx <- liftHandler $ 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
@ -66,12 +64,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 :: FormInput sub master a -> GHandler sub master a runInputPost :: MonadHandler m => FormInput (HandlerSite 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 <- f m l env fenv emx <- liftHandler $ 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

10
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 master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field site Day
jqueryDayField jds = Field jqueryDayField jds = Field
{ fieldParse = parseHelper $ maybe { fieldParse = parseHelper $ maybe
(Left MsgInvalidDay) (Left MsgInvalidDay)
@ -97,8 +97,8 @@ $(function(){
, "]" , "]"
] ]
jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master) jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
=> Route master -> Field sub master Text => Route site -> Field site 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,12 +115,12 @@ $(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})});
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
addScript' :: (master -> Either (Route master) Text) -> GWidget sub master () addScript' :: (site -> Either (Route site) Text) -> GWidget site ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- lift getYesod
addScriptEither $ f y addScriptEither $ f y
addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y () addStylesheet' :: (site -> Either (Route site) Text) -> GWidget site ()
addStylesheet' f = do addStylesheet' f = do
y <- lift getYesod y <- lift getYesod
addStylesheetEither $ f y addStylesheetEither $ f y

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

@ -12,11 +12,8 @@ module Yesod.Form.MassInput
import Yesod.Form.Types import Yesod.Form.Types
import Yesod.Form.Functions import Yesod.Form.Functions
import Yesod.Form.Fields (boolField) import Yesod.Form.Fields (boolField)
import Yesod.Widget (GWidget, whamlet) import Yesod.Core
import Yesod.Core (RenderMessage)
import Yesod.Handler (newIdent, GHandler)
import Text.Blaze.Html (Html) import Text.Blaze.Html (Html)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.RWS (get, put, ask) import Control.Monad.Trans.RWS (get, put, ask)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Text.Read (decimal) import Data.Text.Read (decimal)
@ -25,9 +22,8 @@ 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 Yesod.Core (SomeMessage (SomeMessage))
down :: Int -> MForm sub master () down :: Int -> MForm site ()
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
@ -35,7 +31,7 @@ down i = do
put $ IntCons 0 is put $ IntCons 0 is
down $ i - 1 down $ i - 1
up :: Int -> MForm sub master () up :: Int -> MForm site ()
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
@ -45,11 +41,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 sub master, xml ~ GWidget sub master (), RenderMessage master FormMessage) inputList :: (m ~ GHandler site, xml ~ GWidget site (), RenderMessage site FormMessage)
=> Html => Html
-> ([[FieldView sub master]] -> xml) -> ([[FieldView site]] -> xml)
-> (Maybe a -> AForm sub master a) -> (Maybe a -> AForm site a)
-> (Maybe [a] -> AForm sub master [a]) -> (Maybe [a] -> AForm site [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
@ -89,9 +85,9 @@ $newline never
, fvRequired = False , fvRequired = False
}]) }])
withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage) withDelete :: (xml ~ GWidget site (), RenderMessage site FormMessage)
=> AForm sub master a => AForm site a
-> MForm sub master (Either xml (FormResult a, [FieldView sub master])) -> MForm site (Either xml (FormResult a, [FieldView site]))
withDelete af = do withDelete af = do
down 1 down 1
deleteName <- newFormIdent deleteName <- newFormIdent
@ -114,9 +110,9 @@ $newline never
up 1 up 1
return res return res
fixme :: (xml ~ GWidget sub master ()) fixme :: (xml ~ GWidget site ())
=> [Either xml (FormResult a, [FieldView sub master])] => [Either xml (FormResult a, [FieldView site])]
-> (FormResult [a], [xml], [[FieldView sub master]]) -> (FormResult [a], [xml], [[FieldView site]])
fixme eithers = fixme eithers =
(res, xmls, map snd rest) (res, xmls, map snd rest)
where where
@ -124,8 +120,8 @@ fixme eithers =
res = sequenceA $ map fst rest res = sequenceA $ map fst rest
massDivs, massTable massDivs, massTable
:: [[FieldView sub master]] :: [[FieldView site]]
-> GWidget sub master () -> GWidget site ()
massDivs viewss = [whamlet| massDivs viewss = [whamlet|
$newline never $newline never
$forall views <- viewss $forall views <- viewss

4
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 master => Field sub master Html nicHtmlField :: YesodNic site => Field site 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
@ -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' :: (y -> Either (Route y) Text) -> GWidget sub y () addScript' :: (site -> Either (Route site) Text) -> GWidget site ()
addScript' f = do addScript' f = do
y <- lift getYesod y <- lift getYesod
addScriptEither $ f y addScriptEither $ f y

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

@ -80,26 +80,26 @@ type Env = Map.Map Text [Text]
type FileEnv = Map.Map Text [FileInfo] type FileEnv = Map.Map Text [FileInfo]
type Lang = Text type Lang = Text
type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandler sub master) a type MForm site a = RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (GHandler site) a
newtype AForm sub master a = AForm newtype AForm site a = AForm
{ unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandler sub master (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype) { unAForm :: (site, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandler site (FormResult a, [FieldView site] -> [FieldView site], Ints, Enctype)
} }
instance Functor (AForm sub master) where instance Functor (AForm site) 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 sub master) where instance Applicative (AForm site) 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 sub master a) where instance Monoid a => Monoid (AForm site a) where
mempty = pure mempty mempty = pure mempty
mappend a b = mappend <$> a <*> b mappend a b = mappend <$> a <*> b
instance MonadLift (GHandler sub master) (AForm sub master) where instance MonadLift (GHandler site) (AForm site) 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)
@ -115,26 +115,26 @@ data FieldSettings master = FieldSettings
instance IsString (FieldSettings a) where instance IsString (FieldSettings a) where
fromString s = FieldSettings (fromString s) Nothing Nothing Nothing [] fromString s = FieldSettings (fromString s) Nothing Nothing Nothing []
data FieldView sub master = FieldView data FieldView site = FieldView
{ fvLabel :: Html { fvLabel :: Html
, fvTooltip :: Maybe Html , fvTooltip :: Maybe Html
, fvId :: Text , fvId :: Text
, fvInput :: GWidget sub master () , fvInput :: GWidget site ()
, fvErrors :: Maybe Html , fvErrors :: Maybe Html
, fvRequired :: Bool , fvRequired :: Bool
} }
type FieldViewFunc sub master a type FieldViewFunc site 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 sub master () -> GWidget site ()
data Field sub master a = Field data Field site a = Field
{ fieldParse :: [Text] -> [FileInfo] -> GHandler sub master (Either (SomeMessage master) (Maybe a)) { fieldParse :: [Text] -> [FileInfo] -> GHandler site (Either (SomeMessage site) (Maybe a))
, fieldView :: FieldViewFunc sub master a , fieldView :: FieldViewFunc site a
, fieldEnctype :: Enctype , fieldEnctype :: Enctype
} }

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

@ -37,6 +37,7 @@ library
, attoparsec >= 0.10 , attoparsec >= 0.10
, crypto-api >= 0.8 , crypto-api >= 0.8
, aeson , aeson
, resourcet
exposed-modules: Yesod.Form exposed-modules: Yesod.Form
Yesod.Form.Class Yesod.Form.Class

6
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 master) -> GHandler sub master RepAtom atomFeed :: Feed (Route site) -> GHandler site 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,9 +75,9 @@ 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 m atomLink :: Route site
-> Text -- ^ title -> Text -- ^ title
-> GWidget s m () -> GWidget site ()
atomLink r title = toWidgetHead [hamlet| atomLink r title = toWidgetHead [hamlet|
$newline never $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 master) -> GHandler sub master TypedContent newsFeed :: Feed (Route site) -> GHandler site TypedContent
newsFeed f = selectRep $ do newsFeed f = selectRep $ do
provideRep $ atomFeed f provideRep $ atomFeed f
provideRep $ rssFeed f provideRep $ rssFeed f

6
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 master) -> GHandler sub master RepRss rssFeed :: Feed (Route site) -> GHandler site 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,9 +71,9 @@ 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 m rssLink :: Route site
-> Text -- ^ title -> Text -- ^ title
-> GWidget s m () -> GWidget site ()
rssLink r title = toWidgetHead [hamlet| rssLink r title = toWidgetHead [hamlet|
$newline never $newline never
<link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}> <link href=@{r} type=#{S8.unpack typeRss} rel="alternate" title=#{title}>

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

@ -16,17 +16,17 @@ import Control.Monad.Trans.Class (MonadTrans)
import Yesod.Core import Yesod.Core
type YesodDB sub master = YesodPersistBackend master (GHandler sub master) type YesodDB site = YesodPersistBackend site (GHandler site)
class YesodPersist master where class YesodPersist site where
type YesodPersistBackend master :: (* -> *) -> * -> * type YesodPersistBackend site :: (* -> *) -> * -> *
runDB :: YesodDB sub master a -> GHandler sub master a runDB :: YesodDB site a -> GHandler site 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 sub master , m ~ GHandler site
, 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 sub master , m ~ GHandler site
, Monad (t m) , Monad (t m)
, MonadTrans t , MonadTrans t
, PersistEntityBackend val ~ PersistMonadBackend (t m) , PersistEntityBackend val ~ PersistMonadBackend (t m)

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

@ -75,15 +75,15 @@ template urls render =
, Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority] , Element "priority" Map.empty [NodeContent $ pack $ show sitemapPriority]
] ]
sitemap :: [SitemapUrl (Route master)] -> GHandler sub master RepXml sitemap :: [SitemapUrl (Route site)] -> GHandler site 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 master -- ^ sitemap url robots :: Route site -- ^ sitemap url
-> GHandler sub master RepPlain -> GHandler site 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

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

@ -53,6 +53,7 @@ import Control.Monad
import Data.FileEmbed (embedDir) import Data.FileEmbed (embedDir)
import Yesod.Core hiding (lift) import Yesod.Core hiding (lift)
import Yesod.Core.Types
import Data.List (intercalate) import Data.List (intercalate)
import Language.Haskell.TH import Language.Haskell.TH
@ -142,9 +143,11 @@ instance RenderRoute Static where
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
renderRoute (StaticRoute x y) = (x, y) renderRoute (StaticRoute x y) = (x, y)
instance Yesod master => YesodDispatch Static master where instance YesodSubDispatch Static m where
yesodDispatch _ _ (Static set) _ _ _ _ textPieces _ req = yesodSubDispatch _run getSub _toMaster env req =
staticApp set req { pathInfo = textPieces } staticApp set req
where
Static set = getSub $ yreSite env
notHidden :: Prelude.FilePath -> Bool notHidden :: Prelude.FilePath -> Bool
notHidden "tmp" = False notHidden "tmp" = False

6
yesod/Yesod.hs
View File

@ -67,12 +67,12 @@ readIntegral s =
-- | A convenience method to run an application using the Warp webserver on the -- | A convenience method to run an application using the Warp webserver on the
-- specified port. Automatically calls 'toWaiApp'. -- specified port. Automatically calls 'toWaiApp'.
warp :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () warp :: YesodDispatch site => Int -> site -> IO ()
warp port a = toWaiApp a >>= run port warp port a = toWaiApp a >>= run port
-- | Same as 'warp', but also sends a message to stdout for each request, and -- | Same as 'warp', but also sends a message to stdout for each request, and
-- an \"application launched\" message as well. Can be useful for development. -- an \"application launched\" message as well. Can be useful for development.
warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () warpDebug :: YesodDispatch site => Int -> site -> IO ()
warpDebug port app = do warpDebug port app = do
hPutStrLn stderr $ "Application launched, listening on port " ++ show port hPutStrLn stderr $ "Application launched, listening on port " ++ show port
waiApp <- toWaiApp app waiApp <- toWaiApp app
@ -85,7 +85,7 @@ warpDebug port app = do
-- Note that the exact behavior of this function may be modified slightly over -- Note that the exact behavior of this function may be modified slightly over
-- time to work correctly with external tools, without a change to the type -- time to work correctly with external tools, without a change to the type
-- signature. -- signature.
warpEnv :: (Yesod a, YesodDispatch a a) => a -> IO () warpEnv :: YesodDispatch site => site -> IO ()
warpEnv master = do warpEnv master = do
port <- getEnv "PORT" >>= readIO port <- getEnv "PORT" >>= readIO
app <- toWaiApp master app <- toWaiApp master

7
yesod/Yesod/Default/Handlers.hs
View File

@ -4,11 +4,10 @@ module Yesod.Default.Handlers
, getRobotsR , getRobotsR
) where ) where
import Yesod.Handler (GHandler, sendFile) import Yesod.Core
import Yesod.Content (RepPlain(..))
getFaviconR :: GHandler s m () getFaviconR :: HandlerError m => m ()
getFaviconR = sendFile "image/x-icon" "config/favicon.ico" getFaviconR = sendFile "image/x-icon" "config/favicon.ico"
getRobotsR :: GHandler s m RepPlain getRobotsR :: HandlerError m => m ()
getRobotsR = sendFile "text/plain" "config/robots.txt" getRobotsR = sendFile "text/plain" "config/robots.txt"

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 sub master (Maybe (Either Text (Route master, [(Text, Text)]))) -> GHandler master (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'