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

Completely removed GHandlerT and GGWidget

Browse Source
This commit is contained in:
Michael Snoyman 2011-12-29 15:31:06 +02:00
parent 8e623d04a6
commit a797cd3fe3
4 changed files with 230 additions and 207 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

222
yesod-core/Yesod/Handler.hs
View File

@ -16,7 +16,7 @@
-- License : BSD3 -- License : BSD3
-- --
-- Maintainer : Michael Snoyman <michael@snoyman.com> -- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : unstable -- Stability : stable
-- Portability : portable -- Portability : portable
-- --
-- Define Handler stuff. -- Define Handler stuff.
@ -28,7 +28,6 @@ module Yesod.Handler
, YesodSubRoute (..) , YesodSubRoute (..)
-- * Handler monad -- * Handler monad
, GHandler , GHandler
, GHandlerT
-- ** Read information from handler -- ** Read information from handler
, getYesod , getYesod
, getYesodSub , getYesodSub
@ -95,7 +94,7 @@ module Yesod.Handler
, hamletToRepHtml , hamletToRepHtml
-- ** Misc -- ** Misc
, newIdent , newIdent
, liftIOHandler , liftHandler
-- * i18n -- * i18n
, getMessageRender , getMessageRender
-- * Per-request caching -- * Per-request caching
@ -132,7 +131,6 @@ import Control.Monad (liftM)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import System.IO import System.IO
import qualified Network.Wai as W import qualified Network.Wai as W
@ -173,6 +171,8 @@ import Control.Monad.Trans.Resource (ResourceT)
import Control.Exception.Lifted (catch) import Control.Exception.Lifted (catch)
import Network.Wai (requestBody) import Network.Wai (requestBody)
import Data.Conduit (($$)) import Data.Conduit (($$))
import Control.Monad.Trans.Control
import Control.Monad.Base
-- | The type-safe URLs associated with a site argument. -- | The type-safe URLs associated with a site argument.
type family Route a type family Route a
@ -208,22 +208,22 @@ handlerSubDataMaybe tm ts route hd = hd
, handlerRoute = route , handlerRoute = route
} }
get :: MonadIO monad => GHandlerT sub master monad GHState get :: GHandler sub master GHState
get = do get = do
hd <- ask hd <- ask
liftIO $ I.readIORef $ handlerState hd liftIO $ I.readIORef $ handlerState hd
put :: MonadIO monad => GHState -> GHandlerT sub master monad () put :: GHState -> GHandler sub master ()
put g = do put g = do
hd <- ask hd <- ask
liftIO $ I.writeIORef (handlerState hd) g liftIO $ I.writeIORef (handlerState hd) g
modify :: MonadIO monad => (GHState -> GHState) -> GHandlerT sub master monad () modify :: (GHState -> GHState) -> GHandler sub master ()
modify f = do modify f = do
hd <- ask hd <- ask
liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ()) liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
tell :: MonadIO monad => Endo [Header] -> GHandlerT sub master monad () tell :: Endo [Header] -> GHandler sub master ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
-- | Used internally for promoting subsite handler functions to master site -- | Used internally for promoting subsite handler functions to master site
@ -231,19 +231,19 @@ tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
toMasterHandler :: (Route sub -> Route master) toMasterHandler :: (Route sub -> Route master)
-> (master -> sub) -> (master -> sub)
-> Route sub -> Route sub
-> GHandlerT sub master mo a -> GHandler sub master a
-> GHandlerT sub' master mo a -> GHandler sub' master a
toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route) toMasterHandler tm ts route = local (handlerSubData tm ts route)
toMasterHandlerDyn :: Monad mo -- | FIXME do we need this?
=> (Route sub -> Route master) toMasterHandlerDyn :: (Route sub -> Route master)
-> GHandlerT sub' master mo sub -> GHandler sub' master sub
-> Route sub -> Route sub
-> GHandlerT sub master mo a -> GHandler sub master a
-> GHandlerT sub' master mo a -> GHandler sub' master a
toMasterHandlerDyn tm getSub route h = do toMasterHandlerDyn tm getSub route h = do
sub <- getSub sub <- getSub
withReaderT (handlerSubData tm (const sub) route) h local (handlerSubData tm (const sub) route) h
class SubsiteGetter g m s | g -> s where class SubsiteGetter g m s | g -> s where
runSubsiteGetter :: g -> m s runSubsiteGetter :: g -> m s
@ -260,18 +260,19 @@ instance (anySub ~ anySub'
toMasterHandlerMaybe :: (Route sub -> Route master) toMasterHandlerMaybe :: (Route sub -> Route master)
-> (master -> sub) -> (master -> sub)
-> Maybe (Route sub) -> Maybe (Route sub)
-> GHandlerT sub master mo a -> GHandler sub master a
-> GHandlerT sub' master mo a -> GHandler sub' master a
toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route) toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
-- | A generic handler monad, which can have a different subsite and master -- | A generic handler monad, which can have a different subsite and master
-- site. This monad is a combination of 'ReaderT' for basic arguments, a -- site. We define a newtype for better error message.
-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling --
-- special responses. It is declared as a newtype to make compiler errors more -- Note that, in order to lift actions from the inner monad, you must use
-- readable. -- 'liftHandler' instead of just @lift@, since @GHandler@ is not in fact a
type GHandlerT sub master = ReaderT (HandlerData sub master) -- monad transformer.
newtype GHandler sub master a = GHandler
type GHandler sub master = GHandlerT sub master (ResourceT IO) { unGHandler :: HandlerData sub master -> ResourceT IO a
}
data GHState = GHState data GHState = GHState
{ ghsSession :: SessionMap { ghsSession :: SessionMap
@ -312,10 +313,10 @@ instance Show HandlerContents where
show _ = "Cannot show a HandlerContents" show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents instance Exception HandlerContents
getRequest :: Monad mo => GHandlerT s m mo Request getRequest :: GHandler s m Request
getRequest = handlerRequest `liftM` ask getRequest = handlerRequest `liftM` ask
instance MonadIO monad => Failure ErrorResponse (GHandlerT sub master monad) where instance Failure ErrorResponse (GHandler sub master) where
failure = liftIO . throwIO . HCError failure = liftIO . throwIO . HCError
runRequestBody :: GHandler s m RequestBodyContents runRequestBody :: GHandler s m RequestBodyContents
@ -325,7 +326,7 @@ runRequestBody = do
Just rbc -> return rbc Just rbc -> return rbc
Nothing -> do Nothing -> do
rr <- waiRequest rr <- waiRequest
rbc <- lift $ rbHelper rr rbc <- liftHandler $ rbHelper rr
put x { ghsRBC = Just rbc } put x { ghsRBC = Just rbc }
return rbc return rbc
@ -340,33 +341,32 @@ rbHelper req =
go = decodeUtf8With lenientDecode go = decodeUtf8With lenientDecode
-- | Get the sub application argument. -- | Get the sub application argument.
getYesodSub :: Monad m => GHandlerT sub master m sub getYesodSub :: GHandler sub master sub
getYesodSub = handlerSub `liftM` ask getYesodSub = handlerSub `liftM` ask
-- | Get the master site appliation argument. -- | Get the master site appliation argument.
getYesod :: Monad m => GHandlerT sub master m master getYesod :: GHandler sub master master
getYesod = handlerMaster `liftM` ask getYesod = handlerMaster `liftM` ask
-- | Get the URL rendering function. -- | Get the URL rendering function.
getUrlRender :: Monad m => GHandlerT sub master m (Route master -> Text) getUrlRender :: GHandler sub master (Route master -> Text)
getUrlRender = do getUrlRender = do
x <- handlerRender `liftM` ask x <- handlerRender `liftM` ask
return $ flip x [] return $ flip x []
-- | The URL rendering function with query-string parameters. -- | The URL rendering function with query-string parameters.
getUrlRenderParams getUrlRenderParams
:: Monad m :: GHandler sub master (Route master -> [(Text, Text)] -> Text)
=> GHandlerT sub master m (Route master -> [(Text, Text)] -> Text)
getUrlRenderParams = handlerRender `liftM` ask getUrlRenderParams = handlerRender `liftM` ask
-- | Get the route requested by the user. If this is a 404 response- where the -- | Get the route requested by the user. If this is a 404 response- where the
-- user requested an invalid route- this function will return 'Nothing'. -- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: Monad m => GHandlerT sub master m (Maybe (Route sub)) getCurrentRoute :: GHandler sub master (Maybe (Route sub))
getCurrentRoute = handlerRoute `liftM` ask getCurrentRoute = handlerRoute `liftM` ask
-- | Get the function to promote a route for a subsite to a route for the -- | Get the function to promote a route for a subsite to a route for the
-- master site. -- master site.
getRouteToMaster :: Monad m => GHandlerT sub master m (Route sub -> Route master) getRouteToMaster :: GHandler sub master (Route sub -> Route master)
getRouteToMaster = handlerToMaster `liftM` ask getRouteToMaster = handlerToMaster `liftM` ask
-- | Function used internally by Yesod in the process of converting a -- | Function used internally by Yesod in the process of converting a
@ -401,7 +401,7 @@ runHandler handler mrender sroute tomr master sub =
, handlerToMaster = tomr , handlerToMaster = tomr
, handlerState = istate , handlerState = istate
} }
contents' <- catch (fmap Right $ runReaderT handler hd) contents' <- catch (fmap Right $ unGHandler handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e) $ fromException e)
state <- liftIO $ I.readIORef istate state <- liftIO $ I.readIORef istate
@ -451,19 +451,18 @@ safeEh er = YesodApp $ \_ _ _ session -> do
session session
-- | Redirect to the given route. -- | Redirect to the given route.
redirect :: MonadIO mo => RedirectType -> Route master -> GHandlerT sub master mo a redirect :: RedirectType -> Route master -> GHandler sub master a
redirect rt url = redirectParams rt url [] redirect rt url = redirectParams rt url []
-- | Redirects to the given route with the associated query-string parameters. -- | Redirects to the given route with the associated query-string parameters.
redirectParams :: MonadIO mo redirectParams :: RedirectType -> Route master -> [(Text, Text)]
=> RedirectType -> Route master -> [(Text, Text)] -> GHandler sub master a
-> GHandlerT sub master mo a
redirectParams rt url params = do redirectParams rt url params = do
r <- getUrlRenderParams r <- getUrlRenderParams
redirectString rt $ r url params redirectString rt $ r url params
-- | Redirect to the given URL. -- | Redirect to the given URL.
redirectString, redirectText :: MonadIO mo => RedirectType -> Text -> GHandlerT sub master mo a redirectString, redirectText :: RedirectType -> Text -> GHandler sub master a
redirectText rt = liftIO . throwIO . HCRedirect rt redirectText rt = liftIO . throwIO . HCRedirect rt
redirectString = redirectText redirectString = redirectText
{-# DEPRECATED redirectString "Use redirectText instead" #-} {-# DEPRECATED redirectString "Use redirectText instead" #-}
@ -475,16 +474,16 @@ ultDestKey = "_ULT"
-- --
-- An ultimate destination is stored in the user session and can be loaded -- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'. -- later by 'redirectUltDest'.
setUltDest :: MonadIO mo => Route master -> GHandlerT sub master mo () setUltDest :: Route master -> GHandler sub master ()
setUltDest dest = do setUltDest dest = do
render <- getUrlRender render <- getUrlRender
setUltDestString $ render dest setUltDestString $ render dest
-- | Same as 'setUltDest', but use the given string. -- | Same as 'setUltDest', but use the given string.
setUltDestText :: MonadIO mo => Text -> GHandlerT sub master mo () setUltDestText :: Text -> GHandler sub master ()
setUltDestText = setSession ultDestKey setUltDestText = setSession ultDestKey
setUltDestString :: MonadIO mo => Text -> GHandlerT sub master mo () setUltDestString :: Text -> GHandler sub master ()
setUltDestString = setSession ultDestKey setUltDestString = setSession ultDestKey
{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-} {-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}
@ -492,7 +491,7 @@ setUltDestString = setSession ultDestKey
-- --
-- If this is a 404 handler, there is no current page, and then this call does -- If this is a 404 handler, there is no current page, and then this call does
-- nothing. -- nothing.
setUltDest' :: MonadIO mo => GHandlerT sub master mo () setUltDest' :: GHandler sub master ()
setUltDest' = do setUltDest' = do
route <- getCurrentRoute route <- getCurrentRoute
case route of case route of
@ -506,7 +505,7 @@ setUltDest' = do
-- | Sets the ultimate destination to the referer request header, if present. -- | Sets the ultimate destination to the referer request header, if present.
-- --
-- This function will not overwrite an existing ultdest. -- This function will not overwrite an existing ultdest.
setUltDestReferer :: MonadIO mo => GHandlerT sub master mo () setUltDestReferer :: GHandler sub master ()
setUltDestReferer = do setUltDestReferer = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
maybe maybe
@ -520,17 +519,16 @@ setUltDestReferer = do
-- value from the session. -- value from the session.
-- --
-- The ultimate destination is set with 'setUltDest'. -- The ultimate destination is set with 'setUltDest'.
redirectUltDest :: MonadIO mo redirectUltDest :: RedirectType
=> RedirectType
-> Route master -- ^ default destination if nothing in session -> Route master -- ^ default destination if nothing in session
-> GHandlerT sub master mo a -> GHandler sub master a
redirectUltDest rt def = do redirectUltDest rt def = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
deleteSession ultDestKey deleteSession ultDestKey
maybe (redirect rt def) (redirectText rt) mdest maybe (redirect rt def) (redirectText rt) mdest
-- | Remove a previously set ultimate destination. See 'setUltDest'. -- | Remove a previously set ultimate destination. See 'setUltDest'.
clearUltDest :: MonadIO mo => GHandlerT sub master mo () clearUltDest :: GHandler sub master ()
clearUltDest = deleteSession ultDestKey clearUltDest = deleteSession ultDestKey
msgKey :: Text msgKey :: Text
@ -539,13 +537,13 @@ msgKey = "_MSG"
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessage :: MonadIO mo => Html -> GHandlerT sub master mo () setMessage :: Html -> GHandler sub master ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
-- | Sets a message in the user's session. -- | Sets a message in the user's session.
-- --
-- See 'getMessage'. -- See 'getMessage'.
setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GHandlerT sub y mo () setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y ()
setMessageI msg = do setMessageI msg = do
mr <- getMessageRender mr <- getMessageRender
setMessage $ toHtml $ mr msg setMessage $ toHtml $ mr msg
@ -554,7 +552,7 @@ setMessageI msg = do
-- variable. -- variable.
-- --
-- See 'setMessage'. -- See 'setMessage'.
getMessage :: MonadIO mo => GHandlerT sub master mo (Maybe Html) getMessage :: GHandler sub master (Maybe Html)
getMessage = do getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey deleteSession msgKey
@ -564,34 +562,33 @@ getMessage = do
-- --
-- For some backends, this is more efficient than reading in the file to -- For some backends, this is more efficient than reading in the file to
-- memory, since they can optimize file sending via a system call to sendfile. -- memory, since they can optimize file sending via a system call to sendfile.
sendFile :: MonadIO mo => ContentType -> FilePath -> GHandlerT sub master mo a sendFile :: ContentType -> FilePath -> GHandler sub master a
sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
-- | Same as 'sendFile', but only sends part of a file. -- | Same as 'sendFile', but only sends part of a file.
sendFilePart :: MonadIO mo sendFilePart :: ContentType
=> ContentType
-> FilePath -> FilePath
-> Integer -- ^ offset -> Integer -- ^ offset
-> Integer -- ^ count -> Integer -- ^ count
-> GHandlerT sub master mo a -> GHandler sub master a
sendFilePart ct fp off count = sendFilePart ct fp off count =
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
-- | Bypass remaining handler code and output the given content with a 200 -- | Bypass remaining handler code and output the given content with a 200
-- status code. -- status code.
sendResponse :: (MonadIO mo, HasReps c) => c -> GHandlerT sub master mo a sendResponse :: HasReps c => c -> GHandler sub master a
sendResponse = liftIO . throwIO . HCContent H.status200 sendResponse = liftIO . throwIO . HCContent H.status200
. chooseRep . chooseRep
-- | Bypass remaining handler code and output the given content with the given -- | Bypass remaining handler code and output the given content with the given
-- status code. -- status code.
sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GHandlerT s m mo a sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a
sendResponseStatus s = liftIO . throwIO . HCContent s sendResponseStatus s = liftIO . throwIO . HCContent s
. chooseRep . chooseRep
-- | Send a 201 "Created" response with the given route as the Location -- | Send a 201 "Created" response with the given route as the Location
-- response header. -- response header.
sendResponseCreated :: MonadIO mo => Route m -> GHandlerT s m mo a sendResponseCreated :: Route m -> GHandler s m a
sendResponseCreated url = do sendResponseCreated url = do
r <- getUrlRender r <- getUrlRender
liftIO . throwIO $ HCCreated $ r url liftIO . throwIO $ HCCreated $ r url
@ -601,7 +598,7 @@ sendResponseCreated url = do
-- that you have already specified. This function short-circuits. It should be -- that you have already specified. This function short-circuits. It should be
-- considered only for very specific needs. If you are not sure if you need it, -- considered only for very specific needs. If you are not sure if you need it,
-- you don't. -- you don't.
sendWaiResponse :: MonadIO mo => W.Response -> GHandlerT s m mo b sendWaiResponse :: W.Response -> GHandler s m b
sendWaiResponse = liftIO . throwIO . HCWai sendWaiResponse = liftIO . throwIO . HCWai
-- | Return a 404 not found page. Also denotes no handler available. -- | Return a 404 not found page. Also denotes no handler available.
@ -609,7 +606,7 @@ notFound :: Failure ErrorResponse m => m a
notFound = failure NotFound notFound = failure NotFound
-- | Return a 405 method not supported page. -- | Return a 405 method not supported page.
badMethod :: MonadIO mo => GHandlerT s m mo a badMethod :: GHandler s m a
badMethod = do badMethod = do
w <- waiRequest w <- waiRequest
failure $ BadMethod $ W.requestMethod w failure $ BadMethod $ W.requestMethod w
@ -619,7 +616,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
permissionDenied = failure . PermissionDenied permissionDenied = failure . PermissionDenied
-- | Return a 403 permission denied page. -- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GHandlerT s y mo a permissionDeniedI :: RenderMessage y msg => msg -> GHandler s y a
permissionDeniedI msg = do permissionDeniedI msg = do
mr <- getMessageRender mr <- getMessageRender
permissionDenied $ mr msg permissionDenied $ mr msg
@ -629,7 +626,7 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs invalidArgs = failure . InvalidArgs
-- | Return a 400 invalid arguments page. -- | Return a 400 invalid arguments page.
invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GHandlerT s y mo a invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a
invalidArgsI msg = do invalidArgsI msg = do
mr <- getMessageRender mr <- getMessageRender
invalidArgs $ map mr msg invalidArgs $ map mr msg
@ -639,33 +636,31 @@ invalidArgsI msg = do
-- --
-- Note: although the value used for key and value is 'Text', you should only -- Note: although the value used for key and value is 'Text', you should only
-- use ASCII values to be HTTP compliant. -- use ASCII values to be HTTP compliant.
setCookie :: MonadIO mo setCookie :: Int -- ^ minutes to timeout
=> Int -- ^ minutes to timeout
-> Text -- ^ key -> Text -- ^ key
-> Text -- ^ value -> Text -- ^ value
-> GHandlerT sub master mo () -> GHandler sub master ()
setCookie a b = addHeader . AddCookie a (encodeUtf8 b) . encodeUtf8 setCookie a b = addHeader . AddCookie a (encodeUtf8 b) . encodeUtf8
-- | Unset the cookie on the client. -- | Unset the cookie on the client.
deleteCookie :: MonadIO mo => Text -> GHandlerT sub master mo () deleteCookie :: Text -> GHandler sub master ()
deleteCookie = addHeader . DeleteCookie . encodeUtf8 deleteCookie = addHeader . DeleteCookie . encodeUtf8
-- | Set the language in the user session. Will show up in 'languages' on the -- | Set the language in the user session. Will show up in 'languages' on the
-- next request. -- next request.
setLanguage :: MonadIO mo => Text -> GHandlerT sub master mo () setLanguage :: Text -> GHandler sub master ()
setLanguage = setSession langKey setLanguage = setSession langKey
-- | Set an arbitrary response header. -- | Set an arbitrary response header.
-- --
-- Note that, while the data type used here is 'Text', you must provide only -- Note that, while the data type used here is 'Text', you must provide only
-- ASCII value to be HTTP compliant. -- ASCII value to be HTTP compliant.
setHeader :: MonadIO mo setHeader :: Text -> Text -> GHandler sub master ()
=> Text -> Text -> GHandlerT sub master mo ()
setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8 setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
-- | Set the Cache-Control header to indicate this response should be cached -- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds. -- for the given number of seconds.
cacheSeconds :: MonadIO mo => Int -> GHandlerT s m mo () cacheSeconds :: Int -> GHandler s m ()
cacheSeconds i = setHeader "Cache-Control" $ T.concat cacheSeconds i = setHeader "Cache-Control" $ T.concat
[ "max-age=" [ "max-age="
, T.pack $ show i , T.pack $ show i
@ -674,16 +669,16 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
-- | Set the Expires header to some date in 2037. In other words, this content -- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired. -- is never (realistically) expired.
neverExpires :: MonadIO mo => GHandlerT s m mo () neverExpires :: GHandler s m ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
-- | Set an Expires header in the past, meaning this content should not be -- | Set an Expires header in the past, meaning this content should not be
-- cached. -- cached.
alreadyExpired :: MonadIO mo => GHandlerT s m mo () alreadyExpired :: GHandler s m ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date. -- | Set an Expires header to the given date.
expiresAt :: MonadIO mo => UTCTime -> GHandlerT s m mo () expiresAt :: UTCTime -> GHandler s m ()
expiresAt = setHeader "Expires" . formatRFC1123 expiresAt = setHeader "Expires" . formatRFC1123
-- | Set a variable in the user's session. -- | Set a variable in the user's session.
@ -691,21 +686,20 @@ expiresAt = setHeader "Expires" . formatRFC1123
-- The session is handled by the clientsession package: it sets an encrypted -- The session is handled by the clientsession package: it sets an encrypted
-- and hashed cookie on the client. This ensures that all data is secure and -- and hashed cookie on the client. This ensures that all data is secure and
-- not tampered with. -- not tampered with.
setSession :: MonadIO mo setSession :: Text -- ^ key
=> Text -- ^ key
-> Text -- ^ value -> Text -- ^ value
-> GHandlerT sub master mo () -> GHandler sub master ()
setSession k = modify . modSession . Map.insert k setSession k = modify . modSession . Map.insert k
-- | Unsets a session variable. See 'setSession'. -- | Unsets a session variable. See 'setSession'.
deleteSession :: MonadIO mo => Text -> GHandlerT sub master mo () deleteSession :: Text -> GHandler sub master ()
deleteSession = modify . modSession . Map.delete deleteSession = modify . modSession . Map.delete
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x } modSession f x = x { ghsSession = f $ ghsSession x }
-- | Internal use only, not to be confused with 'setHeader'. -- | Internal use only, not to be confused with 'setHeader'.
addHeader :: MonadIO mo => Header -> GHandlerT sub master mo () addHeader :: Header -> GHandler sub master ()
addHeader = tell . Endo . (:) addHeader = tell . Endo . (:)
getStatus :: ErrorResponse -> H.Status getStatus :: ErrorResponse -> H.Status
@ -728,18 +722,18 @@ data RedirectType = RedirectPermanent
| RedirectSeeOther | RedirectSeeOther
deriving (Show, Eq) deriving (Show, Eq)
localNoCurrent :: Monad mo => GHandlerT s m mo a -> GHandlerT s m mo a localNoCurrent :: GHandler s m a -> GHandler s m a
localNoCurrent = localNoCurrent =
local (\hd -> hd { handlerRoute = Nothing }) local (\hd -> hd { handlerRoute = Nothing })
-- | Lookup for session data. -- | Lookup for session data.
lookupSession :: MonadIO mo => Text -> GHandlerT s m mo (Maybe Text) lookupSession :: Text -> GHandler s m (Maybe Text)
lookupSession n = do lookupSession n = do
m <- liftM ghsSession get m <- liftM ghsSession get
return $ Map.lookup n m return $ Map.lookup n m
-- | Get all session variables. -- | Get all session variables.
getSession :: MonadIO mo => GHandlerT s m mo SessionMap getSession :: GHandler s m SessionMap
getSession = liftM ghsSession get getSession = liftM ghsSession get
handlerToYAR :: (HasReps a, HasReps b) handlerToYAR :: (HasReps a, HasReps b)
@ -834,17 +828,12 @@ headerToPair cp _ (DeleteCookie key) =
headerToPair _ _ (Header key value) = (CI.mk key, value) headerToPair _ _ (Header key value) = (CI.mk key, value)
-- | Get a unique identifier. -- | Get a unique identifier.
newIdent :: MonadIO mo => GHandlerT sub master mo String -- FIXME use Text newIdent :: GHandler sub master Text
newIdent = do newIdent = do
x <- get x <- get
let i' = ghsIdent x + 1 let i' = ghsIdent x + 1
put x { ghsIdent = i' } put x { ghsIdent = i' }
return $ 'h' : show i' return $ T.pack $ 'h' : show i'
liftIOHandler :: MonadIO mo
=> GHandlerT sub master IO a
-> GHandlerT sub master mo a
liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- | Redirect to a POST resource. -- | Redirect to a POST resource.
-- --
@ -852,7 +841,7 @@ liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
-- POST form, and some Javascript to automatically submit the form. This can be -- POST form, and some Javascript to automatically submit the form. This can be
-- useful when you need to post a plain link somewhere that needs to cause -- useful when you need to post a plain link somewhere that needs to cause
-- changes on the server. -- changes on the server.
redirectToPost :: MonadIO mo => Route master -> GHandlerT sub master mo a redirectToPost :: Route master -> GHandler sub master a
redirectToPost dest = hamletToRepHtml redirectToPost dest = hamletToRepHtml
#if GHC7 #if GHC7
[hamlet| [hamlet|
@ -873,36 +862,65 @@ redirectToPost dest = hamletToRepHtml
-- | Converts the given Hamlet template into 'Content', which can be used in a -- | Converts the given Hamlet template into 'Content', which can be used in a
-- Yesod 'Response'. -- Yesod 'Response'.
hamletToContent :: Monad mo hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content
=> HtmlUrl (Route master) -> GHandlerT sub master mo Content
hamletToContent h = do hamletToContent h = do
render <- getUrlRenderParams render <- getUrlRenderParams
return $ toContent $ h render return $ toContent $ h render
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Monad mo hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml
=> HtmlUrl (Route master) -> GHandlerT sub master mo RepHtml
hamletToRepHtml = liftM RepHtml . hamletToContent hamletToRepHtml = liftM RepHtml . hamletToContent
-- | Get the request\'s 'W.Request' value. -- | Get the request\'s 'W.Request' value.
waiRequest :: Monad mo => GHandlerT sub master mo W.Request waiRequest :: GHandler sub master W.Request
waiRequest = reqWaiRequest `liftM` getRequest waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (Monad mo, RenderMessage master message) => GHandlerT s master mo (message -> Text) getMessageRender :: RenderMessage master message => GHandler s master (message -> Text)
getMessageRender = do getMessageRender = do
m <- getYesod m <- getYesod
l <- reqLangs `liftM` getRequest l <- reqLangs `liftM` getRequest
return $ renderMessage m l return $ renderMessage m l
cacheLookup :: MonadIO mo => CacheKey a -> GHandlerT sub master mo (Maybe a) cacheLookup :: CacheKey a -> GHandler sub master (Maybe a)
cacheLookup k = do cacheLookup k = do
gs <- get gs <- get
return $ Cache.lookup k $ ghsCache gs return $ Cache.lookup k $ ghsCache gs
cacheInsert :: MonadIO mo => CacheKey a -> a -> GHandlerT sub master mo () cacheInsert :: CacheKey a -> a -> GHandler sub master ()
cacheInsert k v = modify $ \gs -> cacheInsert k v = modify $ \gs ->
gs { ghsCache = Cache.insert k v $ ghsCache gs } gs { ghsCache = Cache.insert k v $ ghsCache gs }
cacheDelete :: MonadIO mo => CacheKey a -> GHandlerT sub master mo () cacheDelete :: CacheKey a -> GHandler sub master ()
cacheDelete k = modify $ \gs -> cacheDelete k = modify $ \gs ->
gs { ghsCache = Cache.delete k $ ghsCache gs } gs { ghsCache = Cache.delete k $ ghsCache gs }
ask :: GHandler sub master (HandlerData sub master)
ask = GHandler return
local :: (HandlerData sub' master' -> HandlerData sub master)
-> GHandler sub master a
-> GHandler sub' master' a
local f (GHandler x) = GHandler $ \r -> x $ f r
liftHandler :: ResourceT IO a -> GHandler sub master a
liftHandler = GHandler . const
-- Instances for GHandler
instance Functor (GHandler sub master) where
fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)
instance Applicative (GHandler sub master) where
pure = GHandler . const . pure
GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r
instance Monad (GHandler sub master) where
return = pure
GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r
instance MonadIO (GHandler sub master) where
liftIO = GHandler . const . lift
instance MonadBase IO (GHandler sub master) where
liftBase = GHandler . const . lift
instance MonadBaseControl IO (GHandler sub master) where
data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)
liftBaseWith f = GHandler $ \reader ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
restoreM (StH base) = GHandler $ const $ restoreM base

8
yesod-core/Yesod/Internal/Core.hs
View File

@ -280,8 +280,8 @@ class RenderRoute (Route a) => Yesod a where
yepnopeJs :: a -> Maybe (Either Text (Route a)) yepnopeJs :: a -> Maybe (Either Text (Route a))
yepnopeJs _ = Nothing yepnopeJs _ = Nothing
messageLoggerHandler :: (Yesod m, MonadIO mo) messageLoggerHandler :: Yesod m
=> Loc -> LogLevel -> Text -> GHandlerT s m mo () => Loc -> LogLevel -> Text -> GHandler s m ()
messageLoggerHandler loc level msg = do messageLoggerHandler loc level msg = do
y <- getYesod y <- getYesod
liftIO $ messageLogger y loc level msg liftIO $ messageLogger y loc level msg
@ -499,9 +499,9 @@ jelper = fmap jsToHtml
widgetToPageContent :: (Eq (Route master), Yesod master) widgetToPageContent :: (Eq (Route master), Yesod master)
=> GWidget sub master () => GWidget sub master ()
-> GHandler sub master (PageContent (Route master)) -> GHandler sub master (PageContent (Route master))
widgetToPageContent (GWidget w) = do widgetToPageContent w = do
master <- getYesod master <- getYesod
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runWriterT w ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w
let title = maybe mempty unTitle mTitle let title = maybe mempty unTitle mTitle
let scripts = runUniqueList scripts' let scripts = runUniqueList scripts'
let stylesheets = runUniqueList stylesheets' let stylesheets = runUniqueList stylesheets'

10
yesod-core/Yesod/Request.hs
View File

@ -52,20 +52,20 @@ import Data.Text (Text)
-- * Accept-Language HTTP header. -- * Accept-Language HTTP header.
-- --
-- This is handled by parseWaiRequest (not exposed). -- This is handled by parseWaiRequest (not exposed).
languages :: Monad mo => GHandlerT s m mo [Text] languages :: GHandler s m [Text]
languages = reqLangs `liftM` getRequest languages = reqLangs `liftM` getRequest
lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' a = map snd . filter (\x -> a == fst x) lookup' a = map snd . filter (\x -> a == fst x)
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParams :: Monad mo => Text -> GHandlerT s m mo [Text] lookupGetParams :: Text -> GHandler s m [Text]
lookupGetParams pn = do lookupGetParams pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqGetParams rr return $ lookup' pn $ reqGetParams rr
-- | Lookup for GET parameters. -- | Lookup for GET parameters.
lookupGetParam :: Monad mo => Text -> GHandlerT s m mo (Maybe Text) lookupGetParam :: Text -> GHandler s m (Maybe Text)
lookupGetParam = liftM listToMaybe . lookupGetParams lookupGetParam = liftM listToMaybe . lookupGetParams
-- | Lookup for POST parameters. -- | Lookup for POST parameters.
@ -91,11 +91,11 @@ lookupFiles pn = do
return $ lookup' pn files return $ lookup' pn files
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookie :: Monad mo => Text -> GHandlerT s m mo (Maybe Text) lookupCookie :: Text -> GHandler s m (Maybe Text)
lookupCookie = liftM listToMaybe . lookupCookies lookupCookie = liftM listToMaybe . lookupCookies
-- | Lookup for cookie data. -- | Lookup for cookie data.
lookupCookies :: Monad mo => Text -> GHandlerT s m mo [Text] lookupCookies :: Text -> GHandler s m [Text]
lookupCookies pn = do lookupCookies pn = do
rr <- getRequest rr <- getRequest
return $ lookup' pn $ reqCookies rr return $ lookup' pn $ reqCookies rr

197
yesod-core/Yesod/Widget.hs
View File

@ -6,12 +6,13 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
-- FIXME Should we remove the older names here (addJulius, etc)?
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
-- generator, allowing you to create truly modular HTML components. -- generator, allowing you to create truly modular HTML components.
module Yesod.Widget module Yesod.Widget
( -- * Datatype ( -- * Datatype
GWidget GWidget
, GGWidget (..)
, PageContent (..) , PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets -- * Special Hamlet quasiquoter/TH for Widgets
, whamlet , whamlet
@ -53,25 +54,25 @@ module Yesod.Widget
, addScriptRemoteAttrs , addScriptRemoteAttrs
, addScriptEither , addScriptEither
-- * Utilities -- * Utilities
, extractBody , liftWidget
-- * Internal
, unGWidget
) where ) where
import Data.Monoid import Data.Monoid
import Control.Monad.Trans.Writer
import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5 as H
import Text.Hamlet import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
import Text.Coffee import Text.Coffee
import Yesod.Handler import Yesod.Handler
(Route, GHandler, GHandlerT, YesodSubRoute(..), toMasterHandlerMaybe, getYesod ( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
, getMessageRender, getUrlRenderParams , getMessageRender, getUrlRenderParams
) )
import Yesod.Message (RenderMessage) import Yesod.Message (RenderMessage)
import Yesod.Content (RepHtml (..), toContent) import Yesod.Content (RepHtml (..), toContent)
import Control.Applicative (Applicative) import Control.Applicative (Applicative (..), (<$>))
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Class (MonadTrans (lift))
import Yesod.Internal import Yesod.Internal
import Control.Monad (liftM) import Control.Monad (liftM)
import Data.Text (Text) import Data.Text (Text)
@ -79,59 +80,32 @@ import qualified Data.Map as Map
import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
#if MIN_VERSION_monad_control(0, 3, 0) import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Control (MonadTransControl (..), MonadBaseControl (..), defaultLiftBaseWith, defaultRestoreM, ComposeSt)
#else
import Control.Monad.IO.Control (MonadControlIO)
#endif
import qualified Text.Hamlet as NP import qualified Text.Hamlet as NP
import Data.Text.Lazy.Builder (fromLazyText) import Data.Text.Lazy.Builder (fromLazyText)
import Text.Blaze (toHtml, preEscapedLazyText) import Text.Blaze (toHtml, preEscapedLazyText)
import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.Base (MonadBase (liftBase))
-- | A generic widget, allowing specification of both the subsite and master -- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. This is basically a large 'WriterT' stack keeping track of -- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- dependencies along with a 'StateT' to track unique identifiers. -- better error messages.
newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a } --
deriving (Functor, Applicative, Monad, MonadIO -- Note that you must use 'liftWidget' instead of @lift@ since this is not a
#if !MIN_VERSION_monad_control(0, 3, 0) -- monad transformer.
, MonadControlIO newtype GWidget sub master a = GWidget
#endif { unGWidget :: GHandler sub master (a, GWData (Route master))
) }
instance MonadBase b m => MonadBase b (GGWidget master m) where instance (a ~ ()) => Monoid (GWidget sub master a) where
liftBase = lift . liftBase
#if MIN_VERSION_monad_control(0, 3, 0)
instance MonadTransControl (GGWidget master) where
newtype StT (GGWidget master) a =
StWidget {unStWidget :: StT (GWInner master) a}
liftWith f = GWidget $ liftWith $ \run ->
f $ liftM StWidget . run . unGWidget
restoreT = GWidget . restoreT . liftM unStWidget
{-# INLINE liftWith #-}
{-# INLINE restoreT #-}
instance MonadBaseControl b m => MonadBaseControl b (GGWidget master m) where
newtype StM (GGWidget master m) a = StMT {unStMT :: ComposeSt (GGWidget master) m a}
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
#endif
instance MonadTrans (GGWidget m) where
lift = GWidget . lift
type GWidget s m = GGWidget m (GHandler s m)
type GWInner master = WriterT (GWData (Route master))
instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad a) where
mempty = return () mempty = return ()
mappend x y = x >> y mappend x y = x >> y
addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
addSubWidget sub (GWidget w) = do addSubWidget sub (GWidget w) = do
master <- lift getYesod master <- liftWidget getYesod
let sr = fromSubRoute sub master let sr = fromSubRoute sub master
(a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runWriterT w (a, w') <- liftWidget $ toMasterHandlerMaybe sr (const sub) Nothing w
GWidget $ tell w' tell w'
return a return a
class ToWidget sub master a where class ToWidget sub master a where
@ -184,124 +158,116 @@ instance render ~ RY master => ToWidgetHead sub master (render -> Coffeescript)
-- | Set the page title. Calling 'setTitle' multiple times overrides previously -- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values. -- set values.
setTitle :: Monad m => Html -> GGWidget master m () setTitle :: Html -> GWidget sub master ()
setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty 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 the page title. Calling 'setTitle' multiple times overrides previously
-- set values. -- set values.
setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GHandlerT sub master m) () setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()
setTitleI msg = do setTitleI msg = do
mr <- lift getMessageRender mr <- liftWidget getMessageRender
setTitle $ toHtml $ mr msg setTitle $ toHtml $ mr msg
-- | Add a 'Hamlet' to the head tag. -- | Add a 'Hamlet' to the head tag.
addHamletHead :: Monad m => HtmlUrl (Route master) -> GGWidget master m () addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()
addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head addHamletHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
-- | Add a 'Html' to the head tag. -- | Add a 'Html' to the head tag.
addHtmlHead :: Monad m => Html -> GGWidget master m () addHtmlHead :: Html -> GWidget sub master ()
addHtmlHead = addHamletHead . const addHtmlHead = addHamletHead . const
-- | Add a 'Hamlet' to the body tag. -- | Add a 'Hamlet' to the body tag.
addHamlet :: Monad m => HtmlUrl (Route master) -> GGWidget master m () addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()
addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty addHamlet x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
-- | Add a 'Html' to the body tag. -- | Add a 'Html' to the body tag.
addHtml :: Monad m => Html -> GGWidget master m () addHtml :: Html -> GWidget sub master ()
addHtml = addHamlet . const addHtml = addHamlet . const
-- | Add another widget. This is defined as 'id', by can help with types, and -- | Add another widget. This is defined as 'id', by can help with types, and
-- makes widget blocks look more consistent. -- makes widget blocks look more consistent.
addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo () addWidget :: GWidget sub master () -> GWidget sub master ()
addWidget = id addWidget = id
-- | Add some raw CSS to the style tag. Applies to all media types. -- | Add some raw CSS to the style tag. Applies to all media types.
addCassius :: Monad m => CssUrl (Route master) -> GGWidget master m () addCassius :: CssUrl (Route master) -> GWidget sub master ()
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty addCassius x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
-- | Identical to 'addCassius'. -- | Identical to 'addCassius'.
addLucius :: Monad m => CssUrl (Route master) -> GGWidget master m () addLucius :: CssUrl (Route master) -> GWidget sub master ()
addLucius = addCassius addLucius = addCassius
-- | Add some raw CSS to the style tag, for a specific media type. -- | Add some raw CSS to the style tag, for a specific media type.
addCassiusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m () addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
-- | Identical to 'addCassiusMedia'. -- | Identical to 'addCassiusMedia'.
addLuciusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m () addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
addLuciusMedia = addCassiusMedia addLuciusMedia = addCassiusMedia
-- | Link to the specified local stylesheet. -- | Link to the specified local stylesheet.
addStylesheet :: Monad m => Route master -> GGWidget master m () addStylesheet :: Route master -> GWidget sub master ()
addStylesheet = flip addStylesheetAttrs [] addStylesheet = flip addStylesheetAttrs []
-- | Link to the specified local stylesheet. -- | Link to the specified local stylesheet.
addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m () addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
-- | Link to the specified remote stylesheet. -- | Link to the specified remote stylesheet.
addStylesheetRemote :: Monad m => Text -> GGWidget master m () addStylesheetRemote :: Text -> GWidget sub master ()
addStylesheetRemote = flip addStylesheetRemoteAttrs [] addStylesheetRemote = flip addStylesheetRemoteAttrs []
-- | Link to the specified remote stylesheet. -- | Link to the specified remote stylesheet.
addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m () addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget master m () addStylesheetEither :: Either (Route master) Text -> GWidget sub master ()
addStylesheetEither = either addStylesheet addStylesheetRemote addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m () addScriptEither :: Either (Route master) Text -> GWidget sub master ()
addScriptEither = either addScript addScriptRemote addScriptEither = either addScript addScriptRemote
-- | Link to the specified local script. -- | Link to the specified local script.
addScript :: Monad m => Route master -> GGWidget master m () addScript :: Route master -> GWidget sub master ()
addScript = flip addScriptAttrs [] addScript = flip addScriptAttrs []
-- | Link to the specified local script. -- | Link to the specified local script.
addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m () addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
-- | Link to the specified remote script. -- | Link to the specified remote script.
addScriptRemote :: Monad m => Text -> GGWidget master m () addScriptRemote :: Text -> GWidget sub master ()
addScriptRemote = flip addScriptRemoteAttrs [] addScriptRemote = flip addScriptRemoteAttrs []
-- | Link to the specified remote script. -- | Link to the specified remote script.
addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m () addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
-- | Include raw Javascript in the page's script tag. -- | Include raw Javascript in the page's script tag.
addJulius :: Monad m => JavascriptUrl (Route master) -> GGWidget master m () addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()
addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty addJulius x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
-- | Add a new script tag to the body with the contents of this 'Julius' -- | Add a new script tag to the body with the contents of this 'Julius'
-- template. -- template.
addJuliusBody :: Monad m => JavascriptUrl (Route master) -> GGWidget master m () addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master ()
addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
-- | Add Coffesscript to the page's script tag. Requires the coffeescript -- | Add Coffesscript to the page's script tag. Requires the coffeescript
-- executable to be present at runtime. -- executable to be present at runtime.
addCoffee :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GHandlerT sub master m) () addCoffee :: CoffeeUrl (Route master) -> GWidget sub master ()
addCoffee c = do addCoffee c = do
render <- lift getUrlRenderParams render <- liftWidget getUrlRenderParams
t <- liftIO $ renderCoffee render c t <- liftIO $ renderCoffee render c
addJulius $ const $ Javascript $ fromLazyText t addJulius $ const $ Javascript $ fromLazyText t
-- | Add a new script tag to the body with the contents of this Coffesscript -- | Add a new script tag to the body with the contents of this Coffesscript
-- template. Requires the coffeescript executable to be present at runtime. -- template. Requires the coffeescript executable to be present at runtime.
addCoffeeBody :: MonadIO m => CoffeeUrl (Route master) -> GGWidget master (GHandlerT sub master m) () addCoffeeBody :: CoffeeUrl (Route master) -> GWidget sub master ()
addCoffeeBody c = do addCoffeeBody c = do
render <- lift getUrlRenderParams render <- liftWidget getUrlRenderParams
t <- liftIO $ renderCoffee render c t <- liftIO $ renderCoffee render c
addJuliusBody $ const $ Javascript $ fromLazyText t addJuliusBody $ const $ Javascript $ fromLazyText t
-- | Pull out the HTML tag contents and return it. Useful for performing some
-- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (HtmlUrl (Route m))
extractBody (GWidget w) =
GWidget $ mapWriterT (liftM go) w
where
go ((), GWData (Body h) b c d e f g) = (h, GWData (Body mempty) b c d e f g)
-- | Content for a web page. By providing this datatype, we can easily create -- | Content for a web page. By providing this datatype, we can easily create
-- generic site templates, which would have the type signature: -- generic site templates, which would have the type signature:
-- --
@ -330,16 +296,55 @@ rules = do
return $ InfixE (Just g) bind (Just e') return $ InfixE (Just g) bind (Just e')
let ur f = do let ur f = do
let env = NP.Env let env = NP.Env
(Just $ helper [|lift getUrlRenderParams|]) (Just $ helper [|liftWidget getUrlRenderParams|])
(Just $ helper [|liftM (toHtml .) $ lift getMessageRender|]) (Just $ helper [|liftM (toHtml .) $ liftWidget getMessageRender|])
f env f env
return $ NP.HamletRules ah ur $ \_ b -> return b return $ NP.HamletRules ah ur $ \_ b -> return b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: (Monad mo, RenderMessage master message) ihamletToRepHtml :: RenderMessage master message
=> HtmlUrlI18n message (Route master) => HtmlUrlI18n message (Route master)
-> GHandlerT sub master mo RepHtml -> GHandler sub master RepHtml
ihamletToRepHtml ih = do ihamletToRepHtml ih = do
urender <- getUrlRenderParams urender <- getUrlRenderParams
mrender <- getMessageRender mrender <- getMessageRender
return $ RepHtml $ toContent $ ih (toHtml . mrender) urender return $ RepHtml $ toContent $ ih (toHtml . mrender) urender
tell :: GWData (Route master) -> GWidget sub master ()
tell w = GWidget $ return ((), w)
mapWriterT :: (GHandler sub master (a, GWData (Route master))
-> GHandler sub' master' (b, GWData (Route master')))
-> GWidget sub master a
-> GWidget sub' master' b
mapWriterT = undefined
liftWidget :: GHandler sub master a -> GWidget sub master a
liftWidget = GWidget . fmap (\x -> (x, mempty))
-- Instances for GWidget
instance Functor (GWidget sub master) where
fmap f = mapWriterT $ fmap $ \ (a, w) -> (f a, w)
instance Applicative (GWidget sub master) 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 sub master) where
return = pure
GWidget x >>= f = GWidget $ do
(a, wa) <- x
(b, wb) <- unGWidget (f a)
return (b, wa `mappend` wb)
instance MonadIO (GWidget sub master) where
liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO
instance MonadBase IO (GWidget sub master) where
liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase
instance MonadBaseControl IO (GWidget sub master) where
data StM (GWidget sub master) a =
StW (StM (GHandler sub master) (a, GWData (Route master)))
liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . unGWidget)
restoreM (StW base) = GWidget $ restoreM base