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

Incomplete change: GWidget/GHandler->WidgetT/HandlerT

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-14 05:00:16 +02:00
parent 9503921d90
commit 553dff7bd2
11 changed files with 192 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -78,7 +78,6 @@ import Data.Text (Text)
import Yesod.Core.Widget
import Yesod.Core.Json
import Yesod.Core.Types
import Yesod.Core.Class.MonadLift
import Text.Shakespeare.I18N
import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)

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

@ -11,11 +11,11 @@ import Data.Text (Text)
class YesodBreadcrumbs site where
-- | Returns the title and the parent resource, if available. If you return
-- a 'Nothing', then this is considered a top-level page.
breadcrumb :: Route site -> GHandler site (Text , Maybe (Route site))
breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))
-- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles.
breadcrumbs :: YesodBreadcrumbs site => GHandler site (Text, [(Route site, Text)])
breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)])
breadcrumbs = do
x <- getCurrentRoute
case x of

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

@ -1,49 +1,36 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Class.Handler where
import Yesod.Core.Types
import Yesod.Core.Types.Orphan ()
import Yesod.Core.Class.MonadLift (lift)
import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO)
import Control.Monad.Base
import Data.Monoid (mempty)
class Monad m => HandlerReader m where
type HandlerSite m
type HandlerMaster m
askYesodRequest :: m YesodRequest
askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
askHandlerEnvMaster :: m (RunHandlerEnv (HandlerMaster m))
instance HandlerReader (GHandler site) where
type HandlerSite (GHandler site) = site
type HandlerMaster (GHandler site) = site
askYesodRequest = GHandler $ return . handlerRequest
askHandlerEnv = GHandler $ return . handlerEnv
askHandlerEnvMaster = GHandler $ return . handlerEnv
instance HandlerReader m => HandlerReader (HandlerT site m) where
instance Monad m => HandlerReader (HandlerT site m) where
type HandlerSite (HandlerT site m) = site
type HandlerMaster (HandlerT site m) = HandlerMaster m
askYesodRequest = HandlerT $ return . handlerRequest
askHandlerEnv = HandlerT $ return . handlerEnv
askHandlerEnvMaster = lift askHandlerEnvMaster
instance HandlerReader (GWidget site) where
type HandlerSite (GWidget site) = site
type HandlerMaster (GWidget site) = site
instance Monad m => HandlerReader (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
askYesodRequest = lift askYesodRequest
askHandlerEnv = lift askHandlerEnv
askHandlerEnvMaster = lift askHandlerEnvMaster
askYesodRequest = WidgetT $ fmap (, mempty) $ askYesodRequest
askHandlerEnv = WidgetT $ fmap (, mempty) $ askHandlerEnv
class HandlerReader m => HandlerState m where
stateGHState :: (GHState -> (a, GHState)) -> m a
@ -54,26 +41,20 @@ class HandlerReader m => HandlerState m where
putGHState :: GHState -> m ()
putGHState s = stateGHState $ const ((), s)
instance HandlerState (GHandler site) where
instance MonadBase IO m => HandlerState (HandlerT site m) where
stateGHState f =
GHandler $ flip atomicModifyIORef f' . handlerState
HandlerT $ flip atomicModifyIORef f' . handlerState
where
f' z = let (x, y) = f z in (y, x)
instance HandlerState (GWidget site) where
stateGHState = lift . stateGHState
instance HandlerState m => HandlerState (HandlerT site m) where
stateGHState = lift . stateGHState
instance MonadBase IO m => HandlerState (WidgetT site m) where
stateGHState = WidgetT . fmap (, mempty) . stateGHState
class HandlerReader m => HandlerError m where
handlerError :: HandlerContents -> m a
instance HandlerError (GHandler site) where
instance MonadBase IO m => HandlerError (HandlerT site m) where
handlerError = throwIO
instance HandlerError (GWidget site) where
handlerError = lift . handlerError
instance HandlerError m => HandlerError (HandlerT site m) where
handlerError = lift . handlerError
instance MonadBase IO m => HandlerError (WidgetT site m) where
handlerError = throwIO

15
yesod-core/Yesod/Core/Class/MonadLift.hs
View File

@ -1,15 +0,0 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
module Yesod.Core.Class.MonadLift (MonadLift (..)) where
import Control.Monad.Trans.Class
-- | The standard @MonadTrans@ class only allows lifting for monad
-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their
-- types do not express that they actually are transformers. This replacement
-- class accounts for this.
class MonadLift base m | m -> base where
lift :: base a -> m a
instance (Monad m, MonadTrans t) => MonadLift m (t m) where
lift = Control.Monad.Trans.Class.lift

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

@ -58,11 +58,10 @@ import Web.Cookie (SetCookie (..))
import Yesod.Core.Types
import Yesod.Core.Internal.Session
import Yesod.Core.Widget
import Yesod.Core.Class.MonadLift (lift)
-- | Define settings for a Yesod applications. All methods have intelligent
-- defaults, and therefore no implementation is required.
class RenderRoute a => Yesod a where
class RenderRoute site => Yesod site where
-- | An absolute URL to the root of the application. Do not include
-- trailing slash.
--
@ -76,36 +75,34 @@ class RenderRoute a => Yesod a where
--
-- If this is not true, you should override with a different
-- implementation.
approot :: Approot a
approot :: Approot site
approot = ApprootRelative
-- | Output error response pages.
errorHandler :: ErrorResponse -> GHandler a TypedContent
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page.
defaultLayout :: GWidget a () -> GHandler a RepHtml
defaultLayout :: WidgetT site IO () -> HandlerT site IO RepHtml
defaultLayout w = do
p <- widgetToPageContent w
mmsg <- getMessage
hamletToRepHtml [hamlet|
$newline never
$doctype 5
<html>
<head>
<title>#{pageTitle p}
^{pageHead p}
<body>
$maybe msg <- mmsg
<p .message>#{msg}
^{pageBody p}
|]
$doctype 5
<html>
<head>
<title>#{pageTitle p}
^{pageHead p}
<body>
$maybe msg <- mmsg
<p .message>#{msg}
^{pageBody p}
|]
-- | Override the rendering function for a particular URL. One use case for
-- this is to offload static hosting to a different domain name to avoid
-- sending cookies.
urlRenderOverride :: a -> Route a -> Maybe Builder
urlRenderOverride :: site -> Route site -> Maybe Builder
urlRenderOverride _ _ = Nothing
-- | Determine if a request is authorized or not.
@ -113,9 +110,9 @@ $doctype 5
-- Return 'Authorized' if the request is authorized,
-- 'Unauthorized' a message if unauthorized.
-- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route a
isAuthorized :: Route site
-> Bool -- ^ is this a write request?
-> GHandler a AuthResult
-> HandlerT site IO AuthResult
isAuthorized _ _ = return Authorized
-- | Determines whether the current request is a write request. By default,
@ -125,7 +122,7 @@ $doctype 5
--
-- This function is used to determine if a request is authorized; see
-- 'isAuthorized'.
isWriteRequest :: Route a -> GHandler a Bool
isWriteRequest :: Route site -> HandlerT site IO Bool
isWriteRequest _ = do
wai <- waiRequest
return $ W.requestMethod wai `notElem`
@ -135,7 +132,7 @@ $doctype 5
--
-- Used in particular by 'isAuthorized', but library users can do whatever
-- they want with it.
authRoute :: a -> Maybe (Route a)
authRoute :: site -> Maybe (Route site)
authRoute _ = Nothing
-- | A function used to clean up path segments. It returns 'Right' with a
@ -148,7 +145,7 @@ $doctype 5
--
-- Note that versions of Yesod prior to 0.7 used a different set of rules
-- involing trailing slashes.
cleanPath :: a -> [Text] -> Either [Text] [Text]
cleanPath :: site -> [Text] -> Either [Text] [Text]
cleanPath _ s =
if corrected == s
then Right $ map dropDash s
@ -162,7 +159,7 @@ $doctype 5
-- | Builds an absolute URL by concatenating the application root with the
-- pieces of a path and a query string, if any.
-- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.
joinPath :: a
joinPath :: site
-> T.Text -- ^ application root
-> [T.Text] -- ^ path pieces
-> [(T.Text, T.Text)] -- ^ query string
@ -191,7 +188,7 @@ $doctype 5
addStaticContent :: Text -- ^ filename extension
-> Text -- ^ mime-type
-> L.ByteString -- ^ content
-> GHandler a (Maybe (Either Text (Route a, [(Text, Text)])))
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing
{- Temporarily disabled until we have a better interface.
@ -208,17 +205,17 @@ $doctype 5
-- | Maximum allowed length of the request body, in bytes.
--
-- Default: 2 megabytes.
maximumContentLength :: a -> Maybe (Route a) -> Word64
maximumContentLength :: site -> Maybe (Route site) -> Word64
maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
-- | Returns a @Logger@ to use for log messages.
--
-- Default: Sends to stdout and automatically flushes on each write.
getLogger :: a -> IO Logger
getLogger :: site -> IO Logger
getLogger _ = mkLogger True stdout
-- | Send a message to the @Logger@ provided by @getLogger@.
messageLoggerSource :: a
messageLoggerSource :: site
-> Logger
-> Loc -- ^ position in source code
-> LogSource
@ -232,11 +229,11 @@ $doctype 5
-- | The logging level in place for this application. Any messages below
-- this level will simply be ignored.
logLevel :: a -> LogLevel
logLevel :: site -> LogLevel
logLevel _ = LevelInfo
-- | GZIP settings.
gzipSettings :: a -> GzipSettings
gzipSettings :: site -> GzipSettings
gzipSettings _ = def
-- | Where to Load sripts from. We recommend the default value,
@ -245,13 +242,13 @@ $doctype 5
-- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js
--
-- Or write your own async js loader: see 'loadJsYepnope'
jsLoader :: a -> ScriptLoadPosition a
jsLoader :: site -> ScriptLoadPosition site
jsLoader _ = BottomOfBody
-- | Create a session backend. Returning `Nothing' disables sessions.
--
-- Default: Uses clientsession with a 2 hour timeout.
makeSessionBackend :: a -> IO (Maybe SessionBackend)
makeSessionBackend :: site -> IO (Maybe SessionBackend)
makeSessionBackend _ = fmap Just defaultClientSessionBackend
-- | How to store uploaded files.
@ -259,7 +256,7 @@ $doctype 5
-- Default: When the request body is greater than 50kb, store in a temp
-- file. For chunked request bodies, store in a temp file. Otherwise, store
-- in memory.
fileUpload :: a -> W.RequestBodyLength -> FileUpload
fileUpload :: site -> W.RequestBodyLength -> FileUpload
fileUpload _ (W.KnownLength size)
| size <= 50000 = FileUploadMemory lbsBackEnd
fileUpload _ _ = FileUploadDisk tempFileBackEnd
@ -267,8 +264,8 @@ $doctype 5
-- | Should we log the given log source/level combination.
--
-- Default: Logs everything at or above 'logLevel'
shouldLog :: a -> LogSource -> LogLevel -> Bool
shouldLog a _ level = level >= logLevel a
shouldLog :: site -> LogSource -> LogLevel -> Bool
shouldLog site _ level = level >= logLevel site
-- | A Yesod middleware, which will wrap every handler function. This
-- allows you to run code before and after a normal handler.
@ -277,7 +274,7 @@ $doctype 5
-- performs authorization checks.
--
-- Since: 1.1.6
yesodMiddleware :: GHandler a res -> GHandler a res
yesodMiddleware :: HandlerT site IO res -> HandlerT site IO res
yesodMiddleware handler = do
setHeader "Vary" "Accept, Accept-Language"
route <- getCurrentRoute
@ -301,11 +298,11 @@ $doctype 5
-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: (Eq (Route site), Yesod site)
=> GWidget site ()
-> GHandler site (PageContent (Route site))
=> WidgetT site IO ()
-> HandlerT site IO (PageContent (Route site))
widgetToPageContent w = do
master <- getYesod
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unWidgetT w
let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'
@ -396,10 +393,10 @@ $newline never
runUniqueList (UniqueList x) = nub $ x []
-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod site => ErrorResponse -> GHandler site TypedContent
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
defaultErrorHandler NotFound = selectRep $ do
provideRep $ defaultLayout $ do
r <- lift waiRequest
r <- waiRequest
let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
setTitle "Not Found"
toWidget [hamlet|
@ -560,20 +557,3 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
where
line = show . fst . loc_start
char = show . snd . loc_start
class (MonadBaseControl IO m, HandlerState m, HandlerError m, MonadResource m, Yesod (HandlerMaster m)) => MonadHandler m where
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))
instance Yesod site => MonadHandler (GHandler site) where
liftHandler = id
liftHandlerMaster = id
askHandlerData = GHandler return
instance MonadHandler m => MonadHandler (HandlerT site m) where
liftHandlerMaster = lift . liftHandlerMaster
askHandlerData = HandlerT return

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

@ -21,8 +21,7 @@
---------------------------------------------------------
module Yesod.Core.Handler
( -- * Handler monad
GHandler
, HandlerT
HandlerT
-- ** Read information from handler
, getYesod
, getUrlRender
@ -167,7 +166,6 @@ import Data.Maybe (listToMaybe)
import Data.Typeable (Typeable, typeOf)
import Yesod.Core.Class.Handler
import Yesod.Core.Types
import Yesod.Core.Types.Orphan ()
import Yesod.Routes.Class (Route)
get :: HandlerState m => m GHState
@ -251,10 +249,10 @@ getUrlRenderParams = rheRender `liftM` askHandlerEnv
getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute = rheRoute `liftM` askHandlerEnv
-- | Returns a function that runs 'GHandler' actions inside @IO@.
-- | Returns a function that runs 'HandlerT' actions inside @IO@.
--
-- Sometimes you want to run an inner 'GHandler' action outside
-- the control flow of an HTTP request (on the outer 'GHandler'
-- Sometimes you want to run an inner 'HandlerT' action outside
-- the control flow of an HTTP request (on the outer 'HandlerT'
-- action). For example, you may want to spawn a new thread:
--
-- @
@ -287,9 +285,9 @@ getCurrentRoute = rheRoute `liftM` askHandlerEnv
-- This allows the inner 'GHandler' to outlive the outer
-- 'GHandler' (e.g., on the @forkIO@ example above, a response
-- may be sent to the client without killing the new thread).
handlerToIO :: MonadIO m => GHandler site (GHandler site a -> m a)
handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a)
handlerToIO =
GHandler $ \oldHandlerData -> do
HandlerT $ \oldHandlerData -> do
-- Let go of the request body, cache and response headers.
let oldReq = handlerRequest oldHandlerData
oldWaiReq = reqWaiRequest oldReq
@ -311,7 +309,7 @@ handlerToIO =
, ghsHeaders = mempty }
-- Return GHandler running function.
return $ \(GHandler f) -> liftIO $ do
return $ \(HandlerT f) -> liftIO $ do
-- The state IORef needs to be created here, otherwise it
-- will be shared by different invocations of this function.
newStateIORef <- I.newIORef newState
@ -417,7 +415,7 @@ setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
setMessageI :: (HandlerState m, RenderMessage (HandlerMaster m) msg)
setMessageI :: (HandlerState m, RenderMessage (HandlerSite m) msg)
=> msg -> m ()
setMessageI msg = do
mr <- getMessageRender
@ -490,7 +488,7 @@ permissionDenied :: HandlerError m => Text -> m a
permissionDenied = hcError . PermissionDenied
-- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage (HandlerMaster m) msg, HandlerError m)
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, HandlerError m)
=> msg
-> m a
permissionDeniedI msg = do
@ -502,7 +500,7 @@ invalidArgs :: HandlerError m => [Text] -> m a
invalidArgs = hcError . InvalidArgs
-- | Return a 400 invalid arguments page.
invalidArgsI :: (HandlerError m, RenderMessage (HandlerMaster m) msg) => [msg] -> m a
invalidArgsI :: (HandlerError m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
invalidArgsI msg = do
mr <- getMessageRender
invalidArgs $ map mr msg
@ -693,10 +691,10 @@ giveUrlRenderer f = do
waiRequest :: HandlerReader m => m W.Request
waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (HandlerReader m, RenderMessage (HandlerMaster m) message)
getMessageRender :: (HandlerReader m, RenderMessage (HandlerSite m) message)
=> m (message -> Text)
getMessageRender = do
env <- askHandlerEnvMaster
env <- askHandlerEnv
l <- reqLangs `liftM` getRequest
return $ renderMessage (rheSite env) l

45
yesod-core/Yesod/Core/Json.hs
View File

@ -19,11 +19,11 @@ module Yesod.Core.Json
, acceptsJson
) where
import Yesod.Core.Handler (GHandler, waiRequest, invalidArgs, redirect, selectRep, provideRep)
import Yesod.Core.Class.MonadLift (lift)
import Yesod.Core.Handler (HandlerT, waiRequest, invalidArgs, redirect, selectRep, provideRep)
import Yesod.Core.Content (TypedContent)
import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Widget (GWidget)
import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT)
import Yesod.Routes.Class
import Control.Applicative ((<$>))
import Control.Monad (join)
@ -38,6 +38,9 @@ import Network.Wai (requestBody, requestHeaders)
import Network.Wai.Parse (parseHttpAccept)
import qualified Data.ByteString.Char8 as B8
import Data.Maybe (listToMaybe)
import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM)
import Control.Monad.Trans.Resource (liftResourceT)
-- | Provide both an HTML and JSON representation for a piece of
-- data, using the default layout for the HTML output
@ -45,9 +48,9 @@ import Data.Maybe (listToMaybe)
--
-- /Since: 0.3.0/
defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> GWidget site () -- ^ HTML
-> GHandler site a -- ^ JSON
-> GHandler site TypedContent
=> WidgetT site m () -- ^ HTML
-> HandlerT site m a -- ^ JSON
-> HandlerT site m TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
provideRep $ fmap J.toJSON json
@ -56,7 +59,7 @@ defaultLayoutJson w json = selectRep $ do
-- support conversion to JSON via 'J.ToJSON'.
--
-- /Since: 0.3.0/
jsonToRepJson :: J.ToJSON a => a -> GHandler site J.Value
jsonToRepJson :: J.ToJSON a => a -> HandlerT site m J.Value
jsonToRepJson = return . J.toJSON
-- | Parse the request body to a data type as a JSON value. The
@ -65,12 +68,11 @@ jsonToRepJson = return . J.toJSON
-- 'J.Value'@.
--
-- /Since: 0.3.0/
parseJsonBody :: J.FromJSON a => GHandler site (J.Result a)
parseJsonBody :: (MonadResource m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
req <- waiRequest
eValue <- lift
$ runExceptionT
$ transPipe lift (requestBody req)
eValue <- runExceptionT
$ transPipe liftResourceT (requestBody req)
$$ sinkParser JP.value'
return $ case eValue of
Left e -> J.Error $ show e
@ -78,7 +80,7 @@ parseJsonBody = do
-- | Same as 'parseJsonBody', but return an invalid args response on a parse
-- error.
parseJsonBody_ :: J.FromJSON a => GHandler site a
parseJsonBody_ :: (HandlerError m, J.FromJSON a, MonadResource m) => m a
parseJsonBody_ = do
ra <- parseJsonBody
case ra of
@ -96,20 +98,21 @@ array = J.Array . V.fromList . map J.toJSON
-- @application\/json@ (e.g. AJAX, see 'acceptsJSON').
--
-- 2. 3xx otherwise, following the PRG pattern.
jsonOrRedirect :: (Yesod site, J.ToJSON a)
=> Route site -- ^ Redirect target
jsonOrRedirect :: HandlerError m
=> J.ToJSON a
=> Route (HandlerSite m) -- ^ Redirect target
-> a -- ^ Data to send via JSON
-> GHandler site J.Value
-> m J.Value
jsonOrRedirect r j = do
q <- acceptsJson
if q then jsonToRepJson (J.toJSON j)
if q then return (J.toJSON j)
else redirect r
-- | Returns @True@ if the client prefers @application\/json@ as
-- indicated by the @Accept@ HTTP header.
acceptsJson :: Yesod site => GHandler site Bool
acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';'))
acceptsJson :: HandlerReader m => m Bool
acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
. join
. fmap (listToMaybe . parseHttpAccept)
. lookup "Accept" . requestHeaders
<$> waiRequest
. liftM (listToMaybe . parseHttpAccept)
. lookup "Accept" . requestHeaders)
`liftM` waiRequest

146
yesod-core/Yesod/Core/Types.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -54,7 +55,7 @@ import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl)
import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime)
import Yesod.Core.Class.MonadLift (MonadLift (..))
import Control.Monad.Trans.Class
import Yesod.Routes.Class (RenderRoute (..))
-- Sessions
@ -192,23 +193,10 @@ data YesodRunnerEnv site = YesodRunnerEnv
-- | A generic handler monad, which can have a different subsite and master
-- site. We define a newtype for better error message.
newtype GHandler site a = GHandler
{ unGHandler :: HandlerData site -> ResourceT IO a
}
newtype HandlerT site m a = HandlerT
{ unHandlerT :: HandlerData site -> m a
{ unHandlerT :: HandlerData site -> ResourceT m a
}
instance Monad m => Monad (HandlerT sub m) where
return = HandlerT . const . return
HandlerT f >>= g = HandlerT $ \hd -> f hd >>= \x -> unHandlerT (g x) hd
instance Monad m => Functor (HandlerT sub m) where
fmap = liftM
instance Monad m => Applicative (HandlerT sub m) where
pure = return
(<*>) = ap
data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents
@ -219,17 +207,17 @@ data GHState = GHState
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
-- features needed by Yesod. Users should never need to use this directly, as
-- the 'GHandler' monad and template haskell code should hide it away.
-- the 'HandlerT' monad and template haskell code should hide it away.
type YesodApp = YesodRequest -> ResourceT IO YesodResponse
-- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- better error messages.
newtype GWidget site a = GWidget -- FIXME change to WidgetT?
{ unGWidget :: GHandler site (a, GWData (Route site))
newtype WidgetT site m a = WidgetT
{ unWidgetT :: HandlerT site m (a, GWData (Route site))
}
instance (a ~ ()) => Monoid (GWidget site a) where
instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
mempty = return ()
mappend x y = x >> y
@ -344,62 +332,56 @@ instance Show HandlerContents where
show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents
-- Instances for GWidget
instance Functor (GWidget site) where
fmap f (GWidget x) = GWidget (fmap (first f) x)
instance Applicative (GWidget site) where
pure a = GWidget $ pure (a, mempty)
GWidget f <*> GWidget v =
GWidget $ k <$> f <*> v
where
k (a, wa) (b, wb) = (a b, wa `mappend` wb)
instance Monad (GWidget site) where
return = pure
GWidget x >>= f = GWidget $ do
-- Instances for WidgetT
instance Monad m => Functor (WidgetT site m) where
fmap = liftM
instance Monad m => Applicative (WidgetT site m) where
pure = return
(<*>) = ap
instance Monad m => Monad (WidgetT site m) where
return a = WidgetT $ pure (a, mempty)
WidgetT x >>= f = WidgetT $ do
(a, wa) <- x
(b, wb) <- unGWidget (f a)
(b, wb) <- unWidgetT (f a)
return (b, wa `mappend` wb)
instance MonadIO (GWidget site) where
liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO
instance MonadBase IO (GWidget site) where
liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase
instance MonadBaseControl IO (GWidget site) where
data StM (GWidget site) a =
StW (StM (GHandler site) (a, GWData (Route site)))
liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->
instance MonadIO m => MonadIO (WidgetT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . fmap (\a -> (a, mempty)) . liftBase
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
data StM (WidgetT site m) a =
StW (StM (HandlerT site m) (a, GWData (Route site)))
liftBaseWith f = WidgetT $ liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . unGWidget)
restoreM (StW base) = GWidget $ restoreM base
(f $ liftM StW . runInBase . unWidgetT)
restoreM (StW base) = WidgetT $ restoreM base
instance MonadUnsafeIO (GWidget site) where
unsafeLiftIO = liftIO
instance MonadThrow (GWidget site) where
monadThrow = liftIO . throwIO
instance MonadResource (GWidget site) where
liftResourceT = lift . liftResourceT
instance MonadTrans (WidgetT site) where
lift = WidgetT . fmap (, mempty) . lift
instance MonadThrow m => MonadThrow (WidgetT site m) where
monadThrow = lift . monadThrow
instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
liftResourceT = WidgetT . fmap (, mempty) . liftResourceT
instance MonadLogger (GWidget site) where
monadLoggerLog a b c = lift . monadLoggerLog a b c
instance MonadIO m => MonadLogger (WidgetT site m) where
monadLoggerLog a b c d = WidgetT $ fmap (, mempty) $ monadLoggerLog a b c d
instance MonadLift (GHandler site) (GWidget site) where
lift = GWidget . fmap (\x -> (x, mempty))
instance MonadTrans (HandlerT site) where
lift = HandlerT . const . lift
instance MonadLift (ResourceT IO) (GHandler site) where
lift = GHandler . const
-- Instances for GHandler
instance Functor (GHandler site) where
fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)
instance Applicative (GHandler site) where
pure = GHandler . const . pure
GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r
instance Monad (GHandler site) where
return = pure
GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r
instance MonadIO (GHandler site) where
liftIO = GHandler . const . lift
instance MonadBase IO (GHandler site) where
liftBase = GHandler . const . lift
-- Instances for HandlerT
instance Monad m => Functor (HandlerT site m) where
fmap = liftM
instance Monad m => Applicative (HandlerT site m) where
pure = return
(<*>) = ap
instance Monad m => Monad (HandlerT site m) where
return = HandlerT . const . return
HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
instance MonadIO m => MonadIO (HandlerT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (HandlerT site m) where
liftBase = lift . liftBase
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use
@ -408,26 +390,24 @@ instance MonadBase IO (GHandler site) where
-- Using fork usually leads to an exception that says
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
-- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl IO (GHandler site) where
data StM (GHandler site) a = StH (StM (ResourceT IO) a)
liftBaseWith f = GHandler $ \reader ->
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
data StM (HandlerT site m) a = StH (StM (ResourceT m) a)
liftBaseWith f = HandlerT $ \reader ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
restoreM (StH base) = GHandler $ const $ restoreM base
f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
restoreM (StH base) = HandlerT $ const $ restoreM base
instance MonadUnsafeIO (GHandler site) where
unsafeLiftIO = liftIO
instance MonadThrow (GHandler site) where
monadThrow = liftIO . throwIO
instance MonadResource (GHandler site) where
liftResourceT = lift . liftResourceT
instance MonadThrow m => MonadThrow (HandlerT site m) where
monadThrow = lift . monadThrow
instance (MonadIO m, MonadUnsafeIO m, MonadThrow m, Applicative m) => MonadResource (HandlerT site m) where
liftResourceT = HandlerT . const . liftResourceT
instance MonadLogger (GHandler site) where
monadLoggerLog a b c d = GHandler $ \hd ->
instance MonadIO m => MonadLogger (HandlerT site m) where
monadLoggerLog a b c d = HandlerT $ \hd ->
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
instance Exception e => Failure e (GHandler site) where
failure = liftIO . throwIO
instance Failure e m => Failure e (HandlerT site m) where
failure = lift . failure
instance Monoid (UniqueList x) where
mempty = UniqueList id

26
yesod-core/Yesod/Core/Types/Orphan.hs
View File

@ -1,26 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Yesod.Core.Types.Orphan where
import Yesod.Core.Types
import Control.Monad.Trans.Class
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..))
import Data.Conduit (MonadThrow (..))
instance MonadTrans (HandlerT sub) where
lift = HandlerT . const
instance MonadBase b m => MonadBase b (HandlerT sub m) where
liftBase = lift . liftBase
instance MonadBaseControl b m => MonadBaseControl b (HandlerT sub m)
instance MonadResource m => MonadResource (HandlerT sub m) where
liftResourceT = lift . liftResourceT
instance MonadIO m => MonadIO (HandlerT sub m)
instance MonadThrow m => MonadThrow (HandlerT sub m) where
monadThrow = lift . monadThrow

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

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
@ -10,7 +11,7 @@
-- generator, allowing you to create truly modular HTML components.
module Yesod.Core.Widget
( -- * Datatype
GWidget
WidgetT
, PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets
, whamlet
@ -39,7 +40,6 @@ module Yesod.Core.Widget
, addScriptRemoteAttrs
, addScriptEither
-- * Internal
, unGWidget
, whamletFileWithSettings
) where
@ -50,7 +50,6 @@ import Text.Cassius
import Text.Julius
import Yesod.Routes.Class
import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
import Yesod.Core.Class.MonadLift (lift)
import Text.Shakespeare.I18N (RenderMessage)
import Control.Monad (liftM)
import Data.Text (Text)
@ -64,24 +63,26 @@ import Text.Blaze.Html (toHtml, preEscapedToMarkup)
import qualified Data.Text.Lazy as TL
import Yesod.Core.Types
import Yesod.Core.Class.Handler
import Control.Monad.Trans.Class
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
class ToWidget site a where
toWidget :: a -> GWidget site ()
class Monad m => ToWidget site m a where
toWidget :: a -> WidgetT site m ()
instance render ~ RY site => ToWidget site (render -> Html) where
instance (Monad m, render ~ RY site) => ToWidget site m (render -> Html) where
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
instance render ~ RY site => ToWidget site (render -> Css) where
instance (Monad m, render ~ RY site) => ToWidget site m (render -> Css) where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
instance (Monad m, render ~ RY site) => ToWidget site m (render -> CssBuilder) where
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
instance render ~ RY site => ToWidget site (render -> Javascript) where
instance (Monad m, render ~ RY site) => ToWidget site m (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance (site' ~ site) => ToWidget site' (GWidget site ()) where
instance (site' ~ site, Monad m) => ToWidget site' m (WidgetT site m ()) where
toWidget = id
instance ToWidget site Html where
instance Monad m => ToWidget site m Html where
toWidget = toWidget . const
-- | Allows adding some CSS to the page with a specific media type.
@ -91,16 +92,17 @@ class ToWidgetMedia site a where
-- | Add the given content to the page, but only for the given media type.
--
-- Since 1.2
toWidgetMedia :: Text -- ^ media value
toWidgetMedia :: Monad m
=> Text -- ^ media value
-> a
-> GWidget site ()
-> WidgetT site m ()
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
class ToWidgetBody site a where
toWidgetBody :: a -> GWidget site ()
toWidgetBody :: Monad m => a -> WidgetT site m ()
instance render ~ RY site => ToWidgetBody site (render -> Html) where
toWidgetBody = toWidget
@ -110,7 +112,7 @@ instance ToWidgetBody site Html where
toWidgetBody = toWidget
class ToWidgetHead site a where
toWidgetHead :: a -> GWidget site ()
toWidgetHead :: Monad m => a -> WidgetT site m ()
instance render ~ RY site => ToWidgetHead site (render -> Html) where
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
@ -125,52 +127,52 @@ instance ToWidgetHead site Html where
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitle :: Html -> GWidget site ()
setTitle :: Monad m => Html -> WidgetT site m ()
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitleI :: RenderMessage site msg => msg -> GWidget site ()
setTitleI :: (Monad m, RenderMessage site msg) => msg -> WidgetT site m ()
setTitleI msg = do
mr <- lift getMessageRender
mr <- getMessageRender
setTitle $ toHtml $ mr msg
-- | Link to the specified local stylesheet.
addStylesheet :: Route site -> GWidget site ()
addStylesheet :: Monad m => Route site -> WidgetT site m ()
addStylesheet = flip addStylesheetAttrs []
-- | Link to the specified local stylesheet.
addStylesheetAttrs :: Route site -> [(Text, Text)] -> GWidget site ()
addStylesheetAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
-- | Link to the specified remote stylesheet.
addStylesheetRemote :: Text -> GWidget site ()
addStylesheetRemote :: Monad m => Text -> WidgetT site m ()
addStylesheetRemote = flip addStylesheetRemoteAttrs []
-- | Link to the specified remote stylesheet.
addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site ()
addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Either (Route site) Text -> GWidget site ()
addStylesheetEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Either (Route site) Text -> GWidget site ()
addScriptEither :: Monad m => Either (Route site) Text -> WidgetT site m ()
addScriptEither = either addScript addScriptRemote
-- | Link to the specified local script.
addScript :: Route site -> GWidget site ()
addScript :: Monad m => Route site -> WidgetT site m ()
addScript = flip addScriptAttrs []
-- | Link to the specified local script.
addScriptAttrs :: Route site -> [(Text, Text)] -> GWidget site ()
addScriptAttrs :: Monad m => Route site -> [(Text, Text)] -> WidgetT site m ()
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
-- | Link to the specified remote script.
addScriptRemote :: Text -> GWidget site ()
addScriptRemote :: Monad m => Text -> WidgetT site m ()
addScriptRemote = flip addScriptRemoteAttrs []
-- | Link to the specified remote script.
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site ()
addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> WidgetT site m ()
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
whamlet :: QuasiQuoter
@ -194,27 +196,22 @@ rules = do
return $ InfixE (Just g) bind (Just e')
let ur f = do
let env = NP.Env
(Just $ helper [|liftW getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])
(Just $ helper [|getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) getMessageRender|])
f env
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: RenderMessage site message
=> HtmlUrlI18n message (Route site)
-> GHandler site Html
ihamletToRepHtml :: (HandlerReader m, RenderMessage (HandlerSite m) message)
=> HtmlUrlI18n message (Route (HandlerSite m))
-> m Html
ihamletToRepHtml ih = do
urender <- getUrlRenderParams
mrender <- getMessageRender
return $ ih (toHtml . mrender) urender
tell :: GWData (Route site) -> GWidget site ()
tell w = GWidget $ return ((), w)
-- | Type-restricted version of @lift@. Used internally to create better error
-- messages.
liftW :: GHandler site a -> GWidget site a
liftW = lift
tell :: Monad m => GWData (Route site) -> WidgetT site m ()
tell w = WidgetT $ return ((), w)
toUnique :: x -> UniqueList x
toUnique = UniqueList . (:)

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

@ -82,7 +82,7 @@ library
, fast-logger >= 0.2
, monad-logger >= 0.3.1 && < 0.4
, conduit >= 0.5
, resourcet >= 0.4 && < 0.5
, resourcet >= 0.4.6 && < 0.5
, lifted-base >= 0.1
, attoparsec-conduit
, blaze-html >= 0.5
@ -101,12 +101,10 @@ library
Yesod.Core.Class.Handler
Yesod.Core.Internal.Util
Yesod.Core.Internal.Response
Yesod.Core.Class.MonadLift
Yesod.Core.Internal.Run
Yesod.Core.Class.Yesod
Yesod.Core.Class.Dispatch
Yesod.Core.Class.Breadcrumbs
Yesod.Core.Types.Orphan
Paths_yesod_core
ghc-options: -Wall