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

Everything compiles

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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