.Class and .Run modules

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
+
+<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
+
+-- | 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)" #-}

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

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 (ResourceT, runResourceT)
-import Control.Monad.Trans.Resource
+import Yesod.Routes.Class (Route)
-import Yesod.Routes.Class
-import Language.Haskell.TH.Syntax (Loc)
 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

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 (unsafeLazyByteString)
-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 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 System.Log.FastLogger (Logger)
-import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)
-import System.Log.FastLogger.Date (ZonedDate)
-import System.IO (stdout)
 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)
+-- | This class is automatically instantiated when you use the template haskell
-         -> [Script (url)]
+-- mkYesod function. You should never need to deal with it directly.
-         -> Maybe (JavascriptUrl (url))
+class YesodDispatch sub master where
-         -> Maybe Text
+    yesodDispatch
-         -> (Maybe (HtmlUrl url), [Text])
+        :: Yesod master
-asyncHelper render scripts jscript jsLoc =
+        => Logger
-    (mcomplete, scripts'')
+        -> master
-  where
+        -> sub
-    scripts' = map goScript scripts
+        -> (Route sub -> Route master)
-    scripts'' =
+        -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
-        case jsLoc of
+        -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
-            Just s -> scripts' ++ [s]
+        -> Text -- ^ request method
-            Nothing -> scripts'
+        -> [Text] -- ^ pieces
-    goScript (Script (Local url) _) = render url []
+        -> Maybe (SessionBackend master)
-    goScript (Script (Remote s) _) = s
+        -> W.Application
-    mcomplete =
-        case jsLoc of
-            Just{} -> Nothing
-            Nothing ->
-                case jscript of
-                    Nothing -> Nothing
-                    Just j -> Just $ jelper j
 
-yesodRender :: Yesod y
+    yesodRunner :: Yesod master
-            => y
+                => Logger
-            -> ResolvedApproot
+                -> GHandler sub master ChooseRep
-            -> Route y
+                -> master
-            -> [(Text, Text)] -- ^ url query string
+                -> sub
-            -> Text
+                -> Maybe (Route sub)
-yesodRender y ar url params =
+                -> (Route sub -> Route master)
-    TE.decodeUtf8 $ toByteString $
+                -> Maybe (SessionBackend master)
-    fromMaybe
+                -> W.Application
-        (joinPath y ar ps
+    yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv
-          $ params ++ params')
+        { yreLogger = logger
-        (urlRenderOverride y url)
+        , yreMaster = master
-  where
+        , yreSub = sub
-    (ps, params') = renderRoute url
+        , yreRoute = murl
-
+        , yreToMaster = tomaster
-resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot
+        , yreSessionBackend = msb
-resolveApproot master req =
+        } handler
-    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." #-}
 
 instance YesodDispatch WaiSubsite master where
     yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app

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
 

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