Completely removed GHandlerT and GGWidget
This commit is contained in:
Michael Snoyman
parent
8e623d04a6
commit
a797cd3fe3
@ -16,7 +16,7 @@
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : unstable
|
||||
-- Stability : stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Define Handler stuff.
|
||||
@ -28,7 +28,6 @@ module Yesod.Handler
|
||||
, YesodSubRoute (..)
|
||||
-- * Handler monad
|
||||
, GHandler
|
||||
, GHandlerT
|
||||
-- ** Read information from handler
|
||||
, getYesod
|
||||
, getYesodSub
|
||||
@ -95,7 +94,7 @@ module Yesod.Handler
|
||||
, hamletToRepHtml
|
||||
-- ** Misc
|
||||
, newIdent
|
||||
, liftIOHandler
|
||||
, liftHandler
|
||||
-- * i18n
|
||||
, getMessageRender
|
||||
-- * Per-request caching
|
||||
@ -132,7 +131,6 @@ import Control.Monad (liftM)
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Reader
|
||||
|
||||
import System.IO
|
||||
import qualified Network.Wai as W
|
||||
@ -173,6 +171,8 @@ import Control.Monad.Trans.Resource (ResourceT)
|
||||
import Control.Exception.Lifted (catch)
|
||||
import Network.Wai (requestBody)
|
||||
import Data.Conduit (($$))
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Base
|
||||
|
||||
-- | The type-safe URLs associated with a site argument.
|
||||
type family Route a
|
||||
@ -208,22 +208,22 @@ handlerSubDataMaybe tm ts route hd = hd
|
||||
, handlerRoute = route
|
||||
}
|
||||
|
||||
get :: MonadIO monad => GHandlerT sub master monad GHState
|
||||
get :: GHandler sub master GHState
|
||||
get = do
|
||||
hd <- ask
|
||||
liftIO $ I.readIORef $ handlerState hd
|
||||
|
||||
put :: MonadIO monad => GHState -> GHandlerT sub master monad ()
|
||||
put :: GHState -> GHandler sub master ()
|
||||
put g = do
|
||||
hd <- ask
|
||||
liftIO $ I.writeIORef (handlerState hd) g
|
||||
|
||||
modify :: MonadIO monad => (GHState -> GHState) -> GHandlerT sub master monad ()
|
||||
modify :: (GHState -> GHState) -> GHandler sub master ()
|
||||
modify f = do
|
||||
hd <- ask
|
||||
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 }
|
||||
|
||||
-- | 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)
|
||||
-> (master -> sub)
|
||||
-> Route sub
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandlerT sub' master mo a
|
||||
toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandler tm ts route = local (handlerSubData tm ts route)
|
||||
|
||||
toMasterHandlerDyn :: Monad mo
|
||||
=> (Route sub -> Route master)
|
||||
-> GHandlerT sub' master mo sub
|
||||
-- | FIXME do we need this?
|
||||
toMasterHandlerDyn :: (Route sub -> Route master)
|
||||
-> GHandler sub' master sub
|
||||
-> Route sub
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandlerT sub' master mo a
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerDyn tm getSub route h = do
|
||||
sub <- getSub
|
||||
withReaderT (handlerSubData tm (const sub) route) h
|
||||
local (handlerSubData tm (const sub) route) h
|
||||
|
||||
class SubsiteGetter g m s | g -> s where
|
||||
runSubsiteGetter :: g -> m s
|
||||
@ -260,18 +260,19 @@ instance (anySub ~ anySub'
|
||||
toMasterHandlerMaybe :: (Route sub -> Route master)
|
||||
-> (master -> sub)
|
||||
-> Maybe (Route sub)
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandlerT sub' master mo a
|
||||
toMasterHandlerMaybe tm ts route = withReaderT (handlerSubDataMaybe tm ts route)
|
||||
-> GHandler sub master a
|
||||
-> GHandler sub' master a
|
||||
toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
|
||||
|
||||
-- | A generic handler monad, which can have a different subsite and master
|
||||
-- site. This monad is a combination of 'ReaderT' for basic arguments, a
|
||||
-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
|
||||
-- special responses. It is declared as a newtype to make compiler errors more
|
||||
-- readable.
|
||||
type GHandlerT sub master = ReaderT (HandlerData sub master)
|
||||
|
||||
type GHandler sub master = GHandlerT sub master (ResourceT IO)
|
||||
-- site. We define a newtype for better error message.
|
||||
--
|
||||
-- Note that, in order to lift actions from the inner monad, you must use
|
||||
-- 'liftHandler' instead of just @lift@, since @GHandler@ is not in fact a
|
||||
-- monad transformer.
|
||||
newtype GHandler sub master a = GHandler
|
||||
{ unGHandler :: HandlerData sub master -> ResourceT IO a
|
||||
}
|
||||
|
||||
data GHState = GHState
|
||||
{ ghsSession :: SessionMap
|
||||
@ -312,10 +313,10 @@ instance Show HandlerContents where
|
||||
show _ = "Cannot show a HandlerContents"
|
||||
instance Exception HandlerContents
|
||||
|
||||
getRequest :: Monad mo => GHandlerT s m mo Request
|
||||
getRequest :: GHandler s m Request
|
||||
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
|
||||
|
||||
runRequestBody :: GHandler s m RequestBodyContents
|
||||
@ -325,7 +326,7 @@ runRequestBody = do
|
||||
Just rbc -> return rbc
|
||||
Nothing -> do
|
||||
rr <- waiRequest
|
||||
rbc <- lift $ rbHelper rr
|
||||
rbc <- liftHandler $ rbHelper rr
|
||||
put x { ghsRBC = Just rbc }
|
||||
return rbc
|
||||
|
||||
@ -340,33 +341,32 @@ rbHelper req =
|
||||
go = decodeUtf8With lenientDecode
|
||||
|
||||
-- | Get the sub application argument.
|
||||
getYesodSub :: Monad m => GHandlerT sub master m sub
|
||||
getYesodSub :: GHandler sub master sub
|
||||
getYesodSub = handlerSub `liftM` ask
|
||||
|
||||
-- | Get the master site appliation argument.
|
||||
getYesod :: Monad m => GHandlerT sub master m master
|
||||
getYesod :: GHandler sub master master
|
||||
getYesod = handlerMaster `liftM` ask
|
||||
|
||||
-- | Get the URL rendering function.
|
||||
getUrlRender :: Monad m => GHandlerT sub master m (Route master -> Text)
|
||||
getUrlRender :: GHandler sub master (Route master -> Text)
|
||||
getUrlRender = do
|
||||
x <- handlerRender `liftM` ask
|
||||
return $ flip x []
|
||||
|
||||
-- | The URL rendering function with query-string parameters.
|
||||
getUrlRenderParams
|
||||
:: Monad m
|
||||
=> GHandlerT sub master m (Route master -> [(Text, Text)] -> Text)
|
||||
:: GHandler sub master (Route master -> [(Text, Text)] -> Text)
|
||||
getUrlRenderParams = handlerRender `liftM` ask
|
||||
|
||||
-- | 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'.
|
||||
getCurrentRoute :: Monad m => GHandlerT sub master m (Maybe (Route sub))
|
||||
getCurrentRoute :: GHandler sub master (Maybe (Route sub))
|
||||
getCurrentRoute = handlerRoute `liftM` ask
|
||||
|
||||
-- | Get the function to promote a route for a subsite to a route for the
|
||||
-- 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
|
||||
|
||||
-- | Function used internally by Yesod in the process of converting a
|
||||
@ -401,7 +401,7 @@ runHandler handler mrender sroute tomr master sub =
|
||||
, handlerToMaster = tomr
|
||||
, handlerState = istate
|
||||
}
|
||||
contents' <- catch (fmap Right $ runReaderT handler hd)
|
||||
contents' <- catch (fmap Right $ unGHandler handler hd)
|
||||
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
|
||||
$ fromException e)
|
||||
state <- liftIO $ I.readIORef istate
|
||||
@ -451,19 +451,18 @@ safeEh er = YesodApp $ \_ _ _ session -> do
|
||||
session
|
||||
|
||||
-- | 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 []
|
||||
|
||||
-- | Redirects to the given route with the associated query-string parameters.
|
||||
redirectParams :: MonadIO mo
|
||||
=> RedirectType -> Route master -> [(Text, Text)]
|
||||
-> GHandlerT sub master mo a
|
||||
redirectParams :: RedirectType -> Route master -> [(Text, Text)]
|
||||
-> GHandler sub master a
|
||||
redirectParams rt url params = do
|
||||
r <- getUrlRenderParams
|
||||
redirectString rt $ r url params
|
||||
|
||||
-- | 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
|
||||
redirectString = redirectText
|
||||
{-# DEPRECATED redirectString "Use redirectText instead" #-}
|
||||
@ -475,16 +474,16 @@ ultDestKey = "_ULT"
|
||||
--
|
||||
-- An ultimate destination is stored in the user session and can be loaded
|
||||
-- later by 'redirectUltDest'.
|
||||
setUltDest :: MonadIO mo => Route master -> GHandlerT sub master mo ()
|
||||
setUltDest :: Route master -> GHandler sub master ()
|
||||
setUltDest dest = do
|
||||
render <- getUrlRender
|
||||
setUltDestString $ render dest
|
||||
|
||||
-- | Same as 'setUltDest', but use the given string.
|
||||
setUltDestText :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
setUltDestText :: Text -> GHandler sub master ()
|
||||
setUltDestText = setSession ultDestKey
|
||||
|
||||
setUltDestString :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
setUltDestString :: Text -> GHandler sub master ()
|
||||
setUltDestString = setSession ultDestKey
|
||||
{-# 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
|
||||
-- nothing.
|
||||
setUltDest' :: MonadIO mo => GHandlerT sub master mo ()
|
||||
setUltDest' :: GHandler sub master ()
|
||||
setUltDest' = do
|
||||
route <- getCurrentRoute
|
||||
case route of
|
||||
@ -506,7 +505,7 @@ setUltDest' = do
|
||||
-- | Sets the ultimate destination to the referer request header, if present.
|
||||
--
|
||||
-- This function will not overwrite an existing ultdest.
|
||||
setUltDestReferer :: MonadIO mo => GHandlerT sub master mo ()
|
||||
setUltDestReferer :: GHandler sub master ()
|
||||
setUltDestReferer = do
|
||||
mdest <- lookupSession ultDestKey
|
||||
maybe
|
||||
@ -520,17 +519,16 @@ setUltDestReferer = do
|
||||
-- value from the session.
|
||||
--
|
||||
-- The ultimate destination is set with 'setUltDest'.
|
||||
redirectUltDest :: MonadIO mo
|
||||
=> RedirectType
|
||||
redirectUltDest :: RedirectType
|
||||
-> Route master -- ^ default destination if nothing in session
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandler sub master a
|
||||
redirectUltDest rt def = do
|
||||
mdest <- lookupSession ultDestKey
|
||||
deleteSession ultDestKey
|
||||
maybe (redirect rt def) (redirectText rt) mdest
|
||||
|
||||
-- | Remove a previously set ultimate destination. See 'setUltDest'.
|
||||
clearUltDest :: MonadIO mo => GHandlerT sub master mo ()
|
||||
clearUltDest :: GHandler sub master ()
|
||||
clearUltDest = deleteSession ultDestKey
|
||||
|
||||
msgKey :: Text
|
||||
@ -539,13 +537,13 @@ msgKey = "_MSG"
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- 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
|
||||
|
||||
-- | Sets a message in the user's session.
|
||||
--
|
||||
-- See 'getMessage'.
|
||||
setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GHandlerT sub y mo ()
|
||||
setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y ()
|
||||
setMessageI msg = do
|
||||
mr <- getMessageRender
|
||||
setMessage $ toHtml $ mr msg
|
||||
@ -554,7 +552,7 @@ setMessageI msg = do
|
||||
-- variable.
|
||||
--
|
||||
-- See 'setMessage'.
|
||||
getMessage :: MonadIO mo => GHandlerT sub master mo (Maybe Html)
|
||||
getMessage :: GHandler sub master (Maybe Html)
|
||||
getMessage = do
|
||||
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
|
||||
deleteSession msgKey
|
||||
@ -564,34 +562,33 @@ getMessage = do
|
||||
--
|
||||
-- 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.
|
||||
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
|
||||
|
||||
-- | Same as 'sendFile', but only sends part of a file.
|
||||
sendFilePart :: MonadIO mo
|
||||
=> ContentType
|
||||
sendFilePart :: ContentType
|
||||
-> FilePath
|
||||
-> Integer -- ^ offset
|
||||
-> Integer -- ^ count
|
||||
-> GHandlerT sub master mo a
|
||||
-> GHandler sub master a
|
||||
sendFilePart ct fp off count =
|
||||
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
|
||||
|
||||
-- | Bypass remaining handler code and output the given content with a 200
|
||||
-- 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
|
||||
. chooseRep
|
||||
|
||||
-- | Bypass remaining handler code and output the given content with the given
|
||||
-- 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
|
||||
. chooseRep
|
||||
|
||||
-- | Send a 201 "Created" response with the given route as the Location
|
||||
-- response header.
|
||||
sendResponseCreated :: MonadIO mo => Route m -> GHandlerT s m mo a
|
||||
sendResponseCreated :: Route m -> GHandler s m a
|
||||
sendResponseCreated url = do
|
||||
r <- getUrlRender
|
||||
liftIO . throwIO $ HCCreated $ r url
|
||||
@ -601,7 +598,7 @@ sendResponseCreated url = do
|
||||
-- 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,
|
||||
-- you don't.
|
||||
sendWaiResponse :: MonadIO mo => W.Response -> GHandlerT s m mo b
|
||||
sendWaiResponse :: W.Response -> GHandler s m b
|
||||
sendWaiResponse = liftIO . throwIO . HCWai
|
||||
|
||||
-- | Return a 404 not found page. Also denotes no handler available.
|
||||
@ -609,7 +606,7 @@ notFound :: Failure ErrorResponse m => m a
|
||||
notFound = failure NotFound
|
||||
|
||||
-- | Return a 405 method not supported page.
|
||||
badMethod :: MonadIO mo => GHandlerT s m mo a
|
||||
badMethod :: GHandler s m a
|
||||
badMethod = do
|
||||
w <- waiRequest
|
||||
failure $ BadMethod $ W.requestMethod w
|
||||
@ -619,7 +616,7 @@ permissionDenied :: Failure ErrorResponse m => Text -> m a
|
||||
permissionDenied = failure . PermissionDenied
|
||||
|
||||
-- | 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
|
||||
mr <- getMessageRender
|
||||
permissionDenied $ mr msg
|
||||
@ -629,7 +626,7 @@ invalidArgs :: Failure ErrorResponse m => [Text] -> m a
|
||||
invalidArgs = failure . InvalidArgs
|
||||
|
||||
-- | 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
|
||||
mr <- getMessageRender
|
||||
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
|
||||
-- use ASCII values to be HTTP compliant.
|
||||
setCookie :: MonadIO mo
|
||||
=> Int -- ^ minutes to timeout
|
||||
setCookie :: Int -- ^ minutes to timeout
|
||||
-> Text -- ^ key
|
||||
-> Text -- ^ value
|
||||
-> GHandlerT sub master mo ()
|
||||
-> GHandler sub master ()
|
||||
setCookie a b = addHeader . AddCookie a (encodeUtf8 b) . encodeUtf8
|
||||
|
||||
-- | Unset the cookie on the client.
|
||||
deleteCookie :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
deleteCookie :: Text -> GHandler sub master ()
|
||||
deleteCookie = addHeader . DeleteCookie . encodeUtf8
|
||||
|
||||
-- | Set the language in the user session. Will show up in 'languages' on the
|
||||
-- next request.
|
||||
setLanguage :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
setLanguage :: Text -> GHandler sub master ()
|
||||
setLanguage = setSession langKey
|
||||
|
||||
-- | Set an arbitrary response header.
|
||||
--
|
||||
-- Note that, while the data type used here is 'Text', you must provide only
|
||||
-- ASCII value to be HTTP compliant.
|
||||
setHeader :: MonadIO mo
|
||||
=> Text -> Text -> GHandlerT sub master mo ()
|
||||
setHeader :: Text -> Text -> GHandler sub master ()
|
||||
setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
|
||||
|
||||
-- | Set the Cache-Control header to indicate this response should be cached
|
||||
-- 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
|
||||
[ "max-age="
|
||||
, 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
|
||||
-- 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"
|
||||
|
||||
-- | Set an Expires header in the past, meaning this content should not be
|
||||
-- cached.
|
||||
alreadyExpired :: MonadIO mo => GHandlerT s m mo ()
|
||||
alreadyExpired :: GHandler s m ()
|
||||
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | 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
|
||||
-- and hashed cookie on the client. This ensures that all data is secure and
|
||||
-- not tampered with.
|
||||
setSession :: MonadIO mo
|
||||
=> Text -- ^ key
|
||||
setSession :: Text -- ^ key
|
||||
-> Text -- ^ value
|
||||
-> GHandlerT sub master mo ()
|
||||
-> GHandler sub master ()
|
||||
setSession k = modify . modSession . Map.insert k
|
||||
|
||||
-- | Unsets a session variable. See 'setSession'.
|
||||
deleteSession :: MonadIO mo => Text -> GHandlerT sub master mo ()
|
||||
deleteSession :: Text -> GHandler sub master ()
|
||||
deleteSession = modify . modSession . Map.delete
|
||||
|
||||
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
|
||||
modSession f x = x { ghsSession = f $ ghsSession x }
|
||||
|
||||
-- | 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 . (:)
|
||||
|
||||
getStatus :: ErrorResponse -> H.Status
|
||||
@ -728,18 +722,18 @@ data RedirectType = RedirectPermanent
|
||||
| RedirectSeeOther
|
||||
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 =
|
||||
local (\hd -> hd { handlerRoute = Nothing })
|
||||
|
||||
-- | Lookup for session data.
|
||||
lookupSession :: MonadIO mo => Text -> GHandlerT s m mo (Maybe Text)
|
||||
lookupSession :: Text -> GHandler s m (Maybe Text)
|
||||
lookupSession n = do
|
||||
m <- liftM ghsSession get
|
||||
return $ Map.lookup n m
|
||||
|
||||
-- | Get all session variables.
|
||||
getSession :: MonadIO mo => GHandlerT s m mo SessionMap
|
||||
getSession :: GHandler s m SessionMap
|
||||
getSession = liftM ghsSession get
|
||||
|
||||
handlerToYAR :: (HasReps a, HasReps b)
|
||||
@ -834,17 +828,12 @@ headerToPair cp _ (DeleteCookie key) =
|
||||
headerToPair _ _ (Header key value) = (CI.mk key, value)
|
||||
|
||||
-- | Get a unique identifier.
|
||||
newIdent :: MonadIO mo => GHandlerT sub master mo String -- FIXME use Text
|
||||
newIdent :: GHandler sub master Text
|
||||
newIdent = do
|
||||
x <- get
|
||||
let i' = ghsIdent x + 1
|
||||
put x { ghsIdent = i' }
|
||||
return $ 'h' : show i'
|
||||
|
||||
liftIOHandler :: MonadIO mo
|
||||
=> GHandlerT sub master IO a
|
||||
-> GHandlerT sub master mo a
|
||||
liftIOHandler (ReaderT m) = ReaderT $ \r -> liftIO $ m r
|
||||
return $ T.pack $ 'h' : show i'
|
||||
|
||||
-- | 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
|
||||
-- useful when you need to post a plain link somewhere that needs to cause
|
||||
-- changes on the server.
|
||||
redirectToPost :: MonadIO mo => Route master -> GHandlerT sub master mo a
|
||||
redirectToPost :: Route master -> GHandler sub master a
|
||||
redirectToPost dest = hamletToRepHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
@ -873,36 +862,65 @@ redirectToPost dest = hamletToRepHtml
|
||||
|
||||
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
||||
-- Yesod 'Response'.
|
||||
hamletToContent :: Monad mo
|
||||
=> HtmlUrl (Route master) -> GHandlerT sub master mo Content
|
||||
hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content
|
||||
hamletToContent h = do
|
||||
render <- getUrlRenderParams
|
||||
return $ toContent $ h render
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
hamletToRepHtml :: Monad mo
|
||||
=> HtmlUrl (Route master) -> GHandlerT sub master mo RepHtml
|
||||
hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml
|
||||
hamletToRepHtml = liftM RepHtml . hamletToContent
|
||||
|
||||
-- | 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
|
||||
|
||||
getMessageRender :: (Monad mo, RenderMessage master message) => GHandlerT s master mo (message -> Text)
|
||||
getMessageRender :: RenderMessage master message => GHandler s master (message -> Text)
|
||||
getMessageRender = do
|
||||
m <- getYesod
|
||||
l <- reqLangs `liftM` getRequest
|
||||
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
|
||||
gs <- get
|
||||
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 ->
|
||||
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 ->
|
||||
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
|
||||
|
||||
@ -280,8 +280,8 @@ class RenderRoute (Route a) => Yesod a where
|
||||
yepnopeJs :: a -> Maybe (Either Text (Route a))
|
||||
yepnopeJs _ = Nothing
|
||||
|
||||
messageLoggerHandler :: (Yesod m, MonadIO mo)
|
||||
=> Loc -> LogLevel -> Text -> GHandlerT s m mo ()
|
||||
messageLoggerHandler :: Yesod m
|
||||
=> Loc -> LogLevel -> Text -> GHandler s m ()
|
||||
messageLoggerHandler loc level msg = do
|
||||
y <- getYesod
|
||||
liftIO $ messageLogger y loc level msg
|
||||
@ -499,9 +499,9 @@ jelper = fmap jsToHtml
|
||||
widgetToPageContent :: (Eq (Route master), Yesod master)
|
||||
=> GWidget sub master ()
|
||||
-> GHandler sub master (PageContent (Route master))
|
||||
widgetToPageContent (GWidget w) = do
|
||||
widgetToPageContent w = do
|
||||
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 scripts = runUniqueList scripts'
|
||||
let stylesheets = runUniqueList stylesheets'
|
||||
|
||||
@ -52,20 +52,20 @@ import Data.Text (Text)
|
||||
-- * Accept-Language HTTP header.
|
||||
--
|
||||
-- This is handled by parseWaiRequest (not exposed).
|
||||
languages :: Monad mo => GHandlerT s m mo [Text]
|
||||
languages :: GHandler s m [Text]
|
||||
languages = reqLangs `liftM` getRequest
|
||||
|
||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
||||
lookup' a = map snd . filter (\x -> a == fst x)
|
||||
|
||||
-- | Lookup for GET parameters.
|
||||
lookupGetParams :: Monad mo => Text -> GHandlerT s m mo [Text]
|
||||
lookupGetParams :: Text -> GHandler s m [Text]
|
||||
lookupGetParams pn = do
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqGetParams rr
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | Lookup for POST parameters.
|
||||
@ -91,11 +91,11 @@ lookupFiles pn = do
|
||||
return $ lookup' pn files
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | Lookup for cookie data.
|
||||
lookupCookies :: Monad mo => Text -> GHandlerT s m mo [Text]
|
||||
lookupCookies :: Text -> GHandler s m [Text]
|
||||
lookupCookies pn = do
|
||||
rr <- getRequest
|
||||
return $ lookup' pn $ reqCookies rr
|
||||
|
||||
@ -6,12 +6,13 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- FIXME Should we remove the older names here (addJulius, etc)?
|
||||
|
||||
-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
|
||||
-- generator, allowing you to create truly modular HTML components.
|
||||
module Yesod.Widget
|
||||
( -- * Datatype
|
||||
GWidget
|
||||
, GGWidget (..)
|
||||
, PageContent (..)
|
||||
-- * Special Hamlet quasiquoter/TH for Widgets
|
||||
, whamlet
|
||||
@ -53,25 +54,25 @@ module Yesod.Widget
|
||||
, addScriptRemoteAttrs
|
||||
, addScriptEither
|
||||
-- * Utilities
|
||||
, extractBody
|
||||
, liftWidget
|
||||
-- * Internal
|
||||
, unGWidget
|
||||
) where
|
||||
|
||||
import Data.Monoid
|
||||
import Control.Monad.Trans.Writer
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Julius
|
||||
import Text.Coffee
|
||||
import Yesod.Handler
|
||||
(Route, GHandler, GHandlerT, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
, getMessageRender, getUrlRenderParams
|
||||
)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Yesod.Content (RepHtml (..), toContent)
|
||||
import Control.Applicative (Applicative)
|
||||
import Control.Applicative (Applicative (..), (<$>))
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Trans.Class (MonadTrans (lift))
|
||||
import Yesod.Internal
|
||||
import Control.Monad (liftM)
|
||||
import Data.Text (Text)
|
||||
@ -79,59 +80,32 @@ import qualified Data.Map as Map
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
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 (MonadTransControl (..), MonadBaseControl (..), defaultLiftBaseWith, defaultRestoreM, ComposeSt)
|
||||
#else
|
||||
import Control.Monad.IO.Control (MonadControlIO)
|
||||
#endif
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import qualified Text.Hamlet as NP
|
||||
import Data.Text.Lazy.Builder (fromLazyText)
|
||||
import Text.Blaze (toHtml, preEscapedLazyText)
|
||||
import Control.Monad.Base (MonadBase (liftBase))
|
||||
|
||||
-- | A generic widget, allowing specification of both the subsite and master
|
||||
-- site datatypes. This is basically a large 'WriterT' stack keeping track of
|
||||
-- dependencies along with a 'StateT' to track unique identifiers.
|
||||
newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a }
|
||||
deriving (Functor, Applicative, Monad, MonadIO
|
||||
#if !MIN_VERSION_monad_control(0, 3, 0)
|
||||
, MonadControlIO
|
||||
#endif
|
||||
)
|
||||
-- site datatypes. While this is simply a @WriterT@, we define a newtype for
|
||||
-- better error messages.
|
||||
--
|
||||
-- Note that you must use 'liftWidget' instead of @lift@ since this is not a
|
||||
-- monad transformer.
|
||||
newtype GWidget sub master a = GWidget
|
||||
{ unGWidget :: GHandler sub master (a, GWData (Route master))
|
||||
}
|
||||
|
||||
instance MonadBase b m => MonadBase b (GGWidget master m) 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
|
||||
instance (a ~ ()) => Monoid (GWidget sub master a) where
|
||||
mempty = return ()
|
||||
mappend x y = x >> y
|
||||
|
||||
addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
|
||||
addSubWidget sub (GWidget w) = do
|
||||
master <- lift getYesod
|
||||
master <- liftWidget getYesod
|
||||
let sr = fromSubRoute sub master
|
||||
(a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runWriterT w
|
||||
GWidget $ tell w'
|
||||
(a, w') <- liftWidget $ toMasterHandlerMaybe sr (const sub) Nothing w
|
||||
tell w'
|
||||
return a
|
||||
|
||||
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 values.
|
||||
setTitle :: Monad m => Html -> GGWidget master m ()
|
||||
setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
|
||||
setTitle :: Html -> GWidget sub master ()
|
||||
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 master msg, Monad m) => msg -> GGWidget master (GHandlerT sub master m) ()
|
||||
setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()
|
||||
setTitleI msg = do
|
||||
mr <- lift getMessageRender
|
||||
mr <- liftWidget getMessageRender
|
||||
setTitle $ toHtml $ mr msg
|
||||
|
||||
-- | Add a 'Hamlet' to the head tag.
|
||||
addHamletHead :: Monad m => HtmlUrl (Route master) -> GGWidget master m ()
|
||||
addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()
|
||||
addHamletHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
|
||||
|
||||
-- | Add a 'Html' to the head tag.
|
||||
addHtmlHead :: Monad m => Html -> GGWidget master m ()
|
||||
addHtmlHead :: Html -> GWidget sub master ()
|
||||
addHtmlHead = addHamletHead . const
|
||||
|
||||
-- | Add a 'Hamlet' to the body tag.
|
||||
addHamlet :: Monad m => HtmlUrl (Route master) -> GGWidget master m ()
|
||||
addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()
|
||||
addHamlet x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Add a 'Html' to the body tag.
|
||||
addHtml :: Monad m => Html -> GGWidget master m ()
|
||||
addHtml :: Html -> GWidget sub master ()
|
||||
addHtml = addHamlet . const
|
||||
|
||||
-- | Add another widget. This is defined as 'id', by can help with types, and
|
||||
-- makes widget blocks look more consistent.
|
||||
addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo ()
|
||||
addWidget :: GWidget sub master () -> GWidget sub master ()
|
||||
addWidget = id
|
||||
|
||||
-- | Add some raw CSS to the style tag. Applies to all media types.
|
||||
addCassius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
|
||||
addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
|
||||
addCassius :: CssUrl (Route master) -> GWidget sub master ()
|
||||
addCassius x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
|
||||
|
||||
-- | Identical to 'addCassius'.
|
||||
addLucius :: Monad m => CssUrl (Route master) -> GGWidget master m ()
|
||||
addLucius :: CssUrl (Route master) -> GWidget sub master ()
|
||||
addLucius = addCassius
|
||||
|
||||
-- | Add some raw CSS to the style tag, for a specific media type.
|
||||
addCassiusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()
|
||||
addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
|
||||
addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
|
||||
addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
|
||||
|
||||
-- | Identical to 'addCassiusMedia'.
|
||||
addLuciusMedia :: Monad m => Text -> CssUrl (Route master) -> GGWidget master m ()
|
||||
addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
|
||||
addLuciusMedia = addCassiusMedia
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheet :: Monad m => Route master -> GGWidget master m ()
|
||||
addStylesheet :: Route master -> GWidget sub master ()
|
||||
addStylesheet = flip addStylesheetAttrs []
|
||||
|
||||
-- | Link to the specified local stylesheet.
|
||||
addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
|
||||
addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
|
||||
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemote :: Monad m => Text -> GGWidget master m ()
|
||||
addStylesheetRemote :: Text -> GWidget sub master ()
|
||||
addStylesheetRemote = flip addStylesheetRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote stylesheet.
|
||||
addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
|
||||
addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
|
||||
addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
|
||||
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
|
||||
|
||||
addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m ()
|
||||
addScriptEither :: Either (Route master) Text -> GWidget sub master ()
|
||||
addScriptEither = either addScript addScriptRemote
|
||||
|
||||
-- | Link to the specified local script.
|
||||
addScript :: Monad m => Route master -> GGWidget master m ()
|
||||
addScript :: Route master -> GWidget sub master ()
|
||||
addScript = flip addScriptAttrs []
|
||||
|
||||
-- | Link to the specified local script.
|
||||
addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
|
||||
addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
|
||||
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemote :: Monad m => Text -> GGWidget master m ()
|
||||
addScriptRemote :: Text -> GWidget sub master ()
|
||||
addScriptRemote = flip addScriptRemoteAttrs []
|
||||
|
||||
-- | Link to the specified remote script.
|
||||
addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
|
||||
addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
|
||||
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
|
||||
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.
|
||||
addJulius :: Monad m => JavascriptUrl (Route master) -> GGWidget master m ()
|
||||
addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
|
||||
addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()
|
||||
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'
|
||||
-- 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
|
||||
|
||||
-- | Add Coffesscript to the page's script tag. Requires the coffeescript
|
||||
-- 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
|
||||
render <- lift getUrlRenderParams
|
||||
render <- liftWidget getUrlRenderParams
|
||||
t <- liftIO $ renderCoffee render c
|
||||
addJulius $ const $ Javascript $ fromLazyText t
|
||||
|
||||
-- | Add a new script tag to the body with the contents of this Coffesscript
|
||||
-- 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
|
||||
render <- lift getUrlRenderParams
|
||||
render <- liftWidget getUrlRenderParams
|
||||
t <- liftIO $ renderCoffee render c
|
||||
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
|
||||
-- generic site templates, which would have the type signature:
|
||||
--
|
||||
@ -330,16 +296,55 @@ rules = do
|
||||
return $ InfixE (Just g) bind (Just e')
|
||||
let ur f = do
|
||||
let env = NP.Env
|
||||
(Just $ helper [|lift getUrlRenderParams|])
|
||||
(Just $ helper [|liftM (toHtml .) $ lift getMessageRender|])
|
||||
(Just $ helper [|liftWidget getUrlRenderParams|])
|
||||
(Just $ helper [|liftM (toHtml .) $ liftWidget getMessageRender|])
|
||||
f env
|
||||
return $ NP.HamletRules ah ur $ \_ b -> return b
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
ihamletToRepHtml :: (Monad mo, RenderMessage master message)
|
||||
ihamletToRepHtml :: RenderMessage master message
|
||||
=> HtmlUrlI18n message (Route master)
|
||||
-> GHandlerT sub master mo RepHtml
|
||||
-> GHandler sub master RepHtml
|
||||
ihamletToRepHtml ih = do
|
||||
urender <- getUrlRenderParams
|
||||
mrender <- getMessageRender
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user