diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs new file mode 100644 index 00000000..3a657772 --- /dev/null +++ b/yesod-core/Yesod/Core/Class.hs @@ -0,0 +1,567 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Core.Class where + +import Control.Monad.Logger (logErrorS) +import Yesod.Content +import Yesod.Handler hiding (getExpires, lift) + +import Yesod.Routes.Class + +import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder.Char.Utf8 (fromText) +import Control.Arrow ((***)) +import Control.Monad (forM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), + LogSource) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.List (foldl') +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TEE +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Word (Word64) +import Language.Haskell.TH.Syntax (Loc (..)) +import Network.HTTP.Types (encodePath) +import qualified Network.Wai as W +import Network.Wai.Middleware.Gzip (GzipSettings, def) +import Network.Wai.Parse (lbsBackEnd, + tempFileBackEnd) +import System.IO (stdout) +import System.Log.FastLogger (LogStr (..), Logger, + loggerDate, loggerPutStr, + mkLogger) +import System.Log.FastLogger.Date (ZonedDate) +import Text.Blaze (customAttribute, textTag, + toValue, (!)) +import Text.Blaze (preEscapedToMarkup) +import qualified Text.Blaze.Html5 as TBH +import Text.Hamlet +import Text.Julius +import qualified Web.ClientSession as CS +import Web.Cookie (parseCookies) +import Web.Cookie (SetCookie (..)) +import Yesod.Core.Types +import Yesod.Internal +import Yesod.Internal.Session +import Yesod.Widget + +-- | Define settings for a Yesod applications. All methods have intelligent +-- defaults, and therefore no implementation is required. +class RenderRoute a => Yesod a where + -- | An absolute URL to the root of the application. Do not include + -- trailing slash. + -- + -- Default value: 'ApprootRelative'. This is valid under the following + -- conditions: + -- + -- * Your application is served from the root of the domain. + -- + -- * You do not use any features that require absolute URLs, such as Atom + -- feeds and XML sitemaps. + -- + -- If this is not true, you should override with a different + -- implementation. + approot :: Approot a + approot = ApprootRelative + + -- | Output error response pages. + errorHandler :: ErrorResponse -> GHandler sub a ChooseRep + errorHandler = defaultErrorHandler + + -- | Applies some form of layout to the contents of a page. + defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml + defaultLayout w = do + p <- widgetToPageContent w + mmsg <- getMessage + hamletToRepHtml [hamlet| +$newline never +$doctype 5 + + + + #{pageTitle p} + ^{pageHead p} + <body> + $maybe msg <- mmsg + <p .message>#{msg} + ^{pageBody p} +|] + + -- | Override the rendering function for a particular URL. One use case for + -- this is to offload static hosting to a different domain name to avoid + -- sending cookies. + urlRenderOverride :: a -> Route a -> Maybe Builder + urlRenderOverride _ _ = Nothing + + -- | Determine if a request is authorized or not. + -- + -- Return 'Authorized' if the request is authorized, + -- 'Unauthorized' a message if unauthorized. + -- If authentication is required, return 'AuthenticationRequired'. + isAuthorized :: Route a + -> Bool -- ^ is this a write request? + -> GHandler s a AuthResult + isAuthorized _ _ = return Authorized + + -- | Determines whether the current request is a write request. By default, + -- this assumes you are following RESTful principles, and determines this + -- from request method. In particular, all except the following request + -- methods are considered write: GET HEAD OPTIONS TRACE. + -- + -- This function is used to determine if a request is authorized; see + -- 'isAuthorized'. + isWriteRequest :: Route a -> GHandler s a Bool + isWriteRequest _ = do + wai <- waiRequest + return $ W.requestMethod wai `notElem` + ["GET", "HEAD", "OPTIONS", "TRACE"] + + -- | The default route for authentication. + -- + -- Used in particular by 'isAuthorized', but library users can do whatever + -- they want with it. + authRoute :: a -> Maybe (Route a) + authRoute _ = Nothing + + -- | A function used to clean up path segments. It returns 'Right' with a + -- clean path or 'Left' with a new set of pieces the user should be + -- redirected to. The default implementation enforces: + -- + -- * No double slashes + -- + -- * There is no trailing slash. + -- + -- Note that versions of Yesod prior to 0.7 used a different set of rules + -- involing trailing slashes. + cleanPath :: a -> [Text] -> Either [Text] [Text] + cleanPath _ s = + if corrected == s + then Right $ map dropDash s + else Left corrected + where + corrected = filter (not . T.null) s + dropDash t + | T.all (== '-') t = T.drop 1 t + | otherwise = t + + -- | Builds an absolute URL by concatenating the application root with the + -- pieces of a path and a query string, if any. + -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. + joinPath :: a + -> T.Text -- ^ application root + -> [T.Text] -- ^ path pieces + -> [(T.Text, T.Text)] -- ^ query string + -> Builder + joinPath _ ar pieces' qs' = + fromText ar `mappend` encodePath pieces qs + where + pieces = if null pieces' then [""] else map addDash pieces' + qs = map (TE.encodeUtf8 *** go) qs' + go "" = Nothing + go x = Just $ TE.encodeUtf8 x + addDash t + | T.all (== '-') t = T.cons '-' t + | otherwise = t + + -- | This function is used to store some static content to be served as an + -- external file. The most common case of this is stashing CSS and + -- JavaScript content in an external file; the "Yesod.Widget" module uses + -- this feature. + -- + -- The return value is 'Nothing' if no storing was performed; this is the + -- default implementation. A 'Just' 'Left' gives the absolute URL of the + -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is + -- necessary when you are serving the content outside the context of a + -- Yesod application, such as via memcached. + addStaticContent :: Text -- ^ filename extension + -> Text -- ^ mime-type + -> L.ByteString -- ^ content + -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) + addStaticContent _ _ _ = return Nothing + + {- Temporarily disabled until we have a better interface. + -- | Whether or not to tie a session to a specific IP address. Defaults to + -- 'False'. + -- + -- Note: This setting has two known problems: it does not work correctly + -- when behind a reverse proxy (including load balancers), and it may not + -- function correctly if the user is behind a proxy. + sessionIpAddress :: a -> Bool + sessionIpAddress _ = False + -} + + -- | The path value to set for cookies. By default, uses \"\/\", meaning + -- cookies will be sent to every page on the current domain. + cookiePath :: a -> S8.ByteString + cookiePath _ = "/" + + -- | The domain value to set for cookies. By default, the + -- domain is not set, meaning cookies will be sent only to + -- the current domain. + cookieDomain :: a -> Maybe S8.ByteString + cookieDomain _ = Nothing + + -- | Maximum allowed length of the request body, in bytes. + -- + -- Default: 2 megabytes. + maximumContentLength :: a -> Maybe (Route a) -> Word64 + maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes + + -- | Returns a @Logger@ to use for log messages. + -- + -- Default: Sends to stdout and automatically flushes on each write. + getLogger :: a -> IO Logger + getLogger _ = mkLogger True stdout + + -- | Send a message to the @Logger@ provided by @getLogger@. + -- + -- Note: This method is no longer used. Instead, you should override + -- 'messageLoggerSource'. + messageLogger :: a + -> Logger + -> Loc -- ^ position in source code + -> LogLevel + -> LogStr -- ^ message + -> IO () + messageLogger a logger loc = messageLoggerSource a logger loc "" + + -- | Send a message to the @Logger@ provided by @getLogger@. + messageLoggerSource :: a + -> Logger + -> Loc -- ^ position in source code + -> LogSource + -> LogLevel + -> LogStr -- ^ message + -> IO () + messageLoggerSource a logger loc source level msg = + if shouldLog a source level + then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger + else return () + + -- | The logging level in place for this application. Any messages below + -- this level will simply be ignored. + logLevel :: a -> LogLevel + logLevel _ = LevelInfo + + -- | GZIP settings. + gzipSettings :: a -> GzipSettings + gzipSettings _ = def + + -- | Where to Load sripts from. We recommend the default value, + -- 'BottomOfBody'. Alternatively use the built in async yepnope loader: + -- + -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js + -- + -- Or write your own async js loader: see 'loadJsYepnope' + jsLoader :: a -> ScriptLoadPosition a + jsLoader _ = BottomOfBody + + -- | Create a session backend. Returning `Nothing' disables sessions. + -- + -- Default: Uses clientsession with a 2 hour timeout. + makeSessionBackend :: a -> IO (Maybe (SessionBackend a)) + makeSessionBackend _ = fmap Just defaultClientSessionBackend + + -- | How to store uploaded files. + -- + -- Default: When the request body is greater than 50kb, store in a temp + -- file. For chunked request bodies, store in a temp file. Otherwise, store + -- in memory. + fileUpload :: a -> W.RequestBodyLength -> FileUpload + fileUpload _ (W.KnownLength size) + | size <= 50000 = FileUploadMemory lbsBackEnd + fileUpload _ _ = FileUploadDisk tempFileBackEnd + + -- | Should we log the given log source/level combination. + -- + -- Default: Logs everything at or above 'logLevel' + shouldLog :: a -> LogSource -> LogLevel -> Bool + shouldLog a _ level = level >= logLevel a + + -- | A Yesod middleware, which will wrap every handler function. This + -- allows you to run code before and after a normal handler. + -- + -- Default: Adds the response header \"Vary: Accept, Accept-Language\". + -- + -- Since: 1.1.6 + yesodMiddleware :: GHandler sub a res -> GHandler sub a res + yesodMiddleware handler = do + setHeader "Vary" "Accept, Accept-Language" + handler + +-- | Convert a widget to a 'PageContent'. +widgetToPageContent :: (Eq (Route master), Yesod master) + => GWidget sub master () + -> GHandler sub master (PageContent (Route master)) +widgetToPageContent w = do + master <- getYesod + ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w + let title = maybe mempty unTitle mTitle + scripts = runUniqueList scripts' + stylesheets = runUniqueList stylesheets' + + render <- getUrlRenderParams + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right (u, p)) -> Just $ render u p + css <- forM (Map.toList style) $ \(mmedia, content) -> do + let rendered = toLazyText $ content render + x <- addStaticContent "css" "text/css; charset=utf-8" + $ encodeUtf8 rendered + return (mmedia, + case x of + Nothing -> Left $ preEscapedToMarkup rendered + Just y -> Right $ either id (uncurry render) y) + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ encodeUtf8 $ renderJavascriptUrl render s + return $ renderLoc x + + -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing + -- the asynchronous loader means your page doesn't have to wait for all the js to load + let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc + regularScriptLoad = [hamlet| +$newline never +$forall s <- scripts + ^{mkScriptTag s} +$maybe j <- jscript + $maybe s <- jsLoc + <script src="#{s}"> + $nothing + <script>^{jelper j} +|] + + headAll = [hamlet| +$newline never +\^{head'} +$forall s <- stylesheets + ^{mkLinkTag s} +$forall s <- css + $maybe t <- right $ snd s + $maybe media <- fst s + <link rel=stylesheet media=#{media} href=#{t}> + $nothing + <link rel=stylesheet href=#{t}> + $maybe content <- left $ snd s + $maybe media <- fst s + <style media=#{media}>#{content} + $nothing + <style>#{content} +$case jsLoader master + $of BottomOfBody + $of BottomOfHeadAsync asyncJsLoader + ^{asyncJsLoader asyncScripts mcomplete} + $of BottomOfHeadBlocking + ^{regularScriptLoad} +|] + let bodyScript = [hamlet| +$newline never +^{body} +^{regularScriptLoad} +|] + + return $ PageContent title headAll (case jsLoader master of + BottomOfBody -> bodyScript + _ -> body) + where + renderLoc' render' (Local url) = render' url [] + renderLoc' _ (Remote s) = s + + addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) + mkScriptTag (Script loc attrs) render' = + foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () + mkLinkTag (Stylesheet loc attrs) render' = + foldl' addAttr TBH.link + ( ("rel", "stylesheet") + : ("href", renderLoc' render' loc) + : attrs + ) + +-- | Helper function for 'defaultErrorHandler'. +applyLayout' :: Yesod master + => Html -- ^ title + -> HtmlUrl (Route master) -- ^ body + -> GHandler sub master ChooseRep +applyLayout' title body = fmap chooseRep $ defaultLayout $ do + setTitle title + toWidget body + +-- | The default error handler for 'errorHandler'. +defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep +defaultErrorHandler NotFound = do + r <- waiRequest + let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r + applyLayout' "Not Found" + [hamlet| +$newline never +<h1>Not Found +<p>#{path'} +|] +defaultErrorHandler (PermissionDenied msg) = + applyLayout' "Permission Denied" + [hamlet| +$newline never +<h1>Permission denied +<p>#{msg} +|] +defaultErrorHandler (InvalidArgs ia) = + applyLayout' "Invalid Arguments" + [hamlet| +$newline never +<h1>Invalid Arguments +<ul> + $forall msg <- ia + <li>#{msg} +|] +defaultErrorHandler (InternalError e) = do + $logErrorS "yesod-core" e + applyLayout' "Internal Server Error" + [hamlet| +$newline never +<h1>Internal Server Error +<pre>#{e} +|] +defaultErrorHandler (BadMethod m) = + applyLayout' "Bad Method" + [hamlet| +$newline never +<h1>Method Not Supported +<p>Method <code>#{S8.unpack m}</code> not supported +|] + +asyncHelper :: (url -> [x] -> Text) + -> [Script (url)] + -> Maybe (JavascriptUrl (url)) + -> Maybe Text + -> (Maybe (HtmlUrl url), [Text]) +asyncHelper render scripts jscript jsLoc = + (mcomplete, scripts'') + where + scripts' = map goScript scripts + scripts'' = + case jsLoc of + Just s -> scripts' ++ [s] + Nothing -> scripts' + goScript (Script (Local url) _) = render url [] + goScript (Script (Remote s) _) = s + mcomplete = + case jsLoc of + Just{} -> Nothing + Nothing -> + case jscript of + Nothing -> Nothing + Just j -> Just $ jelper j + +formatLogMessage :: IO ZonedDate + -> Loc + -> LogSource + -> LogLevel + -> LogStr -- ^ message + -> IO [LogStr] +formatLogMessage getdate loc src level msg = do + now <- getdate + return + [ LB now + , LB " [" + , LS $ + case level of + LevelOther t -> T.unpack t + _ -> drop 5 $ show level + , LS $ + if T.null src + then "" + else "#" ++ T.unpack src + , LB "] " + , msg + , LB " @(" + , LS $ fileLocationToString loc + , LB ")\n" + ] + +defaultClientSessionBackend :: Yesod master => IO (SessionBackend master) +defaultClientSessionBackend = do + key <- CS.getKey CS.defaultKeyFile + let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes + (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout + return $ clientSessionBackend key getCachedDate + +jsToHtml :: Javascript -> Html +jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b + +jelper :: JavascriptUrl url -> HtmlUrl url +jelper = fmap jsToHtml + +left :: Either a b -> Maybe a +left (Left x) = Just x +left _ = Nothing + +right :: Either a b -> Maybe b +right (Right x) = Just x +right _ = Nothing + +clientSessionBackend :: Yesod master + => CS.Key -- ^ The encryption key + -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> SessionBackend master +clientSessionBackend key getCachedDate = + SessionBackend { + sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req + } + +loadClientSession :: Yesod master + => CS.Key + -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> S8.ByteString -- ^ session name + -> master + -> W.Request + -> IO (SessionMap, SaveSession) +loadClientSession key getCachedDate sessionName master req = load + where + load = do + date <- getCachedDate + return (sess date, save date) + sess date = fromMaybe Map.empty $ do + raw <- lookup "Cookie" $ W.requestHeaders req + val <- lookup sessionName $ parseCookies raw + let host = "" -- fixme, properly lock sessions to client address + decodeClientSession key date host val + save date sess' = do + -- We should never cache the IV! Be careful! + iv <- liftIO CS.randomIV + return [AddCookie def + { setCookieName = sessionName + , setCookieValue = encodeClientSession key iv date host sess' + , setCookiePath = Just (cookiePath master) + , setCookieExpires = Just (csdcExpires date) + , setCookieDomain = cookieDomain master + , setCookieHttpOnly = True + }] + where + host = "" -- fixme, properly lock sessions to client address + +-- taken from file-location package +-- turn the TH Loc loaction information into a human readable string +-- leaving out the loc_end parameter +fileLocationToString :: Loc -> String +fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ + ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) + where + line = show . fst . loc_start + char = show . snd . loc_start + +{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-} diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs new file mode 100644 index 00000000..6ba18081 --- /dev/null +++ b/yesod-core/Yesod/Core/Run.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Yesod.Core.Run where + +import Blaze.ByteString.Builder (fromLazyByteString, toByteString, + toLazyByteString) +import Control.Applicative ((<$>)) +import Control.Exception (SomeException, fromException, + handle) +import Control.Exception.Lifted (catch) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (LogLevel, LogSource) +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans.Resource (ResourceT) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import qualified Data.IORef as I +import qualified Data.Map as Map +import Data.Maybe (isJust) +import Data.Maybe (fromMaybe) +import Data.Monoid (appEndo, mempty) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Language.Haskell.TH.Syntax (Loc) +import qualified Network.HTTP.Types as H +import Network.Wai +import Prelude hiding (catch) +import System.IO (hPutStrLn, stderr) +import System.Log.FastLogger (LogStr) +import System.Log.FastLogger (Logger) +import System.Random (newStdGen) +import Web.Cookie (renderSetCookie) +import Yesod.Content +import Yesod.Core.Class +import Yesod.Core.Types +import Yesod.Handler +import Yesod.Internal (tokenKey) +import Yesod.Internal.Request (parseWaiRequest, + tooLargeResponse) +import Yesod.Routes.Class (Route, renderRoute) + +handlerToYAR :: (HasReps a, HasReps b) + => master -- ^ master site foundation + -> sub -- ^ sub site foundation + -> (RequestBodyLength -> FileUpload) + -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + -> (Route sub -> Route master) + -> (Route master -> [(Text, Text)] -> Text) -- route renderer + -> (ErrorResponse -> GHandler sub master a) + -> YesodRequest + -> Maybe (Route sub) + -> SessionMap + -> GHandler sub master b + -> ResourceT IO YesodResponse +handlerToYAR y s upload log' toMasterRoute render errorHandler0 rr murl sessionMap h = + ya rr { reqOnError = eh', reqSession = sessionMap } + where + ya = runHandler h render murl toMasterRoute y s upload log' + eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' + errorHandler' = localNoCurrent . errorHandler0 + +yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response +yarToResponse (YRWai a) _ = a +yarToResponse (YRPlain s hs _ c _) extraHeaders = + go c + where + finalHeaders = extraHeaders ++ map headerToPair hs + finalHeaders' len = ("Content-Length", S8.pack $ show len) + : finalHeaders + + go (ContentBuilder b mlen) = + ResponseBuilder s hs' b + where + hs' = maybe finalHeaders finalHeaders' mlen + go (ContentFile fp p) = ResponseFile s finalHeaders fp p + go (ContentSource body) = ResponseSource s finalHeaders body + go (ContentDontEvaluate c') = go c' + +-- | Convert Header to a key/value pair. +headerToPair :: Header + -> (CI ByteString, ByteString) +headerToPair (AddCookie sc) = + ("Set-Cookie", toByteString $ renderSetCookie $ sc) +headerToPair (DeleteCookie key path) = + ( "Set-Cookie" + , S.concat + [ key + , "=; path=" + , path + , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" + ] + ) +headerToPair (Header key value) = (CI.mk key, value) + +localNoCurrent :: GHandler s m a -> GHandler s m a +localNoCurrent = + local (\hd -> hd { handlerRoute = Nothing }) + +local :: (HandlerData sub' master' -> HandlerData sub master) + -> GHandler sub master a + -> GHandler sub' master' a +local f (GHandler x) = GHandler $ \r -> x $ f r + +-- | Function used internally by Yesod in the process of converting a +-- 'GHandler' into an 'Application'. Should not be needed by users. +runHandler :: HasReps c + => GHandler sub master c + -> (Route master -> [(Text, Text)] -> Text) + -> Maybe (Route sub) + -> (Route sub -> Route master) + -> master + -> sub + -> (RequestBodyLength -> FileUpload) + -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + -> YesodApp +runHandler handler mrender sroute tomr master sub upload log' req = do + let toErrorHandler e = + case fromException e of + Just (HCError x) -> x + _ -> InternalError $ T.pack $ show e + istate <- liftIO $ I.newIORef GHState + { ghsSession = initSession + , ghsRBC = Nothing + , ghsIdent = 1 + , ghsCache = mempty + , ghsHeaders = mempty + } + let hd = HandlerData + { handlerRequest = req + , handlerSub = sub + , handlerMaster = master + , handlerRoute = sroute + , handlerRender = mrender + , handlerToMaster = tomr + , handlerState = istate + , handlerUpload = upload + , handlerLog = log' + } + contents' <- catch (fmap Right $ unGHandler handler hd) + (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id + $ fromException e) + state <- liftIO $ I.readIORef istate + let finalSession = ghsSession state + let headers = ghsHeaders state + let contents = either id (HCContent H.status200 . chooseRep) contents' + let handleError e = do + yar <- eh e req + { reqOnError = safeEh + , reqSession = finalSession + } + case yar of + YRPlain _ hs ct c sess -> + let hs' = appEndo headers hs + in return $ YRPlain (getStatus e) hs' ct c sess + YRWai _ -> return yar + let sendFile' ct fp p = + return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession + case contents of + HCContent status a -> do + (ct, c) <- liftIO $ a cts + ec' <- liftIO $ evaluateContent c + case ec' of + Left e -> handleError e + Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession + HCError e -> handleError e + HCRedirect status loc -> do + let disable_caching x = + Header "Cache-Control" "no-cache, must-revalidate" + : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" + : x + hs = (if status /= H.movedPermanently301 then disable_caching else id) + $ Header "Location" (encodeUtf8 loc) : appEndo headers [] + return $ YRPlain + status hs typePlain emptyContent + finalSession + HCSendFile ct fp p -> catch + (sendFile' ct fp p) + (handleError . toErrorHandler) + HCCreated loc -> do + let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] + return $ YRPlain + H.status201 + hs + typePlain + emptyContent + finalSession + HCWai r -> return $ YRWai r + where + eh = reqOnError req + cts = reqAccept req + initSession = reqSession req + +safeEh :: ErrorResponse -> YesodApp +safeEh er req = do + liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er + return $ YRPlain + H.status500 + [] + typePlain + (toContent ("Internal Server Error" :: S.ByteString)) + (reqSession req) + +evaluateContent :: Content -> IO (Either ErrorResponse Content) +evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do + let lbs = toLazyByteString b + L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen) + where + f :: SomeException -> IO (Either ErrorResponse Content) + f = return . Left . InternalError . T.pack . show +evaluateContent c = return (Right c) + +getStatus :: ErrorResponse -> H.Status +getStatus NotFound = H.status404 +getStatus (InternalError _) = H.status500 +getStatus (InvalidArgs _) = H.status400 +getStatus (PermissionDenied _) = H.status403 +getStatus (BadMethod _) = H.status405 + +-- | Run a 'GHandler' completely outside of Yesod. This +-- function comes with many caveats and you shouldn't use it +-- unless you fully understand what it's doing and how it works. +-- +-- As of now, there's only one reason to use this function at +-- all: in order to run unit tests of functions inside 'GHandler' +-- but that aren't easily testable with a full HTTP request. +-- Even so, it's better to use @wai-test@ or @yesod-test@ instead +-- of using this function. +-- +-- This function will create a fake HTTP request (both @wai@'s +-- 'Request' and @yesod@'s 'Request') and feed it to the +-- @GHandler@. The only useful information the @GHandler@ may +-- get from the request is the session map, which you must supply +-- as argument to @runFakeHandler@. All other fields contain +-- fake information, which means that they can be accessed but +-- won't have any useful information. The response of the +-- @GHandler@ is completely ignored, including changes to the +-- session, cookies or headers. We only return you the +-- @GHandler@'s return value. +runFakeHandler :: (Yesod master, MonadIO m) => + SessionMap + -> (master -> Logger) + -> master + -> GHandler master master a + -> m (Either ErrorResponse a) +runFakeHandler fakeSessionMap logger master handler = liftIO $ do + ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") + let handler' = do liftIO . I.writeIORef ret . Right =<< handler + return () + let yapp = + runHandler + handler' + (yesodRender master $ resolveApproot master fakeWaiRequest) + Nothing + id + master + master + (fileUpload master) + (messageLoggerSource master $ logger master) + errHandler err req = do + liftIO $ I.writeIORef ret (Left err) + return $ YRPlain + H.status500 + [] + typePlain + (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) + (reqSession req) + fakeWaiRequest = + Request + { requestMethod = "POST" + , httpVersion = H.http11 + , rawPathInfo = "/runFakeHandler/pathInfo" + , rawQueryString = "" + , serverName = "runFakeHandler-serverName" + , serverPort = 80 + , requestHeaders = [] + , isSecure = False + , remoteHost = error "runFakeHandler-remoteHost" + , pathInfo = ["runFakeHandler", "pathInfo"] + , queryString = [] + , requestBody = mempty + , vault = mempty + , requestBodyLength = KnownLength 0 + } + fakeRequest = + YesodRequest + { reqGetParams = [] + , reqCookies = [] + , reqWaiRequest = fakeWaiRequest + , reqLangs = [] + , reqToken = Just "NaN" -- not a nonce =) + , reqOnError = errHandler + , reqAccept = [] + , reqSession = fakeSessionMap + } + _ <- runResourceT $ yapp fakeRequest + I.readIORef ret +{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} + +data YesodRunnerEnv sub master = YesodRunnerEnv + { yreLogger :: !Logger + , yreMaster :: !master + , yreSub :: !sub + , yreRoute :: !(Maybe (Route sub)) + , yreToMaster :: !(Route sub -> Route master) + , yreSessionBackend :: !(Maybe (SessionBackend master)) + } + +defaultYesodRunner :: Yesod master + => YesodRunnerEnv sub master + -> GHandler sub master ChooseRep + -> Application +defaultYesodRunner YesodRunnerEnv {..} handler' req + | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse + | otherwise = do + let dontSaveSession _ = return [] + let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError" + (session, saveSession) <- liftIO $ do + maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend + rr <- liftIO $ parseWaiRequest req session onError (isJust yreSessionBackend) maxLen <$> newStdGen + let h = {-# SCC "h" #-} do + case yreRoute of + Nothing -> handler + Just url -> do + isWrite <- isWriteRequest $ yreToMaster url + ar <- isAuthorized (yreToMaster url) isWrite + case ar of + Authorized -> return () + AuthenticationRequired -> + case authRoute yreMaster of + Nothing -> + permissionDenied "Authentication required" + Just url' -> do + setUltDestCurrent + redirect url' + Unauthorized s' -> permissionDenied s' + handler + let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session + let ra = resolveApproot yreMaster req + let log' = messageLoggerSource yreMaster yreLogger + yar <- handlerToYAR yreMaster yreSub (fileUpload yreMaster) log' yreToMaster + (yesodRender yreMaster ra) errorHandler rr yreRoute sessionMap h + extraHeaders <- case yar of + (YRPlain _ _ ct _ newSess) -> do + let nsToken = maybe + newSess + (\n -> Map.insert tokenKey (encodeUtf8 n) newSess) + (reqToken rr) + sessionHeaders <- liftIO (saveSession nsToken) + return $ ("Content-Type", ct) : map headerToPair sessionHeaders + _ -> return [] + return $ yarToResponse yar extraHeaders + where + maxLen = maximumContentLength yreMaster $ fmap yreToMaster yreRoute + handler = yesodMiddleware handler' + +yesodRender :: Yesod y + => y + -> ResolvedApproot + -> Route y + -> [(Text, Text)] -- ^ url query string + -> Text +yesodRender y ar url params = + decodeUtf8With lenientDecode $ toByteString $ + fromMaybe + (joinPath y ar ps + $ params ++ params') + (urlRenderOverride y url) + where + (ps, params') = renderRoute url + +toMasterHandlerMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) + +-- | FIXME do we need this? +toMasterHandlerDyn :: (Route sub -> Route master) + -> GHandler sub' master sub + -> Route sub + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerDyn tm getSub route h = do + sub <- getSub + local (handlerSubData tm (const sub) route) h + +-- | Used internally for promoting subsite handler functions to master site +-- handler functions. Should not be needed by users. +toMasterHandler :: (Route sub -> Route master) + -> (master -> sub) + -> Route sub + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandler tm ts route = local (handlerSubData tm ts route) + +handlerSubData :: (Route sub -> Route master) + -> (master -> sub) + -> Route sub + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubData tm ts = handlerSubDataMaybe tm ts . Just + +handlerSubDataMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubDataMaybe tm ts route hd = hd + { handlerSub = ts $ handlerMaster hd + , handlerToMaster = tm + , handlerRoute = route + } + +resolveApproot :: Yesod master => master -> Request -> ResolvedApproot +resolveApproot master req = + case approot of + ApprootRelative -> "" + ApprootStatic t -> t + ApprootMaster f -> f master + ApprootRequest f -> f master req diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index c9ee243a..5f260034 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -105,18 +105,10 @@ module Yesod.Handler , cacheInsert , cacheDelete -- * Internal Yesod - , runHandler , YesodApp , runSubsiteGetter - , toMasterHandler - , toMasterHandlerDyn - , toMasterHandlerMaybe - , localNoCurrent , HandlerData , ErrorResponse (..) - , handlerToYAR - , yarToResponse - , headerToPair ) where import Prelude hiding (catch) @@ -131,7 +123,6 @@ import Control.Monad (liftM) import Control.Monad.IO.Class -import System.IO import qualified Network.Wai as W import qualified Network.HTTP.Types as H @@ -144,59 +135,31 @@ import qualified Data.Text.Lazy as TL import qualified Data.Map as Map import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L import Yesod.Content import Data.Maybe (mapMaybe) -import Web.Cookie (SetCookie (..), renderSetCookie) +import Web.Cookie (SetCookie (..)) import Control.Arrow ((***)) import qualified Network.Wai.Parse as NWP import Data.Monoid (mappend, mempty, Endo (..)) import qualified Data.ByteString.Char8 as S8 -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString) import Data.Text (Text) import Text.Shakespeare.I18N (RenderMessage (..)) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup -import System.Log.FastLogger -import Control.Monad.Logger - import qualified Yesod.Internal.Cache as Cache import Yesod.Internal.Cache (mkCacheKey) import qualified Data.IORef as I -import Control.Exception.Lifted (catch) -import Control.Monad.Trans.Resource -import Yesod.Routes.Class -import Language.Haskell.TH.Syntax (Loc) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Yesod.Routes.Class (Route) import Yesod.Core.Types import Yesod.Core.Trans.Class class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y -handlerSubData :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubData tm ts = handlerSubDataMaybe tm ts . Just - -handlerSubDataMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubDataMaybe tm ts route hd = hd - { handlerSub = ts $ handlerMaster hd - , handlerToMaster = tm - , handlerRoute = route - } - get :: GHandler sub master GHState get = do hd <- ask @@ -215,25 +178,6 @@ modify f = do 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 --- handler functions. Should not be needed by users. -toMasterHandler :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandler tm ts route = local (handlerSubData tm ts route) - --- | FIXME do we need this? -toMasterHandlerDyn :: (Route sub -> Route master) - -> GHandler sub' master sub - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerDyn tm getSub route h = do - sub <- getSub - local (handlerSubData tm (const sub) route) h - class SubsiteGetter g m s | g -> s where runSubsiteGetter :: g -> m s @@ -246,13 +190,6 @@ instance (anySub ~ anySub' ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where runSubsiteGetter = id -toMasterHandlerMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) - getRequest :: GHandler s m YesodRequest getRequest = handlerRequest `liftM` ask @@ -401,114 +338,6 @@ handlerToIO = , handlerState = newStateIORef } --- | Function used internally by Yesod in the process of converting a --- 'GHandler' into an 'W.Application'. Should not be needed by users. -runHandler :: HasReps c - => GHandler sub master c - -> (Route master -> [(Text, Text)] -> Text) - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> master - -> sub - -> (W.RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' req = do - let toErrorHandler e = - case fromException e of - Just (HCError x) -> x - _ -> InternalError $ T.pack $ show e - istate <- liftIO $ I.newIORef GHState - { ghsSession = initSession - , ghsRBC = Nothing - , ghsIdent = 1 - , ghsCache = mempty - , ghsHeaders = mempty - } - let hd = HandlerData - { handlerRequest = req - , handlerSub = sub - , handlerMaster = master - , handlerRoute = sroute - , handlerRender = mrender - , handlerToMaster = tomr - , handlerState = istate - , handlerUpload = upload - , handlerLog = log' - } - contents' <- catch (fmap Right $ unGHandler handler hd) - (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id - $ fromException e) - state <- liftIO $ I.readIORef istate - let finalSession = ghsSession state - let headers = ghsHeaders state - let contents = either id (HCContent H.status200 . chooseRep) contents' - let handleError e = do - yar <- eh e req - { reqOnError = safeEh - , reqSession = finalSession - } - case yar of - YRPlain _ hs ct c sess -> - let hs' = appEndo headers hs - in return $ YRPlain (getStatus e) hs' ct c sess - YRWai _ -> return yar - let sendFile' ct fp p = - return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession - case contents of - HCContent status a -> do - (ct, c) <- liftIO $ a cts - ec' <- liftIO $ evaluateContent c - case ec' of - Left e -> handleError e - Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession - HCError e -> handleError e - HCRedirect status loc -> do - let disable_caching x = - Header "Cache-Control" "no-cache, must-revalidate" - : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" - : x - hs = (if status /= H.movedPermanently301 then disable_caching else id) - $ Header "Location" (encodeUtf8 loc) : appEndo headers [] - return $ YRPlain - status hs typePlain emptyContent - finalSession - HCSendFile ct fp p -> catch - (sendFile' ct fp p) - (handleError . toErrorHandler) - HCCreated loc -> do - let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] - return $ YRPlain - H.status201 - hs - typePlain - emptyContent - finalSession - HCWai r -> return $ YRWai r - where - eh = reqOnError req - cts = reqAccept req - initSession = reqSession req - -evaluateContent :: Content -> IO (Either ErrorResponse Content) -evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do - let lbs = toLazyByteString b - L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen) - where - f :: SomeException -> IO (Either ErrorResponse Content) - f = return . Left . InternalError . T.pack . show -evaluateContent c = return (Right c) - -safeEh :: ErrorResponse -> YesodApp -safeEh er req = do - liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ YRPlain - H.status500 - [] - typePlain - (toContent ("Internal Server Error" :: S.ByteString)) - (reqSession req) - -- | Redirect to the given route. -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0 -- This is the appropriate choice for a get-following-post @@ -782,13 +611,6 @@ modSession f x = x { ghsSession = f $ ghsSession x } addHeader :: Header -> GHandler sub master () addHeader = tell . Endo . (:) -getStatus :: ErrorResponse -> H.Status -getStatus NotFound = H.status404 -getStatus (InternalError _) = H.status500 -getStatus (InvalidArgs _) = H.status400 -getStatus (PermissionDenied _) = H.status403 -getStatus (BadMethod _) = H.status405 - -- | Some value which can be turned into a URL for redirects. class RedirectUrl master a where -- | Converts the value to the URL and a list of query-string parameters. @@ -813,10 +635,6 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where toTextUrl (url, params) = toTextUrl (url, Map.toList params) -localNoCurrent :: GHandler s m a -> GHandler s m a -localNoCurrent = - local (\hd -> hd { handlerRoute = Nothing }) - -- | Lookup for session data. lookupSession :: Text -> GHandler s m (Maybe Text) lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS @@ -831,59 +649,6 @@ lookupSessionBS n = do getSession :: GHandler sub master SessionMap getSession = liftM ghsSession get -handlerToYAR :: (HasReps a, HasReps b) - => master -- ^ master site foundation - -> sub -- ^ sub site foundation - -> (W.RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - -> (Route sub -> Route master) - -> (Route master -> [(Text, Text)] -> Text) -- route renderer - -> (ErrorResponse -> GHandler sub master a) - -> YesodRequest - -> Maybe (Route sub) - -> SessionMap - -> GHandler sub master b - -> ResourceT IO YesodResponse -handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = - ya rr { reqOnError = eh', reqSession = sessionMap } - where - ya = runHandler h render murl toMasterRoute y s upload log' - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' - errorHandler' = localNoCurrent . errorHandler - -yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> W.Response -yarToResponse (YRWai a) _ = a -yarToResponse (YRPlain s hs _ c _) extraHeaders = - go c - where - finalHeaders = extraHeaders ++ map headerToPair hs - finalHeaders' len = ("Content-Length", S8.pack $ show len) - : finalHeaders - - go (ContentBuilder b mlen) = - W.ResponseBuilder s hs' b - where - hs' = maybe finalHeaders finalHeaders' mlen - go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p - go (ContentSource body) = W.ResponseSource s finalHeaders body - go (ContentDontEvaluate c') = go c' - --- | Convert Header to a key/value pair. -headerToPair :: Header - -> (CI ByteString, ByteString) -headerToPair (AddCookie sc) = - ("Set-Cookie", toByteString $ renderSetCookie $ sc) -headerToPair (DeleteCookie key path) = - ( "Set-Cookie" - , S.concat - [ key - , "=; path=" - , path - , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" - ] - ) -headerToPair (Header key value) = (CI.mk key, value) - -- | Get a unique identifier. newIdent :: GHandler sub master Text newIdent = do @@ -951,8 +716,3 @@ cacheDelete k = modify $ \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 diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 50fc4a21..3c9f73d0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -43,427 +43,28 @@ module Yesod.Internal.Core import Yesod.Content import Yesod.Handler hiding (lift, getExpires) -import Control.Monad.Logger (logErrorS) -import Control.Applicative ((<$>)) -import System.Random (newStdGen) import Yesod.Routes.Class -import Data.Word (Word64) -import Control.Arrow ((***)) -import Control.Monad (forM) -import Yesod.Widget -import Yesod.Request import qualified Network.Wai as W -import Yesod.Internal import Yesod.Internal.Session import Yesod.Internal.Request -import qualified Web.ClientSession as CS -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import qualified Data.IORef as I -import Data.Monoid import Text.Hamlet -import Text.Julius -import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString) -import qualified Text.Blaze.Html5 as TBH -import Data.Text.Lazy.Builder (toLazyText) -import Data.Text.Lazy.Encoding (encodeUtf8) -import Data.Maybe (fromMaybe, isJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Resource (runResourceT) -import Web.Cookie (parseCookies) -import qualified Data.Map as Map -import Network.HTTP.Types (encodePath) -import qualified Data.Text as T +import Text.Blaze (unsafeLazyByteString) import Data.Text (Text) -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TEE -import Blaze.ByteString.Builder (Builder, toByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromText) -import Data.List (foldl') -import qualified Network.HTTP.Types as H -import Web.Cookie (SetCookie (..)) -import Language.Haskell.TH.Syntax (Loc (..)) -import Text.Blaze (preEscapedToMarkup) import Data.Aeson (Value (Array, String)) import Data.Aeson.Encode (encode) import qualified Data.Vector as Vector -import Network.Wai.Middleware.Gzip (GzipSettings, def) -import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd) import qualified Paths_yesod_core import Data.Version (showVersion) -import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr) -import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) -import System.Log.FastLogger.Date (ZonedDate) -import System.IO (stdout) +import System.Log.FastLogger (Logger) import Yesod.Core.Types +import Yesod.Core.Class +import Yesod.Core.Run yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version --- | This class is automatically instantiated when you use the template haskell --- mkYesod function. You should never need to deal with it directly. -class YesodDispatch sub master where - yesodDispatch - :: Yesod master - => Logger - -> master - -> sub - -> (Route sub -> Route master) - -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler - -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler - -> Text -- ^ request method - -> [Text] -- ^ pieces - -> Maybe (SessionBackend master) - -> W.Application - - yesodRunner :: Yesod master - => Logger - -> GHandler sub master ChooseRep - -> master - -> sub - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> Maybe (SessionBackend master) - -> W.Application - yesodRunner = defaultYesodRunner - --- | Define settings for a Yesod applications. All methods have intelligent --- defaults, and therefore no implementation is required. -class RenderRoute a => Yesod a where - -- | An absolute URL to the root of the application. Do not include - -- trailing slash. - -- - -- Default value: 'ApprootRelative'. This is valid under the following - -- conditions: - -- - -- * Your application is served from the root of the domain. - -- - -- * You do not use any features that require absolute URLs, such as Atom - -- feeds and XML sitemaps. - -- - -- If this is not true, you should override with a different - -- implementation. - approot :: Approot a - approot = ApprootRelative - - -- | Output error response pages. - errorHandler :: ErrorResponse -> GHandler sub a ChooseRep - errorHandler = defaultErrorHandler - - -- | Applies some form of layout to the contents of a page. - defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml - defaultLayout w = do - p <- widgetToPageContent w - mmsg <- getMessage - hamletToRepHtml [hamlet| -$newline never -$doctype 5 - -<html> - <head> - <title>#{pageTitle p} - ^{pageHead p} - <body> - $maybe msg <- mmsg - <p .message>#{msg} - ^{pageBody p} -|] - - -- | Override the rendering function for a particular URL. One use case for - -- this is to offload static hosting to a different domain name to avoid - -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe Builder - urlRenderOverride _ _ = Nothing - - -- | Determine if a request is authorized or not. - -- - -- Return 'Authorized' if the request is authorized, - -- 'Unauthorized' a message if unauthorized. - -- If authentication is required, return 'AuthenticationRequired'. - isAuthorized :: Route a - -> Bool -- ^ is this a write request? - -> GHandler s a AuthResult - isAuthorized _ _ = return Authorized - - -- | Determines whether the current request is a write request. By default, - -- this assumes you are following RESTful principles, and determines this - -- from request method. In particular, all except the following request - -- methods are considered write: GET HEAD OPTIONS TRACE. - -- - -- This function is used to determine if a request is authorized; see - -- 'isAuthorized'. - isWriteRequest :: Route a -> GHandler s a Bool - isWriteRequest _ = do - wai <- waiRequest - return $ W.requestMethod wai `notElem` - ["GET", "HEAD", "OPTIONS", "TRACE"] - - -- | The default route for authentication. - -- - -- Used in particular by 'isAuthorized', but library users can do whatever - -- they want with it. - authRoute :: a -> Maybe (Route a) - authRoute _ = Nothing - - -- | A function used to clean up path segments. It returns 'Right' with a - -- clean path or 'Left' with a new set of pieces the user should be - -- redirected to. The default implementation enforces: - -- - -- * No double slashes - -- - -- * There is no trailing slash. - -- - -- Note that versions of Yesod prior to 0.7 used a different set of rules - -- involing trailing slashes. - cleanPath :: a -> [Text] -> Either [Text] [Text] - cleanPath _ s = - if corrected == s - then Right $ map dropDash s - else Left corrected - where - corrected = filter (not . T.null) s - dropDash t - | T.all (== '-') t = T.drop 1 t - | otherwise = t - - -- | Builds an absolute URL by concatenating the application root with the - -- pieces of a path and a query string, if any. - -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. - joinPath :: a - -> T.Text -- ^ application root - -> [T.Text] -- ^ path pieces - -> [(T.Text, T.Text)] -- ^ query string - -> Builder - joinPath _ ar pieces' qs' = - fromText ar `mappend` encodePath pieces qs - where - pieces = if null pieces' then [""] else map addDash pieces' - qs = map (TE.encodeUtf8 *** go) qs' - go "" = Nothing - go x = Just $ TE.encodeUtf8 x - addDash t - | T.all (== '-') t = T.cons '-' t - | otherwise = t - - -- | This function is used to store some static content to be served as an - -- external file. The most common case of this is stashing CSS and - -- JavaScript content in an external file; the "Yesod.Widget" module uses - -- this feature. - -- - -- The return value is 'Nothing' if no storing was performed; this is the - -- default implementation. A 'Just' 'Left' gives the absolute URL of the - -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is - -- necessary when you are serving the content outside the context of a - -- Yesod application, such as via memcached. - addStaticContent :: Text -- ^ filename extension - -> Text -- ^ mime-type - -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) - addStaticContent _ _ _ = return Nothing - - {- Temporarily disabled until we have a better interface. - -- | Whether or not to tie a session to a specific IP address. Defaults to - -- 'False'. - -- - -- Note: This setting has two known problems: it does not work correctly - -- when behind a reverse proxy (including load balancers), and it may not - -- function correctly if the user is behind a proxy. - sessionIpAddress :: a -> Bool - sessionIpAddress _ = False - -} - - -- | The path value to set for cookies. By default, uses \"\/\", meaning - -- cookies will be sent to every page on the current domain. - cookiePath :: a -> S8.ByteString - cookiePath _ = "/" - - -- | The domain value to set for cookies. By default, the - -- domain is not set, meaning cookies will be sent only to - -- the current domain. - cookieDomain :: a -> Maybe S8.ByteString - cookieDomain _ = Nothing - - -- | Maximum allowed length of the request body, in bytes. - -- - -- Default: 2 megabytes. - maximumContentLength :: a -> Maybe (Route a) -> Word64 - maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes - - -- | Returns a @Logger@ to use for log messages. - -- - -- Default: Sends to stdout and automatically flushes on each write. - getLogger :: a -> IO Logger - getLogger _ = mkLogger True stdout - - -- | Send a message to the @Logger@ provided by @getLogger@. - -- - -- Note: This method is no longer used. Instead, you should override - -- 'messageLoggerSource'. - messageLogger :: a - -> Logger - -> Loc -- ^ position in source code - -> LogLevel - -> LogStr -- ^ message - -> IO () - messageLogger a logger loc = messageLoggerSource a logger loc "" - - -- | Send a message to the @Logger@ provided by @getLogger@. - messageLoggerSource :: a - -> Logger - -> Loc -- ^ position in source code - -> LogSource - -> LogLevel - -> LogStr -- ^ message - -> IO () - messageLoggerSource a logger loc source level msg = - if shouldLog a source level - then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger - else return () - - -- | The logging level in place for this application. Any messages below - -- this level will simply be ignored. - logLevel :: a -> LogLevel - logLevel _ = LevelInfo - - -- | GZIP settings. - gzipSettings :: a -> GzipSettings - gzipSettings _ = def - - -- | Where to Load sripts from. We recommend the default value, - -- 'BottomOfBody'. Alternatively use the built in async yepnope loader: - -- - -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js - -- - -- Or write your own async js loader: see 'loadJsYepnope' - jsLoader :: a -> ScriptLoadPosition a - jsLoader _ = BottomOfBody - - -- | Create a session backend. Returning `Nothing' disables sessions. - -- - -- Default: Uses clientsession with a 2 hour timeout. - makeSessionBackend :: a -> IO (Maybe (SessionBackend a)) - makeSessionBackend _ = fmap Just defaultClientSessionBackend - - -- | How to store uploaded files. - -- - -- Default: When the request body is greater than 50kb, store in a temp - -- file. For chunked request bodies, store in a temp file. Otherwise, store - -- in memory. - fileUpload :: a -> W.RequestBodyLength -> FileUpload - fileUpload _ (W.KnownLength size) - | size <= 50000 = FileUploadMemory lbsBackEnd - fileUpload _ _ = FileUploadDisk tempFileBackEnd - - -- | Should we log the given log source/level combination. - -- - -- Default: Logs everything at or above 'logLevel' - shouldLog :: a -> LogSource -> LogLevel -> Bool - shouldLog a _ level = level >= logLevel a - - -- | A Yesod middleware, which will wrap every handler function. This - -- allows you to run code before and after a normal handler. - -- - -- Default: Adds the response header \"Vary: Accept, Accept-Language\". - -- - -- Since: 1.1.6 - yesodMiddleware :: GHandler sub a res -> GHandler sub a res - yesodMiddleware handler = do - setHeader "Vary" "Accept, Accept-Language" - handler - -{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-} - -formatLogMessage :: IO ZonedDate - -> Loc - -> LogSource - -> LogLevel - -> LogStr -- ^ message - -> IO [LogStr] -formatLogMessage getdate loc src level msg = do - now <- getdate - return - [ LB now - , LB " [" - , LS $ - case level of - LevelOther t -> T.unpack t - _ -> drop 5 $ show level - , LS $ - if T.null src - then "" - else "#" ++ T.unpack src - , LB "] " - , msg - , LB " @(" - , LS $ fileLocationToString loc - , LB ")\n" - ] - --- taken from file-location package --- turn the TH Loc loaction information into a human readable string --- leaving out the loc_end parameter -fileLocationToString :: Loc -> String -fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ - ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) - where - line = show . fst . loc_start - char = show . snd . loc_start - -defaultYesodRunner :: Yesod master - => Logger - -> GHandler sub master ChooseRep - -> master - -> sub - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> Maybe (SessionBackend master) - -> W.Application -defaultYesodRunner logger handler' master sub murl toMasterRoute msb req - | W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse - | otherwise = do - let dontSaveSession _ = return [] - let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError" - (session, saveSession) <- liftIO $ do - maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb master req) msb - rr <- liftIO $ parseWaiRequest req session onError (isJust msb) maxLen <$> newStdGen - let h = {-# SCC "h" #-} do - case murl of - Nothing -> handler - Just url -> do - isWrite <- isWriteRequest $ toMasterRoute url - ar <- isAuthorized (toMasterRoute url) isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute master of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDestCurrent - redirect url' - Unauthorized s' -> permissionDenied s' - handler - let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session - let ra = resolveApproot master req - let log' = messageLoggerSource master logger - yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute - (yesodRender master ra) errorHandler rr murl sessionMap h - extraHeaders <- case yar of - (YRPlain _ _ ct _ newSess) -> do - let nsToken = maybe - newSess - (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess) - (reqToken rr) - sessionHeaders <- liftIO (saveSession nsToken) - return $ ("Content-Type", ct) : map headerToPair sessionHeaders - _ -> return [] - return $ yarToResponse yar extraHeaders - where - maxLen = maximumContentLength master $ fmap toMasterRoute murl - handler = yesodMiddleware handler' - -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if -- present). @@ -491,57 +92,6 @@ breadcrumbs = do (title, next) <- breadcrumb this go ((this, title) : back) next -applyLayout' :: Yesod master - => Html -- ^ title - -> HtmlUrl (Route master) -- ^ body - -> GHandler sub master ChooseRep -applyLayout' title body = fmap chooseRep $ defaultLayout $ do - setTitle title - toWidget body - --- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep -defaultErrorHandler NotFound = do - r <- waiRequest - let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r - applyLayout' "Not Found" - [hamlet| -$newline never -<h1>Not Found -<p>#{path'} -|] -defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" - [hamlet| -$newline never -<h1>Permission denied -<p>#{msg} -|] -defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" - [hamlet| -$newline never -<h1>Invalid Arguments -<ul> - $forall msg <- ia - <li>#{msg} -|] -defaultErrorHandler (InternalError e) = do - $logErrorS "yesod-core" e - applyLayout' "Internal Server Error" - [hamlet| -$newline never -<h1>Internal Server Error -<pre>#{e} -|] -defaultErrorHandler (BadMethod m) = - applyLayout' "Bad Method" - [hamlet| -$newline never -<h1>Method Not Supported -<p>Method <code>#{S8.unpack m}</code> not supported -|] - -- | Return the same URL if the user is authorized to see it. -- -- Built on top of 'isAuthorized'. This is useful for building page that only @@ -554,113 +104,6 @@ maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing -jsToHtml :: Javascript -> Html -jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b - -jelper :: JavascriptUrl url -> HtmlUrl url -jelper = fmap jsToHtml - --- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) -widgetToPageContent w = do - master <- getYesod - ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w - let title = maybe mempty unTitle mTitle - scripts = runUniqueList scripts' - stylesheets = runUniqueList stylesheets' - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - css <- forM (Map.toList style) $ \(mmedia, content) -> do - let rendered = toLazyText $ content render - x <- addStaticContent "css" "text/css; charset=utf-8" - $ encodeUtf8 rendered - return (mmedia, - case x of - Nothing -> Left $ preEscapedToMarkup rendered - Just y -> Right $ either id (uncurry render) y) - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ encodeUtf8 $ renderJavascriptUrl render s - return $ renderLoc x - - -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing - -- the asynchronous loader means your page doesn't have to wait for all the js to load - let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc - regularScriptLoad = [hamlet| -$newline never -$forall s <- scripts - ^{mkScriptTag s} -$maybe j <- jscript - $maybe s <- jsLoc - <script src="#{s}"> - $nothing - <script>^{jelper j} -|] - - headAll = [hamlet| -$newline never -\^{head'} -$forall s <- stylesheets - ^{mkLinkTag s} -$forall s <- css - $maybe t <- right $ snd s - $maybe media <- fst s - <link rel=stylesheet media=#{media} href=#{t}> - $nothing - <link rel=stylesheet href=#{t}> - $maybe content <- left $ snd s - $maybe media <- fst s - <style media=#{media}>#{content} - $nothing - <style>#{content} -$case jsLoader master - $of BottomOfBody - $of BottomOfHeadAsync asyncJsLoader - ^{asyncJsLoader asyncScripts mcomplete} - $of BottomOfHeadBlocking - ^{regularScriptLoad} -|] - let bodyScript = [hamlet| -$newline never -^{body} -^{regularScriptLoad} -|] - - return $ PageContent title headAll (case jsLoader master of - BottomOfBody -> bodyScript - _ -> body) - where - renderLoc' render' (Local url) = render' url [] - renderLoc' _ (Remote s) = s - - addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) - mkScriptTag (Script loc attrs) render' = - foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () - mkLinkTag (Stylesheet loc attrs) render' = - foldl' addAttr TBH.link - ( ("rel", "stylesheet") - : ("href", renderLoc' render' loc) - : attrs - ) - -left :: Either a b -> Maybe a -left (Left x) = Just x -left _ = Nothing - -right :: Either a b -> Maybe b -right (Right x) = Just x -right _ = Nothing - jsonArray :: [Text] -> Html jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String @@ -679,181 +122,39 @@ $newline never <script>yepnope({load:#{jsonArray scripts}}); |] -asyncHelper :: (url -> [x] -> Text) - -> [Script (url)] - -> Maybe (JavascriptUrl (url)) - -> Maybe Text - -> (Maybe (HtmlUrl url), [Text]) -asyncHelper render scripts jscript jsLoc = - (mcomplete, scripts'') - where - scripts' = map goScript scripts - scripts'' = - case jsLoc of - Just s -> scripts' ++ [s] - Nothing -> scripts' - goScript (Script (Local url) _) = render url [] - goScript (Script (Remote s) _) = s - mcomplete = - case jsLoc of - Just{} -> Nothing - Nothing -> - case jscript of - Nothing -> Nothing - Just j -> Just $ jelper j +-- | This class is automatically instantiated when you use the template haskell +-- mkYesod function. You should never need to deal with it directly. +class YesodDispatch sub master where + yesodDispatch + :: Yesod master + => Logger + -> master + -> sub + -> (Route sub -> Route master) + -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler + -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler + -> Text -- ^ request method + -> [Text] -- ^ pieces + -> Maybe (SessionBackend master) + -> W.Application -yesodRender :: Yesod y - => y - -> ResolvedApproot - -> Route y - -> [(Text, Text)] -- ^ url query string - -> Text -yesodRender y ar url params = - TE.decodeUtf8 $ toByteString $ - fromMaybe - (joinPath y ar ps - $ params ++ params') - (urlRenderOverride y url) - where - (ps, params') = renderRoute url - -resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot -resolveApproot master req = - case approot of - ApprootRelative -> "" - ApprootStatic t -> t - ApprootMaster f -> f master - ApprootRequest f -> f master req - -defaultClientSessionBackend :: Yesod master => IO (SessionBackend master) -defaultClientSessionBackend = do - key <- CS.getKey CS.defaultKeyFile - let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes - (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout - return $ clientSessionBackend key getCachedDate - -clientSessionBackend :: Yesod master - => CS.Key -- ^ The encryption key - -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' - -> SessionBackend master -clientSessionBackend key getCachedDate = - SessionBackend { - sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req - } - -loadClientSession :: Yesod master - => CS.Key - -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' - -> S8.ByteString -- ^ session name - -> master - -> W.Request - -> IO (SessionMap, SaveSession) -loadClientSession key getCachedDate sessionName master req = load - where - load = do - date <- getCachedDate - return (sess date, save date) - sess date = fromMaybe Map.empty $ do - raw <- lookup "Cookie" $ W.requestHeaders req - val <- lookup sessionName $ parseCookies raw - let host = "" -- fixme, properly lock sessions to client address - decodeClientSession key date host val - save date sess' = do - -- We should never cache the IV! Be careful! - iv <- liftIO CS.randomIV - return [AddCookie def - { setCookieName = sessionName - , setCookieValue = encodeClientSession key iv date host sess' - , setCookiePath = Just (cookiePath master) - , setCookieExpires = Just (csdcExpires date) - , setCookieDomain = cookieDomain master - , setCookieHttpOnly = True - }] - where - host = "" -- fixme, properly lock sessions to client address - - --- | Run a 'GHandler' completely outside of Yesod. This --- function comes with many caveats and you shouldn't use it --- unless you fully understand what it's doing and how it works. --- --- As of now, there's only one reason to use this function at --- all: in order to run unit tests of functions inside 'GHandler' --- but that aren't easily testable with a full HTTP request. --- Even so, it's better to use @wai-test@ or @yesod-test@ instead --- of using this function. --- --- This function will create a fake HTTP request (both @wai@'s --- 'W.Request' and @yesod@'s 'Request') and feed it to the --- @GHandler@. The only useful information the @GHandler@ may --- get from the request is the session map, which you must supply --- as argument to @runFakeHandler@. All other fields contain --- fake information, which means that they can be accessed but --- won't have any useful information. The response of the --- @GHandler@ is completely ignored, including changes to the --- session, cookies or headers. We only return you the --- @GHandler@'s return value. -runFakeHandler :: (Yesod master, MonadIO m) => - SessionMap - -> (master -> Logger) - -> master - -> GHandler master master a - -> m (Either ErrorResponse a) -runFakeHandler fakeSessionMap logger master handler = liftIO $ do - ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") - let handler' = do liftIO . I.writeIORef ret . Right =<< handler - return () - let yapp = - runHandler - handler' - (yesodRender master $ resolveApproot master fakeWaiRequest) - Nothing - id - master - master - (fileUpload master) - (messageLoggerSource master $ logger master) - errHandler err req = do - liftIO $ I.writeIORef ret (Left err) - return $ YRPlain - H.status500 - [] - typePlain - (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) - (reqSession req) - fakeWaiRequest = - W.Request - { W.requestMethod = "POST" - , W.httpVersion = H.http11 - , W.rawPathInfo = "/runFakeHandler/pathInfo" - , W.rawQueryString = "" - , W.serverName = "runFakeHandler-serverName" - , W.serverPort = 80 - , W.requestHeaders = [] - , W.isSecure = False - , W.remoteHost = error "runFakeHandler-remoteHost" - , W.pathInfo = ["runFakeHandler", "pathInfo"] - , W.queryString = [] - , W.requestBody = mempty - , W.vault = mempty -#if MIN_VERSION_wai(1, 4, 0) - , W.requestBodyLength = W.KnownLength 0 -#endif - } - fakeRequest = - YesodRequest - { reqGetParams = [] - , reqCookies = [] - , reqWaiRequest = fakeWaiRequest - , reqLangs = [] - , reqToken = Just "NaN" -- not a nonce =) - , reqOnError = errHandler - , reqAccept = [] - , reqSession = fakeSessionMap - } - _ <- runResourceT $ yapp fakeRequest - I.readIORef ret -{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} + yesodRunner :: Yesod master + => Logger + -> GHandler sub master ChooseRep + -> master + -> sub + -> Maybe (Route sub) + -> (Route sub -> Route master) + -> Maybe (SessionBackend master) + -> W.Application + yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv + { yreLogger = logger + , yreMaster = master + , yreSub = sub + , yreRoute = murl + , yreToMaster = tomaster + , yreSessionBackend = msb + } handler instance YesodDispatch WaiSubsite master where yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index c6fc55eb..353f4915 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -52,7 +52,7 @@ import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Handler - ( YesodSubRoute(..), toMasterHandlerMaybe, getYesod + ( YesodSubRoute(..), getYesod , getMessageRender, getUrlRenderParams, MonadLift (..) ) import Text.Shakespeare.I18N (RenderMessage) @@ -78,7 +78,7 @@ addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWi addSubWidget sub (GWidget w) = do master <- lift getYesod let sr = fromSubRoute sub master - (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w + (a, w') <- lift $ error "FIXME Yesod.Widget.toMasterHandlerMaybe" sr (const sub) Nothing w tell w' return a diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 424e3fea..40cddf9e 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -104,6 +104,8 @@ library Yesod.Core.Types Yesod.Core.Time Yesod.Core.Trans.Class + Yesod.Core.Run + Yesod.Core.Class Paths_yesod_core ghc-options: -Wall