Merge remote-tracking branch 'origin/yesod1.2'

Conflicts:
	yesod-auth/Yesod/Auth.hs
	yesod-auth/yesod-auth.cabal
	yesod-core/yesod-core.cabal
	yesod-static/Yesod/Static.hs
	yesod-static/yesod-static.cabal
	yesod/yesod.cabal

.gitignore

@@ -7,3 +7,5 @@ client_session_key.aes
 cabal-dev/
 yesod/foobar/
 .virthualenv
+/vendor/
+/.shelly/

.travis.yml

@@ -1,7 +1,13 @@
 language: haskell
 
 install:
+    - cabal update
     - cabal install mega-sdist hspec cabal-meta cabal-src
-    - cabal-meta install --force-reinstalls
+    - git clone https://github.com/snoyberg/tagstream-conduit.git
+    - cd tagstream-conduit
+    - cabal-src-install --src-only
+    - cd ..
+    - cabal-meta install --force-reinstalls --enable-tests
 
-script: mega-sdist --test
+script:
+    - echo Done

demo/appcache/AppCache.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module AppCache where
+
+import           Control.Monad              (when)
+import           Control.Monad.Trans.Writer
+import           Data.Hashable              (hashWithSalt)
+import           Data.List                  (intercalate)
+import qualified Data.Set                   as Set
+import           Data.Text                  (Text)
+import           Data.Text                  (pack)
+import           Language.Haskell.TH.Syntax
+import           Yesod.Core
+import           Yesod.Routes.TH
+
+newtype AppCache = AppCache { unAppCache :: Text }
+
+appCache :: [ResourceTree String] -> Q Exp
+appCache trees = do
+    piecesSet <- execWriterT $ mapM_ (goTree id) trees
+    let body = unlines $ map toPath $ Set.toList piecesSet
+        hash = hashWithSalt 0 body
+        total = concat
+            [ "CACHE MANIFEST\n# Version: "
+            , show hash
+            , "\n\nCACHE:\n"
+            , body
+            ]
+    [|return (AppCache (pack total))|]
+  where
+    toPath [] = "/"
+    toPath x = concatMap ('/':) x
+
+goTree :: Monad m
+       => ([String] -> [String])
+       -> ResourceTree String
+       -> WriterT (Set.Set [String]) m ()
+goTree front (ResourceLeaf res) = do
+    pieces' <- goPieces (resourceName res) $ resourcePieces res
+    when ("CACHE" `elem` resourceAttrs res) $
+        tell $ Set.singleton $ front pieces'
+goTree front (ResourceParent name pieces trees) = do
+    pieces' <- goPieces name pieces
+    mapM_ (goTree $ front . (pieces' ++)) trees
+
+goPieces :: Monad m => String -> [(CheckOverlap, Piece String)] -> m [String]
+goPieces name =
+    mapM (goPiece . snd)
+  where
+    goPiece (Static s) = return s
+    goPiece (Dynamic _) = fail $ concat
+        [ "AppCache only applies to fully-static paths, but "
+        , name
+        , " has dynamic pieces."
+        ]
+
+instance ToContent AppCache where
+    toContent = toContent . unAppCache
+instance ToTypedContent AppCache where
+    toTypedContent = TypedContent "text/cache-manifest" . toContent

demo/appcache/Main.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+import           AppCache
+import           Routes
+import           Yesod.Core
+
+instance Yesod App
+
+mkYesodDispatch "App" resourcesApp
+
+getHomeR :: Handler String
+getHomeR = return "Hello"
+
+getSomethingR :: Handler String
+getSomethingR = return "Hello"
+
+getAppCacheR :: Handler AppCache
+getAppCacheR = $(appCache resourcesApp)
+
+main :: IO ()
+main = warp 3000 App

demo/appcache/Routes.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Routes where
+
+import           Yesod.Core
+
+data App = App
+
+mkYesodData "App" [parseRoutes|
+/ HomeR GET
+/some/thing SomethingR GET !CACHE
+/appcache AppCacheR GET
+|]

demo/lite/lite.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Yesod.Core
+import Data.Aeson
+import Data.Monoid ((<>))
+import Data.Text (Text, pack)
+
+people :: [(Text, Int)]
+people = [("Alice", 25), ("Bob", 43), ("Charlie", 37)]
+
+main = warp 3000 $ liteApp $ do
+    onStatic "people" $ dispatchTo getPeople
+    onStatic "person" $ withDynamic $ dispatchTo . getPerson
+
+getPeople = return $ toJSON $ map fst people
+
+getPerson name =
+    case lookup name people of
+        Nothing -> notFound
+        Just age -> selectRep $ do
+            provideRep $ return $ object ["name" .= name, "age" .= age]
+            provideRep $ return $ name <> " is " <> pack (show age) <> " years old"

demo/streaming-db/streaming-db.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE EmptyDataDecls    #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE GADTs             #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeFamilies      #-}
+import           Control.Monad.Logger    (runNoLoggingT)
+import           Data.Conduit            (awaitForever, runResourceT, ($=))
+import           Data.Text               (Text)
+import           Database.Persist.Sqlite (ConnectionPool, SqlPersist,
+                                          SqliteConf (..), runMigration,
+                                          runSqlPool)
+import           Database.Persist.Store  (createPoolConfig)
+import           Yesod.Core
+import           Yesod.Persist
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
+Person
+    name Text
+|]
+
+data App = App
+    { appConfig :: SqliteConf
+    , appPool   :: ConnectionPool
+    }
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App
+instance YesodPersist App where
+    type YesodPersistBackend App = SqlPersist
+    runDB = defaultRunDB appConfig appPool
+instance YesodPersistRunner App where
+    getDBRunner = defaultGetDBRunner appPool
+
+getHomeR :: Handler TypedContent
+getHomeR = do
+    runDB $ do
+        runMigration migrateAll
+        deleteWhere ([] :: [Filter Person])
+        insert_ $ Person "Charlie"
+        insert_ $ Person "Alice"
+        insert_ $ Person "Bob"
+    respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder
+  where
+    toBuilder (Entity _ (Person name)) = do
+        sendChunkText name
+        sendChunkText "\n"
+        sendFlush
+
+main :: IO ()
+main = do
+    let config = SqliteConf ":memory:" 1
+    pool <- createPoolConfig config
+    runNoLoggingT $ runResourceT $ flip runSqlPool pool $ do
+        runMigration migrateAll
+        deleteWhere ([] :: [Filter Person])
+        insert_ $ Person "Charlie"
+        insert_ $ Person "Alice"
+        insert_ $ Person "Bob"
+    warp 3000 App
+        { appConfig = config
+        , appPool = pool
+        }

demo/streaming/streaming.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}
+import Yesod.Core
+import Data.Conduit
+import qualified Data.Conduit.Binary as CB
+import Control.Concurrent.Lifted (threadDelay)
+import Data.Monoid ((<>))
+import qualified Data.Text as T
+import Control.Monad (forM_)
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod App
+
+fibs :: [Int]
+fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
+
+getHomeR :: Handler TypedContent
+getHomeR = do
+    value <- lookupGetParam "x"
+    case value of
+        Just "file" -> respondSource typePlain $ do
+            sendChunkText "Going to read a file\n\n"
+            CB.sourceFile "streaming.hs" $= awaitForever sendChunkBS
+            sendChunkText "Finished reading the file\n"
+        Just "fibs" -> respondSource typePlain $ do
+            forM_ fibs $ \fib -> do
+                $logError $ "Got fib: " <> T.pack (show fib)
+                sendChunkText $ "Next fib is: " <> T.pack (show fib) <> "\n"
+                yield Flush
+                sendFlush
+                threadDelay 1000000
+        _ -> fmap toTypedContent $ defaultLayout $ do
+            setTitle "Streaming"
+            [whamlet|
+                <p>Notice how in the code above we perform selection before starting the stream.
+                <p>Anyway, choose one of the options below.
+                <ul>
+                    <li>
+                        <a href=?x=file>Read a file
+                    <li>
+                        <a href=?x=fibs>See the fibs
+            |]
+
+main = warp 3000 App

demo/subsite/Main.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Main where
+
+import           Control.Applicative ((<$>))
+import           Wiki
+import           Yesod
+
+-- A very simple App, doesn't do anything except provide the Wiki.
+data App = App
+    { appWiki :: Wiki
+    }
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+/wiki WikiR Wiki appWiki
+|]
+
+instance Yesod App
+instance YesodWiki App -- Just use the defaults
+instance RenderMessage App FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+getHomeR :: Handler Html
+getHomeR = defaultLayout
+    [whamlet|
+        <p>
+            Welcome to my test application.
+            The application is pretty boring.
+            You probably want to go to
+            <a href=@{WikiR WikiHomeR}>the wiki#
+            .
+    |]
+
+main :: IO ()
+main = do
+    app <- App <$> newWiki
+    warp 3000 app

demo/subsite/Wiki.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | Define the dispatch for a Wiki. You should probably start off by reading
+-- WikiRoutes.
+module Wiki
+    ( module WikiRoutes
+    ) where
+
+import           Control.Applicative ((<$>))
+import           Control.Monad       (unless)
+import           Data.IORef.Lifted   (readIORef, atomicModifyIORef)
+import           Data.Map            (Map)
+import qualified Data.Map            as Map
+import           Data.Text           (Text)
+import           WikiRoutes
+import           Yesod
+
+-- | A subsite needs to be an instance of YesodSubDispatch, which states how to
+-- dispatch. By using constraints, we can make requirements of our master site.
+-- In this example, we're saying that the master site must be an instance of
+-- YesodWiki.
+instance YesodWiki master => YesodSubDispatch Wiki (HandlerT master IO) where
+    -- | This is all the TH magic for dispatch. WikiRoutes provides the
+    -- resourcesWiki value automatically, and mkYesodSubDispatch will generate
+    -- a dispatch function that will call out to the appropriate handler
+    -- functions.
+    yesodSubDispatch = $(mkYesodSubDispatch resourcesWiki)
+
+-- | Helper type synonym to be used below.
+type WikiHandler a = forall master. YesodWiki master
+                  => HandlerT Wiki (HandlerT master IO) a
+
+------------- Helper functions
+
+-- | Get all of the content in the Wiki.
+getContent :: WikiHandler (Map Texts Textarea)
+getContent = getYesod >>= readIORef . wikiContent
+
+-- | Put a single new value into the Wiki.
+putContent :: Texts -> Textarea -> WikiHandler ()
+putContent k v = do
+    refMap <- wikiContent <$> getYesod
+    atomicModifyIORef refMap $ \m -> (Map.insert k v m, ())
+
+-- | Gets the homepage, which lists all of the pages available.
+getWikiHomeR :: WikiHandler TypedContent
+getWikiHomeR = do
+    content <- getContent
+    -- We use the new selectRep/provideRep functionality to provide either an
+    -- HTML or JSON representation of the page. You could just as easily
+    -- provide YAML, plain text, RSS, or anything else.
+    selectRep $ do
+        provideRep $ do
+            -- We'll use toParent to convert Wiki routes into our master site
+            -- routes.
+            toParent <- getRouteToParent
+
+            -- Run the master site's defaultLayout to style the page.
+            lift $ defaultLayout
+                [whamlet|
+                    <p>This wiki has the following pages:
+                    <ul>
+                        $forall page <- Map.keys content
+                            <li>
+                                -- Notice the usage of toParent!
+                                <a href=@{toParent $ WikiReadR page}>#{show page}
+                |]
+        -- You provide a JSON representation just by returning a JSON value.
+        -- aeson's toJSON make it easy to convert a list of values into JSON.
+        provideRep $ return $ toJSON $ Map.keys content
+
+getWikiReadR :: Texts -> WikiHandler TypedContent
+getWikiReadR page = do
+    content <- getContent
+    selectRep $ do
+        provideRep $
+            case Map.lookup page content of
+                Nothing -> do
+                    setMessage $ "Page does not exist, please create it."
+
+                    -- We don't need to convert or lift here: we're using a
+                    -- route from our subsite, and redirect lives in our
+                    -- subsite.
+                    redirect $ WikiEditR page
+                Just t -> do
+                    toParent <- getRouteToParent
+
+                    -- Notice that we lift the canEditPage function from the
+                    -- master site.
+                    canEdit <- lift $ canEditPage page
+
+                    lift $ defaultLayout
+                        [whamlet|
+                            <article>#{t}
+                            $if canEdit
+                                <p>
+                                    <a href=@{toParent $ WikiEditR page}>Edit
+                        |]
+        provideRep $ return $ toJSON $
+            case Map.lookup page content of
+                -- Our HTML representation sends a redirect if the page isn't
+                -- found, but our JSON representation just returns a JSON value
+                -- instead.
+                Nothing -> object ["error" .= ("Page not found" :: Text)]
+                Just (Textarea t) -> object ["content" .= t]
+
+getWikiEditR :: Texts -> WikiHandler Html
+getWikiEditR page = do
+    canEdit <- lift $ canEditPage page
+    unless canEdit $ permissionDenied "You do not have permissions to edit this page."
+
+    content <- getContent
+    let form = renderTable
+             $ areq textareaField "Content" (Map.lookup page content)
+
+    -- We need to use lift here since the widget will be used below.
+    -- Practically speaking, this means that we'll be rendering form messages
+    -- using the master site's translation functions.
+    ((res, widget), enctype) <- lift $ runFormPost form
+
+    case res of
+        FormSuccess t -> do
+            putContent page t
+            setMessage "Content updated"
+            redirect $ WikiEditR page
+        _ -> do
+            toParent <- getRouteToParent
+            lift $ defaultLayout
+                [whamlet|
+                    <p>
+                        <a href=@{toParent $ WikiReadR page}>Read page
+                    <form method=post action=@{toParent $ WikiEditR page} enctype=#{enctype}>
+                        <table>
+                            ^{widget}
+                            <tr>
+                                <td colspan=2>
+                                    <button>Update page
+                |]
+
+postWikiEditR :: Texts -> WikiHandler Html
+postWikiEditR = getWikiEditR

demo/subsite/WikiRoutes.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+-- | Define our Wiki data type, routes, and the YesodWiki typeclass. Due to the
+-- GHC stage restriction, the routes must be declared in a separate module from
+-- our dispatch instance.
+module WikiRoutes where
+
+import           Control.Monad          (liftM)
+import           Control.Monad.IO.Class (MonadIO)
+import           Data.IORef             (IORef, newIORef)
+import           Data.Map               (Map, empty)
+import           Yesod
+
+-- | Simple Wiki datatype: just store a Map from Wiki path to the contents of
+-- the page.
+data Wiki = Wiki
+    { wikiContent :: IORef (Map Texts Textarea)
+    }
+
+-- | A typeclass that all master sites that want a Wiki must implement. A
+-- master must be able to render form messages, as we use yesod-forms for
+-- processing user input.
+class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where
+    -- | Write protection. By default, no protection.
+    canEditPage :: Texts -> HandlerT master IO Bool
+    canEditPage _ = return True
+
+-- | Define our routes. We'll have a homepage that lists all of the pages, a
+-- read route for reading a page, and an edit route.
+mkYesodSubData "Wiki" [parseRoutes|
+/ WikiHomeR GET
+/read/*Texts WikiReadR GET
+/edit/*Texts WikiEditR GET POST
+|]
+
+-- | A convenience function for creating an empty Wiki.
+newWiki :: MonadIO m => m Wiki
+newWiki = Wiki `liftM` liftIO (newIORef empty)

sources.txt

@@ -1,12 +1,12 @@
 ./yesod-routes
 ./yesod-core
-./yesod-json
 ./yesod-static
 ./yesod-persistent
 ./yesod-newsfeed
 ./yesod-form
 ./yesod-auth
 ./yesod-sitemap
-./yesod-default
 ./yesod-test
+./yesod-bin
 ./yesod
+https://github.com/yesodweb/persistent persistent1.2

yesod-auth/Yesod/Auth.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -15,6 +17,8 @@ module Yesod.Auth
     , AuthPlugin (..)
     , getAuth
     , YesodAuth (..)
+    , YesodAuthPersist
+    , AuthEntity
       -- * Plugin interface
     , Creds (..)
     , setCreds
@@ -26,11 +30,14 @@ module Yesod.Auth
     , requireAuth
       -- * Exception
     , AuthException (..)
+      -- * Helper
+    , AuthHandler
     ) where
 
-import Control.Monad                 (when)  
+import Control.Monad                 (when)
 import Control.Monad.Trans.Maybe
 
+import Yesod.Auth.Routes
 import Data.Aeson
 import Data.Text.Encoding (decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
@@ -39,31 +46,28 @@ import qualified Data.Text as T
 import qualified Data.HashMap.Lazy as Map
 import Network.HTTP.Conduit (Manager)
 
-import Language.Haskell.TH.Syntax hiding (lift)
-
 import qualified Network.Wai as W
 import Text.Hamlet (shamlet)
 
 import Yesod.Core
 import Yesod.Persist
-import Yesod.Json
 import Yesod.Auth.Message (AuthMessage, defaultMessage)
 import qualified Yesod.Auth.Message as Msg
 import Yesod.Form (FormMessage)
 import Data.Typeable (Typeable)
 import Control.Exception (Exception)
 
-data Auth = Auth
-
 type AuthRoute = Route Auth
 
+type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a
+
 type Method = Text
 type Piece = Text
 
 data AuthPlugin master = AuthPlugin
     { apName :: Text
-    , apDispatch :: Method -> [Piece] -> GHandler Auth master ()
+    , apDispatch :: Method -> [Piece] -> AuthHandler master ()
-    , apLogin :: forall sub. (Route Auth -> Route master) -> GWidget sub master ()
+    , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
     }
 
 getAuth :: a -> Auth
@@ -88,23 +92,25 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     logoutDest :: master -> Route master
 
     -- | Determine the ID associated with the set of credentials.
-    getAuthId :: Creds master -> GHandler sub master (Maybe (AuthId master))
+    getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))
 
     -- | Which authentication backends to use.
     authPlugins :: master -> [AuthPlugin master]
 
     -- | What to show on the login page.
-    loginHandler :: GHandler Auth master RepHtml
+    loginHandler :: AuthHandler master RepHtml
-    loginHandler = defaultLayout $ do
+    loginHandler = do
-        setTitleI Msg.LoginTitle
+        tp <- getRouteToParent
-        tm <- lift getRouteToMaster
+        lift $ defaultLayout $ do
-        master <- lift getYesod
+            setTitleI Msg.LoginTitle
-        mapM_ (flip apLogin tm) (authPlugins master)
+            master <- getYesod
+            mapM_ (flip apLogin tp) (authPlugins master)
 
     -- | Used for i18n of messages provided by this package.
     renderAuthMessage :: master
                       -> [Text] -- ^ languages
-                      -> AuthMessage -> Text
+                      -> AuthMessage
+                      -> Text
     renderAuthMessage _ _ = defaultMessage
 
     -- | After login and logout, redirect to the referring page, instead of
@@ -120,11 +126,11 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
 
     -- | Called on a successful login. By default, calls
     -- @setMessageI NowLoggedIn@.
-    onLogin :: GHandler sub master ()
+    onLogin :: HandlerT master IO ()
     onLogin = setMessageI Msg.NowLoggedIn
 
     -- | Called on logout. By default, does nothing
-    onLogout :: GHandler sub master ()
+    onLogout :: HandlerT master IO ()
     onLogout = return ()
 
     -- | Retrieves user credentials, if user is authenticated.
@@ -135,8 +141,20 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     -- especially useful for creating an API to be accessed via some means
     -- other than a browser.
     --
-    -- Since 1.1.2
+    -- Since 1.2.0
-    maybeAuthId :: GHandler sub master (Maybe (AuthId master))
+    maybeAuthId :: HandlerT master IO (Maybe (AuthId master))
+
+    default maybeAuthId
+        :: ( YesodAuth master
+           , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
+           , b ~ YesodPersistBackend master
+           , Key val ~ AuthId master
+           , PersistStore (b (HandlerT master IO))
+           , PersistEntity val
+           , YesodPersist master
+           , Typeable val
+           )
+        => HandlerT master IO (Maybe (AuthId master))
     maybeAuthId = defaultMaybeAuthId
 
 credsKey :: Text
@@ -144,50 +162,80 @@ credsKey = "_ID"
 
 -- | Retrieves user credentials from the session, if user is authenticated.
 --
+-- This function does /not/ confirm that the credentials are valid, see
+-- 'maybeAuthIdRaw' for more information.
+--
 -- Since 1.1.2
-defaultMaybeAuthId :: YesodAuth master
+defaultMaybeAuthId
-                   => GHandler sub master (Maybe (AuthId master))
+          :: ( YesodAuth master
+             , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
+             , b ~ YesodPersistBackend master
+             , Key val ~ AuthId master
+             , PersistStore (b (HandlerT master IO))
+             , PersistEntity val
+             , YesodPersist master
+             , Typeable val
+             ) => HandlerT master IO (Maybe (AuthId master))
 defaultMaybeAuthId = do
     ms <- lookupSession credsKey
     case ms of
         Nothing -> return Nothing
-        Just s -> return $ fromPathPiece s
+        Just s ->
+            case fromPathPiece s of
+                Nothing -> return Nothing
+                Just aid -> fmap (fmap entityKey) $ cachedAuth aid
 
-mkYesodSub "Auth"
+cachedAuth :: ( YesodAuth master
-    [ ClassP ''YesodAuth [VarT $ mkName "master"]
+             , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
-    ]
+             , b ~ YesodPersistBackend master
-#define STRINGS *Texts
+             , Key val ~ AuthId master
-    [parseRoutes|
+             , PersistStore (b (HandlerT master IO))
-/check                 CheckR      GET
+             , PersistEntity val
-/login                 LoginR      GET
+             , YesodPersist master
-/logout                LogoutR     GET POST
+             , Typeable val
-/page/#Text/STRINGS PluginR
+             ) => AuthId master -> HandlerT master IO (Maybe (Entity val))
-|]
+cachedAuth aid = runMaybeT $ do
+    a <- MaybeT $ fmap unCachedMaybeAuth
+                $ cached
+                $ fmap CachedMaybeAuth
+                $ runDB
+                $ get aid
+    return $ Entity aid a
 
 -- | Sets user credentials for the session after checking them with authentication backends.
 setCreds :: YesodAuth master
          => Bool         -- ^ if HTTP redirects should be done
          -> Creds master -- ^ new credentials
-         -> GHandler sub master ()
+         -> HandlerT master IO ()
 setCreds doRedirects creds = do
     y    <- getYesod
     maid <- getAuthId creds
     case maid of
-        Nothing ->
+        Nothing -> when doRedirects $ do
-          when doRedirects $ do
             case authRoute y of
-              Nothing -> do rh <- defaultLayout $ toWidget [shamlet|
+                Nothing -> do
-$newline never
+                    res <- selectRep $ do
-<h1>Invalid login
+                        provideRep $ defaultLayout $ toWidget [shamlet|<h1>Invalid login|]
-|]
+                        provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
-                            sendResponse rh
+                    sendResponse res
-              Just ar -> do setMessageI Msg.InvalidLogin
+                Just ar -> do
-                            redirect ar
+                    res <- selectRep $ do
+                        provideRepType typeHtml $ do
+                            setMessageI Msg.InvalidLogin
+                            _ <- redirect ar
+                            return ()
+                        provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
+                    sendResponse res
         Just aid -> do
             setSession credsKey $ toPathPiece aid
             when doRedirects $ do
               onLogin
-              redirectUltDest $ loginDest y
+              res <- selectRep $ do
+                  provideRepType typeHtml $ do
+                      _ <- redirectUltDest $ loginDest y
+                      return ()
+                  provideRep $ return $ object ["message" .= ("Login Successful" :: Text)]
+              sendResponse res
 
 -- | Clears current user credentials for the session.
 --
@@ -202,12 +250,12 @@ clearCreds doRedirects = do
         onLogout
         redirectUltDest $ logoutDest y
 
-getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson
+getCheckR :: AuthHandler master TypedContent
-getCheckR = do
+getCheckR = lift $ do
     creds <- maybeAuthId
     defaultLayoutJson (do
         setTitle "Authentication Status"
-        toWidget $ html' creds) (jsonCreds creds)
+        toWidget $ html' creds) (return $ jsonCreds creds)
   where
     html' creds =
         [shamlet|
@@ -223,25 +271,32 @@ $nothing
             [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
             ]
 
-setUltDestReferer' :: YesodAuth master => GHandler sub master ()
+setUltDestReferer' :: AuthHandler master ()
-setUltDestReferer' = do
+setUltDestReferer' = lift $ do
     master <- getYesod
     when (redirectToReferer master) setUltDestReferer
 
-getLoginR :: YesodAuth master => GHandler Auth master RepHtml
+getLoginR :: AuthHandler master RepHtml
 getLoginR = setUltDestReferer' >> loginHandler
 
-getLogoutR :: YesodAuth master => GHandler Auth master ()
+getLogoutR :: AuthHandler master ()
-getLogoutR = do
+getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
-    tm <- getRouteToMaster
-    setUltDestReferer' >> redirectToPost (tm LogoutR)
 
+<<<<<<< HEAD
 postLogoutR :: YesodAuth master => GHandler Auth master ()
 postLogoutR = clearCreds True
+=======
+postLogoutR :: AuthHandler master ()
+postLogoutR = lift $ do
+    y <- getYesod
+    deleteSession credsKey
+    onLogout
+    redirectUltDest $ logoutDest y
+>>>>>>> origin/yesod1.2
 
-handlePluginR :: YesodAuth master => Text -> [Text] -> GHandler Auth master ()
+handlePluginR :: Text -> [Text] -> AuthHandler master ()
 handlePluginR plugin pieces = do
-    master <- getYesod
+    master <- lift getYesod
     env <- waiRequest
     let method = decodeUtf8With lenientDecode $ W.requestMethod env
     case filter (\x -> apName x == plugin) (authPlugins master) of
@@ -249,45 +304,58 @@ handlePluginR plugin pieces = do
         ap:_ -> apDispatch ap method pieces
 
 maybeAuth :: ( YesodAuth master
-#if MIN_VERSION_persistent(1, 1, 0)
+             , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
-             , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val
              , b ~ YesodPersistBackend master
              , Key val ~ AuthId master
-             , PersistStore (b (GHandler sub master))
+             , PersistStore (b (HandlerT master IO))
-#else
-             , b ~ YesodPersistBackend master
-             , b ~ PersistEntityBackend val
-             , Key b val ~ AuthId master
-             , PersistStore b (GHandler sub master)
-#endif
              , PersistEntity val
              , YesodPersist master
-             ) => GHandler sub master (Maybe (Entity val))
+             , Typeable val
+             ) => HandlerT master IO (Maybe (Entity val))
 maybeAuth = runMaybeT $ do
-    aid <- MaybeT $ maybeAuthId
+    aid <- MaybeT maybeAuthId
-    a   <- MaybeT $ runDB $ get aid
+    MaybeT $ cachedAuth aid
-    return $ Entity aid a
 
-requireAuthId :: YesodAuth master => GHandler sub master (AuthId master)
+newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
+    deriving Typeable
+
+-- | Constraint which states that the given site is an instance of @YesodAuth@
+-- and that its @AuthId@ is in fact a persistent @Key@ for the given value.
+-- This is the common case in Yesod, and means that you can easily look up the
+-- full informatin on a given user.
+--
+-- Since 1.2.0
+type YesodAuthPersist master =
+    ( YesodAuth master
+    , PersistMonadBackend (YesodPersistBackend master (HandlerT master IO))
+        ~ PersistEntityBackend (AuthEntity master)
+    , Key (AuthEntity master) ~ AuthId master
+    , PersistStore (YesodPersistBackend master (HandlerT master IO))
+    , PersistEntity (AuthEntity master)
+    , YesodPersist master
+    , Typeable (AuthEntity master)
+    )
+
+-- | If the @AuthId@ for a given site is a persistent ID, this will give the
+-- value for that entity. E.g.:
+--
+-- > type AuthId MySite = UserId
+-- > AuthEntity MySite ~ User
+--
+-- Since 1.2.0
+type AuthEntity master = KeyEntity (AuthId master)
+
+-- | Similar to 'maybeAuthId', but redirects to a login page if user is not
+-- authenticated.
+--
+-- Since 1.1.0
+requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master)
 requireAuthId = maybeAuthId >>= maybe redirectLogin return
 
-requireAuth :: ( YesodAuth master
+requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master))
-               , b ~ YesodPersistBackend master
-#if MIN_VERSION_persistent(1, 1, 0)
-               , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val
-               , Key val ~ AuthId master
-               , PersistStore (b (GHandler sub master))
-#else
-               , b ~ PersistEntityBackend val
-               , Key b val ~ AuthId master
-               , PersistStore b (GHandler sub master)
-#endif
-               , PersistEntity val
-               , YesodPersist master
-               ) => GHandler sub master (Entity val)
 requireAuth = maybeAuth >>= maybe redirectLogin return
 
-redirectLogin :: Yesod master => GHandler sub master a
+redirectLogin :: Yesod master => HandlerT master IO a
 redirectLogin = do
     y <- getYesod
     setUltDestCurrent
@@ -302,3 +370,6 @@ data AuthException = InvalidBrowserIDAssertion
                    | InvalidFacebookResponse
     deriving (Show, Typeable)
 instance Exception AuthException
+
+instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
+    yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
 module Yesod.Auth.BrowserId
     ( authBrowserId
-    , authBrowserIdAudience
     , createOnClick
+    , def
+    , BrowserIdSettings
+    , bisAudience
+    , bisLazyLoad
     ) where
 
 import Yesod.Auth
@@ -14,14 +18,13 @@ import Yesod.Core
 import Text.Hamlet (hamlet)
 import qualified Data.Text as T
 import Data.Maybe (fromMaybe)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad (when, unless)
-import Control.Monad (when)
 import Control.Exception (throwIO)
 import Text.Julius (julius, rawJS)
-import Data.Aeson (toJSON)
 import Network.URI (uriPath, parseURI)
 import Data.FileEmbed (embedFile)
 import Data.ByteString (ByteString)
+import Data.Default
 
 pid :: Text
 pid = "browserid"
@@ -29,38 +32,50 @@ pid = "browserid"
 complete :: Route Auth
 complete = PluginR pid []
 
--- | Log into browser ID with an audience value determined from the 'approot'.
+-- | A settings type for various configuration options relevant to BrowserID.
-authBrowserId :: YesodAuth m => AuthPlugin m
+--
-authBrowserId = helper Nothing
+-- See: <http://www.yesodweb.com/book/settings-types>
+--
+-- Since 1.2.0
+data BrowserIdSettings = BrowserIdSettings
+    { bisAudience :: Maybe Text
+    -- ^ BrowserID audience value. If @Nothing@, will be extracted based on the
+    -- approot.
+    --
+    -- Default: @Nothing@
+    --
+    -- Since 1.2.0
+    , bisLazyLoad :: Bool
+    -- ^ Use asynchronous Javascript loading for the BrowserID JS file.
+    --
+    -- Default: @True@.
+    --
+    -- Since 1.2.0
+    }
 
--- | Log into browser ID with the given audience value. Note that this must be
+instance Default BrowserIdSettings where
--- your actual hostname, or login will fail.
+    def = BrowserIdSettings
-authBrowserIdAudience
+        { bisAudience = Nothing
-    :: YesodAuth m
+        , bisLazyLoad = True
-    => Text -- ^ audience
+        }
-    -> AuthPlugin m
-authBrowserIdAudience = helper . Just
 
-helper :: YesodAuth m
+authBrowserId :: YesodAuth m => BrowserIdSettings -> AuthPlugin m
-       => Maybe Text -- ^ audience
+authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
-       -> AuthPlugin m
-helper maudience = AuthPlugin
     { apName = pid
     , apDispatch = \m ps ->
         case (m, ps) of
             ("GET", [assertion]) -> do
-                master <- getYesod
+                master <- lift getYesod
                 audience <-
-                    case maudience of
+                    case bisAudience of
                         Just a -> return a
                         Nothing -> do
-                            tm <- getRouteToMaster
                             r <- getUrlRender
-                            return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
+                            return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR
                 memail <- lift $ checkAssertion audience assertion (authHttpManager master)
                 case memail of
                     Nothing -> liftIO $ throwIO InvalidBrowserIDAssertion
-                    Just email -> setCreds True Creds
+                    Just email -> lift $ setCreds True Creds
                         { credsPlugin = pid
                         , credsIdent = email
                         , credsExtra = []
@@ -72,12 +87,10 @@ helper maudience = AuthPlugin
             (_, []) -> badMethod
             _ -> notFound
     , apLogin = \toMaster -> do
-        onclick <- createOnClick toMaster
+        onclick <- createOnClick bis toMaster
 
-        autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin"
+        autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
-        when autologin $ toWidget [julius|
+        when autologin $ toWidget [julius|#{rawJS onclick}();|]
-#{rawJS onclick}();
-|]
 
         toWidget [hamlet|
 $newline never
@@ -92,29 +105,45 @@ $newline never
 
 -- | Generates a function to handle on-click events, and returns that function
 -- name.
-createOnClick :: (Route Auth -> Route master) -> GWidget sub master Text
+createOnClick :: BrowserIdSettings
-createOnClick toMaster = do
+              -> (Route Auth -> Route master)
-    addScriptRemote browserIdJs
+              -> WidgetT master IO Text
-    onclick <- lift newIdent
+createOnClick BrowserIdSettings {..} toMaster = do
-    render <- lift getUrlRender
+    unless bisLazyLoad $ addScriptRemote browserIdJs
+    onclick <- newIdent
+    render <- getUrlRender
     let login = toJSON $ getPath $ render (toMaster LoginR)
     toWidget [julius|
         function #{rawJS onclick}() {
-            navigator.id.watch({
+            if (navigator.id) {
-                onlogin: function (assertion) {
+                navigator.id.watch({
-                    if (assertion) {
+                    onlogin: function (assertion) {
-                        document.location = "@{toMaster complete}/" + assertion;
+                        if (assertion) {
-                    }
+                            document.location = "@{toMaster complete}/" + assertion;
-                },
+                        }
-                onlogout: function () {}
+                    },
-            });
+                    onlogout: function () {}
-            navigator.id.request({
+                });
-                returnTo: #{login} + "?autologin=true"
+                navigator.id.request({
-            });
+                    returnTo: #{login} + "?autologin=true"
+                });
+            }
+            else {
+                alert("Loading, please try again");
+            }
         }
     |]
+    when bisLazyLoad $ toWidget [julius|
+        (function(){
+            var bid = document.createElement("script");
+            bid.async = true;
+            bid.src = #{toJSON browserIdJs};
+            var s = document.getElementsByTagName('script')[0];
+            s.parentNode.insertBefore(bid, s);
+        })();
+    |]
 
-    autologin <- fmap (== Just "true") $ lift $ lookupGetParam "autologin"
+    autologin <- fmap (== Just "true") $ lookupGetParam "autologin"
     when autologin $ toWidget [julius|#{rawJS onclick}();|]
     return onclick
   where

yesod-auth/Yesod/Auth/Dummy.hs

@@ -9,17 +9,16 @@ module Yesod.Auth.Dummy
 
 import Yesod.Auth
 import Yesod.Form (runInputPost, textField, ireq)
-import Yesod.Handler (notFound)
 import Text.Hamlet (hamlet)
-import Yesod.Widget (toWidget)
+import Yesod.Core
 
 authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
     dispatch "POST" [] = do
-        ident <- runInputPost $ ireq textField "ident"
+        ident <- lift $ runInputPost $ ireq textField "ident"
-        setCreds True $ Creds "dummy" ident []
+        lift $ setCreds True $ Creds "dummy" ident []
     dispatch _ _ = notFound
     url = PluginR "dummy" []
     login authToMaster =

yesod-auth/Yesod/Auth/Email.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternGuards #-}
 module Yesod.Auth.Email
     ( -- * Plugin
       authEmail
@@ -10,33 +11,40 @@ module Yesod.Auth.Email
       -- * Routes
     , loginR
     , registerR
+    , forgotPasswordR
     , setpassR
     , isValidPass
+      -- * Types
+    , Email
+    , VerKey
+    , VerUrl
+    , SaltedPass
+    , VerStatus
+    , Identifier
     ) where
 
 import Network.Mail.Mime (randomString)
 import Yesod.Auth
 import System.Random
-import Control.Monad (when)
-import Control.Applicative ((<$>), (<*>))
 import Data.Digest.Pure.MD5
-import qualified Data.Text.Lazy as T
 import qualified Data.Text as TS
-import Data.Text.Lazy.Encoding (encodeUtf8)
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TLE
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
 import Data.Text (Text)
+import Yesod.Core
 import qualified Crypto.PasswordStore as PS
-import qualified Data.Text.Encoding as DTE
+import qualified Text.Email.Validate
-
-import Yesod.Form
-import Yesod.Handler
-import Yesod.Content
-import Yesod.Core (PathPiece, fromPathPiece, whamlet, defaultLayout, setTitleI, toPathPiece)
-import Control.Monad.IO.Class (liftIO)
 import qualified Yesod.Auth.Message as Msg
+import Control.Applicative ((<$>), (<*>))
+import Yesod.Form
+import Control.Monad (when)
 
-loginR, registerR, setpassR :: AuthRoute
+loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
 loginR = PluginR "email" ["login"]
 registerR = PluginR "email" ["register"]
+forgotPasswordR = PluginR "email" ["forgot-password"]
 setpassR = PluginR "email" ["set-password"]
 
 verify :: Text -> Text -> AuthRoute -- FIXME
@@ -48,33 +56,86 @@ type VerUrl = Text
 type SaltedPass = Text
 type VerStatus = Bool
 
+-- | An Identifier generalizes an email address to allow users to log in with
+-- some other form of credentials (e.g., username).
+--
+-- Note that any of these other identifiers must not be valid email addresses.
+--
+-- Since 1.2.0
+type Identifier = Text
+
 -- | Data stored in a database for each e-mail address.
-data EmailCreds m = EmailCreds
+data EmailCreds site = EmailCreds
-    { emailCredsId :: AuthEmailId m
+    { emailCredsId :: AuthEmailId site
-    , emailCredsAuthId :: Maybe (AuthId m)
+    , emailCredsAuthId :: Maybe (AuthId site)
     , emailCredsStatus :: VerStatus
     , emailCredsVerkey :: Maybe VerKey
+    , emailCredsEmail :: Email
     }
 
-class (YesodAuth m, PathPiece (AuthEmailId m)) => YesodAuthEmail m where
+class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where
-    type AuthEmailId m
+    type AuthEmailId site
 
-    addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
+    -- | Add a new email address to the database, but indicate that the address
-    sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
+    -- has not yet been verified.
-    getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)
+    --
-    setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()
+    -- Since 1.1.0
-    verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))
+    addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)
-    getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)
+
-    setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()
+    -- | Send an email to the given address to verify ownership.
-    getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))
+    --
-    getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)
+    -- Since 1.1.0
+    sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO ()
+
+    -- | Get the verification key for the given email ID.
+    --
+    -- Since 1.1.0
+    getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey)
+
+    -- | Set the verification key for the given email ID.
+    --
+    -- Since 1.1.0
+    setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
+
+    -- | Verify the email address on the given account.
+    --
+    -- Since 1.1.0
+    verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))
+
+    -- | Get the salted password for the given account.
+    --
+    -- Since 1.1.0
+    getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass)
+
+    -- | Set the salted password for the given account.
+    --
+    -- Since 1.1.0
+    setPassword :: AuthId site -> SaltedPass -> HandlerT site IO ()
+
+    -- | Get the credentials for the given @Identifier@, which may be either an
+    -- email address or some other identification (e.g., username).
+    --
+    -- Since 1.2.0
+    getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site))
+
+    -- | Get the email address for the given email ID.
+    --
+    -- Since 1.1.0
+    getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email)
 
     -- | Generate a random alphanumeric string.
-    randomKey :: m -> IO Text
+    --
+    -- Since 1.1.0
+    randomKey :: site -> IO Text
     randomKey _ = do
         stdgen <- newStdGen
         return $ TS.pack $ fst $ randomString 10 stdgen
 
+    -- | Route to send user to after password has been set correctly.
+    --
+    -- Since 1.2.0
+    afterPasswordRoute :: site -> Route site
+
 authEmail :: YesodAuthEmail m => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch $ \tm ->
@@ -98,6 +159,8 @@ $newline never
   where
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
     dispatch "POST" ["register"] = postRegisterR >>= sendResponse
+    dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
+    dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
     dispatch "GET" ["verify", eid, verkey] =
         case fromPathPiece eid of
             Nothing -> notFound
@@ -107,113 +170,157 @@ $newline never
     dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse
     dispatch _ _ = notFound
 
-getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
+getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getRegisterR = do
-    toMaster <- getRouteToMaster
     email <- newIdent
-    defaultLayout $ do
+    tp <- getRouteToParent
+    lift $ defaultLayout $ do
         setTitleI Msg.RegisterLong
         [whamlet|
-$newline never
+            <p>_{Msg.EnterEmail}
-<p>_{Msg.EnterEmail}
+            <form method="post" action="@{tp registerR}">
-<form method="post" action="@{toMaster registerR}">
+                <div id="registerForm">
-    <label for=#{email}>_{Msg.Email}
+                    <label for=#{email}>_{Msg.Email}:
-    <input ##{email} type="email" name="email" width="150">
+                    <input ##{email} type="email" name="email" width="150">
-    <input type="submit" value=_{Msg.Register}>
+                <button .btn>_{Msg.Register}
-|]
+        |]
 
-postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
+registerHelper :: YesodAuthEmail master
-postRegisterR = do
+               => Bool -- ^ allow usernames?
-    y <- getYesod
+               -> Route Auth
-    email <- runInputPost $ ireq emailField "email"
+               -> HandlerT Auth (HandlerT master IO) Html
-    mecreds <- getEmailCreds email
+registerHelper allowUsername dest = do
-    (lid, verKey) <-
+    y <- lift getYesod
-        case mecreds of
+    midentifier <- lookupPostParam "email"
-            Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)
+    identifier <-
-            Just (EmailCreds lid _ _ Nothing) -> do
+        case midentifier of
-                key <- liftIO $ randomKey y
-                setVerifyKey lid key
-                return (lid, key)
             Nothing -> do
+                lift $ setMessageI Msg.NoIdentifierProvided
+                redirect dest
+            Just x
+                | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
+                    return $ decodeUtf8With lenientDecode x'
+                | allowUsername -> return $ TS.strip x
+                | otherwise -> do
+                    lift $ setMessageI Msg.InvalidEmailAddress
+                    redirect dest
+    mecreds <- lift $ getEmailCreds identifier
+    (lid, verKey, email) <-
+        case mecreds of
+            Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)
+            Just (EmailCreds lid _ _ Nothing email) -> do
                 key <- liftIO $ randomKey y
-                lid <- addUnverified email key
+                lift $ setVerifyKey lid key
-                return (lid, key)
+                return (lid, key, email)
+            Nothing
+                | allowUsername -> do
+                    setMessage $ toHtml $ "No record for that identifier in our database: " `TS.append` identifier
+                    redirect dest
+                | otherwise -> do
+                    key <- liftIO $ randomKey y
+                    lid <- lift $ addUnverified identifier key
+                    return (lid, key, identifier)
     render <- getUrlRender
-    tm <- getRouteToMaster
+    let verUrl = render $ verify (toPathPiece lid) verKey
-    let verUrl = render $ tm $ verify (toPathPiece lid) verKey
+    lift $ sendVerifyEmail email verKey verUrl
-    sendVerifyEmail email verKey verUrl
+    lift $ defaultLayout $ do
-    defaultLayout $ do
         setTitleI Msg.ConfirmationEmailSentTitle
+        [whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]
+
+postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+postRegisterR = registerHelper False registerR
+
+getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+getForgotPasswordR = do
+    tp <- getRouteToParent
+    email <- newIdent
+    lift $ defaultLayout $ do
+        setTitleI Msg.PasswordResetTitle
         [whamlet|
-$newline never
+            <p>_{Msg.PasswordResetPrompt}
-<p>_{Msg.ConfirmationEmailSent email}
+            <form method="post" action="@{tp forgotPasswordR}">
-|]
+                <div id="registerForm">
+                    <label for=#{email}>_{Msg.ProvideIdentifier}
+                    <input ##{email} type=text name="email" width="150">
+                <button .btn>_{Msg.SendPasswordResetEmail}
+        |]
+
+postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+postForgotPasswordR = registerHelper True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail m
-           => AuthEmailId m -> Text -> GHandler Auth m RepHtml
+           => AuthEmailId m -> Text -> HandlerT Auth (HandlerT m IO) Html
 getVerifyR lid key = do
-    realKey <- getVerifyKey lid
+    realKey <- lift $ getVerifyKey lid
-    memail <- getEmail lid
+    memail <- lift $ getEmail lid
     case (realKey == Just key, memail) of
         (True, Just email) -> do
-            muid <- verifyAccount lid
+            muid <- lift $ verifyAccount lid
             case muid of
                 Nothing -> return ()
                 Just _uid -> do
-                    setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?
+                    lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
-                    toMaster <- getRouteToMaster
+                    lift $ setMessageI Msg.AddressVerified
-                    setMessageI Msg.AddressVerified
+                    redirect setpassR
-                    redirect $ toMaster setpassR
         _ -> return ()
-    defaultLayout $ do
+    lift $ defaultLayout $ do
         setTitleI Msg.InvalidKey
         [whamlet|
 $newline never
 <p>_{Msg.InvalidKey}
 |]
 
-postLoginR :: YesodAuthEmail master => GHandler Auth master ()
+postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
 postLoginR = do
-    (email, pass) <- runInputPost $ (,)
+    (identifier, pass) <- lift $ runInputPost $ (,)
-        <$> ireq emailField "email"
+        <$> ireq textField "email"
         <*> ireq textField "password"
-    mecreds <- getEmailCreds email
+    mecreds <- lift $ getEmailCreds identifier
     maid <-
-        case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of
+        case ( mecreds >>= emailCredsAuthId
-            (Just aid, Just True) -> do
+             , emailCredsEmail <$> mecreds
-                mrealpass <- getPassword aid
+             , emailCredsStatus <$> mecreds
+             ) of
+            (Just aid, Just email, Just True) -> do
+                mrealpass <- lift $ getPassword aid
                 case mrealpass of
                     Nothing -> return Nothing
                     Just realpass -> return $
                         if isValidPass pass realpass
-                            then Just aid
+                            then Just email
                             else Nothing
             _ -> return Nothing
+    let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
     case maid of
-        Just _aid ->
+        Just email ->
-            setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?
+            lift $ setCreds True $ Creds
+                (if isEmail then "email" else "username")
+                email
+                [("verifiedEmail", email)]
         Nothing -> do
-            setMessageI Msg.InvalidEmailPass
+            lift $ setMessageI $
-            toMaster <- getRouteToMaster
+                if isEmail
-            redirect $ toMaster LoginR
+                    then Msg.InvalidEmailPass
+                    else Msg.InvalidUsernamePass
+            redirect LoginR
 
-getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml
+getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getPasswordR = do
-    toMaster <- getRouteToMaster
+    maid <- lift maybeAuthId
-    maid <- maybeAuthId
     pass1 <- newIdent
     pass2 <- newIdent
     case maid of
         Just _ -> return ()
         Nothing -> do
-            setMessageI Msg.BadSetPass
+            lift $ setMessageI Msg.BadSetPass
-            redirect $ toMaster LoginR
+            redirect LoginR
-    defaultLayout $ do
+    tp <- getRouteToParent
+    lift $ defaultLayout $ do
         setTitleI Msg.SetPassTitle
         [whamlet|
 $newline never
 <h3>_{Msg.SetPass}
-<form method="post" action="@{toMaster setpassR}">
+<form method="post" action="@{tp setpassR}">
     <table>
         <tr>
             <th>
@@ -227,50 +334,47 @@ $newline never
                 <input ##{pass2} type="password" name="confirm">
         <tr>
             <td colspan="2">
-                <input type="submit" value="_{Msg.SetPassTitle}">
+                <input type="submit" value=_{Msg.SetPassTitle}>
 |]
 
-postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
+postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
 postPasswordR = do
-    (new, confirm) <- runInputPost $ (,)
+    (new, confirm) <- lift $ runInputPost $ (,)
         <$> ireq textField "new"
         <*> ireq textField "confirm"
-    toMaster <- getRouteToMaster
-    y <- getYesod
     when (new /= confirm) $ do
-        setMessageI Msg.PassMismatch
+        lift $ setMessageI Msg.PassMismatch
-        redirect $ toMaster setpassR
+        redirect setpassR
-    maid <- maybeAuthId
+    maid <- lift maybeAuthId
     aid <- case maid of
             Nothing -> do
-                setMessageI Msg.BadSetPass
+                lift $ setMessageI Msg.BadSetPass
-                redirect $ toMaster LoginR
+                redirect LoginR
             Just aid -> return aid
     salted <- liftIO $ saltPass new
-    setPassword aid salted
+    lift $ do
-    setMessageI Msg.PassUpdated
+        y <- getYesod
-    redirect $ loginDest y
+        setPassword aid salted
+        setMessageI Msg.PassUpdated
+        redirect $ afterPasswordRoute y
 
 saltLength :: Int
 saltLength = 5
 
 -- | Salt a password with a randomly generated salt.
 saltPass :: Text -> IO Text
-saltPass = fmap DTE.decodeUtf8
+saltPass = fmap (decodeUtf8With lenientDecode)
          . flip PS.makePassword 12
-         . DTE.encodeUtf8
+         . encodeUtf8
 
 saltPass' :: String -> String -> String
-saltPass' salt pass =
+saltPass' salt pass = salt ++ show (md5 $ TLE.encodeUtf8 $ TL.pack $ salt ++ pass)
-    salt ++ show (md5 $ fromString $ salt ++ pass)
-  where
-    fromString = encodeUtf8 . T.pack
 
 isValidPass :: Text -- ^ cleartext password
             -> SaltedPass -- ^ salted password
             -> Bool
 isValidPass ct salted =
-    PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted
+    PS.verifyPassword (encodeUtf8 ct) (encodeUtf8 salted) || isValidPass' ct salted
 
 isValidPass' :: Text -- ^ cleartext password
             -> SaltedPass -- ^ salted password

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
 -- | Use an email address as an identifier via Google's OpenID login system.
 --
 -- This backend will not use the OpenID identifier at all. It only uses OpenID
@@ -18,14 +19,7 @@ module Yesod.Auth.GoogleEmail
 import Yesod.Auth
 import qualified Web.Authenticate.OpenId as OpenId
 
-import Yesod.Handler
+import Yesod.Core
-import Yesod.Widget (whamlet)
-import Yesod.Request
-#if MIN_VERSION_blaze_html(0, 5, 0)
-import Text.Blaze.Html (toHtml)
-#else
-import Text.Blaze (toHtml)
-#endif
 import Data.Text (Text)
 import qualified Yesod.Auth.Message as Msg
 import qualified Data.Text as T
@@ -46,15 +40,11 @@ authGoogleEmail =
   where
     complete = PluginR pid ["complete"]
     login tm =
-        [whamlet|
+        [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
-$newline never
-<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}
-|]
     dispatch "GET" ["forward"] = do
         render <- getUrlRender
-        toMaster <- getRouteToMaster
+        let complete' = render complete
-        let complete' = render $ toMaster complete
+        master <- lift getYesod
-        master <- getYesod
         eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing
             [ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
             , ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
@@ -66,7 +56,7 @@ $newline never
         either
           (\err -> do
                 setMessage $ toHtml $ show (err :: SomeException)
-                redirect $ toMaster LoginR
+                redirect LoginR
                 )
           redirect
           eres
@@ -80,23 +70,22 @@ $newline never
         completeHelper posts
     dispatch _ _ = notFound
 
-completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
+completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master ()
 completeHelper gets' = do
-        master <- getYesod
+        master <- lift getYesod
         eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
-        toMaster <- getRouteToMaster
         let onFailure err = do
             setMessage $ toHtml $ show (err :: SomeException)
-            redirect $ toMaster LoginR
+            redirect LoginR
         let onSuccess oir = do
                 let OpenId.Identifier ident = OpenId.oirOpLocal oir
                 memail <- lookupGetParam "openid.ext1.value.email"
                 case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
-                    (Just email, True) -> setCreds True $ Creds pid email []
+                    (Just email, True) -> lift $ setCreds True $ Creds pid email []
                     (_, False) -> do
                         setMessage "Only Google login is supported"
-                        redirect $ toMaster LoginR
+                        redirect LoginR
                     (Nothing, _) -> do
                         setMessage "No email address provided"
-                        redirect $ toMaster LoginR
+                        redirect LoginR
         either onFailure onSuccess eres

yesod-auth/Yesod/Auth/HashDB.hs

@@ -74,15 +74,13 @@ module Yesod.Auth.HashDB
     ) where
 
 import Yesod.Persist
-import Yesod.Handler
 import Yesod.Form
 import Yesod.Auth
-import Yesod.Widget (toWidget)
+import Yesod.Core
 import Text.Hamlet (hamlet)
 
 import Control.Applicative         ((<$>), (<*>))
 import Control.Monad               (replicateM,liftM)
-import Control.Monad.IO.Class      (MonadIO, liftIO)
 
 import qualified Data.ByteString.Lazy.Char8 as BS (pack)
 import Data.Digest.Pure.SHA        (sha1, showDigest)
@@ -135,26 +133,15 @@ setPassword pwd u = do salt <- randomSalt
 -- | Given a user ID and password in plaintext, validate them against
 --   the database values.
 validateUser :: ( YesodPersist yesod
-#if MIN_VERSION_persistent(1, 1, 0)
                 , b ~ YesodPersistBackend yesod
-                , PersistMonadBackend (b (GHandler sub yesod)) ~ PersistEntityBackend user
+                , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user
-                , PersistUnique (b (GHandler sub yesod))
+                , PersistUnique (b (HandlerT yesod IO))
-#else
-                , b ~ YesodPersistBackend yesod
-                , b ~ PersistEntityBackend user
-                , PersistStore b (GHandler sub yesod)
-                , PersistUnique b (GHandler sub yesod)
-#endif
                 , PersistEntity user
                 , HashDBUser    user
                 ) => 
-#if MIN_VERSION_persistent(1, 1, 0)
                 Unique user     -- ^ User unique identifier
-#else
-                Unique user b   -- ^ User unique identifier
-#endif
              -> Text            -- ^ Password in plaint-text
-             -> GHandler sub yesod Bool
+             -> HandlerT yesod IO Bool
 validateUser userID passwd = do
   -- Checks that hash and password match
   let validate u = do hash <- userPasswordHash u
@@ -173,62 +160,38 @@ login = PluginR "hashdb" ["login"]
 --   username (whatever it might be) to unique user ID.
 postLoginR :: ( YesodAuth y, YesodPersist y
               , HashDBUser user, PersistEntity user
-#if MIN_VERSION_persistent(1, 1, 0)
               , b ~ YesodPersistBackend y
-              , PersistMonadBackend (b (GHandler Auth y)) ~ PersistEntityBackend user
+              , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user
-              , PersistUnique (b (GHandler Auth y))
+              , PersistUnique (b (HandlerT y IO))
-#else
-              , b ~ YesodPersistBackend y
-              , b ~ PersistEntityBackend user
-              , PersistStore b (GHandler Auth y)
-              , PersistUnique b (GHandler Auth y)
-#endif
               )
-#if MIN_VERSION_persistent(1, 1, 0)
            => (Text -> Maybe (Unique user))
-#else
+           -> HandlerT Auth (HandlerT y IO) ()
-           => (Text -> Maybe (Unique user b))
-#endif
-           -> GHandler Auth y ()
 postLoginR uniq = do
-    (mu,mp) <- runInputPost $ (,)
+    (mu,mp) <- lift $ runInputPost $ (,)
         <$> iopt textField "username"
         <*> iopt textField "password"
 
-    isValid <- fromMaybe (return False) 
+    isValid <- lift $ fromMaybe (return False) 
                  (validateUser <$> (uniq =<< mu) <*> mp)
     if isValid 
-       then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
+       then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
        else do setMessage "Invalid username/password"
-               toMaster <- getRouteToMaster
+               redirect LoginR
-               redirect $ toMaster LoginR
 
 
 -- | A drop in for the getAuthId method of your YesodAuth instance which
 --   can be used if authHashDB is the only plugin in use.
 getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
                    , HashDBUser user, PersistEntity user
-#if MIN_VERSION_persistent(1, 1, 0)
                    , Key user ~ AuthId master
                    , b ~ YesodPersistBackend master
-                   , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend user
+                   , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user
-                   , PersistUnique (b (GHandler sub master))
+                   , PersistUnique (b (HandlerT master IO))
-#else
-                   , Key b user ~ AuthId master
-                   , b ~ YesodPersistBackend master
-                   , b ~ PersistEntityBackend user
-                   , PersistUnique b (GHandler sub master)
-                   , PersistStore b (GHandler sub master)
-#endif
                    )
                 => (AuthRoute -> Route master)   -- ^ your site's Auth Route
-#if MIN_VERSION_persistent(1, 1, 0)
                 -> (Text -> Maybe (Unique user)) -- ^ gets user ID
-#else
-                -> (Text -> Maybe (Unique user b)) -- ^ gets user ID
-#endif
                 -> Creds master                  -- ^ the creds argument
-                -> GHandler sub master (Maybe (AuthId master))
+                -> HandlerT master IO (Maybe (AuthId master))
 getAuthIdHashDB authR uniq creds = do
     muid <- maybeAuthId
     case muid of
@@ -250,18 +213,10 @@ getAuthIdHashDB authR uniq creds = do
 authHashDB :: ( YesodAuth m, YesodPersist m
               , HashDBUser user
               , PersistEntity user
-#if MIN_VERSION_persistent(1, 1, 0)
               , b ~ YesodPersistBackend m
-              , PersistMonadBackend (b (GHandler Auth m)) ~ PersistEntityBackend user
+              , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user
-              , PersistUnique (b (GHandler Auth m)))
+              , PersistUnique (b (HandlerT m IO)))
            => (Text -> Maybe (Unique user)) -> AuthPlugin m
-#else
-              , b ~ YesodPersistBackend m
-              , b ~ PersistEntityBackend user
-              , PersistStore b (GHandler Auth m)
-              , PersistUnique b (GHandler Auth m))
-           => (Text -> Maybe (Unique user b)) -> AuthPlugin m
-#endif
 authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
 $newline never
     <div id="header">

yesod-auth/Yesod/Auth/Message.hs

@@ -12,6 +12,8 @@ module Yesod.Auth.Message
     , norwegianBokmålMessage
     , japaneseMessage
     , finnishMessage
+    , chineseMessage
+    , spanishMessage
     ) where
 
 import Data.Monoid (mappend)
@@ -47,6 +49,13 @@ data AuthMessage =
     | LoginTitle
     | PleaseProvideUsername
     | PleaseProvidePassword
+    | NoIdentifierProvided
+    | InvalidEmailAddress
+    | PasswordResetTitle
+    | ProvideIdentifier
+    | SendPasswordResetEmail
+    | PasswordResetPrompt
+    | InvalidUsernamePass
 
 -- | Defaults to 'englishMessage'.
 defaultMessage :: AuthMessage -> Text
@@ -85,6 +94,13 @@ englishMessage NowLoggedIn = "You are now logged in"
 englishMessage LoginTitle = "Login"
 englishMessage PleaseProvideUsername = "Please fill in your username"
 englishMessage PleaseProvidePassword = "Please fill in your password"
+englishMessage NoIdentifierProvided = "No email/username provided"
+englishMessage InvalidEmailAddress = "Invalid email address provided"
+englishMessage PasswordResetTitle = "Password Reset"
+englishMessage ProvideIdentifier = "Email or Username"
+englishMessage SendPasswordResetEmail = "Send password reset email"
+englishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+englishMessage InvalidUsernamePass = "Invalid username/password combination"
 
 portugueseMessage :: AuthMessage -> Text
 portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"
@@ -119,6 +135,54 @@ portugueseMessage NowLoggedIn = "Você acaba de entrar no site com sucesso!"
 portugueseMessage LoginTitle = "Entrar no site"
 portugueseMessage PleaseProvideUsername = "Por favor digite seu nome de usuário"
 portugueseMessage PleaseProvidePassword = "Por favor digite sua senha"
+portugueseMessage NoIdentifierProvided = "Nenhum e-mail ou nome de usuário informado"
+portugueseMessage InvalidEmailAddress = "Endereço de e-mail inválido informado"
+portugueseMessage PasswordResetTitle = "Resetar senha"
+portugueseMessage ProvideIdentifier = "E-mail ou nome de usuário"
+portugueseMessage SendPasswordResetEmail = "Enviar e-mail para resetar senha"
+portugueseMessage PasswordResetPrompt = "Insira seu endereço de e-mail ou nome de usuário abaixo.  Um e-mail para resetar sua senha será enviado para você."
+portugueseMessage InvalidUsernamePass = "Nome de usuário ou senha inválidos"
+
+spanishMessage :: AuthMessage -> Text
+spanishMessage NoOpenID = "No se encuentra el identificador OpenID"
+spanishMessage LoginOpenID = "Entrar utilizando OpenID"
+spanishMessage LoginGoogle = "Entrar utilizando Google"
+spanishMessage LoginYahoo = "Entrar utilizando Yahoo"
+spanishMessage Email = "Correo electrónico"
+spanishMessage Password = "Contraseña"
+spanishMessage Register = "Registrarse"
+spanishMessage RegisterLong = "Registrar una nueva cuenta"
+spanishMessage EnterEmail = "Coloque su dirección de correo electrónico, y un correo de confirmación le será enviado a su cuenta."
+spanishMessage ConfirmationEmailSentTitle = "La confirmación de correo ha sido enviada"
+spanishMessage (ConfirmationEmailSent email) =
+    "Una confirmación de correo electrónico ha sido enviada a " `mappend`
+    email `mappend`
+    "."
+spanishMessage AddressVerified = "Dirección verificada, por favor introduzca una contraseña"
+spanishMessage InvalidKeyTitle = "Clave de verificación invalida"
+spanishMessage InvalidKey = "Lo sentimos, pero esa clave de verificación es inválida."
+spanishMessage InvalidEmailPass = "La combinación cuenta de correo/contraseña es inválida"
+spanishMessage BadSetPass = "Debe acceder a la aplicación para modificar la contraseña"
+spanishMessage SetPassTitle = "Modificar contraseña"
+spanishMessage SetPass = "Actualizar nueva contraseña"
+spanishMessage NewPass = "Nueva contraseña"
+spanishMessage ConfirmPass = "Confirmar"
+spanishMessage PassMismatch = "Las contraseñas no coinciden, inténtelo de nuevo"
+spanishMessage PassUpdated = "Contraseña actualizada"
+spanishMessage Facebook = "Entrar mediante Facebook"
+spanishMessage LoginViaEmail = "Entrar mediante una cuenta de correo"
+spanishMessage InvalidLogin = "Login inválido"
+spanishMessage NowLoggedIn = "Usted ha ingresado al sitio"
+spanishMessage LoginTitle = "Login"
+spanishMessage PleaseProvideUsername = "Por favor escriba su nombre de usuario"
+spanishMessage PleaseProvidePassword = "Por favor escriba su contraseña"
+spanishMessage NoIdentifierProvided = "No ha indicado una cuenta de correo/nombre de usuario"
+spanishMessage InvalidEmailAddress = "La cuenta de correo es inválida"
+spanishMessage PasswordResetTitle = "Contraseña actualizada"
+spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"
+spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"
+spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."
+spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"
 
 swedishMessage :: AuthMessage -> Text
 swedishMessage NoOpenID = "Fann ej OpenID identifierare"
@@ -153,6 +217,14 @@ swedishMessage NowLoggedIn = "Du är nu inloggad"
 swedishMessage LoginTitle = "Logga in"
 swedishMessage PleaseProvideUsername = "Vänligen fyll i användarnamn"
 swedishMessage PleaseProvidePassword = "Vänligen fyll i lösenord"
+swedishMessage NoIdentifierProvided = "Emailadress eller användarnamn saknas"
+swedishMessage InvalidEmailAddress = "Ogiltig emailadress angiven"
+swedishMessage PasswordResetTitle = "Återställning av lösenord"
+swedishMessage ProvideIdentifier = "Epost eller användarnamn"
+swedishMessage SendPasswordResetEmail = "Skicka email för återställning av lösenord"
+swedishMessage PasswordResetPrompt = "Skriv in din emailadress eller användarnamn nedan och " `mappend`
+                                     "ett email för återställning av lösenord kommmer att skickas till dig."
+swedishMessage InvalidUsernamePass = "Ogiltig kombination av användarnamn och lösenord"
 
 germanMessage :: AuthMessage -> Text
 germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
@@ -187,8 +259,13 @@ germanMessage NowLoggedIn = "Login erfolgreich"
 germanMessage LoginTitle = "Login"
 germanMessage PleaseProvideUsername = "Bitte Nutzername angeben"
 germanMessage PleaseProvidePassword = "Bitte Passwort angeben"
-
+germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"
-
+germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"
+germanMessage PasswordResetTitle = "Passwort zurücksetzen"
+germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
+germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
+germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
+germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
@@ -223,6 +300,13 @@ frenchMessage NowLoggedIn = "Vous êtes maintenant connecté"
 frenchMessage LoginTitle = "Se connecter"
 frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur"
 frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"
+frenchMessage NoIdentifierProvided = "No email/username provided"
+frenchMessage InvalidEmailAddress = "Invalid email address provided"
+frenchMessage PasswordResetTitle = "Password Reset"
+frenchMessage ProvideIdentifier = "Email or Username"
+frenchMessage SendPasswordResetEmail = "Send password reset email"
+frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+frenchMessage InvalidUsernamePass = "Invalid username/password combination"
 
 norwegianBokmålMessage :: AuthMessage -> Text
 norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"
@@ -257,6 +341,13 @@ norwegianBokmålMessage NowLoggedIn = "Du er nå logget inn"
 norwegianBokmålMessage LoginTitle = "Logg inn"
 norwegianBokmålMessage PleaseProvideUsername = "Vennligst fyll inn ditt brukernavn"
 norwegianBokmålMessage PleaseProvidePassword = "Vennligst fyll inn ditt passord"
+norwegianBokmålMessage NoIdentifierProvided = "No email/username provided"
+norwegianBokmålMessage InvalidEmailAddress = "Invalid email address provided"
+norwegianBokmålMessage PasswordResetTitle = "Password Reset"
+norwegianBokmålMessage ProvideIdentifier = "Email or Username"
+norwegianBokmålMessage SendPasswordResetEmail = "Send password reset email"
+norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combination"
 
 japaneseMessage :: AuthMessage -> Text
 japaneseMessage NoOpenID = "OpenID識別子がありません"
@@ -291,6 +382,13 @@ japaneseMessage NowLoggedIn = "ログインしました"
 japaneseMessage LoginTitle = "ログイン"
 japaneseMessage PleaseProvideUsername = "ユーザ名を入力してください"
 japaneseMessage PleaseProvidePassword = "パスワードを入力してください"
+japaneseMessage NoIdentifierProvided = "No email/username provided"
+japaneseMessage InvalidEmailAddress = "Invalid email address provided"
+japaneseMessage PasswordResetTitle = "Password Reset"
+japaneseMessage ProvideIdentifier = "Email or Username"
+japaneseMessage SendPasswordResetEmail = "Send password reset email"
+japaneseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+japaneseMessage InvalidUsernamePass = "Invalid username/password combination"
 
 finnishMessage :: AuthMessage -> Text
 finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"
@@ -307,6 +405,7 @@ finnishMessage (ConfirmationEmailSent email) =
     "Vahvistussähköposti on lähetty osoitteeseen " `mappend`
     email `mappend`
     "."
+
 finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana"
 finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain"
 finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen."
@@ -325,5 +424,53 @@ finnishMessage NowLoggedIn = "Olet nyt kirjautunut sisään"
 finnishMessage LoginTitle = "Kirjautuminen"
 finnishMessage PleaseProvideUsername = "Käyttäjänimi puuttuu"
 finnishMessage PleaseProvidePassword = "Salasana puuttuu"
+finnishMessage NoIdentifierProvided = "Sähköpostiosoite/käyttäjänimi puuttuu"
+finnishMessage InvalidEmailAddress = "Annettu sähköpostiosoite ei kelpaa"
+finnishMessage PasswordResetTitle = "Uuden salasanan tilaaminen"
+finnishMessage ProvideIdentifier = "Sähköpostiosoite tai käyttäjänimi"
+finnishMessage SendPasswordResetEmail = "Lähetä uusi salasana sähköpostitse"
+finnishMessage PasswordResetPrompt = "Anna sähköpostiosoitteesi tai käyttäjätunnuksesi alla, niin lähetämme uuden salasanan sähköpostitse."
+finnishMessage InvalidUsernamePass = "Virheellinen käyttäjänimi tai salasana."
+
+chineseMessage :: AuthMessage -> Text
+chineseMessage NoOpenID = "无效的OpenID"
+chineseMessage LoginOpenID = "用OpenID登录"
+chineseMessage LoginGoogle = "用Google帐户登录"
+chineseMessage LoginYahoo = "用Yahoo帐户登录"
+chineseMessage Email = "邮箱"
+chineseMessage Password = "密码"
+chineseMessage Register = "注册"
+chineseMessage RegisterLong = "注册新帐户"
+chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。"
+chineseMessage ConfirmationEmailSentTitle = "确认邮件已发送"
+chineseMessage (ConfirmationEmailSent email) =
+    "确认邮件已发送至 " `mappend`
+    email `mappend`
+    "."
+chineseMessage AddressVerified = "地址验证成功，请设置新密码"
+chineseMessage InvalidKeyTitle = "无效的验证码"
+chineseMessage InvalidKey = "对不起，验证码无效。"
+chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"
+chineseMessage BadSetPass = "你需要登录才能设置密码"
+chineseMessage SetPassTitle = "设置密码"
+chineseMessage SetPass = "设置新密码"
+chineseMessage NewPass = "新密码"
+chineseMessage ConfirmPass = "确认"
+chineseMessage PassMismatch = "密码不匹配，请重新输入"
+chineseMessage PassUpdated = "密码更新成功"
+chineseMessage Facebook = "用Facebook帐户登录"
+chineseMessage LoginViaEmail = "用邮箱登录"
+chineseMessage InvalidLogin = "登录失败"
+chineseMessage NowLoggedIn = "登录成功"
+chineseMessage LoginTitle = "登录"
+chineseMessage PleaseProvideUsername = "请输入用户名"
+chineseMessage PleaseProvidePassword = "请输入密码"
+chineseMessage NoIdentifierProvided = "缺少邮箱/用户名"
+chineseMessage InvalidEmailAddress = "无效的邮箱地址"
+chineseMessage PasswordResetTitle = "重置密码"
+chineseMessage ProvideIdentifier = "邮箱或用户名"
+chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
+chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
+chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
 
 

yesod-auth/Yesod/Auth/OpenId.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Auth.OpenId
     ( authOpenId
     , forwardUrl
@@ -14,15 +15,8 @@ import Yesod.Auth
 import qualified Web.Authenticate.OpenId as OpenId
 
 import Yesod.Form
-import Yesod.Handler
+import Yesod.Core
-import Yesod.Widget (toWidget, whamlet)
-import Yesod.Request
 import Text.Cassius (cassius)
-#if MIN_VERSION_blaze_html(0, 5, 0)
-import Text.Blaze.Html (toHtml)
-#else
-import Text.Blaze (toHtml)
-#endif
 import Data.Text (Text, isPrefixOf)
 import qualified Yesod.Auth.Message as Msg
 import Control.Exception.Lifted (SomeException, try)
@@ -43,7 +37,7 @@ authOpenId idType extensionFields =
     complete = PluginR "openid" ["complete"]
     name = "openid_identifier"
     login tm = do
-        ident <- lift newIdent
+        ident <- newIdent
         -- FIXME this is a hack to get GHC 7.6's type checker to allow the
         -- code, but it shouldn't be necessary
         let y :: a -> [(Text, Text)] -> Text
@@ -66,23 +60,21 @@ $newline never
     <input type="submit" value="_{Msg.LoginOpenID}">
 |]
     dispatch "GET" ["forward"] = do
-        roid <- runInputGet $ iopt textField name
+        roid <- lift $ runInputGet $ iopt textField name
         case roid of
             Just oid -> do
                 render <- getUrlRender
-                toMaster <- getRouteToMaster
+                let complete' = render complete
-                let complete' = render $ toMaster complete
+                master <- lift getYesod
-                master <- getYesod
                 eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
                 case eres of
                     Left err -> do
                         setMessage $ toHtml $ show (err :: SomeException)
-                        redirect $ toMaster LoginR
+                        redirect LoginR
                     Right x -> redirect x
             Nothing -> do
-                toMaster <- getRouteToMaster
+                lift $ setMessageI Msg.NoOpenID
-                setMessageI Msg.NoOpenID
+                redirect LoginR
-                redirect $ toMaster LoginR
     dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
     dispatch "GET" ["complete"] = do
         rr <- getRequest
@@ -93,14 +85,13 @@ $newline never
         completeHelper idType posts
     dispatch _ _ = notFound
 
-completeHelper :: YesodAuth m => IdentifierType -> [(Text, Text)] -> GHandler Auth m ()
+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()
 completeHelper idType gets' = do
-        master <- getYesod
+        master <- lift getYesod
-        eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
+        eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
-        toMaster <- getRouteToMaster
         let onFailure err = do
             setMessage $ toHtml $ show (err :: SomeException)
-            redirect $ toMaster LoginR
+            redirect LoginR
         let onSuccess oir = do
                 let claimed =
                         case OpenId.oirClaimed oir of
@@ -114,7 +105,7 @@ completeHelper idType gets' = do
                             case idType of
                                 OPLocal -> OpenId.oirOpLocal oir
                                 Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
-                setCreds True $ Creds "openid" i gets''
+                lift $ setCreds True $ Creds "openid" i gets''
         either onFailure onSuccess eres
 
 -- | The main identifier provided by the OpenID authentication plugin is the

yesod-auth/Yesod/Auth/Routes.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Yesod.Auth.Routes where
+
+import Yesod.Core
+import Data.Text (Text)
+
+data Auth = Auth
+
+mkYesodSubData "Auth" [parseRoutes|
+/check                 CheckR      GET
+/login                 LoginR      GET
+/logout                LogoutR     GET POST
+/page/#Text/*Texts     PluginR
+|]

yesod-auth/Yesod/Auth/Rpxnow.hs

@@ -10,9 +10,7 @@ import Yesod.Auth
 import qualified Web.Authenticate.Rpxnow as Rpxnow
 import Control.Monad (mplus)
 
-import Yesod.Handler
+import Yesod.Core
-import Yesod.Widget
-import Yesod.Request
 import Text.Hamlet (hamlet)
 import Data.Text (pack, unpack)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
@@ -27,12 +25,8 @@ authRpxnow :: YesodAuth m
 authRpxnow app apiKey =
     AuthPlugin "rpxnow" dispatch login
   where
-    login ::
-        forall sub master.
-        ToWidget sub master (GWidget sub master ())
-        => (Route Auth -> Route master) -> GWidget sub master ()
     login tm = do
-        render <- lift getUrlRender
+        render <- getUrlRender
         let queryString = decodeUtf8With lenientDecode
                         $ renderQuery True [("token_url", Just $ encodeUtf8 $ render $ tm $ PluginR "rpxnow" [])]
         toWidget [hamlet|
@@ -45,7 +39,7 @@ $newline never
         token <- case token1 ++ token2 of
                         [] -> invalidArgs ["token: Value not supplied"]
                         x:_ -> return $ unpack x
-        master <- getYesod
+        master <- lift getYesod
         Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)
         let creds =
                 Creds "rpxnow" ident
@@ -54,7 +48,7 @@ $newline never
                 $ maybe id (\x -> (:) ("displayName", x))
                     (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
                   []
-        setCreds True creds
+        lift $ setCreds True creds
     dispatch _ _ = notFound
 
 -- | Get some form of a display name.

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.1.7
+version:         1.2.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -17,24 +17,23 @@ library
     build-depends:   base                    >= 4         && < 5
                    , authenticate            >= 1.3
                    , bytestring              >= 0.9.1.4
-                   , yesod-core              >= 1.1       && < 1.2
+                   , yesod-core              >= 1.2       && < 1.3
-                   , wai                     >= 1.3
+                   , wai                     >= 1.4
                    , template-haskell
                    , pureMD5                 >= 2.0
                    , random                  >= 1.0.0.2
                    , text                    >= 0.7
                    , mime-mail               >= 0.3
-                   , yesod-persistent        >= 1.1
+                   , yesod-persistent        >= 1.2
                    , hamlet                  >= 1.1       && < 1.2
                    , shakespeare-css         >= 1.0       && < 1.1
                    , shakespeare-js          >= 1.0.2     && < 1.2
-                   , yesod-json              >= 1.1       && < 1.2
                    , containers
                    , unordered-containers
-                   , yesod-form              >= 1.1       && < 1.3
+                   , yesod-form              >= 1.3       && < 1.4
                    , transformers            >= 0.2.2
-                   , persistent              >= 1.0       && < 1.2
+                   , persistent              >= 1.2       && < 1.3
-                   , persistent-template     >= 1.0       && < 1.2
+                   , persistent-template     >= 1.2       && < 1.3
                    , SHA                     >= 1.4.1.3
                    , http-conduit            >= 1.5
                    , aeson                   >= 0.5
@@ -45,6 +44,8 @@ library
                    , network
                    , http-types
                    , file-embed
+                   , email-validate          >= 1.0
+                   , data-default
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId
@@ -55,6 +56,7 @@ library
                      Yesod.Auth.HashDB
                      Yesod.Auth.Message
                      Yesod.Auth.GoogleEmail
+    other-modules:   Yesod.Auth.Routes
     ghc-options:     -Wall
 
 source-repository head

yesod-bin/AddHandler.hs

@@ -89,7 +89,7 @@ mkHandler name pattern methods = unlines
   where
     go method =
         [ ""
-        , concat $ func : " :: " : map toArrow types ++ ["Handler RepHtml"]
+        , concat $ func : " :: " : map toArrow types ++ ["Handler Html"]
         , concat
             [ func
             , " = error \"Not yet implemented: "

yesod-bin/Devel.hs

@@ -123,7 +123,10 @@ reverseProxy opts iappPort = do
                     return $ Right $ ProxyDest "127.0.0.1" appPort)
                 def
                     { wpsOnExc = onExc
-                    , wpsTimeout = Just (1000000 * proxyTimeout opts)
+                    , wpsTimeout =
+                        if proxyTimeout opts == 0
+                            then Nothing
+                            else Just (1000000 * proxyTimeout opts)
                     }
                 manager
             putStrLn "Reverse proxy stopped, but it shouldn't"

yesod-bin/Options.hs

@@ -70,13 +70,8 @@ injectDefaultP env path p@(OptP o)
            let (Just parseri) = f cmd
            in  parseri { infoParser = injectDefaultP env (path ++ [normalizeName cmd]) (infoParser parseri) }
      in  OptP (Option (CmdReader cmds (`M.lookup` cmdMap)) props)
-#if MIN_VERSION_optparse_applicative(0, 5, 0)
   | (Option (OptReader names (CReader _ rdr) _) _) <- o =
      p <|> either (const empty) pure (msum $ map (rdr <=< (maybe (Left $ ErrorMsg "Missing environment variable") Right . getEnvValue env path)) names)
-#else
-  | (Option (OptReader names (CReader _ rdr)) _) <- o =
-     p <|> maybe empty pure (msum $ map (rdr <=< getEnvValue env path) names)
-#endif
   | (Option (FlagReader names a) _) <- o =
      p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty
   | otherwise = p

yesod-bin/main.hs

@@ -8,18 +8,14 @@ import           Options.Applicative
 import           System.Exit            (ExitCode (ExitSuccess), exitWith)
 import           System.Process         (rawSystem)
 
-import           Yesod.Core             (yesodVersion)
-
 import           AddHandler             (addHandler)
 import           Devel                  (DevelOpts (..), devel)
 import           Keter                  (keter)
 import           Options                (injectDefaults)
-import qualified Paths_yesod
+import qualified Paths_yesod_bin
 import           Scaffolding.Scaffolder
 
-#if MIN_VERSION_optparse_applicative(0, 5, 0)
 import           Options.Applicative.Builder.Internal (Mod, OptionFields)
-#endif
 
 #ifndef WINDOWS
 import           Build                  (touch)
@@ -98,8 +94,7 @@ main = do
     Touch                   -> touch'
     Devel da s f r b _ig es p t -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b p t) es
     Keter noRebuild         -> keter (cabalCommand o) noRebuild
-    Version                 -> do putStrLn ("yesod-core version:" ++ yesodVersion)
+    Version                 -> do putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
-                                  putStrLn ("yesod version:" ++ showVersion Paths_yesod.version)
     AddHandler              -> addHandler
     Test                    -> do touch'
                                   cabal ["configure", "--enable-tests", "-flibrary-only"]
@@ -153,8 +148,8 @@ develOptions = Devel <$> switch ( long "disable-api"  <> short 'd'
                      <*> extraCabalArgs
                      <*> option ( long "port" <> short 'p' <> value 3000 <> metavar "N"
                             <> help "Devel server listening port" )
-                     <*> option ( long "proxy-timeout" <> short 'x' <> value 10 <> metavar "N"
+                     <*> option ( long "proxy-timeout" <> short 'x' <> value 0 <> metavar "N"
-                            <> help "Devel server timeout before returning 'not ready' message (in seconds)" )
+                            <> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" )
 
 extraCabalArgs :: Parser [String]
 extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
@@ -166,11 +161,7 @@ optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
 optStr m =
     nullOption $ value Nothing <> reader (success . str)  <> m
   where
-#if MIN_VERSION_optparse_applicative(0, 5, 0)
     success = Right
-#else
-    success = Just
-#endif
 
 -- | Like @rawSystem@, but exits if it receives a non-success result.
 rawSystem' :: String -> [String] -> IO ()

yesod-bin/yesod-bin.cabal

@@ -0,0 +1,103 @@
+name:            yesod-bin
+version:         1.2.0
+license:         MIT
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        The yesod helper executable.
+description:     Provides scaffolding, devel server, and some simple code generation helpers.
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+
+extra-source-files:
+  input/*.cg
+  hsfiles/mongo.hsfiles
+  hsfiles/mysql.hsfiles
+  hsfiles/postgres.hsfiles
+  hsfiles/postgres-fay.hsfiles
+  hsfiles/simple.hsfiles
+  hsfiles/sqlite.hsfiles
+
+executable             yesod-ghc-wrapper
+    main-is: ghcwrapper.hs
+    build-depends:
+                    base                       >= 4         && < 5
+                  , Cabal
+
+executable             yesod-ld-wrapper
+    main-is: ghcwrapper.hs
+    cpp-options:     -DLDCMD
+    build-depends:
+                    base                       >= 4         && < 5
+                  , Cabal
+executable             yesod-ar-wrapper
+    main-is: ghcwrapper.hs
+    cpp-options:     -DARCMD
+    build-depends:
+                     base                       >= 4         && < 5
+                   , Cabal
+
+executable             yesod
+    if os(windows)
+        cpp-options:     -DWINDOWS
+    build-depends:     base               >= 4.3          && < 5
+                     , ghc                >= 7.0.3        && < 7.8
+                     , ghc-paths          >= 0.1
+                     , parsec             >= 2.1          && < 4
+                     , text               >= 0.11
+                     , shakespeare-text   >= 1.0          && < 1.1
+                     , shakespeare        >= 1.0.2        && < 1.1
+                     , shakespeare-js     >= 1.0.2        && < 1.2
+                     , shakespeare-css    >= 1.0.2        && < 1.1
+                     , bytestring         >= 0.9.1.4
+                     , time               >= 1.1.4
+                     , template-haskell
+                     , directory          >= 1.0
+                     , Cabal
+                     , unix-compat        >= 0.2          && < 0.5
+                     , containers         >= 0.2
+                     , attoparsec         >= 0.10
+                     , http-types         >= 0.7
+                     , blaze-builder      >= 0.2.1.4      && < 0.4
+                     , filepath           >= 1.1
+                     , process
+                     , zlib               >= 0.5          && < 0.6
+                     , tar                >= 0.4          && < 0.5
+                     , system-filepath    >= 0.4          && < 0.5
+                     , system-fileio      >= 0.3          && < 0.4
+                     , unordered-containers
+                     , yaml               >= 0.8          && < 0.9
+                     , optparse-applicative >= 0.5
+                     , fsnotify           >= 0.0          && < 0.1
+                     , split              >= 0.2          && < 0.3
+                     , file-embed
+                     , conduit            >= 0.5          && < 1.1
+                     , resourcet          >= 0.3          && < 0.5
+                     , base64-bytestring
+                     , lifted-base
+                     , http-reverse-proxy >= 0.1.1
+                     , network
+                     , http-conduit
+                     , network-conduit
+                     , project-template   >= 0.1.1
+                     , transformers
+                     , warp               >= 1.3.7.5
+                     , wai                >= 1.4
+
+    ghc-options:       -Wall -threaded
+    main-is:           main.hs
+    other-modules:     Scaffolding.Scaffolder
+                       Devel
+                       Build
+                       GhcBuild
+                       Keter
+                       AddHandler
+                       Paths_yesod_bin
+                       Options
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod

yesod-core/Yesod/Content.hs

@@ -1,263 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
-module Yesod.Content
-    ( -- * Content
-      Content (..)
-    , emptyContent
-    , ToContent (..)
-      -- * Mime types
-      -- ** Data type
-    , ContentType
-    , typeHtml
-    , typePlain
-    , typeJson
-    , typeXml
-    , typeAtom
-    , typeRss
-    , typeJpeg
-    , typePng
-    , typeGif
-    , typeSvg
-    , typeJavascript
-    , typeCss
-    , typeFlv
-    , typeOgv
-    , typeOctet
-      -- * Utilities
-    , simpleContentType
-      -- * Evaluation strategy
-    , DontFullyEvaluate (..)
-      -- * Representations
-    , ChooseRep
-    , HasReps (..)
-    , defChooseRep
-      -- ** Specific content types
-    , RepHtml (..)
-    , RepJson (..)
-    , RepHtmlJson (..)
-    , RepPlain (..)
-    , RepXml (..)
-      -- * Utilities
-    , formatW3
-    , formatRFC1123
-    , formatRFC822
-    ) where
-
-import Data.Maybe (mapMaybe)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as L
-import Data.Text.Lazy (Text, pack)
-import qualified Data.Text as T
-
-import Data.Time
-import System.Locale
-
-import qualified Data.Text.Encoding
-import qualified Data.Text.Lazy.Encoding
-
-import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
-import Data.Monoid (mempty)
-
-import Text.Hamlet (Html)
-import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
-import Data.String (IsString (fromString))
-import Network.Wai (FilePart)
-import Data.Conduit (Source, ResourceT, Flush)
-
-import qualified Data.Aeson as J
-import Data.Aeson.Encode (fromValue)
-import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
-import Data.Text.Lazy.Builder (toLazyText)
-
-data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.
-             | ContentSource !(Source (ResourceT IO) (Flush Builder))
-             | ContentFile !FilePath !(Maybe FilePart)
-             | ContentDontEvaluate !Content
-
--- | Zero-length enumerator.
-emptyContent :: Content
-emptyContent = ContentBuilder mempty $ Just 0
-
-instance IsString Content where
-    fromString = toContent
-
--- | Anything which can be converted into 'Content'. Most of the time, you will
--- want to use the 'ContentBuilder' constructor. An easier approach will be to use
--- a pre-defined 'toContent' function, such as converting your data into a lazy
--- bytestring and then calling 'toContent' on that.
---
--- Please note that the built-in instances for lazy data structures ('String',
--- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include
--- the content length for the 'ContentBuilder' constructor.
-class ToContent a where
-    toContent :: a -> Content
-
-instance ToContent Builder where
-    toContent = flip ContentBuilder Nothing
-instance ToContent B.ByteString where
-    toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
-instance ToContent L.ByteString where
-    toContent = flip ContentBuilder Nothing . fromLazyByteString
-instance ToContent T.Text where
-    toContent = toContent . Data.Text.Encoding.encodeUtf8
-instance ToContent Text where
-    toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8
-instance ToContent String where
-    toContent = toContent . pack
-instance ToContent Html where
-    toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
-
--- | A function which gives targetted representations of content based on the
--- content-types the user accepts.
-type ChooseRep =
-    [ContentType] -- ^ list of content-types user accepts, ordered by preference
- -> IO (ContentType, Content)
-
--- | Any type which can be converted to representations.
-class HasReps a where
-    chooseRep :: a -> ChooseRep
-
--- | A helper method for generating 'HasReps' instances.
---
--- This function should be given a list of pairs of content type and conversion
--- functions. If none of the content types match, the first pair is used.
-defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep
-defChooseRep reps a ts = do
-  let (ct, c) =
-        case mapMaybe helper ts of
-            (x:_) -> x
-            [] -> case reps of
-                    [] -> error "Empty reps to defChooseRep"
-                    (x:_) -> x
-  c' <- c a
-  return (ct, c')
-        where
-            helper ct = do
-                c <- lookup ct reps
-                return (ct, c)
-
-instance HasReps ChooseRep where
-    chooseRep = id
-
-instance HasReps () where
-    chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)]
-
-instance HasReps (ContentType, Content) where
-    chooseRep = const . return
-
-instance HasReps [(ContentType, Content)] where
-    chooseRep a cts = return $
-        case filter (\(ct, _) -> go ct `elem` map go cts) a of
-            ((ct, c):_) -> (ct, c)
-            _ -> case a of
-                    (x:_) -> x
-                    _ -> error "chooseRep [(ContentType, Content)] of empty"
-      where
-        go = simpleContentType
-
-newtype RepHtml = RepHtml Content
-instance HasReps RepHtml where
-    chooseRep (RepHtml c) _ = return (typeHtml, c)
-newtype RepJson = RepJson Content
-instance HasReps RepJson where
-    chooseRep (RepJson c) _ = return (typeJson, c)
-data RepHtmlJson = RepHtmlJson Content Content
-instance HasReps RepHtmlJson where
-    chooseRep (RepHtmlJson html json) = chooseRep
-        [ (typeHtml, html)
-        , (typeJson, json)
-        ]
-newtype RepPlain = RepPlain Content
-instance HasReps RepPlain where
-    chooseRep (RepPlain c) _ = return (typePlain, c)
-newtype RepXml = RepXml Content
-instance HasReps RepXml where
-    chooseRep (RepXml c) _ = return (typeXml, c)
-
-type ContentType = B.ByteString -- FIXME Text?
-
-typeHtml :: ContentType
-typeHtml = "text/html; charset=utf-8"
-
-typePlain :: ContentType
-typePlain = "text/plain; charset=utf-8"
-
-typeJson :: ContentType
-typeJson = "application/json; charset=utf-8"
-
-typeXml :: ContentType
-typeXml = "text/xml"
-
-typeAtom :: ContentType
-typeAtom = "application/atom+xml"
-
-typeRss :: ContentType
-typeRss = "application/rss+xml"
-
-typeJpeg :: ContentType
-typeJpeg = "image/jpeg"
-
-typePng :: ContentType
-typePng = "image/png"
-
-typeGif :: ContentType
-typeGif = "image/gif"
-
-typeSvg :: ContentType
-typeSvg = "image/svg+xml"
-
-typeJavascript :: ContentType
-typeJavascript = "text/javascript; charset=utf-8"
-
-typeCss :: ContentType
-typeCss = "text/css; charset=utf-8"
-
-typeFlv :: ContentType
-typeFlv = "video/x-flv"
-
-typeOgv :: ContentType
-typeOgv = "video/ogg"
-
-typeOctet :: ContentType
-typeOctet = "application/octet-stream"
-
--- | Removes \"extra\" information at the end of a content type string. In
--- particular, removes everything after the semicolon, if present.
---
--- For example, \"text/html; charset=utf-8\" is commonly used to specify the
--- character encoding for HTML data. This function would return \"text/html\".
-simpleContentType :: ContentType -> ContentType
-simpleContentType = fst . B.breakByte 59 -- 59 == ;
-
--- | Format a 'UTCTime' in W3 format.
-formatW3 :: UTCTime -> T.Text
-formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"
-
--- | Format as per RFC 1123.
-formatRFC1123 :: UTCTime -> T.Text
-formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
-
--- | Format as per RFC 822.
-formatRFC822 :: UTCTime -> T.Text
-formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
-
--- | Prevents a response body from being fully evaluated before sending the
--- request.
---
--- Since 1.1.0
-newtype DontFullyEvaluate a = DontFullyEvaluate a
-
-instance HasReps a => HasReps (DontFullyEvaluate a) where
-    chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a
-
-instance ToContent a => ToContent (DontFullyEvaluate a) where
-    toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
-
-instance ToContent J.Value where
-    toContent = flip ContentBuilder Nothing
-              . Blaze.fromLazyText
-              . toLazyText
-              . fromValue

yesod-core/Yesod/Core.hs

@@ -1,16 +1,24 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Yesod.Core
     ( -- * Type classes
       Yesod (..)
     , YesodDispatch (..)
+    , YesodSubDispatch (..)
     , RenderRoute (..)
+    , ParseRoute (..)
+    , RouteAttrs (..)
       -- ** Breadcrumbs
     , YesodBreadcrumbs (..)
     , breadcrumbs
       -- * Types
     , Approot (..)
     , FileUpload (..)
+    , ErrorResponse (..)
       -- * Utitlities
     , maybeAuthorized
     , widgetToPageContent
@@ -35,41 +43,96 @@ module Yesod.Core
     , SessionBackend (..)
     , defaultClientSessionBackend
     , clientSessionBackend
-    , clientSessionBackend2
     , clientSessionDateCacher
     , loadClientSession
     , Header(..)
-    , BackendSession
     -- * JS loaders
-    , loadJsYepnope
     , ScriptLoadPosition (..)
     , BottomOfHeadAsync
+      -- * Subsites
+    , MonadHandler (..)
+    , MonadWidget (..)
+    , getRouteToParent
+    , defaultLayoutSub
       -- * Misc
     , yesodVersion
     , yesodRender
     , runFakeHandler
+      -- * LiteApp
+    , module Yesod.Core.Internal.LiteApp
+      -- * Low-level
+    , yesodRunner
       -- * Re-exports
-    , module Yesod.Content
+    , module Yesod.Core.Content
-    , module Yesod.Dispatch
+    , module Yesod.Core.Dispatch
-    , module Yesod.Handler
+    , module Yesod.Core.Handler
-    , module Yesod.Request
+    , module Yesod.Core.Widget
-    , module Yesod.Widget
+    , module Yesod.Core.Json
-    , module Yesod.Message
+    , module Text.Shakespeare.I18N
+    , module Yesod.Core.Internal.Util
+    , module Text.Blaze.Html
+    , MonadTrans (..)
+    , MonadIO (..)
+    , MonadBase (..)
+    , MonadBaseControl
+    , MonadResource (..)
+    , MonadLogger
     ) where
 
-import Yesod.Internal.Core
+import Yesod.Core.Content
-import Yesod.Internal (Header(..))
+import Yesod.Core.Dispatch
-import Yesod.Content
+import Yesod.Core.Handler
-import Yesod.Dispatch
+import Yesod.Core.Class.Handler
-import Yesod.Handler
+import Yesod.Core.Widget
-import Yesod.Request
+import Yesod.Core.Json
-import Yesod.Widget
+import Yesod.Core.Types
-import Yesod.Message
+import Text.Shakespeare.I18N
+import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)
+import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup)
 
 import Control.Monad.Logger
+import Control.Monad.Trans.Class (MonadTrans (..))
+import Yesod.Core.Internal.Session
+import Yesod.Core.Internal.Run (yesodRunner)
+import Yesod.Core.Class.Yesod
+import Yesod.Core.Class.Dispatch
+import Yesod.Core.Class.Breadcrumbs
+import Yesod.Core.Internal.Run (yesodRender, runFakeHandler)
+import qualified Paths_yesod_core
+import Data.Version (showVersion)
+import Yesod.Routes.Class
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Base (MonadBase (..))
+import Control.Monad.Trans.Control (MonadBaseControl (..))
+
+import Control.Monad.Trans.Resource (MonadResource (..))
+import Yesod.Core.Internal.LiteApp
 
 -- | Return an 'Unauthorized' value, with the given i18n message.
-unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
+unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult
-unauthorizedI msg =do
+unauthorizedI msg = do
     mr <- getMessageRender
     return $ Unauthorized $ mr msg
+
+yesodVersion :: String
+yesodVersion = showVersion Paths_yesod_core.version
+
+-- | 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
+-- contain links to pages the user is allowed to see.
+maybeAuthorized :: Yesod site
+                => Route site
+                -> Bool -- ^ is this a write request?
+                -> HandlerT site IO (Maybe (Route site))
+maybeAuthorized r isWrite = do
+    x <- isAuthorized r isWrite
+    return $ if x == Authorized then Just r else Nothing
+
+getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)
+getRouteToParent = HandlerT $ return . handlerToParent
+
+defaultLayoutSub :: Yesod parent
+                 => WidgetT child IO ()
+                 -> HandlerT child (HandlerT parent IO) Html
+defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout

yesod-core/Yesod/Core/Class/Breadcrumbs.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Core.Class.Breadcrumbs where
+
+import Yesod.Core.Handler
+import Yesod.Routes.Class
+import Data.Text (Text)
+
+-- | 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).
+class YesodBreadcrumbs site where
+    -- | Returns the title and the parent resource, if available. If you return
+    -- a 'Nothing', then this is considered a top-level page.
+    breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))
+
+-- | Gets the title of the current page and the hierarchy of parent pages,
+-- along with their respective titles.
+breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)])
+breadcrumbs = do
+    x <- getCurrentRoute
+    case x of
+        Nothing -> return ("Not found", [])
+        Just y -> do
+            (title, next) <- breadcrumb y
+            z <- go [] next
+            return (title, z)
+  where
+    go back Nothing = return back
+    go back (Just this) = do
+        (title, next) <- breadcrumb this
+        go ((this, title) : back) next

yesod-core/Yesod/Core/Class/Dispatch.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts  #-}
+module Yesod.Core.Class.Dispatch where
+
+import Yesod.Routes.Class
+import qualified Network.Wai as W
+import Yesod.Core.Types
+import Yesod.Core.Content
+import Yesod.Core.Class.Yesod
+import Yesod.Core.Class.Handler
+import Yesod.Core.Internal.Run
+
+-- | This class is automatically instantiated when you use the template haskell
+-- mkYesod function. You should never need to deal with it directly.
+class Yesod site => YesodDispatch site where
+    yesodDispatch :: YesodRunnerEnv site -> W.Application
+
+class YesodSubDispatch sub m where
+    yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m
+                     -> W.Application
+
+instance YesodSubDispatch WaiSubsite master where
+    yesodSubDispatch YesodSubRunnerEnv {..} req =
+        app req
+      where
+        WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv
+
+-- | A helper function for creating YesodSubDispatch instances, used by the
+-- internal generated code.
+subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.
+          => HandlerT child (HandlerT parent m) TypedContent
+          -> YesodSubRunnerEnv child parent (HandlerT parent m)
+          -> Maybe (Route child)
+          -> W.Application
+subHelper handlert YesodSubRunnerEnv {..} route =
+    ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
+  where
+    base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route

yesod-core/Yesod/Core/Class/Handler.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Yesod.Core.Class.Handler
+    ( MonadHandler (..)
+    , MonadWidget (..)
+    ) where
+
+import Yesod.Core.Types
+import Data.Monoid (mempty)
+import Control.Monad (liftM)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..))
+import Control.Monad.Trans.Class (lift)
+import Data.Monoid (Monoid)
+import Data.Conduit.Internal (Pipe, ConduitM)
+
+import Control.Monad.Trans.Identity ( IdentityT)
+import Control.Monad.Trans.List     ( ListT    )
+import Control.Monad.Trans.Maybe    ( MaybeT   )
+import Control.Monad.Trans.Error    ( ErrorT, Error)
+import Control.Monad.Trans.Reader   ( ReaderT  )
+import Control.Monad.Trans.State    ( StateT   )
+import Control.Monad.Trans.Writer   ( WriterT  )
+import Control.Monad.Trans.RWS      ( RWST     )
+import qualified Control.Monad.Trans.RWS.Strict    as Strict ( RWST   )
+import qualified Control.Monad.Trans.State.Strict  as Strict ( StateT )
+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
+
+class MonadResource m => MonadHandler m where
+    type HandlerSite m
+    liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
+
+replaceToParent :: HandlerData site route -> HandlerData site ()
+replaceToParent hd = hd { handlerToParent = const () }
+
+instance MonadResourceBase m => MonadHandler (HandlerT site m) where
+    type HandlerSite (HandlerT site m) = site
+    liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
+{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-}
+
+instance MonadResourceBase m => MonadHandler (WidgetT site m) where
+    type HandlerSite (WidgetT site m) = site
+    liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent
+{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}
+
+#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
+GO(IdentityT)
+GO(ListT)
+GO(MaybeT)
+GOX(Error e, ErrorT e)
+GO(ReaderT r)
+GO(StateT s)
+GOX(Monoid w, WriterT w)
+GOX(Monoid w, RWST r w s)
+GOX(Monoid w, Strict.RWST r w s)
+GO(Strict.StateT s)
+GOX(Monoid w, Strict.WriterT w)
+GO(ExceptionT)
+GO(Pipe l i o u)
+GO(ConduitM i o)
+#undef GO
+#undef GOX
+
+class MonadHandler m => MonadWidget m where
+    liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
+instance MonadResourceBase m => MonadWidget (WidgetT site m) where
+    liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent
+
+#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
+#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
+GO(IdentityT)
+GO(ListT)
+GO(MaybeT)
+GOX(Error e, ErrorT e)
+GO(ReaderT r)
+GO(StateT s)
+GOX(Monoid w, WriterT w)
+GOX(Monoid w, RWST r w s)
+GOX(Monoid w, Strict.RWST r w s)
+GO(Strict.StateT s)
+GOX(Monoid w, Strict.WriterT w)
+GO(ExceptionT)
+GO(Pipe l i o u)
+GO(ConduitM i o)
+#undef GO
+#undef GOX

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -0,0 +1,603 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Yesod.Core.Class.Yesod where
+
+import           Control.Monad.Logger               (logErrorS)
+import           Yesod.Core.Content
+import           Yesod.Core.Handler
+
+import           Yesod.Routes.Class
+
+import           Blaze.ByteString.Builder           (Builder)
+import           Blaze.ByteString.Builder.Char.Utf8 (fromText)
+import           Control.Arrow                      ((***))
+import           Control.Monad                      (forM, when, void)
+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.Aeson (object, (.=))
+import           Data.List                          (foldl')
+import           Data.List                          (nub)
+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           Data.Default                       (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.Core.Internal.Session
+import           Yesod.Core.Widget
+import Control.Monad.Trans.Class (lift)
+
+-- | Define settings for a Yesod applications. All methods have intelligent
+-- defaults, and therefore no implementation is required.
+class RenderRoute site => Yesod site 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 site
+    approot = ApprootRelative
+
+    -- | Output error response pages.
+    --
+    -- Default value: 'defaultErrorHandler'.
+    errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
+    errorHandler = defaultErrorHandler
+
+    -- | Applies some form of layout to the contents of a page.
+    defaultLayout :: WidgetT site IO () -> HandlerT site IO RepHtml
+    defaultLayout w = do
+        p <- widgetToPageContent w
+        mmsg <- getMessage
+        hamletToRepHtml [hamlet|
+            $newline never
+            $doctype 5
+            <html>
+                <head>
+                    <title>#{pageTitle p}
+                    ^{pageHead p}
+                <body>
+                    $maybe msg <- mmsg
+                        <p .message>#{msg}
+                    ^{pageBody p}
+            |]
+
+    -- | 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 :: site -> Route site -> 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 site
+                 -> Bool -- ^ is this a write request?
+                 -> HandlerT site IO 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 site -> HandlerT site IO 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 :: site -> Maybe (Route site)
+    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 :: site -> [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 :: site
+             -> 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
+                     -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))
+    addStaticContent _ _ _ = return Nothing
+
+    -- | Maximum allowed length of the request body, in bytes.
+    --
+    -- If @Nothing@, no maximum is applied.
+    --
+    -- Default: 2 megabytes.
+    maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
+    maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes
+
+    -- | Creates a @Logger@ to use for log messages.
+    --
+    -- Note that a common technique (endorsed by the scaffolding) is to create
+    -- a @Logger@ value and place it in your foundation datatype, and have this
+    -- method return that already created value. That way, you can use that
+    -- same @Logger@ for printing messages during app initialization.
+    --
+    -- Default: Sends to stdout and automatically flushes on each write.
+    makeLogger :: site -> IO Logger
+    makeLogger _ = mkLogger True stdout
+
+    -- | Send a message to the @Logger@ provided by @getLogger@.
+    --
+    -- Default implementation: checks if the message should be logged using
+    -- 'shouldLog' and, if so, formats using 'formatLogMessage'.
+    messageLoggerSource :: site
+                        -> Logger
+                        -> Loc -- ^ position in source code
+                        -> LogSource
+                        -> LogLevel
+                        -> LogStr -- ^ message
+                        -> IO ()
+    messageLoggerSource a logger loc source level msg =
+        when (shouldLog a source level) $
+            formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger
+
+    -- | 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.
+    jsLoader :: site -> ScriptLoadPosition site
+    jsLoader _ = BottomOfBody
+
+    -- | Create a session backend. Returning `Nothing' disables sessions.
+    --
+    -- Default: Uses clientsession with a 2 hour timeout.
+    makeSessionBackend :: site -> IO (Maybe SessionBackend)
+    makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile
+
+    -- | 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 :: site -> 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 :: site -> LogSource -> LogLevel -> Bool
+    shouldLog _ _ level = level >= LevelInfo
+
+    -- | A Yesod middleware, which will wrap every handler function. This
+    -- allows you to run code before and after a normal handler.
+    --
+    -- Default: the 'defaultYesodMiddleware' function.
+    --
+    -- Since: 1.1.6
+    yesodMiddleware :: HandlerT site IO res -> HandlerT site IO res
+    yesodMiddleware = defaultYesodMiddleware
+
+-- | Default implementation of 'yesodMiddleware'. Adds the response header
+-- \"Vary: Accept, Accept-Language\" and performs authorization checks.
+--
+-- Since 1.2.0
+defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res
+defaultYesodMiddleware handler = do
+    addHeader "Vary" "Accept, Accept-Language"
+    authorizationCheck
+    handler
+
+-- | Check if a given request is authorized via 'isAuthorized' and
+-- 'isWriteRequest'.
+--
+-- Since 1.2.0
+authorizationCheck :: Yesod site => HandlerT site IO ()
+authorizationCheck = do
+    getCurrentRoute >>= maybe (return ()) checkUrl
+  where
+    checkUrl url = do
+        isWrite <- isWriteRequest url
+        ar <- isAuthorized url isWrite
+        case ar of
+            Authorized -> return ()
+            AuthenticationRequired -> do
+                master <- getYesod
+                case authRoute master of
+                    Nothing -> void $ notAuthenticated
+                    Just url' -> do
+                      void $ selectRep $ do
+                          provideRepType typeHtml $ do
+                              setUltDestCurrent
+                              void $ redirect url'
+                          provideRepType typeJson $
+                              void $ notAuthenticated
+            Unauthorized s' -> permissionDenied s'
+
+-- | Convert a widget to a 'PageContent'.
+widgetToPageContent :: (Eq (Route site), Yesod site)
+                    => WidgetT site IO ()
+                    -> HandlerT site IO (PageContent (Route site))
+widgetToPageContent w = do
+    master <- getYesod
+    hd <- HandlerT return
+    ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd
+    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
+            )
+
+    runUniqueList :: Eq x => UniqueList x -> [x]
+    runUniqueList (UniqueList x) = nub $ x []
+
+-- | The default error handler for 'errorHandler'.
+defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent
+defaultErrorHandler NotFound = selectRep $ do
+    provideRep $ defaultLayout $ do
+        r <- waiRequest
+        let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r
+        setTitle "Not Found"
+        toWidget [hamlet|
+            <h1>Not Found
+            <p>#{path'}
+        |]
+    provideRep $ return $ object ["message" .= ("Not Found" :: Text)]
+
+-- For API requests.
+-- For a user with a browser,
+-- if you specify an authRoute the user will be redirected there and
+-- this page will not be shown.
+defaultErrorHandler NotAuthenticated = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle "Not logged in"
+        toWidget [hamlet|
+            <h1>Not logged in
+            <p style="display:none;">Set the authRoute and the user will be redirected there.
+        |]
+
+    provideRep $ do
+        -- 401 *MUST* include a WWW-Authenticate header
+        -- however, there is no standard to indicate a redirection
+        --
+        -- change this to Basic or Digest if you allow those forms of authentications
+        addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\""
+
+        -- The client will just use the authentication_url in the JSON
+        site <- getYesod
+        rend <- getUrlRender
+        return $ object $ [
+          "message" .= ("Not logged in"::Text)
+          ] ++
+          case authRoute site of
+              Nothing -> []
+              Just url -> ["authentication_url" .= rend url]
+
+defaultErrorHandler (PermissionDenied msg) = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle "Permission Denied"
+        toWidget [hamlet|
+            <h1>Permission denied
+            <p>#{msg}
+        |]
+    provideRep $
+        return $ object $ [
+          "message" .= ("Permission Denied. " <> msg)
+          ]
+
+defaultErrorHandler (InvalidArgs ia) = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle "Invalid Arguments"
+        toWidget [hamlet|
+            <h1>Invalid Arguments
+            <ul>
+                $forall msg <- ia
+                    <li>#{msg}
+        |]
+    provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]
+defaultErrorHandler (InternalError e) = do
+    $logErrorS "yesod-core" e
+    selectRep $ do
+        provideRep $ defaultLayout $ do
+            setTitle "Internal Server Error"
+            toWidget [hamlet|
+                <h1>Internal Server Error
+                <pre>#{e}
+            |]
+        provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]
+defaultErrorHandler (BadMethod m) = selectRep $ do
+    provideRep $ defaultLayout $ do
+        setTitle"Bad Method"
+        toWidget [hamlet|
+            <h1>Method Not Supported
+            <p>Method <code>#{S8.unpack m}</code> not supported
+        |]
+    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]
+
+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 :: Int -- ^ minutes
+                            -> FilePath -- ^ key file
+                            -> IO SessionBackend
+defaultClientSessionBackend minutes fp = do
+  key <- CS.getKey fp
+  let timeout = fromIntegral (minutes * 60)
+  (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 :: CS.Key  -- ^ The encryption key
+                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
+                     -> SessionBackend
+clientSessionBackend key getCachedDate =
+  SessionBackend {
+    sbLoadSession = loadClientSession key getCachedDate "_SESSION"
+  }
+
+loadClientSession :: CS.Key
+                  -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
+                  -> S8.ByteString -- ^ session name
+                  -> W.Request
+                  -> IO (SessionMap, SaveSession)
+loadClientSession key getCachedDate sessionName 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 "/"
+          , setCookieExpires = Just (csdcExpires date)
+          , setCookieDomain = Nothing
+          , 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

yesod-core/Yesod/Core/Content.hs

@@ -0,0 +1,278 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+module Yesod.Core.Content
+    ( -- * Content
+      Content (..)
+    , emptyContent
+    , ToContent (..)
+    , ToFlushBuilder (..)
+      -- * Mime types
+      -- ** Data type
+    , ContentType
+    , typeHtml
+    , typePlain
+    , typeJson
+    , typeXml
+    , typeAtom
+    , typeRss
+    , typeJpeg
+    , typePng
+    , typeGif
+    , typeSvg
+    , typeJavascript
+    , typeCss
+    , typeFlv
+    , typeOgv
+    , typeOctet
+      -- * Utilities
+    , simpleContentType
+    , contentTypeTypes
+      -- * Evaluation strategy
+    , DontFullyEvaluate (..)
+      -- * Representations
+    , TypedContent (..)
+    , ToTypedContent (..)
+    , HasContentType (..)
+      -- ** Specific content types
+    , RepHtml
+    , RepJson (..)
+    , RepPlain (..)
+    , RepXml (..)
+      -- ** Smart constructors
+    , repJson
+    , repPlain
+    , repXml
+    ) where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import Data.Text.Lazy (Text, pack)
+import qualified Data.Text as T
+import Control.Monad (liftM)
+
+import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
+import Data.Monoid (mempty)
+
+import Text.Hamlet (Html)
+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
+import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput)
+import Data.Conduit.Internal (ResumableSource (ResumableSource))
+
+import qualified Data.Aeson as J
+import Data.Aeson.Encode (fromValue)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
+import Data.Text.Lazy.Builder (toLazyText)
+import Yesod.Core.Types
+
+-- | Zero-length enumerator.
+emptyContent :: Content
+emptyContent = ContentBuilder mempty $ Just 0
+
+-- | Anything which can be converted into 'Content'. Most of the time, you will
+-- want to use the 'ContentBuilder' constructor. An easier approach will be to use
+-- a pre-defined 'toContent' function, such as converting your data into a lazy
+-- bytestring and then calling 'toContent' on that.
+--
+-- Please note that the built-in instances for lazy data structures ('String',
+-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include
+-- the content length for the 'ContentBuilder' constructor.
+class ToContent a where
+    toContent :: a -> Content
+
+instance ToContent Content where
+    toContent = id
+instance ToContent Builder where
+    toContent = flip ContentBuilder Nothing
+instance ToContent B.ByteString where
+    toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs
+instance ToContent L.ByteString where
+    toContent = flip ContentBuilder Nothing . fromLazyByteString
+instance ToContent T.Text where
+    toContent = toContent . Blaze.fromText
+instance ToContent Text where
+    toContent = toContent . Blaze.fromLazyText
+instance ToContent String where
+    toContent = toContent . Blaze.fromString
+instance ToContent Html where
+    toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing
+instance ToContent () where
+    toContent () = toContent B.empty
+instance ToContent (ContentType, Content) where
+    toContent = snd
+instance ToContent TypedContent where
+    toContent (TypedContent _ c) = c
+
+instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
+    toContent src = ContentSource $ mapOutput toFlushBuilder src
+instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
+    toContent (ResumableSource src _) = toContent src
+
+-- | A class for all data which can be sent in a streaming response. Note that
+-- for textual data, instances must use UTF-8 encoding.
+--
+-- Since 1.2.0
+class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder
+instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id
+instance ToFlushBuilder Builder where toFlushBuilder = Chunk
+instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString
+instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString
+instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString
+instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString
+instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText
+instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText
+instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText
+instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText
+instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString
+instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString
+instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder
+instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder
+
+repJson :: ToContent a => a -> RepJson
+repJson = RepJson . toContent
+
+repPlain :: ToContent a => a -> RepPlain
+repPlain = RepPlain . toContent
+
+repXml :: ToContent a => a -> RepXml
+repXml = RepXml . toContent
+
+class ToTypedContent a => HasContentType a where
+    getContentType :: Monad m => m a -> ContentType
+
+instance HasContentType RepJson where
+    getContentType _ = typeJson
+deriving instance ToContent RepJson
+
+instance HasContentType RepPlain where
+    getContentType _ = typePlain
+deriving instance ToContent RepPlain
+
+instance HasContentType RepXml where
+    getContentType _ = typeXml
+deriving instance ToContent RepXml
+
+
+typeHtml :: ContentType
+typeHtml = "text/html; charset=utf-8"
+
+typePlain :: ContentType
+typePlain = "text/plain; charset=utf-8"
+
+typeJson :: ContentType
+typeJson = "application/json; charset=utf-8"
+
+typeXml :: ContentType
+typeXml = "text/xml"
+
+typeAtom :: ContentType
+typeAtom = "application/atom+xml"
+
+typeRss :: ContentType
+typeRss = "application/rss+xml"
+
+typeJpeg :: ContentType
+typeJpeg = "image/jpeg"
+
+typePng :: ContentType
+typePng = "image/png"
+
+typeGif :: ContentType
+typeGif = "image/gif"
+
+typeSvg :: ContentType
+typeSvg = "image/svg+xml"
+
+typeJavascript :: ContentType
+typeJavascript = "text/javascript; charset=utf-8"
+
+typeCss :: ContentType
+typeCss = "text/css; charset=utf-8"
+
+typeFlv :: ContentType
+typeFlv = "video/x-flv"
+
+typeOgv :: ContentType
+typeOgv = "video/ogg"
+
+typeOctet :: ContentType
+typeOctet = "application/octet-stream"
+
+-- | Removes \"extra\" information at the end of a content type string. In
+-- particular, removes everything after the semicolon, if present.
+--
+-- For example, \"text/html; charset=utf-8\" is commonly used to specify the
+-- character encoding for HTML data. This function would return \"text/html\".
+simpleContentType :: ContentType -> ContentType
+simpleContentType = fst . B.breakByte 59 -- 59 == ;
+
+-- Give just the media types as a pair.
+-- For example, \"text/html; charset=utf-8\" returns ("text", "html")
+contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)
+contentTypeTypes ct = (main, fst $ B.breakByte semicolon (tailEmpty sub))
+  where
+    tailEmpty x = if B.null x then "" else B.tail x
+    (main, sub) = B.breakByte slash ct
+    slash = 47
+    semicolon = 59
+
+
+instance HasContentType a => HasContentType (DontFullyEvaluate a) where
+    getContentType = getContentType . liftM unDontFullyEvaluate
+
+instance ToContent a => ToContent (DontFullyEvaluate a) where
+    toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a
+
+instance ToContent J.Value where
+    toContent = flip ContentBuilder Nothing
+              . Blaze.fromLazyText
+              . toLazyText
+              . fromValue
+instance HasContentType J.Value where
+    getContentType _ = typeJson
+
+instance HasContentType Html where
+    getContentType _ = typeHtml
+
+instance HasContentType Text where
+    getContentType _ = typePlain
+
+instance HasContentType T.Text where
+    getContentType _ = typePlain
+
+-- | Any type which can be converted to 'TypedContent'.
+--
+-- Since 1.2.0
+class ToContent a => ToTypedContent a where
+    toTypedContent :: a -> TypedContent
+
+instance ToTypedContent TypedContent where
+    toTypedContent = id
+instance ToTypedContent () where
+    toTypedContent () = TypedContent typePlain (toContent ())
+instance ToTypedContent (ContentType, Content) where
+    toTypedContent (ct, content) = TypedContent ct content
+instance ToTypedContent RepJson where
+    toTypedContent (RepJson c) = TypedContent typeJson c
+instance ToTypedContent RepPlain where
+    toTypedContent (RepPlain c) = TypedContent typePlain c
+instance ToTypedContent RepXml where
+    toTypedContent (RepXml c) = TypedContent typeXml c
+instance ToTypedContent J.Value where
+    toTypedContent v = TypedContent typeJson (toContent v)
+instance ToTypedContent Html where
+    toTypedContent h = TypedContent typeHtml (toContent h)
+instance ToTypedContent T.Text where
+    toTypedContent t = TypedContent typePlain (toContent t)
+instance ToTypedContent [Char] where
+    toTypedContent = toTypedContent . pack
+instance ToTypedContent Text where
+    toTypedContent t = TypedContent typePlain (toContent t)
+instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
+    toTypedContent (DontFullyEvaluate a) =
+        let TypedContent ct c = toTypedContent a
+         in TypedContent ct (ContentDontEvaluate c)

yesod-core/Yesod/Core/Dispatch.hs

@@ -0,0 +1,193 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Yesod.Core.Dispatch
+    ( -- * Quasi-quoted routing
+      parseRoutes
+    , parseRoutesNoCheck
+    , parseRoutesFile
+    , parseRoutesFileNoCheck
+    , mkYesod
+      -- ** More fine-grained
+    , mkYesodData
+    , mkYesodSubData
+    , mkYesodDispatch
+    , mkYesodSubDispatch
+      -- ** Path pieces
+    , PathPiece (..)
+    , PathMultiPiece (..)
+    , Texts
+      -- * Convert to WAI
+    , toWaiApp
+    , toWaiAppPlain
+    , warp
+    , warpDebug
+    , warpEnv
+    , mkDefaultMiddlewares
+      -- * WAI subsites
+    , WaiSubsite (..)
+    ) where
+
+import Prelude hiding (exp)
+import Yesod.Core.Internal.TH
+import Language.Haskell.TH.Syntax (qLocation)
+
+import Web.PathPieces
+
+import qualified Network.Wai as W
+
+import Data.ByteString.Lazy.Char8 ()
+
+import Data.Text (Text)
+import Data.Monoid (mappend)
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+import qualified Blaze.ByteString.Builder
+import Network.HTTP.Types (status301)
+import Yesod.Routes.Parse
+import Yesod.Core.Types
+import Yesod.Core.Class.Yesod
+import Yesod.Core.Class.Dispatch
+import Yesod.Core.Internal.Run
+import Safe (readMay)
+import System.Environment (getEnvironment)
+
+import Network.Wai.Middleware.Autohead
+import Network.Wai.Middleware.AcceptOverride
+import Network.Wai.Middleware.RequestLogger
+import Network.Wai.Middleware.Gzip
+import Network.Wai.Middleware.MethodOverride
+
+import qualified Network.Wai.Handler.Warp
+import System.Log.FastLogger
+import Control.Monad.Logger
+import qualified Paths_yesod_core
+import Data.Version (showVersion)
+
+-- | Convert the given argument into a WAI application, executable with any WAI
+-- handler. This function will provide no middlewares; if you want commonly
+-- used middlewares, please use 'toWaiApp'.
+toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
+toWaiAppPlain site = do
+    logger <- makeLogger site
+    sb <- makeSessionBackend site
+    return $ toWaiAppYre $ YesodRunnerEnv
+            { yreLogger = logger
+            , yreSite = site
+            , yreSessionBackend = sb
+            }
+
+toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application
+toWaiAppYre yre req =
+    case cleanPath site $ W.pathInfo req of
+        Left pieces -> sendRedirect site pieces req
+        Right pieces -> yesodDispatch yre req
+            { W.pathInfo = pieces
+            }
+  where
+    site = yreSite yre
+    sendRedirect :: Yesod master => master -> [Text] -> W.Application
+    sendRedirect y segments' env =
+         return $ W.responseLBS status301
+                [ ("Content-Type", "text/plain")
+                , ("Location", Blaze.ByteString.Builder.toByteString dest')
+                ] "Redirecting"
+      where
+        dest = joinPath y (resolveApproot y env) segments' []
+        dest' =
+            if S.null (W.rawQueryString env)
+                then dest
+                else (dest `mappend`
+                     Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
+
+-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This
+-- set may change with future releases, but currently covers:
+--
+-- * Logging
+--
+-- * GZIP compression
+--
+-- * Automatic HEAD method handling
+--
+-- * Request method override with the _method query string parameter
+--
+-- * Accept header override with the _accept query string parameter
+toWaiApp :: YesodDispatch site => site -> IO W.Application
+toWaiApp site = do
+    logger <- makeLogger site
+    sb <- makeSessionBackend site
+    let yre = YesodRunnerEnv
+                { yreLogger = logger
+                , yreSite = site
+                , yreSessionBackend = sb
+                }
+    messageLoggerSource
+        site
+        logger
+        $(qLocation >>= liftLoc)
+        "yesod-core"
+        LevelInfo
+        (toLogStr ("Application launched" :: S.ByteString))
+    middleware <- mkDefaultMiddlewares logger
+    return $ middleware $ toWaiAppYre yre
+
+-- | A convenience method to run an application using the Warp webserver on the
+-- specified port. Automatically calls 'toWaiApp'. Provides a default set of
+-- middlewares. This set may change at any point without a breaking version
+-- number. Currently, it includes:
+--
+-- If you need more fine-grained control of middlewares, please use 'toWaiApp'
+-- directly.
+--
+-- Since 1.2.0
+warp :: YesodDispatch site => Int -> site -> IO ()
+warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
+    Network.Wai.Handler.Warp.defaultSettings
+        { Network.Wai.Handler.Warp.settingsPort = port
+        , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
+            [ "Warp/"
+            , Network.Wai.Handler.Warp.warpVersion
+            , " + Yesod/"
+            , showVersion Paths_yesod_core.version
+            , " (core)"
+            ]
+        }
+
+-- | A default set of middlewares.
+--
+-- Since 1.2.0
+mkDefaultMiddlewares :: Logger -> IO W.Middleware
+mkDefaultMiddlewares logger = do
+    logWare <- mkRequestLogger def
+        { destination = Logger logger
+        , outputFormat = Apache FromSocket
+        }
+    return $ logWare
+           . acceptOverride
+           . autohead
+           . gzip def
+           . methodOverride
+
+-- | Deprecated synonym for 'warp'.
+warpDebug :: YesodDispatch site => Int -> site -> IO ()
+warpDebug = warp
+{-# DEPRECATED warpDebug "Please use warp instead" #-}
+
+-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It
+-- reads port information from the PORT environment variable, as used by tools
+-- such as Keter and the FP Complete School of Haskell.
+--
+-- Note that the exact behavior of this function may be modified slightly over
+-- time to work correctly with external tools, without a change to the type
+-- signature.
+warpEnv :: YesodDispatch site => site -> IO ()
+warpEnv site = do
+    env <- getEnvironment
+    case lookup "PORT" env of
+        Nothing -> error $ "warpEnv: no PORT environment variable found"
+        Just portS ->
+            case readMay portS of
+                Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS
+                Just port -> warp port site

yesod-core/Yesod/Core/Internal.hs

@@ -0,0 +1,7 @@
+-- | Exposed mostly for testing. These functions provide an unstable API and
+-- should not be relied upon.
+module Yesod.Core.Internal
+    ( module X
+    ) where
+
+import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest)

yesod-core/Yesod/Core/Internal/LiteApp.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternGuards #-}
+module Yesod.Core.Internal.LiteApp where
+
+import Yesod.Routes.Class
+import Data.Monoid
+import Yesod.Core.Class.Yesod
+import Yesod.Core.Class.Dispatch
+import Yesod.Core.Types
+import Yesod.Core.Content
+import Data.Text (Text)
+import Web.PathPieces
+import Network.Wai
+import Yesod.Core.Handler
+import Yesod.Core.Internal.Run
+import Network.HTTP.Types (Method)
+import Data.Maybe (fromMaybe)
+import Control.Applicative ((<|>))
+import Control.Monad.Trans.Writer
+
+newtype LiteApp = LiteApp
+    { unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent)
+    }
+
+instance Yesod LiteApp
+
+instance YesodDispatch LiteApp where
+    yesodDispatch yre req =
+        yesodRunner
+            (fromMaybe notFound $ f (requestMethod req) (pathInfo req))
+            yre
+            (Just $ LiteAppRoute $ pathInfo req)
+            req
+      where
+        LiteApp f = yreSite yre
+
+instance RenderRoute LiteApp where
+    data Route LiteApp = LiteAppRoute [Text]
+        deriving (Show, Eq, Read, Ord)
+    renderRoute (LiteAppRoute x) = (x, [])
+instance ParseRoute LiteApp where
+    parseRoute (x, _) = Just $ LiteAppRoute x
+
+instance Monoid LiteApp where
+    mempty = LiteApp $ \_ _ -> Nothing
+    mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
+
+type LiteHandler = HandlerT LiteApp IO
+type LiteWidget = WidgetT LiteApp IO
+
+liteApp :: Writer LiteApp () -> LiteApp
+liteApp = execWriter
+
+dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp ()
+dispatchTo handler = tell $ LiteApp $ \_ ps ->
+    if null ps
+        then Just $ fmap toTypedContent handler
+        else Nothing
+
+onMethod :: Method -> Writer LiteApp () -> Writer LiteApp ()
+onMethod method f = tell $ LiteApp $ \m ps ->
+    if method == m
+        then unLiteApp (liteApp f) m ps
+        else Nothing
+
+onStatic :: Text -> Writer LiteApp () -> Writer LiteApp ()
+onStatic p0 f = tell $ LiteApp $ \m ps0 ->
+    case ps0 of
+        p:ps | p == p0 -> unLiteApp (liteApp f) m ps
+        _ -> Nothing
+
+withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp ()
+withDynamic f = tell $ LiteApp $ \m ps0 ->
+    case ps0 of
+        p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps
+        _ -> Nothing
+
+withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp ()
+withDynamicMulti f = tell $ LiteApp $ \m ps ->
+    case fromPathMultiPiece ps of
+        Nothing -> Nothing
+        Just v -> unLiteApp (liteApp $ f v) m []

yesod-core/Yesod/Core/Internal/Request.hs

@@ -1,36 +1,34 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
-module Yesod.Internal.Request
+module Yesod.Core.Internal.Request
     ( parseWaiRequest
-    , Request (..)
     , RequestBodyContents
     , FileInfo
     , fileName
     , fileContentType
-    , fileSource
     , fileMove
     , mkFileInfoLBS
     , mkFileInfoFile
     , mkFileInfoSource
     , FileUpload (..)
     , tooLargeResponse
+    , tokenKey
+    , langKey
+    , textQueryString
     -- The below are exported for testing.
     , randomString
-    , parseWaiRequest'
     ) where
 
-import Control.Applicative ((<$>))
+import Data.String (IsString)
 import Control.Arrow (second)
 import qualified Network.Wai.Parse as NWP
-import Yesod.Internal
 import qualified Network.Wai as W
-import System.Random (RandomGen, newStdGen, randomRs)
+import System.Random (RandomGen, randomRs)
 import Web.Cookie (parseCookiesText)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
 import Data.Text (Text, pack)
 import Network.HTTP.Types (queryToQueryText, Status (Status))
-import Control.Monad (join)
 import Data.Maybe (fromMaybe, catMaybes)
 import qualified Data.ByteString.Lazy as L
 import qualified Data.Set as Set
@@ -43,31 +41,8 @@ import Data.Conduit.Binary (sourceFile, sinkFile)
 import Data.Word (Word64)
 import Control.Monad.IO.Class (liftIO)
 import Control.Exception (throwIO)
-
+import Yesod.Core.Types
--- | The parsed request information.
+import qualified Data.Map as Map
-data Request = Request
-    { reqGetParams :: [(Text, Text)]
-    , reqCookies :: [(Text, Text)]
-    , reqWaiRequest :: W.Request
-      -- | Languages which the client supports.
-    , reqLangs :: [Text]
-      -- | A random, session-specific token used to prevent CSRF attacks.
-    , reqToken :: Maybe Text
-      -- | Size of the request body.
-      --
-      -- Note: in the presence of chunked request bodies, this value will be 0,
-      -- even though data is available.
-    , reqBodySize :: Word64 -- FIXME Consider in the future using a Maybe to represent chunked bodies
-    }
-
-parseWaiRequest :: W.Request
-                -> [(Text, ByteString)] -- ^ session
-                -> Bool
-                -> Word64 -- ^ actual length... might be meaningless, see 'reqBodySize'
-                -> Word64 -- ^ maximum allowed body size
-                -> IO Request
-parseWaiRequest env session' useToken bodySize maxBodySize =
-    parseWaiRequest' env session' useToken bodySize maxBodySize <$> newStdGen
 
 -- | Impose a limit on the size of the request body.
 limitRequestBody :: Word64 -> W.Request -> W.Request
@@ -94,30 +69,44 @@ tooLargeResponse = W.responseLBS
     [("Content-Type", "text/plain")]
     "Request body too large to be processed."
 
-parseWaiRequest' :: RandomGen g
+parseWaiRequest :: RandomGen g
-                 => W.Request
+                => W.Request
-                 -> [(Text, ByteString)] -- ^ session
+                -> SessionMap
-                 -> Bool
+                -> Bool
-                 -> Word64
+                -> Maybe Word64 -- ^ max body size
-                 -> Word64 -- ^ max body size
+                -> (Either YesodRequest (g -> YesodRequest))
-                 -> g
+parseWaiRequest env session useToken mmaxBodySize =
-                 -> Request
+    -- In most cases, we won't need to generate any random values. Therefore,
-parseWaiRequest' env session' useToken bodySize maxBodySize gen =
+    -- we split our results: if we need a random generator, return a Right
-    Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token bodySize
+    -- value, otherwise return a Left and avoid the relatively costly generator
+    -- acquisition.
+    case etoken of
+        Left token -> Left $ mkRequest token
+        Right mkToken -> Right $ mkRequest . mkToken
   where
-    gets' = queryToQueryText $ W.queryString env
+    mkRequest token' = YesodRequest
-    gets'' = map (second $ fromMaybe "") gets'
+        { reqGetParams  = gets
+        , reqCookies    = cookies
+        , reqWaiRequest = maybe id limitRequestBody mmaxBodySize env
+        , reqLangs      = langs''
+        , reqToken      = token'
+        , reqSession    = if useToken
+                            then Map.delete tokenKey session
+                            else session
+        , reqAccept     = httpAccept env
+        }
+    gets = textQueryString env
     reqCookie = lookup "Cookie" $ W.requestHeaders env
-    cookies' = maybe [] parseCookiesText reqCookie
+    cookies = maybe [] parseCookiesText reqCookie
     acceptLang = lookup "Accept-Language" $ W.requestHeaders env
     langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
 
-    lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k
+    lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k
 
     -- The language preferences are prioritized as follows:
-    langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG
+    langs' = catMaybes [ lookup langKey gets -- Query _LANG
-                       , lookup langKey cookies'     -- Cookie _LANG
+                       , lookup langKey cookies     -- Cookie _LANG
-                       , lookupText langKey session' -- Session _LANG
+                       , lookupText langKey session -- Session _LANG
                        ] ++ langs                    -- Accept-Language(s)
 
     -- Github issue #195. We want to add an extra two-letter version of any
@@ -128,12 +117,27 @@ parseWaiRequest' env session' useToken bodySize maxBodySize gen =
     -- tokenKey present in the session is ignored). If sessions
     -- are enabled and a session has no tokenKey a new one is
     -- generated.
-    token = if not useToken
+    etoken
-              then Nothing
+        | useToken =
-              else Just $ maybe
+            case Map.lookup tokenKey session of
-                            (pack $ randomString 10 gen)
+                -- Already have a token, use it.
-                            (decodeUtf8With lenientDecode)
+                Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs
-                            (lookup tokenKey session')
+                -- Don't have a token, get a random generator and make a new one.
+                Nothing -> Right $ Just . pack . randomString 10
+        | otherwise = Left Nothing
+
+textQueryString :: W.Request -> [(Text, Text)]
+textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString
+
+-- | Get the list of accepted content types from the WAI Request\'s Accept
+-- header.
+--
+-- Since 1.2.0
+httpAccept :: W.Request -> [ContentType]
+httpAccept = NWP.parseHttpAccept
+           . fromMaybe S8.empty
+           . lookup "Accept"
+           . W.requestHeaders
 
 addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]
 addTwoLetters (toAdd, exist) [] =
@@ -156,19 +160,6 @@ randomString len = take len . map toChar . randomRs (0, 61)
         | i < 52 = toEnum $ i + fromEnum 'a' - 26
         | otherwise = toEnum $ i + fromEnum '0' - 52
 
--- | A tuple containing both the POST parameters and submitted files.
-type RequestBodyContents =
-    ( [(Text, Text)]
-    , [(Text, FileInfo)]
-    )
-
-data FileInfo = FileInfo
-    { fileName :: Text
-    , fileContentType :: Text
-    , fileSource :: Source (ResourceT IO) ByteString
-    , fileMove :: FilePath -> IO ()
-    }
-
 mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo
 mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)
 
@@ -178,6 +169,8 @@ mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourc
 mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
 mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
 
-data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)
+tokenKey :: IsString a => a
-                | FileUploadDisk (NWP.BackEnd FilePath)
+tokenKey = "_TOKEN"
-                | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))
+
+langKey :: IsString a => a
+langKey = "_LANG"

yesod-core/Yesod/Core/Internal/Response.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Yesod.Core.Internal.Response where
+
+import           Blaze.ByteString.Builder     (toByteString)
+import           Data.ByteString              (ByteString)
+import qualified Data.ByteString              as S
+import qualified Data.ByteString.Char8        as S8
+import           Data.CaseInsensitive         (CI)
+import qualified Data.CaseInsensitive         as CI
+import           Network.Wai
+import           Prelude                      hiding (catch)
+import           Web.Cookie                   (renderSetCookie)
+import           Yesod.Core.Content
+import           Yesod.Core.Types
+import qualified Network.HTTP.Types           as H
+import qualified Data.Text                    as T
+import           Control.Exception            (SomeException, handle)
+import           Blaze.ByteString.Builder     (fromLazyByteString,
+                                               toLazyByteString)
+import qualified Data.ByteString.Lazy         as L
+import qualified Data.Map                     as Map
+import           Yesod.Core.Internal.Request  (tokenKey)
+import           Data.Text.Encoding           (encodeUtf8)
+
+yarToResponse :: Monad m
+              => YesodResponse
+              -> (SessionMap -> m [Header]) -- ^ save session
+              -> YesodRequest
+              -> m Response
+yarToResponse (YRWai a) _ _ = return a
+yarToResponse (YRPlain s hs ct c newSess) saveSession yreq = do
+    extraHeaders <- do
+        let nsToken = maybe
+                newSess
+                (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
+                (reqToken yreq)
+        sessionHeaders <- saveSession nsToken
+        return $ ("Content-Type", ct) : map headerToPair sessionHeaders
+    let finalHeaders = extraHeaders ++ map headerToPair hs
+        finalHeaders' len = ("Content-Length", S8.pack $ show len)
+                          : finalHeaders
+    let go (ContentBuilder b mlen) =
+            let hs' = maybe finalHeaders finalHeaders' mlen
+             in ResponseBuilder s hs' b
+        go (ContentFile fp p) = ResponseFile s finalHeaders fp p
+        go (ContentSource body) = ResponseSource s finalHeaders body
+        go (ContentDontEvaluate c') = go c'
+    return $ 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)
+
+evaluateContent :: Content -> IO (Either ErrorResponse Content)
+evaluateContent (ContentBuilder b mlen) = 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 NotAuthenticated = H.status401
+getStatus (PermissionDenied _) = H.status403
+getStatus (BadMethod _) = H.status405

yesod-core/Yesod/Core/Internal/Run.hs

@@ -0,0 +1,286 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE FlexibleContexts  #-}
+module Yesod.Core.Internal.Run where
+
+import Yesod.Core.Internal.Response
+import           Blaze.ByteString.Builder     (toByteString)
+import           Control.Applicative          ((<$>))
+import           Control.Exception            (fromException)
+import           Control.Exception.Lifted     (catch)
+import           Control.Monad.IO.Class       (MonadIO)
+import           Control.Monad.IO.Class       (liftIO)
+import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,
+                                               liftLoc)
+import           Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)
+import qualified Data.ByteString              as S
+import qualified Data.ByteString.Char8        as S8
+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, qLocation)
+import qualified Network.HTTP.Types           as H
+import           Network.Wai
+import           Prelude                      hiding (catch)
+import           System.Log.FastLogger        (Logger)
+import           System.Log.FastLogger        (LogStr, toLogStr)
+import           System.Random                (newStdGen)
+import           Yesod.Core.Content
+import           Yesod.Core.Class.Yesod
+import           Yesod.Core.Types
+import           Yesod.Core.Internal.Request  (parseWaiRequest,
+                                               tooLargeResponse)
+import           Yesod.Routes.Class           (Route, renderRoute)
+
+-- | Function used internally by Yesod in the process of converting a
+-- 'HandlerT' into an 'Application'. Should not be needed by users.
+runHandler :: ToTypedContent c
+           => RunHandlerEnv site
+           -> HandlerT site IO c
+           -> YesodApp
+runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
+    let toErrorHandler e =
+            case fromException e of
+                Just (HCError x) -> x
+                _ -> InternalError $ T.pack $ show e
+    istate <- liftIO $ I.newIORef GHState
+        { ghsSession = reqSession yreq
+        , ghsRBC = Nothing
+        , ghsIdent = 1
+        , ghsCache = mempty
+        , ghsHeaders = mempty
+        }
+    let hd = HandlerData
+            { handlerRequest = yreq
+            , handlerEnv     = rhe
+            , handlerState   = istate
+            , handlerToParent = const ()
+            , handlerResource = resState
+            }
+    contents' <- catch (fmap Right $ unHandlerT 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 . toTypedContent) contents'
+    let handleError e = flip runInternalState resState $ do
+            yar <- rheOnError e yreq
+                { 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 (TypedContent ct c) -> do
+            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
+
+safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+       -> ErrorResponse
+       -> YesodApp
+safeEh log' er req = do
+    liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError
+           $ toLogStr $ "Error handler errored out: " ++ show er
+    return $ YRPlain
+        H.status500
+        []
+        typePlain
+        (toContent ("Internal Server Error" :: S.ByteString))
+        (reqSession req)
+
+-- | Run a 'HandlerT' 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 'HandlerT'
+-- 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
+-- @HandlerT@.  The only useful information the @HandlerT@ 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
+-- @HandlerT@ is completely ignored, including changes to the
+-- session, cookies or headers.  We only return you the
+-- @HandlerT@'s return value.
+runFakeHandler :: (Yesod site, MonadIO m) =>
+                  SessionMap
+               -> (site -> Logger)
+               -> site
+               -> HandlerT site IO a
+               -> m (Either ErrorResponse a)
+runFakeHandler fakeSessionMap logger site handler = liftIO $ do
+  ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
+  let handler' = do liftIO . I.writeIORef ret . Right =<< handler
+                    return ()
+  let yapp = runHandler
+         RunHandlerEnv
+            { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
+            , rheRoute = Nothing
+            , rheSite = site
+            , rheUpload = fileUpload site
+            , rheLog = messageLoggerSource site $ logger site
+            , rheOnError = errHandler
+            }
+        handler'
+      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 =)
+          , 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 :: (ToTypedContent res, Yesod site)
+            => HandlerT site IO res
+            -> YesodRunnerEnv site
+            -> Maybe (Route site)
+            -> Application
+yesodRunner handler' YesodRunnerEnv {..} route req
+  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
+  | otherwise = do
+    let dontSaveSession _ = return []
+    (session, saveSession) <- liftIO $ do
+        maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend
+    let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen
+    yreq <-
+        case mkYesodReq of
+            Left yreq -> return yreq
+            Right needGen -> liftIO $ needGen <$> newStdGen
+    let ra = resolveApproot yreSite req
+    let log' = messageLoggerSource yreSite yreLogger
+        -- We set up two environments: the first one has a "safe" error handler
+        -- which will never throw an exception. The second one uses the
+        -- user-provided errorHandler function. If that errorHandler function
+        -- errors out, it will use the safeEh below to recover.
+        rheSafe = RunHandlerEnv
+            { rheRender = yesodRender yreSite ra
+            , rheRoute = route
+            , rheSite = yreSite
+            , rheUpload = fileUpload yreSite
+            , rheLog = log'
+            , rheOnError = safeEh log'
+            }
+        rhe = rheSafe
+            { rheOnError = runHandler rheSafe . errorHandler
+            }
+    yar <- runHandler rhe handler yreq
+    liftIO $ yarToResponse yar saveSession yreq
+  where
+    mmaxLen = maximumContentLength yreSite route
+    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
+
+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
+
+stripHandlerT :: HandlerT child (HandlerT parent m) a
+              -> (parent -> child)
+              -> (Route child -> Route parent)
+              -> Maybe (Route child)
+              -> HandlerT parent m a
+stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
+    let env = handlerEnv hd
+    ($ hd) $ unHandlerT $ f hd
+        { handlerEnv = env
+            { rheSite = getSub $ rheSite env
+            , rheRoute = newRoute
+            , rheRender = \url params -> rheRender env (toMaster url) params
+            }
+        , handlerToParent = toMaster
+        }

yesod-core/Yesod/Core/Internal/Session.hs

@@ -0,0 +1,68 @@
+module Yesod.Core.Internal.Session
+    ( encodeClientSession
+    , decodeClientSession
+    , clientSessionDateCacher
+    , ClientSessionDateCache(..)
+    , SaveSession
+    , SessionBackend(..)
+    ) where
+
+import qualified Web.ClientSession as CS
+import Data.Serialize
+import Data.Time
+import Data.ByteString (ByteString)
+import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Monad (forever, guard)
+import Yesod.Core.Types
+import Yesod.Core.Internal.Util
+import qualified Data.IORef as I
+
+encodeClientSession :: CS.Key
+                    -> CS.IV
+                    -> ClientSessionDateCache  -- ^ expire time
+                    -> ByteString -- ^ remote host
+                    -> SessionMap -- ^ session
+                    -> ByteString -- ^ cookie value
+encodeClientSession key iv date rhost session' =
+    CS.encrypt key iv $ encode $ SessionCookie expires rhost session'
+      where expires = Right (csdcExpiresSerialized date)
+
+decodeClientSession :: CS.Key
+                    -> ClientSessionDateCache  -- ^ current time
+                    -> ByteString -- ^ remote host field
+                    -> ByteString -- ^ cookie value
+                    -> Maybe SessionMap
+decodeClientSession key date rhost encrypted = do
+    decrypted <- CS.decrypt key encrypted
+    SessionCookie (Left expire) rhost' session' <-
+        either (const Nothing) Just $ decode decrypted
+    guard $ expire > csdcNow date
+    guard $ rhost' == rhost
+    return session'
+
+
+----------------------------------------------------------------------
+
+
+-- Mostly copied from Kazu's date-cache, but with modifications
+-- that better suit our needs.
+--
+-- The cached date is updated every 10s, we don't need second
+-- resolution for session expiration times.
+
+clientSessionDateCacher ::
+     NominalDiffTime -- ^ Inactive session valitity.
+  -> IO (IO ClientSessionDateCache, IO ())
+clientSessionDateCacher validity = do
+    ref <- getUpdated >>= I.newIORef
+    tid <- forkIO $ forever (doUpdate ref)
+    return $! (I.readIORef ref, killThread tid)
+  where
+    getUpdated = do
+      now <- getCurrentTime
+      let expires  = validity `addUTCTime` now
+          expiresS = runPut (putTime expires)
+      return $! ClientSessionDateCache now expires expiresS
+    doUpdate ref = do
+      threadDelay 10000000 -- 10s
+      I.writeIORef ref =<< getUpdated

yesod-core/Yesod/Core/Internal/TH.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Yesod.Core.Internal.TH where
+
+import Prelude hiding (exp)
+import Yesod.Core.Handler
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import qualified Network.Wai as W
+
+import Data.ByteString.Lazy.Char8 ()
+import Data.List (foldl')
+
+import Yesod.Routes.TH
+import Yesod.Routes.Parse
+import Yesod.Core.Types
+import Yesod.Core.Content
+import Yesod.Core.Class.Dispatch
+import Yesod.Core.Internal.Run
+
+-- | Generates URL datatype and site function for the given 'Resource's. This
+-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
+-- Use 'parseRoutes' to create the 'Resource's.
+mkYesod :: String -- ^ name of the argument datatype
+        -> [ResourceTree String]
+        -> Q [Dec]
+mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False
+
+-- | Sometimes, you will want to declare your routes in one file and define
+-- your handlers elsewhere. For example, this is the only way to break up a
+-- monolithic file into smaller parts. Use this function, paired with
+-- 'mkYesodDispatch', to do just that.
+mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodData name res = mkYesodDataGeneral name False res
+
+mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodSubData name res = mkYesodDataGeneral name True res
+
+mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
+mkYesodDataGeneral name isSub res = do
+    let (name':rest) = words name
+    fmap fst $ mkYesodGeneral name' rest isSub res
+
+-- | See 'mkYesodData'.
+mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False
+
+-- | Get the Handler and Widget type synonyms for the given site.
+masterTypeSyns :: Type -> [Dec]
+masterTypeSyns site =
+    [ TySynD (mkName "Handler") []
+      $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
+    , TySynD (mkName "Widget")  []
+      $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()
+    ]
+
+mkYesodGeneral :: String                   -- ^ foundation type
+               -> [String]                 -- ^ arguments for the type
+               -> Bool                     -- ^ it this a subsite
+               -> [ResourceTree String]
+               -> Q([Dec],[Dec])
+mkYesodGeneral name args isSub resS = do
+    renderRouteDec <- mkRenderRouteInstance site res
+    routeAttrsDec  <- mkRouteAttrsInstance site res
+    dispatchDec    <- mkDispatchInstance site res
+    parse <- mkParseRouteInstance site res
+    let rname = mkName $ "resources" ++ name
+    eres <- lift resS
+    let resourcesDec =
+            [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
+            , FunD rname [Clause [] (NormalB eres) []]
+            ]
+    let dataDec = concat
+            [ [parse]
+            , renderRouteDec
+            , [routeAttrsDec]
+            , resourcesDec
+            , if isSub then [] else masterTypeSyns site
+            ]
+    return (dataDec, dispatchDec)
+  where site    = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args)
+        res     = map (fmap parseType) resS
+
+mkMDS :: Q Exp -> MkDispatchSettings
+mkMDS rh = MkDispatchSettings
+    { mdsRunHandler = rh
+    , mdsSubDispatcher =
+        [|\parentRunner getSub toParent env -> yesodSubDispatch
+                                 YesodSubRunnerEnv
+                                    { ysreParentRunner = parentRunner
+                                    , ysreGetSub = getSub
+                                    , ysreToParentRoute = toParent
+                                    , ysreParentEnv = env
+                                    }
+                              |]
+    , mdsGetPathInfo = [|W.pathInfo|]
+    , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
+    , mdsMethod = [|W.requestMethod|]
+    , mds404 = [|notFound >> return ()|]
+    , mds405 = [|badMethod >> return ()|]
+    , mdsGetHandler = defaultGetHandler
+    }
+
+-- | If the generation of @'YesodDispatch'@ instance require finer
+-- control of the types, contexts etc. using this combinator. You will
+-- hardly need this generality. However, in certain situations, like
+-- when writing library/plugin for yesod, this combinator becomes
+-- handy.
+mkDispatchInstance :: Type                -- ^ The master site type
+                   -> [ResourceTree a]    -- ^ The resource
+                   -> DecsQ
+mkDispatchInstance master res = do
+    clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
+    let thisDispatch = FunD 'yesodDispatch [clause']
+    return [InstanceD [] yDispatch [thisDispatch]]
+  where
+    yDispatch = ConT ''YesodDispatch `AppT` master
+
+mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
+mkYesodSubDispatch res = do
+    clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
+    inner <- newName "inner"
+    let innerFun = FunD inner [clause']
+    helper <- newName "helper"
+    let fun = FunD helper
+                [ Clause
+                    []
+                    (NormalB $ VarE inner)
+                    [innerFun]
+                ]
+    return $ LetE [fun] (VarE helper)

yesod-core/Yesod/Core/Internal/Util.hs

@@ -0,0 +1,46 @@
+module Yesod.Core.Internal.Util
+    ( putTime
+    , getTime
+    , formatW3
+    , formatRFC1123
+    , formatRFC822
+    ) where
+
+import           Data.Int       (Int64)
+import           Data.Serialize (Get, Put, Serialize (..))
+import qualified Data.Text      as T
+import           Data.Time      (Day (ModifiedJulianDay, toModifiedJulianDay),
+                                 DiffTime, UTCTime (..), formatTime)
+import           System.Locale  (defaultTimeLocale)
+
+putTime :: UTCTime -> Put
+putTime (UTCTime d t) =
+  let d' = fromInteger  $ toModifiedJulianDay d
+      t' = fromIntegral $ fromEnum (t / diffTimeScale)
+  in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')
+
+getTime :: Get UTCTime
+getTime = do
+  val <- get
+  let (d, t) = val `divMod` posixDayLength_int64
+      d' = ModifiedJulianDay $! fromIntegral d
+      t' = fromIntegral t
+  d' `seq` t' `seq` return (UTCTime d' t')
+
+posixDayLength_int64 :: Int64
+posixDayLength_int64 = 86400
+
+diffTimeScale :: DiffTime
+diffTimeScale = 1e12
+
+-- | Format a 'UTCTime' in W3 format.
+formatW3 :: UTCTime -> T.Text
+formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"
+
+-- | Format as per RFC 1123.
+formatRFC1123 :: UTCTime -> T.Text
+formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"
+
+-- | Format as per RFC 822.
+formatRFC822 :: UTCTime -> T.Text
+formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"

yesod-core/Yesod/Core/Json.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Yesod.Core.Json
+    ( -- * Convert from a JSON value
+      defaultLayoutJson
+    , jsonToRepJson
+
+      -- * Convert to a JSON value
+    , parseJsonBody
+    , parseJsonBody_
+
+      -- * Produce JSON values
+    , J.Value (..)
+    , J.ToJSON (..)
+    , J.FromJSON (..)
+    , array
+    , object
+    , (.=)
+    , (J..:)
+
+      -- * Convenience functions
+    , jsonOrRedirect
+    , acceptsJson
+    ) where
+
+import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody)
+import Yesod.Core.Content (TypedContent)
+import Yesod.Core.Types (reqAccept)
+import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
+import Yesod.Core.Class.Handler
+import Yesod.Core.Widget (WidgetT)
+import Yesod.Routes.Class
+import qualified Data.Aeson as J
+import qualified Data.Aeson.Parser as JP
+import Data.Aeson ((.=), object)
+import Data.Conduit.Attoparsec (sinkParser)
+import Data.Text (pack)
+import qualified Data.Vector as V
+import Data.Conduit
+import qualified Data.ByteString.Char8 as B8
+import Data.Maybe (listToMaybe)
+import Control.Monad (liftM)
+
+-- | Provide both an HTML and JSON representation for a piece of
+-- data, using the default layout for the HTML output
+-- ('defaultLayout').
+--
+-- /Since: 0.3.0/
+defaultLayoutJson :: (Yesod site, J.ToJSON a)
+                  => WidgetT site IO ()  -- ^ HTML
+                  -> HandlerT site IO a  -- ^ JSON
+                  -> HandlerT site IO TypedContent
+defaultLayoutJson w json = selectRep $ do
+    provideRep $ defaultLayout w
+    provideRep $ fmap J.toJSON json
+
+-- | Wraps a data type in a 'RepJson'.  The data type must
+-- support conversion to JSON via 'J.ToJSON'.
+--
+-- /Since: 0.3.0/
+jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value
+jsonToRepJson = return . J.toJSON
+
+-- | Parse the request body to a data type as a JSON value.  The
+-- data type must support conversion from JSON via 'J.FromJSON'.
+-- If you want the raw JSON value, just ask for a @'J.Result'
+-- 'J.Value'@.
+--
+-- /Since: 0.3.0/
+parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
+parseJsonBody = do
+    eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
+    return $ case eValue of
+        Left e -> J.Error $ show e
+        Right value -> J.fromJSON value
+
+-- | Same as 'parseJsonBody', but return an invalid args response on a parse
+-- error.
+parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
+parseJsonBody_ = do
+    ra <- parseJsonBody
+    case ra of
+        J.Error s -> invalidArgs [pack s]
+        J.Success a -> return a
+
+-- | Convert a list of values to an 'J.Array'.
+array :: J.ToJSON a => [a] -> J.Value
+array = J.Array . V.fromList . map J.toJSON
+
+-- | jsonOrRedirect simplifies the scenario where a POST handler sends a different
+-- response based on Accept headers:
+--
+--     1. 200 with JSON data if the client prefers
+--     @application\/json@ (e.g. AJAX, see 'acceptsJSON').
+--
+--     2. 3xx otherwise, following the PRG pattern.
+jsonOrRedirect :: (MonadHandler m, J.ToJSON a)
+               => Route (HandlerSite m) -- ^ Redirect target
+               -> a            -- ^ Data to send via JSON
+               -> m J.Value
+jsonOrRedirect r j = do
+    q <- acceptsJson
+    if q then return (J.toJSON j)
+         else redirect r
+
+-- | Returns @True@ if the client prefers @application\/json@ as
+-- indicated by the @Accept@ HTTP header.
+acceptsJson :: MonadHandler m => m Bool
+acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
+            .  listToMaybe
+            .  reqAccept)
+           `liftM` getRequest

yesod-core/Yesod/Core/Types.hs

@@ -0,0 +1,439 @@
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Yesod.Core.Types where
+
+import qualified Blaze.ByteString.Builder           as BBuilder
+import qualified Blaze.ByteString.Builder.Char.Utf8
+import           Control.Applicative                (Applicative (..))
+import           Control.Applicative                ((<$>))
+import           Control.Arrow                      (first)
+import           Control.Exception                  (Exception)
+import           Control.Monad                      (liftM, ap)
+import           Control.Monad.Base                 (MonadBase (liftBase))
+import           Control.Monad.IO.Class             (MonadIO (liftIO))
+import           Control.Monad.Logger               (LogLevel, LogSource,
+                                                     MonadLogger (..))
+import           Control.Monad.Trans.Control        (MonadBaseControl (..))
+import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState)
+import           Data.ByteString                    (ByteString)
+import qualified Data.ByteString.Lazy               as L
+import           Data.Conduit                       (Flush, MonadThrow (..),
+                                                     MonadUnsafeIO (..),
+                                                     ResourceT, Source)
+import           Data.Dynamic                       (Dynamic)
+import           Data.IORef                         (IORef)
+import           Data.Map                           (Map, unionWith)
+import qualified Data.Map                           as Map
+import           Data.Monoid                        (Endo (..), Last (..),
+                                                     Monoid (..))
+import           Data.Serialize                     (Serialize (..),
+                                                     putByteString)
+import           Data.String                        (IsString (fromString))
+import           Data.Text                          (Text)
+import qualified Data.Text                          as T
+import qualified Data.Text.Lazy.Builder             as TBuilder
+import           Data.Time                          (UTCTime)
+import           Data.Typeable                      (Typeable)
+import           Data.Typeable                      (TypeRep)
+import           Language.Haskell.TH.Syntax         (Loc)
+import qualified Network.HTTP.Types                 as H
+import           Network.Wai                        (FilePart,
+                                                     RequestBodyLength)
+import qualified Network.Wai                        as W
+import qualified Network.Wai.Parse                  as NWP
+import           System.Log.FastLogger              (LogStr, Logger, toLogStr)
+import           Text.Blaze.Html                    (Html)
+import           Text.Hamlet                        (HtmlUrl)
+import           Text.Julius                        (JavascriptUrl)
+import           Web.Cookie                         (SetCookie)
+import           Yesod.Core.Internal.Util           (getTime, putTime)
+import           Control.Monad.Trans.Class          (MonadTrans (..))
+import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))
+
+-- Sessions
+type SessionMap = Map Text ByteString
+
+type SaveSession = SessionMap -- ^ The session contents after running the handler
+                -> IO [Header]
+
+newtype SessionBackend = SessionBackend
+    { sbLoadSession :: W.Request
+                    -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
+    }
+
+data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap
+    deriving (Show, Read)
+instance Serialize SessionCookie where
+    put (SessionCookie a b c) = do
+        either putTime putByteString a
+        put b
+        put (map (first T.unpack) $ Map.toList c)
+
+    get = do
+        a <- getTime
+        b <- get
+        c <- map (first T.pack) <$> get
+        return $ SessionCookie (Left a) b (Map.fromList c)
+
+data ClientSessionDateCache =
+  ClientSessionDateCache {
+    csdcNow               :: !UTCTime
+  , csdcExpires           :: !UTCTime
+  , csdcExpiresSerialized :: !ByteString
+  } deriving (Eq, Show)
+
+-- | The parsed request information. This type augments the standard WAI
+-- 'W.Request' with additional information.
+data YesodRequest = YesodRequest
+    { reqGetParams  :: ![(Text, Text)]
+      -- ^ Same as 'W.queryString', but decoded to @Text@.
+    , reqCookies    :: ![(Text, Text)]
+    , reqWaiRequest :: !W.Request
+    , reqLangs      :: ![Text]
+      -- ^ Languages which the client supports. This is an ordered list by preference.
+    , reqToken      :: !(Maybe Text)
+      -- ^ A random, session-specific token used to prevent CSRF attacks.
+    , reqSession    :: !SessionMap
+      -- ^ Initial session sent from the client.
+      --
+      -- Since 1.2.0
+    , reqAccept     :: ![ContentType]
+      -- ^ An ordered list of the accepted content types.
+      --
+      -- Since 1.2.0
+    }
+
+-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,
+-- or a higher-level data structure which Yesod will turn into a @Response@.
+data YesodResponse
+    = YRWai !W.Response
+    | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap
+
+-- | A tuple containing both the POST parameters and submitted files.
+type RequestBodyContents =
+    ( [(Text, Text)]
+    , [(Text, FileInfo)]
+    )
+
+data FileInfo = FileInfo
+    { fileName        :: !Text
+    , fileContentType :: !Text
+    , fileSourceRaw   :: !(Source (ResourceT IO) ByteString)
+    , fileMove        :: !(FilePath -> IO ())
+    }
+
+data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
+                | FileUploadDisk !(NWP.BackEnd FilePath)
+                | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
+
+-- | How to determine the root of the application for constructing URLs.
+--
+-- Note that future versions of Yesod may add new constructors without bumping
+-- the major version number. As a result, you should /not/ pattern match on
+-- @Approot@ values.
+data Approot master = ApprootRelative -- ^ No application root.
+                    | ApprootStatic !Text
+                    | ApprootMaster !(master -> Text)
+                    | ApprootRequest !(master -> W.Request -> Text)
+
+type ResolvedApproot = Text
+
+data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
+    deriving (Eq, Show, Read)
+
+data ScriptLoadPosition master
+    = BottomOfBody
+    | BottomOfHeadBlocking
+    | BottomOfHeadAsync (BottomOfHeadAsync master)
+
+type BottomOfHeadAsync master
+       = [Text] -- ^ urls to load asynchronously
+      -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
+      -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
+
+newtype Cache = Cache (Map TypeRep Dynamic)
+    deriving Monoid
+
+type Texts = [Text]
+
+-- | Wrap up a normal WAI application as a Yesod subsite.
+newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
+
+data RunHandlerEnv site = RunHandlerEnv
+    { rheRender   :: !(Route site -> [(Text, Text)] -> Text)
+    , rheRoute    :: !(Maybe (Route site))
+    , rheSite     :: !site
+    , rheUpload   :: !(RequestBodyLength -> FileUpload)
+    , rheLog      :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
+    , rheOnError  :: !(ErrorResponse -> YesodApp)
+      -- ^ How to respond when an error is thrown internally.
+      --
+      -- Since 1.2.0
+    }
+
+data HandlerData site parentRoute = HandlerData
+    { handlerRequest  :: !YesodRequest
+    , handlerEnv      :: !(RunHandlerEnv site)
+    , handlerState    :: !(IORef GHState)
+    , handlerToParent :: !(Route site -> parentRoute)
+    , handlerResource :: !InternalState
+    }
+
+data YesodRunnerEnv site = YesodRunnerEnv
+    { yreLogger         :: !Logger
+    , yreSite           :: !site
+    , yreSessionBackend :: !(Maybe SessionBackend)
+    }
+
+data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv
+    { ysreParentRunner  :: !(ParentRunner parent parentMonad)
+    , ysreGetSub        :: !(parent -> sub)
+    , ysreToParentRoute :: !(Route sub -> Route parent)
+    , ysreParentEnv     :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?
+    }
+
+type ParentRunner parent m
+    = m TypedContent
+   -> YesodRunnerEnv parent
+   -> Maybe (Route parent)
+   -> W.Application
+
+-- | A generic handler monad, which can have a different subsite and master
+-- site. We define a newtype for better error message.
+newtype HandlerT site m a = HandlerT
+    { unHandlerT :: HandlerData site (MonadRoute m) -> m a
+    }
+
+type family MonadRoute (m :: * -> *)
+type instance MonadRoute IO = ()
+type instance MonadRoute (HandlerT site m) = (Route site)
+
+data GHState = GHState
+    { ghsSession :: SessionMap
+    , ghsRBC     :: Maybe RequestBodyContents
+    , ghsIdent   :: Int
+    , ghsCache   :: Cache
+    , ghsHeaders :: Endo [Header]
+    }
+
+-- | An extension of the basic WAI 'W.Application' datatype to provide extra
+-- features needed by Yesod. Users should never need to use this directly, as
+-- the 'HandlerT' monad and template haskell code should hide it away.
+type YesodApp = YesodRequest -> ResourceT IO YesodResponse
+
+-- | A generic widget, allowing specification of both the subsite and master
+-- site datatypes. While this is simply a @WriterT@, we define a newtype for
+-- better error messages.
+newtype WidgetT site m a = WidgetT
+    { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))
+    }
+
+instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where
+    mempty = return ()
+    mappend x y = x >> y
+
+type RY master = Route master -> [(Text, Text)] -> Text
+
+-- | Newtype wrapper allowing injection of arbitrary content into CSS.
+--
+-- Usage:
+--
+-- > toWidget $ CssBuilder "p { color: red }"
+--
+-- Since: 1.1.3
+newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
+
+-- | Content for a web page. By providing this datatype, we can easily create
+-- generic site templates, which would have the type signature:
+--
+-- > PageContent url -> HtmlUrl url
+data PageContent url = PageContent
+    { pageTitle :: Html
+    , pageHead  :: HtmlUrl url
+    , pageBody  :: HtmlUrl url
+    }
+
+data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.
+             | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))
+             | ContentFile !FilePath !(Maybe FilePart)
+             | ContentDontEvaluate !Content
+
+data TypedContent = TypedContent !ContentType !Content
+
+type RepHtml = Html
+newtype RepJson = RepJson Content
+newtype RepPlain = RepPlain Content
+newtype RepXml = RepXml Content
+
+type ContentType = ByteString -- FIXME Text?
+
+-- | Prevents a response body from being fully evaluated before sending the
+-- request.
+--
+-- Since 1.1.0
+newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
+
+-- | Responses to indicate some form of an error occurred. These are different
+-- from 'SpecialResponse' in that they allow for custom error pages.
+data ErrorResponse =
+      NotFound
+    | InternalError Text
+    | InvalidArgs [Text]
+    | NotAuthenticated
+    | PermissionDenied Text
+    | BadMethod H.Method
+    deriving (Show, Eq, Typeable)
+
+----- header stuff
+-- | Headers to be added to a 'Result'.
+data Header =
+    AddCookie SetCookie
+    | DeleteCookie ByteString ByteString
+    | Header ByteString ByteString
+    deriving (Eq, Show)
+
+data Location url = Local url | Remote Text
+    deriving (Show, Eq)
+
+newtype UniqueList x = UniqueList ([x] -> [x])
+
+data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
+    deriving (Show, Eq)
+data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
+    deriving (Show, Eq)
+newtype Title = Title { unTitle :: Html }
+
+newtype Head url = Head (HtmlUrl url)
+    deriving Monoid
+newtype Body url = Body (HtmlUrl url)
+    deriving Monoid
+
+type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder
+
+data GWData a = GWData
+    { gwdBody        :: !(Body a)
+    , gwdTitle       :: !(Last Title)
+    , gwdScripts     :: !(UniqueList (Script a))
+    , gwdStylesheets :: !(UniqueList (Stylesheet a))
+    , gwdCss         :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type
+    , gwdJavascript  :: !(Maybe (JavascriptUrl a))
+    , gwdHead        :: !(Head a)
+    }
+instance Monoid (GWData a) where
+    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
+    mappend (GWData a1 a2 a3 a4 a5 a6 a7)
+            (GWData b1 b2 b3 b4 b5 b6 b7) = GWData
+        (a1 `mappend` b1)
+        (a2 `mappend` b2)
+        (a3 `mappend` b3)
+        (a4 `mappend` b4)
+        (unionWith mappend a5 b5)
+        (a6 `mappend` b6)
+        (a7 `mappend` b7)
+
+data HandlerContents =
+      HCContent H.Status !TypedContent
+    | HCError ErrorResponse
+    | HCSendFile ContentType FilePath (Maybe FilePart)
+    | HCRedirect H.Status Text
+    | HCCreated Text
+    | HCWai W.Response
+    deriving Typeable
+
+instance Show HandlerContents where
+    show _ = "Cannot show a HandlerContents"
+instance Exception HandlerContents
+
+-- Instances for WidgetT
+instance Monad m => Functor (WidgetT site m) where
+    fmap = liftM
+instance Monad m => Applicative (WidgetT site m) where
+    pure = return
+    (<*>) = ap
+instance Monad m => Monad (WidgetT site m) where
+    return a = WidgetT $ const $ return (a, mempty)
+    WidgetT x >>= f = WidgetT $ \r -> do
+        (a, wa) <- x r
+        (b, wb) <- unWidgetT (f a) r
+        return (b, wa `mappend` wb)
+instance MonadIO m => MonadIO (WidgetT site m) where
+    liftIO = lift . liftIO
+instance MonadBase b m => MonadBase b (WidgetT site m) where
+    liftBase = WidgetT . const . liftBase . fmap (, mempty)
+instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
+    data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
+    liftBaseWith f = WidgetT $ \reader ->
+        liftBaseWith $ \runInBase ->
+            liftM (\x -> (x, mempty))
+            (f $ liftM StW . runInBase . flip unWidgetT reader)
+    restoreM (StW base) = WidgetT $ const $ restoreM base
+
+instance MonadTrans (WidgetT site) where
+    lift = WidgetT . const . liftM (, mempty)
+instance MonadThrow m => MonadThrow (WidgetT site m) where
+    monadThrow = lift . monadThrow
+instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
+    liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
+
+instance MonadIO m => MonadLogger (WidgetT site m) where
+    monadLoggerLog a b c d = WidgetT $ \hd ->
+        liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)
+
+instance MonadTrans (HandlerT site) where
+    lift = HandlerT . const
+
+-- Instances for HandlerT
+instance Monad m => Functor (HandlerT site m) where
+    fmap = liftM
+instance Monad m => Applicative (HandlerT site m) where
+    pure = return
+    (<*>) = ap
+instance Monad m => Monad (HandlerT site m) where
+    return = HandlerT . const . return
+    HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
+instance MonadIO m => MonadIO (HandlerT site m) where
+    liftIO = lift . liftIO
+instance MonadBase b m => MonadBase b (HandlerT site m) where
+    liftBase = lift . liftBase
+-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
+-- @fork@ function is incompatible with the underlying @ResourceT@ system.
+-- Instead, if you must fork a separate thread, you should use
+-- @resourceForkIO@.
+--
+-- Using fork usually leads to an exception that says
+-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
+-- after cleanup. Please contact the maintainers.\"
+instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
+    data StM (HandlerT site m) a = StH (StM m a)
+    liftBaseWith f = HandlerT $ \reader ->
+        liftBaseWith $ \runInBase ->
+            f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
+    restoreM (StH base) = HandlerT $ const $ restoreM base
+
+instance MonadThrow m => MonadThrow (HandlerT site m) where
+    monadThrow = lift . monadThrow
+instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
+    liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
+
+instance MonadIO m => MonadLogger (HandlerT site m) where
+    monadLoggerLog a b c d = HandlerT $ \hd ->
+        liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
+
+instance Monoid (UniqueList x) where
+    mempty = UniqueList id
+    UniqueList x `mappend` UniqueList y = UniqueList $ x . y
+
+instance IsString Content where
+    fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString
+
+instance RenderRoute WaiSubsite where
+    data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
+        deriving (Show, Eq, Read, Ord)
+    renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
+instance ParseRoute WaiSubsite where
+    parseRoute (x, y) = Just $ WaiSubsiteRoute x y

yesod-core/Yesod/Core/Widget.hs

@@ -0,0 +1,270 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
+-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
+-- generator, allowing you to create truly modular HTML components.
+module Yesod.Core.Widget
+    ( -- * Datatype
+      WidgetT
+    , PageContent (..)
+      -- * Special Hamlet quasiquoter/TH for Widgets
+    , whamlet
+    , whamletFile
+    , ihamletToRepHtml
+      -- * Convert to Widget
+    , ToWidget (..)
+    , ToWidgetHead (..)
+    , ToWidgetBody (..)
+    , ToWidgetMedia (..)
+      -- * Creating
+      -- ** Head of page
+    , setTitle
+    , setTitleI
+      -- ** CSS
+    , addStylesheet
+    , addStylesheetAttrs
+    , addStylesheetRemote
+    , addStylesheetRemoteAttrs
+    , addStylesheetEither
+    , CssBuilder (..)
+      -- ** Javascript
+    , addScript
+    , addScriptAttrs
+    , addScriptRemote
+    , addScriptRemoteAttrs
+    , addScriptEither
+      -- * Subsites
+    , widgetToParentWidget
+    , handlerToWidget
+      -- * Internal
+    , whamletFileWithSettings
+    ) where
+
+import Data.Monoid
+import qualified Text.Blaze.Html5 as H
+import Text.Hamlet
+import Text.Cassius
+import Text.Julius
+import Yesod.Routes.Class
+import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Text.Shakespeare.I18N (RenderMessage)
+import Control.Monad (liftM)
+import Data.Text (Text)
+import qualified Data.Map as Map
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
+
+import qualified Text.Hamlet as NP
+import Data.Text.Lazy.Builder (fromLazyText)
+import Text.Blaze.Html (toHtml, preEscapedToMarkup)
+import qualified Data.Text.Lazy as TL
+
+import Yesod.Core.Types
+import Yesod.Core.Class.Handler
+
+preEscapedLazyText :: TL.Text -> Html
+preEscapedLazyText = preEscapedToMarkup
+
+class ToWidget site a where
+    toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
+
+instance render ~ RY site => ToWidget site (render -> Html) where
+    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
+instance render ~ RY site => ToWidget site (render -> Css) where
+    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
+instance render ~ RY site => ToWidget site (render -> CssBuilder) where
+    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
+instance render ~ RY site => ToWidget site (render -> Javascript) where
+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
+instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
+    toWidget = liftWidgetT
+instance ToWidget site Html where
+    toWidget = toWidget . const
+
+-- | Allows adding some CSS to the page with a specific media type.
+--
+-- Since 1.2
+class ToWidgetMedia site a where
+    -- | Add the given content to the page, but only for the given media type.
+    --
+    -- Since 1.2
+    toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)
+                  => Text -- ^ media value
+                  -> a
+                  -> m ()
+instance render ~ RY site => ToWidgetMedia site (render -> Css) where
+    toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
+instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
+
+class ToWidgetBody site a where
+    toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
+
+instance render ~ RY site => ToWidgetBody site (render -> Html) where
+    toWidgetBody = toWidget
+instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
+    toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
+instance ToWidgetBody site Html where
+    toWidgetBody = toWidget
+
+class ToWidgetHead site a where
+    toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
+
+instance render ~ RY site => ToWidgetHead site (render -> Html) where
+    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
+instance render ~ RY site => ToWidgetHead site (render -> Css) where
+    toWidgetHead = toWidget
+instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
+    toWidgetHead = toWidget
+instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
+    toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
+instance ToWidgetHead site Html where
+    toWidgetHead = toWidgetHead . const
+
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- set values.
+setTitle :: MonadWidget m => Html -> m ()
+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
+
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- set values.
+setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()
+setTitleI msg = do
+    mr <- getMessageRender
+    setTitle $ toHtml $ mr msg
+
+-- | Link to the specified local stylesheet.
+addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()
+addStylesheet = flip addStylesheetAttrs []
+
+-- | Link to the specified local stylesheet.
+addStylesheetAttrs :: MonadWidget m
+                   => Route (HandlerSite m)
+                   -> [(Text, Text)]
+                   -> m ()
+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
+
+-- | Link to the specified remote stylesheet.
+addStylesheetRemote :: MonadWidget m => Text -> m ()
+addStylesheetRemote = flip addStylesheetRemoteAttrs []
+
+-- | Link to the specified remote stylesheet.
+addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
+
+addStylesheetEither :: MonadWidget m
+                    => Either (Route (HandlerSite m)) Text
+                    -> m ()
+addStylesheetEither = either addStylesheet addStylesheetRemote
+
+addScriptEither :: MonadWidget m
+                => Either (Route (HandlerSite m)) Text
+                -> m ()
+addScriptEither = either addScript addScriptRemote
+
+-- | Link to the specified local script.
+addScript :: MonadWidget m => Route (HandlerSite m) -> m ()
+addScript = flip addScriptAttrs []
+
+-- | Link to the specified local script.
+addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()
+addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
+
+-- | Link to the specified remote script.
+addScriptRemote :: MonadWidget m => Text -> m ()
+addScriptRemote = flip addScriptRemoteAttrs []
+
+-- | Link to the specified remote script.
+addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()
+addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
+
+whamlet :: QuasiQuoter
+whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
+
+whamletFile :: FilePath -> Q Exp
+whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
+
+whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
+whamletFileWithSettings = NP.hamletFileWithSettings rules
+
+asWidgetT :: WidgetT site m () -> WidgetT site m ()
+asWidgetT = id
+
+rules :: Q NP.HamletRules
+rules = do
+    ah <- [|asWidgetT . toWidget|]
+    let helper qg f = do
+            x <- newName "urender"
+            e <- f $ VarE x
+            let e' = LamE [VarP x] e
+            g <- qg
+            bind <- [|(>>=)|]
+            return $ InfixE (Just g) bind (Just e')
+    let ur f = do
+            let env = NP.Env
+                    (Just $ helper [|getUrlRenderParams|])
+                    (Just $ helper [|liftM (toHtml .) getMessageRender|])
+            f env
+    return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
+
+-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
+ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)
+                 => HtmlUrlI18n message (Route (HandlerSite m))
+                 -> m Html
+ihamletToRepHtml ih = do
+    urender <- getUrlRenderParams
+    mrender <- getMessageRender
+    return $ ih (toHtml . mrender) urender
+
+tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
+tell w = liftWidgetT $ WidgetT $ const $ return ((), w)
+
+toUnique :: x -> UniqueList x
+toUnique = UniqueList . (:)
+
+handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a
+handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f
+
+widgetToParentWidget :: MonadIO m
+                     => WidgetT child IO a
+                     -> HandlerT child (HandlerT parent m) (WidgetT parent m a)
+widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do
+    (a, gwd) <- liftIO $ f hd { handlerToParent = const () }
+    return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)
+
+liftGWD :: (child -> parent) -> GWData child -> GWData parent
+liftGWD tp gwd = GWData
+    { gwdBody = fixBody $ gwdBody gwd
+    , gwdTitle = gwdTitle gwd
+    , gwdScripts = fixUnique fixScript $ gwdScripts gwd
+    , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
+    , gwdCss = fmap fixCss $ gwdCss gwd
+    , gwdJavascript = fmap fixJS $ gwdJavascript gwd
+    , gwdHead = fixHead $ gwdHead gwd
+    }
+  where
+    fixRender f route params = f (tp route) params
+
+    fixBody (Body h) = Body $ h . fixRender
+    fixHead (Head h) = Head $ h . fixRender
+
+    fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)
+
+    fixScript (Script loc attrs) = Script (fixLoc loc) attrs
+    fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs
+
+    fixLoc (Local url) = Local $ tp url
+    fixLoc (Remote t) = Remote t
+
+    fixCss f = f . fixRender
+
+    fixJS f = f . fixRender

yesod-core/Yesod/Dispatch.hs

@@ -1,223 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Yesod.Dispatch
-    ( -- * Quasi-quoted routing
-      parseRoutes
-    , parseRoutesNoCheck
-    , parseRoutesFile
-    , parseRoutesFileNoCheck
-    , mkYesod
-    , mkYesodSub
-      -- ** More fine-grained
-    , mkYesodData
-    , mkYesodSubData
-    , mkYesodDispatch
-    , mkYesodSubDispatch
-    , mkDispatchInstance
-      -- ** Path pieces
-    , PathPiece (..)
-    , PathMultiPiece (..)
-    , Texts
-      -- * Convert to WAI
-    , toWaiApp
-    , toWaiAppPlain
-      -- * WAI subsites
-    , WaiSubsite (..)
-    ) where
-
-import Control.Applicative ((<$>), (<*>))
-import Prelude hiding (exp)
-import Yesod.Internal.Core
-import Yesod.Handler hiding (lift)
-import Yesod.Widget (GWidget)
-
-import Web.PathPieces
-import Language.Haskell.TH
-import Language.Haskell.TH.Syntax
-
-import qualified Network.Wai as W
-import Network.Wai.Middleware.Gzip
-import Network.Wai.Middleware.Autohead
-
-import Data.ByteString.Lazy.Char8 ()
-
-import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8With)
-import Data.Text.Encoding.Error (lenientDecode)
-import Data.Monoid (mappend)
-import qualified Data.ByteString as S
-import qualified Blaze.ByteString.Builder
-import Network.HTTP.Types (status301)
-import Yesod.Routes.TH
-import Yesod.Content (chooseRep)
-import Yesod.Routes.Parse
-import System.Log.FastLogger (Logger)
-
-type Texts = [Text]
-
--- | Generates URL datatype and site function for the given 'Resource's. This
--- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
--- Use 'parseRoutes' to create the 'Resource's.
-mkYesod :: String -- ^ name of the argument datatype
-        -> [ResourceTree String]
-        -> Q [Dec]
-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
-
--- | Generates URL datatype and site function for the given 'Resource's. This
--- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.
--- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not
--- executable by itself, but instead provides functionality to
--- be embedded in other sites.
-mkYesodSub :: String -- ^ name of the argument datatype
-           -> Cxt
-           -> [ResourceTree String]
-           -> Q [Dec]
-mkYesodSub name clazzes =
-    fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
-  where
-    (name':rest) = words name
-
--- | Sometimes, you will want to declare your routes in one file and define
--- your handlers elsewhere. For example, this is the only way to break up a
--- monolithic file into smaller parts. Use this function, paired with
--- 'mkYesodDispatch', to do just that.
-mkYesodData :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodData name res = mkYesodDataGeneral name [] False res
-
-mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
-mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
-
-mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]
-mkYesodDataGeneral name clazzes isSub res = do
-    let (name':rest) = words name
-    (x, _) <- mkYesodGeneral name' rest clazzes isSub res
-    let rname = mkName $ "resources" ++ name
-    eres <- lift res
-    let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)
-            , FunD rname [Clause [] (NormalB eres) []]
-            ]
-    return $ x ++ y
-
--- | See 'mkYesodData'.
-mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
-
-mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]
-mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
-  where (name':rest) = words name
-
-mkYesodGeneral :: String                   -- ^ foundation type
-               -> [String]                 -- ^ arguments for the type
-               -> Cxt                      -- ^ the type constraints
-               -> Bool                     -- ^ it this a subsite
-               -> [ResourceTree String]
-               -> Q([Dec],[Dec])
-mkYesodGeneral name args clazzes isSub resS = do
-     subsite        <- sub
-     masterTypeSyns <- if isSub then return   [] 
-                                else sequence [handler, widget]
-     renderRouteDec <- mkRenderRouteInstance subsite res
-     dispatchDec    <- mkDispatchInstance context sub master res
-     return (renderRouteDec ++ masterTypeSyns, dispatchDec)
-  where sub     = foldl appT subCons subArgs
-        master  = if isSub then (varT $ mkName "master") else sub
-        context = if isSub then cxt $ yesod : map return clazzes
-                           else return []
-        yesod   = classP ''Yesod [master]
-        handler = tySynD (mkName "Handler") [] [t| GHandler $master $master    |]
-        widget  = tySynD (mkName "Widget")  [] [t| GWidget  $master $master () |]
-        res     = map (fmap parseType) resS
-        subCons = conT $ mkName name
-        subArgs = map (varT. mkName) args
-        
--- | If the generation of @'YesodDispatch'@ instance require finer
--- control of the types, contexts etc. using this combinator. You will
--- hardly need this generality. However, in certain situations, like
--- when writing library/plugin for yesod, this combinator becomes
--- handy.
-mkDispatchInstance :: CxtQ                -- ^ The context
-                   -> TypeQ               -- ^ The subsite type
-                   -> TypeQ               -- ^ The master site type
-                   -> [ResourceTree a]    -- ^ The resource
-                   -> DecsQ
-mkDispatchInstance context sub master res = do
-  logger <- newName "logger"
-  let loggerE = varE logger
-      loggerP = VarP logger
-      yDispatch = conT ''YesodDispatch `appT` sub `appT` master
-      thisDispatch = do
-            Clause pat body decs <- mkDispatchClause
-                                    [|yesodRunner   $loggerE |]
-                                    [|yesodDispatch $loggerE |]
-                                    [|fmap chooseRep|]
-                                    res
-            return $ FunD 'yesodDispatch
-                         [ Clause (loggerP:pat)
-                                  body
-                                  decs
-                         ]
-      in sequence [instanceD context yDispatch [thisDispatch]]
-        
-
--- | Convert the given argument into a WAI application, executable with any WAI
--- handler. This is the same as 'toWaiAppPlain', except it includes two
--- middlewares: GZIP compression and autohead. This is the
--- recommended approach for most users.
-toWaiApp :: ( Yesod master
-            , YesodDispatch master master
-            ) => master -> IO W.Application
-toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
-
--- | Convert the given argument into a WAI application, executable with any WAI
--- handler. This differs from 'toWaiApp' in that it uses no middlewares.
-toWaiAppPlain :: ( Yesod master
-                 , YesodDispatch master master
-                 ) => master -> IO W.Application
-toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a
-
-
-toWaiApp' :: ( Yesod master
-             , YesodDispatch master master
-             )
-          => master
-          -> Logger
-          -> Maybe (SessionBackend master)
-          -> W.Application
-toWaiApp' y logger sb env =
-    case cleanPath y $ W.pathInfo env of
-        Left pieces -> sendRedirect y pieces env
-        Right pieces ->
-            yesodDispatch logger y y id app404 handler405 method pieces sb env
-  where
-    app404 = yesodRunner logger notFound y y Nothing id
-    handler405 route = yesodRunner logger badMethod y y (Just route) id
-    method = decodeUtf8With lenientDecode $ W.requestMethod env
-
-sendRedirect :: Yesod master => master -> [Text] -> W.Application
-sendRedirect y segments' env =
-     return $ W.responseLBS status301
-            [ ("Content-Type", "text/plain")
-            , ("Location", Blaze.ByteString.Builder.toByteString dest')
-            ] "Redirecting"
-  where
-    dest = joinPath y (resolveApproot y env) segments' []
-    dest' =
-        if S.null (W.rawQueryString env)
-            then dest
-            else (dest `mappend`
-                 Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
-
--- | Wrap up a normal WAI application as a Yesod subsite.
-newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
-
-instance RenderRoute WaiSubsite where
-    data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]
-        deriving (Show, Eq, Read, Ord)
-    renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
-
-instance YesodDispatch WaiSubsite master where
-    yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app

yesod-core/Yesod/Internal.hs

@@ -1,138 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
--- | Normal users should never need access to these.
---
--- Note that no guarantees of API stability are provided on this module. Use at your own risk.
-module Yesod.Internal
-    ( -- * Error responses
-      ErrorResponse (..)
-    , HandlerContents (..)
-      -- * Header
-    , Header (..)
-      -- * Cookie names
-    , langKey
-      -- * Widgets
-    , GWData (..)
-    , Location (..)
-    , UniqueList (..)
-    , Script (..)
-    , Stylesheet (..)
-    , Title (..)
-    , Head (..)
-    , Body (..)
-    , locationToHtmlUrl
-    , runUniqueList
-    , toUnique
-      -- * Names
-    , tokenKey
-    ) where
-
-import Text.Hamlet (HtmlUrl, Html)
-import Text.Blaze.Html (toHtml)
-import Text.Julius (JavascriptUrl)
-import Data.Monoid (Monoid (..), Last)
-import Data.List (nub)
-
-import Data.Text (Text)
-
-import Data.Typeable (Typeable)
-import Control.Exception (Exception)
-
-import qualified Network.HTTP.Types as H
-import Data.String (IsString)
-import qualified Data.Map as Map
-import Data.Text.Lazy.Builder (Builder)
-import Web.Cookie (SetCookie (..))
-import Data.ByteString (ByteString)
-import qualified Network.Wai as W
-import Yesod.Content (ChooseRep, ContentType)
-
--- | Responses to indicate some form of an error occurred. These are different
--- from 'SpecialResponse' in that they allow for custom error pages.
-data ErrorResponse =
-      NotFound
-    | InternalError Text
-    | InvalidArgs [Text]
-    | PermissionDenied Text
-    | BadMethod H.Method
-    deriving (Show, Eq, Typeable)
-instance Exception ErrorResponse
-
------ header stuff
--- | Headers to be added to a 'Result'.
-data Header =
-    AddCookie SetCookie
-    | DeleteCookie ByteString ByteString
-    | Header ByteString ByteString
-    deriving (Eq, Show)
-
-langKey :: IsString a => a
-langKey = "_LANG"
-
-data Location url = Local url | Remote Text
-    deriving (Show, Eq)
-locationToHtmlUrl :: Location url -> HtmlUrl url
-locationToHtmlUrl (Local url) render = toHtml $ render url []
-locationToHtmlUrl (Remote s) _ = toHtml s
-
-newtype UniqueList x = UniqueList ([x] -> [x])
-instance Monoid (UniqueList x) where
-    mempty = UniqueList id
-    UniqueList x `mappend` UniqueList y = UniqueList $ x . y
-runUniqueList :: Eq x => UniqueList x -> [x]
-runUniqueList (UniqueList x) = nub $ x []
-toUnique :: x -> UniqueList x
-toUnique = UniqueList . (:)
-
-data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
-    deriving (Show, Eq)
-data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
-    deriving (Show, Eq)
-newtype Title = Title { unTitle :: Html }
-
-newtype Head url = Head (HtmlUrl url)
-    deriving Monoid
-newtype Body url = Body (HtmlUrl url)
-    deriving Monoid
-
-tokenKey :: IsString a => a
-tokenKey = "_TOKEN"
-
-type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder
-
-data GWData a = GWData
-    { gwdBody :: !(Body a)
-    , gwdTitle :: !(Last Title)
-    , gwdScripts :: !(UniqueList (Script a))
-    , gwdStylesheets :: !(UniqueList (Stylesheet a))
-    , gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type
-    , gwdJavascript :: !(Maybe (JavascriptUrl a))
-    , gwdHead :: !(Head a)
-    }
-instance Monoid (GWData a) where
-    mempty = GWData mempty mempty mempty mempty mempty mempty mempty
-    mappend (GWData a1 a2 a3 a4 a5 a6 a7)
-            (GWData b1 b2 b3 b4 b5 b6 b7) = GWData
-        (a1 `mappend` b1)
-        (a2 `mappend` b2)
-        (a3 `mappend` b3)
-        (a4 `mappend` b4)
-        (Map.unionWith mappend a5 b5)
-        (a6 `mappend` b6)
-        (a7 `mappend` b7)
-
-data HandlerContents =
-      HCContent H.Status ChooseRep
-    | HCError ErrorResponse
-    | HCSendFile ContentType FilePath (Maybe W.FilePart)
-    | HCRedirect H.Status Text
-    | HCCreated Text
-    | HCWai W.Response
-    deriving Typeable
-
-instance Show HandlerContents where
-    show _ = "Cannot show a HandlerContents"
-instance Exception HandlerContents

yesod-core/Yesod/Internal/Cache.hs

@@ -1,38 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Yesod.Internal.Cache
-    ( Cache
-    , CacheKey
-    , mkCacheKey
-    , lookup
-    , insert
-    , delete
-    ) where
-
-import Prelude hiding (lookup)
-import qualified Data.IntMap as Map
-import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL))
-import Language.Haskell.TH (appE)
-import Data.Unique (hashUnique, newUnique)
-import GHC.Exts (Any)
-import Unsafe.Coerce (unsafeCoerce)
-import Data.Monoid (Monoid)
-import Control.Applicative ((<$>))
-
-newtype Cache = Cache (Map.IntMap Any)
-    deriving Monoid
-
-newtype CacheKey a = CacheKey Int
-
--- | Generate a new 'CacheKey'. Be sure to give a full type signature.
-mkCacheKey :: Q Exp
-mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)
-
-lookup :: CacheKey a -> Cache -> Maybe a
-lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m
-
-insert :: CacheKey a -> a -> Cache -> Cache
-insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m)
-
-delete :: CacheKey a -> Cache -> Cache
-delete (CacheKey k) (Cache m) = Cache (Map.delete k m)

yesod-core/Yesod/Internal/Core.hs

@@ -1,928 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TemplateHaskell #-}
--- | The basic typeclass for a Yesod application.
-module Yesod.Internal.Core
-    ( -- * Type classes
-      Yesod (..)
-    , YesodDispatch (..)
-    , RenderRoute (..)
-      -- ** Breadcrumbs
-    , YesodBreadcrumbs (..)
-    , breadcrumbs
-      -- * Utitlities
-    , maybeAuthorized
-    , widgetToPageContent
-      -- * Defaults
-    , defaultErrorHandler
-      -- * Data types
-    , AuthResult (..)
-      -- * Sessions
-    , SessionBackend (..)
-    , defaultClientSessionBackend
-    , clientSessionBackend
-    , loadClientSession
-    , clientSessionBackend2
-    , loadClientSession2
-    , clientSessionDateCacher
-    , BackendSession
-      -- * jsLoader
-    , ScriptLoadPosition (..)
-    , BottomOfHeadAsync
-    , loadJsYepnope
-      -- * Misc
-    , yesodVersion
-    , yesodRender
-    , resolveApproot
-    , Approot (..)
-    , FileUpload (..)
-    , runFakeHandler
-    ) where
-
-import Yesod.Content
-import Yesod.Handler hiding (lift, getExpires)
-import Control.Monad.Logger (logErrorS)
-
-import Yesod.Routes.Class
-import Data.Time (UTCTime, addUTCTime, getCurrentTime)
-
-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 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)
-
-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
-
--- | How to determine the root of the application for constructing URLs.
---
--- Note that future versions of Yesod may add new constructors without bumping
--- the major version number. As a result, you should /not/ pattern match on
--- @Approot@ values.
-data Approot master = ApprootRelative -- ^ No application root.
-                    | ApprootStatic Text
-                    | ApprootMaster (master -> Text)
-                    | ApprootRequest (master -> W.Request -> Text)
-
-type ResolvedApproot = Text
-
--- | 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. Otherwise, store in memory.
-    fileUpload :: a
-               -> Word64 -- ^ request body size
-               -> FileUpload
-    fileUpload _ size
-        | size > 50000 = FileUploadDisk tempFileBackEnd
-        | otherwise = FileUploadMemory lbsBackEnd
-
-    -- | 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
-  | maxLen < len = return tooLargeResponse
-  | otherwise = do
-    let dontSaveSession _ _ = return []
-    now <- liftIO getCurrentTime -- FIXME remove in next major version bump
-    (session, saveSession) <- liftIO $ do
-        maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb
-    rr <- liftIO $ parseWaiRequest req session (isJust msb) len maxLen
-    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.fromList . filter ((/=) tokenKey . fst) $ 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
-        (YARPlain _ _ ct _ newSess) -> do
-            let nsToken = Map.toList $ maybe
-                    newSess
-                    (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)
-                    (reqToken rr)
-            sessionHeaders <- liftIO (saveSession nsToken now)
-            return $ ("Content-Type", ct) : map headerToPair sessionHeaders
-        _ -> return []
-    return $ yarToResponse yar extraHeaders
-  where
-    maxLen = maximumContentLength master $ fmap toMasterRoute murl
-    len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
-    readMay s =
-        case reads $ S8.unpack s of
-            [] -> Nothing
-            (x, _):_ -> Just x
-    handler = yesodMiddleware handler'
-
-data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
-    deriving (Eq, Show, Read)
-
--- | 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).
-class YesodBreadcrumbs y where
-    -- | Returns the title and the parent resource, if available. If you return
-    -- a 'Nothing', then this is considered a top-level page.
-    breadcrumb :: Route y -> GHandler sub y (Text , Maybe (Route y))
-
--- | Gets the title of the current page and the hierarchy of parent pages,
--- along with their respective titles.
-breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)])
-breadcrumbs = do
-    x' <- getCurrentRoute
-    tm <- getRouteToMaster
-    let x = fmap tm x'
-    case x of
-        Nothing -> return ("Not found", [])
-        Just y -> do
-            (title, next) <- breadcrumb y
-            z <- go [] next
-            return (title, z)
-  where
-    go back Nothing = return back
-    go back (Just this) = 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
--- contain links to pages the user is allowed to see.
-maybeAuthorized :: Yesod a
-                => Route a
-                -> Bool -- ^ is this a write request?
-                -> GHandler s a (Maybe (Route a))
-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
-            )
-
-data ScriptLoadPosition master
-    = BottomOfBody
-    | BottomOfHeadBlocking
-    | BottomOfHeadAsync (BottomOfHeadAsync master)
-
-type BottomOfHeadAsync master
-       = [Text] -- ^ urls to load asynchronously
-      -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion
-      -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>
-
-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
-
--- | For use with setting 'jsLoader' to 'BottomOfHeadAsync'
-loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))
-loadJsYepnope eyn scripts mcomplete =
-  [hamlet|
-$newline never
-    $maybe yn <- left eyn
-        <script src=#{yn}>
-    $maybe yn <- right eyn
-        <script src=@{yn}>
-    $maybe complete <- mcomplete
-        <script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}});
-    $nothing
-        <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
-
-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 $ clientSessionBackend2 key getCachedDate
-
-
-clientSessionBackend :: Yesod master
-                     => CS.Key  -- ^ The encryption key
-                     -> Int -- ^ Inactive session valitity in minutes
-                     -> SessionBackend master
-clientSessionBackend key timeout = SessionBackend
-    { sbLoadSession = loadClientSession key timeout "_SESSION"
-    }
-{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-}
-
-loadClientSession :: Yesod master
-                  => CS.Key
-                  -> Int -- ^ timeout
-                  -> S8.ByteString -- ^ session name
-                  -> master
-                  -> W.Request
-                  -> UTCTime
-                  -> IO (BackendSession, SaveSession)
-loadClientSession key timeout sessionName master req now = return (sess, save)
-  where
-    sess = fromMaybe [] $ do
-      raw <- lookup "Cookie" $ W.requestHeaders req
-      val <- lookup sessionName $ parseCookies raw
-      let host = "" -- fixme, properly lock sessions to client address
-      decodeClientSessionOld key now host val
-    save sess' now' = do
-      -- We should never cache the IV!  Be careful!
-      iv <- liftIO CS.randomIV
-      return [AddCookie def
-          { setCookieName = sessionName
-          , setCookieValue = sessionVal iv
-          , setCookiePath = Just (cookiePath master)
-          , setCookieExpires = Just expires
-          , setCookieDomain = cookieDomain master
-          , setCookieHttpOnly = True
-          }]
-        where
-          host = "" -- fixme, properly lock sessions to client address
-          expires = fromIntegral (timeout * 60) `addUTCTime` now'
-          sessionVal iv = encodeClientSessionOld key iv expires host sess'
-{-# DEPRECATED loadClientSession "Please use loadClientSession2, which is more efficient." #-}
-
-clientSessionBackend2 :: Yesod master
-                     => CS.Key  -- ^ The encryption key
-                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
-                     -> SessionBackend master
-clientSessionBackend2 key getCachedDate =
-  SessionBackend {
-    sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req
-  }
-
-loadClientSession2 :: Yesod master
-                  => CS.Key
-                  -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
-                  -> S8.ByteString -- ^ session name
-                  -> master
-                  -> W.Request
-                  -> IO (BackendSession, SaveSession)
-loadClientSession2 key getCachedDate sessionName master req = load
-  where
-    load = do
-      date <- getCachedDate
-      return (sess date, save date)
-    sess date = fromMaybe [] $ 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 YesodApp yapp =
-        runHandler
-          handler'
-          (yesodRender master $ resolveApproot master fakeWaiRequest)
-          Nothing
-          id
-          master
-          master
-          (fileUpload master)
-          (messageLoggerSource master $ logger master)
-      errHandler err =
-        YesodApp $ \_ _ _ session -> do
-          liftIO $ I.writeIORef ret (Left err)
-          return $ YARPlain
-                     H.status500
-                     []
-                     typePlain
-                     (toContent ("runFakeHandler: errHandler" :: S8.ByteString))
-                     session
-      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 =
-        Request
-          { reqGetParams  = []
-          , reqCookies    = []
-          , reqWaiRequest = fakeWaiRequest
-          , reqLangs      = []
-          , reqToken      = Just "NaN" -- not a nonce =)
-          , reqBodySize   = 0
-          }
-      fakeContentType = []
-  _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap
-  I.readIORef ret
-{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}

yesod-core/Yesod/Internal/Session.hs

@@ -1,161 +0,0 @@
-module Yesod.Internal.Session
-    ( encodeClientSession
-    , encodeClientSessionOld
-    , decodeClientSession
-    , decodeClientSessionOld
-    , clientSessionDateCacher
-    , ClientSessionDateCache(..)
-    , BackendSession
-    , SaveSession
-    , SaveSessionOld
-    , SessionBackend(..)
-    ) where
-
-import Yesod.Internal (Header(..))
-import qualified Web.ClientSession as CS
-import Data.Int (Int64)
-import Data.Serialize
-import Data.Time
-import Data.ByteString (ByteString)
-import Control.Concurrent (forkIO, killThread, threadDelay)
-import Control.Monad (forever, guard)
-import Data.Text (Text, pack, unpack)
-import Control.Arrow (first)
-import Control.Applicative ((<$>))
-
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.IORef as I
-import qualified Network.Wai as W
-
-type BackendSession = [(Text, S8.ByteString)]
-
-type SaveSession = BackendSession    -- ^ The session contents after running the handler
-                -> UTCTime -- FIXME remove this in the next major version bump
-                -> IO [Header]
-
-type SaveSessionOld = BackendSession    -- ^ The session contents after running the handler
-                -> UTCTime
-                -> IO [Header]
-
-newtype SessionBackend master = SessionBackend
-    { sbLoadSession :: master
-                    -> W.Request
-                    -> UTCTime -- FIXME remove this in the next major version bump
-                    -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session
-    }
-
-encodeClientSession :: CS.Key
-                    -> CS.IV
-                    -> ClientSessionDateCache  -- ^ expire time
-                    -> ByteString -- ^ remote host
-                    -> [(Text, ByteString)] -- ^ session
-                    -> ByteString -- ^ cookie value
-encodeClientSession key iv date rhost session' =
-    CS.encrypt key iv $ encode $ SessionCookie expires rhost session'
-      where expires = Right (csdcExpiresSerialized date)
-
-decodeClientSession :: CS.Key
-                    -> ClientSessionDateCache  -- ^ current time
-                    -> ByteString -- ^ remote host field
-                    -> ByteString -- ^ cookie value
-                    -> Maybe [(Text, ByteString)]
-decodeClientSession key date rhost encrypted = do
-    decrypted <- CS.decrypt key encrypted
-    SessionCookie (Left expire) rhost' session' <-
-        either (const Nothing) Just $ decode decrypted
-    guard $ expire > csdcNow date
-    guard $ rhost' == rhost
-    return session'
-
-data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]
-    deriving (Show, Read)
-instance Serialize SessionCookie where
-    put (SessionCookie a b c) = do
-        either putTime putByteString a
-        put b
-        put (map (first unpack) c)
-    get = do
-        a <- getTime
-        b <- get
-        c <- map (first pack) <$> get
-        return $ SessionCookie (Left a) b c
-
-
-----------------------------------------------------------------------
-
-
--- Mostly copied from Kazu's date-cache, but with modifications
--- that better suit our needs.
---
--- The cached date is updated every 10s, we don't need second
--- resolution for session expiration times.
-
-data ClientSessionDateCache =
-  ClientSessionDateCache {
-    csdcNow               :: !UTCTime
-  , csdcExpires           :: !UTCTime
-  , csdcExpiresSerialized :: !ByteString
-  } deriving (Eq, Show)
-
-clientSessionDateCacher ::
-     NominalDiffTime -- ^ Inactive session valitity.
-  -> IO (IO ClientSessionDateCache, IO ())
-clientSessionDateCacher validity = do
-    ref <- getUpdated >>= I.newIORef
-    tid <- forkIO $ forever (doUpdate ref)
-    return $! (I.readIORef ref, killThread tid)
-  where
-    getUpdated = do
-      now <- getCurrentTime
-      let expires  = validity `addUTCTime` now
-          expiresS = runPut (putTime expires)
-      return $! ClientSessionDateCache now expires expiresS
-    doUpdate ref = do
-      threadDelay 10000000 -- 10s
-      I.writeIORef ref =<< getUpdated
-
-
-----------------------------------------------------------------------
-
-
-putTime :: Putter UTCTime
-putTime (UTCTime d t) =
-  let d' = fromInteger  $ toModifiedJulianDay d
-      t' = fromIntegral $ fromEnum (t / diffTimeScale)
-  in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')
-
-getTime :: Get UTCTime
-getTime = do
-  val <- get
-  let (d, t) = val `divMod` posixDayLength_int64
-      d' = ModifiedJulianDay $! fromIntegral d
-      t' = fromIntegral t
-  d' `seq` t' `seq` return (UTCTime d' t')
-
-posixDayLength_int64 :: Int64
-posixDayLength_int64 = 86400
-
-diffTimeScale :: DiffTime
-diffTimeScale = 1e12
-
-encodeClientSessionOld :: CS.Key
-                    -> CS.IV
-                    -> UTCTime -- ^ expire time
-                    -> ByteString -- ^ remote host
-                    -> [(Text, ByteString)] -- ^ session
-                    -> ByteString -- ^ cookie value
-encodeClientSessionOld key iv expire rhost session' =
-    CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session'
-
-decodeClientSessionOld :: CS.Key
-                    -> UTCTime -- ^ current time
-                    -> ByteString -- ^ remote host field
-                    -> ByteString -- ^ cookie value
-                    -> Maybe [(Text, ByteString)]
-decodeClientSessionOld key now rhost encrypted = do
-    decrypted <- CS.decrypt key encrypted
-    SessionCookie (Left expire) rhost' session' <-
-        either (const Nothing) Just $ decode decrypted
-    guard $ expire > now
-    guard $ rhost' == rhost
-    return session'

yesod-core/Yesod/Internal/TestApi.hs

@@ -1,11 +0,0 @@
---
--- | WARNING: This module exposes internal interfaces solely for the
--- purpose of facilitating cabal-driven testing of said interfaces.
--- This module is NOT part of the public Yesod API and should NOT be
--- imported by library users.
---
-module Yesod.Internal.TestApi
-  ( randomString, parseWaiRequest'
-  ) where
-
-import Yesod.Internal.Request (randomString, parseWaiRequest')

yesod-core/Yesod/Message.hs

@@ -1,6 +0,0 @@
--- | This module has moved to "Text.Shakespeare.I18N"
-module Yesod.Message
-    ( module Text.Shakespeare.I18N
-    ) where
-
-import Text.Shakespeare.I18N

yesod-core/Yesod/Request.hs

@@ -1,108 +0,0 @@
----------------------------------------------------------
---
--- Module        : Yesod.Request
--- Copyright     : Michael Snoyman
--- License       : BSD3
---
--- Maintainer    : Michael Snoyman <michael@snoyman.com>
--- Stability     : Stable
--- Portability   : portable
---
--- | Provides a parsed version of the raw 'W.Request' data.
---
----------------------------------------------------------
-module Yesod.Request
-    (
-      -- * Request datatype
-      RequestBodyContents
-    , Request (..)
-    , FileInfo
-    , fileName
-    , fileContentType
-    , fileSource
-    , fileMove
-      -- * Convenience functions
-    , languages
-      -- * Lookup parameters
-    , lookupGetParam
-    , lookupPostParam
-    , lookupCookie
-    , lookupFile
-      -- ** Multi-lookup
-    , lookupGetParams
-    , lookupPostParams
-    , lookupCookies
-    , lookupFiles
-    ) where
-
-import Yesod.Internal.Request
-import Yesod.Handler
-import Control.Monad (liftM)
-import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
-import Data.Maybe (listToMaybe)
-import Data.Text (Text)
-
--- | Get the list of supported languages supplied by the user.
---
--- Languages are determined based on the following three (in descending order
--- of preference):
---
--- * The _LANG get parameter.
---
--- * The _LANG cookie.
---
--- * The _LANG user session variable.
---
--- * Accept-Language HTTP header.
---
--- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.
--- If a matching language is not found the default language will be used.
---
--- This is handled by parseWaiRequest (not exposed).
-languages :: GHandler s m [Text]
-languages = reqLangs `liftM` getRequest
-
-lookup' :: Eq a => a -> [(a, b)] -> [b]
-lookup' a = map snd . filter (\x -> a == fst x)
-
--- | Lookup for GET parameters.
-lookupGetParams :: Text -> GHandler s m [Text]
-lookupGetParams pn = do
-    rr <- getRequest
-    return $ lookup' pn $ reqGetParams rr
-
--- | Lookup for GET parameters.
-lookupGetParam :: Text -> GHandler s m (Maybe Text)
-lookupGetParam = liftM listToMaybe . lookupGetParams
-
--- | Lookup for POST parameters.
-lookupPostParams :: Text -> GHandler s m [Text]
-lookupPostParams pn = do
-    (pp, _) <- runRequestBody
-    return $ lookup' pn pp
-
-lookupPostParam :: Text
-                -> GHandler s m (Maybe Text)
-lookupPostParam = liftM listToMaybe . lookupPostParams
-
--- | Lookup for POSTed files.
-lookupFile :: Text
-           -> GHandler s m (Maybe FileInfo)
-lookupFile = liftM listToMaybe . lookupFiles
-
--- | Lookup for POSTed files.
-lookupFiles :: Text
-            -> GHandler s m [FileInfo]
-lookupFiles pn = do
-    (_, files) <- runRequestBody
-    return $ lookup' pn files
-
--- | Lookup for cookie data.
-lookupCookie :: Text -> GHandler s m (Maybe Text)
-lookupCookie = liftM listToMaybe . lookupCookies
-
--- | Lookup for cookie data.
-lookupCookies :: Text -> GHandler s m [Text]
-lookupCookies pn = do
-    rr <- getRequest
-    return $ lookup' pn $ reqCookies rr

yesod-core/Yesod/Widget.hs

@@ -1,369 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE CPP #-}
--- FIXME Should we remove the older names here (addJulius, etc)?
-
--- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
--- generator, allowing you to create truly modular HTML components.
-module Yesod.Widget
-    ( -- * Datatype
-      GWidget
-    , PageContent (..)
-      -- * Special Hamlet quasiquoter/TH for Widgets
-    , whamlet
-    , whamletFile
-    , ihamletToRepHtml
-      -- * Convert to Widget
-    , ToWidget (..)
-    , ToWidgetHead (..)
-    , ToWidgetBody (..)
-      -- * Creating
-      -- ** Head of page
-    , setTitle
-    , setTitleI
-    , addHamletHead
-    , addHtmlHead
-      -- ** Body
-    , addHamlet
-    , addHtml
-    , addWidget
-    , addSubWidget
-      -- ** CSS
-    , addCassius
-    , addCassiusMedia
-    , addLucius
-    , addLuciusMedia
-    , addStylesheet
-    , addStylesheetAttrs
-    , addStylesheetRemote
-    , addStylesheetRemoteAttrs
-    , addStylesheetEither
-    , CssBuilder (..)
-      -- ** Javascript
-    , addJulius
-    , addJuliusBody
-    , addScript
-    , addScriptAttrs
-    , addScriptRemote
-    , addScriptRemoteAttrs
-    , addScriptEither
-      -- * Internal
-    , unGWidget
-    , whamletFileWithSettings
-    ) where
-
-import Data.Monoid
-import qualified Text.Blaze.Html5 as H
-import Text.Hamlet
-import Text.Cassius
-import Text.Julius
-import Yesod.Routes.Class
-import Yesod.Handler
-    ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
-    , getMessageRender, getUrlRenderParams, MonadLift (..)
-    )
-import Yesod.Message (RenderMessage)
-import Yesod.Content (RepHtml (..), toContent)
-import Control.Applicative (Applicative (..), (<$>))
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import Yesod.Internal
-import Control.Monad (liftM)
-import Data.Text (Text)
-import qualified Data.Map as Map
-import Language.Haskell.TH.Quote (QuasiQuoter)
-import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)
-
-import Control.Monad.Trans.Control (MonadBaseControl (..))
-import Control.Exception (throwIO)
-import qualified Text.Hamlet as NP
-import Data.Text.Lazy.Builder (fromLazyText, Builder)
-import Text.Blaze.Html (toHtml, preEscapedToMarkup)
-import qualified Data.Text.Lazy as TL
-import Control.Monad.Base (MonadBase (liftBase))
-import Control.Arrow (first)
-import Control.Monad.Trans.Resource
-
-import Control.Monad.Logger
-
-preEscapedLazyText :: TL.Text -> Html
-preEscapedLazyText = preEscapedToMarkup
-
--- | A generic widget, allowing specification of both the subsite and master
--- site datatypes. While this is simply a @WriterT@, we define a newtype for
--- better error messages.
-newtype GWidget sub master a = GWidget
-    { unGWidget :: GHandler sub master (a, GWData (Route master))
-    }
-
-instance (a ~ ()) => Monoid (GWidget sub master a) where
-    mempty = return ()
-    mappend x y = x >> y
-
-addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a
-addSubWidget sub (GWidget w) = do
-    master <- lift getYesod
-    let sr = fromSubRoute sub master
-    (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w
-    tell w'
-    return a
-
-class ToWidget sub master a where
-    toWidget :: a -> GWidget sub master ()
-
-type RY master = Route master -> [(Text, Text)] -> Text
-
--- | Newtype wrapper allowing injection of arbitrary content into CSS.
---
--- Usage:
---
--- > toWidget $ CssBuilder "p { color: red }"
---
--- Since: 1.1.3
-newtype CssBuilder = CssBuilder { unCssBuilder :: Builder }
-
-instance render ~ RY master => ToWidget sub master (render -> Html) where
-    toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
-instance render ~ RY master => ToWidget sub master (render -> Css) where
-    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
-instance render ~ RY master => ToWidget sub master (render -> CssBuilder) where
-    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
-instance render ~ RY master => ToWidget sub master (render -> Javascript) where
-    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
-instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where
-    toWidget = id
-instance ToWidget sub master Html where
-    toWidget = toWidget . const
-
-class ToWidgetBody sub master a where
-    toWidgetBody :: a -> GWidget sub master ()
-
-instance render ~ RY master => ToWidgetBody sub master (render -> Html) where
-    toWidgetBody = toWidget
-instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where
-    toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
-instance ToWidgetBody sub master Html where
-    toWidgetBody = toWidget
-
-class ToWidgetHead sub master a where
-    toWidgetHead :: a -> GWidget sub master ()
-
-instance render ~ RY master => ToWidgetHead sub master (render -> Html) where
-    toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
-instance render ~ RY master => ToWidgetHead sub master (render -> Css) where
-    toWidgetHead = toWidget
-instance render ~ RY master => ToWidgetHead sub master (render -> CssBuilder) where
-    toWidgetHead = toWidget
-instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where
-    toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
-instance ToWidgetHead sub master Html where
-    toWidgetHead = toWidgetHead . const
-
--- | Set the page title. Calling 'setTitle' multiple times overrides previously
--- set values.
-setTitle :: Html -> GWidget sub master ()
-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
-
--- | Set the page title. Calling 'setTitle' multiple times overrides previously
--- set values.
-setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()
-setTitleI msg = do
-    mr <- lift getMessageRender
-    setTitle $ toHtml $ mr msg
-
-{-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-}
-{-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-}
-{-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-}
-{-# DEPRECATED addWidget "addWidget can be omitted" #-}
-
--- | Add a 'Hamlet' to the head tag.
-addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()
-addHamletHead = toWidgetHead
-
--- | Add a 'Html' to the head tag.
-addHtmlHead :: Html -> GWidget sub master ()
-addHtmlHead = toWidgetHead . const
-
--- | Add a 'Hamlet' to the body tag.
-addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()
-addHamlet = toWidget
-
--- | Add a 'Html' to the body tag.
-addHtml :: Html -> GWidget sub master ()
-addHtml = toWidget
-
--- | Add another widget. This is defined as 'id', by can help with types, and
--- makes widget blocks look more consistent.
-addWidget :: GWidget sub master () -> GWidget sub master ()
-addWidget = id
-
--- | Add some raw CSS to the style tag. Applies to all media types.
-addCassius :: CssUrl (Route master) -> GWidget sub master ()
-addCassius = toWidget
-
--- | Identical to 'addCassius'.
-addLucius :: CssUrl (Route master) -> GWidget sub master ()
-addLucius = toWidget
-
--- | Add some raw CSS to the style tag, for a specific media type.
-addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
-addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty
-
--- | Identical to 'addCassiusMedia'.
-addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()
-addLuciusMedia = addCassiusMedia
-
--- | Link to the specified local stylesheet.
-addStylesheet :: Route master -> GWidget sub master ()
-addStylesheet = flip addStylesheetAttrs []
-
--- | Link to the specified local stylesheet.
-addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
-
--- | Link to the specified remote stylesheet.
-addStylesheetRemote :: Text -> GWidget sub master ()
-addStylesheetRemote = flip addStylesheetRemoteAttrs []
-
--- | Link to the specified remote stylesheet.
-addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
-
-addStylesheetEither :: Either (Route master) Text -> GWidget sub master ()
-addStylesheetEither = either addStylesheet addStylesheetRemote
-
-addScriptEither :: Either (Route master) Text -> GWidget sub master ()
-addScriptEither = either addScript addScriptRemote
-
--- | Link to the specified local script.
-addScript :: Route master -> GWidget sub master ()
-addScript = flip addScriptAttrs []
-
--- | Link to the specified local script.
-addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
-addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
-
--- | Link to the specified remote script.
-addScriptRemote :: Text -> GWidget sub master ()
-addScriptRemote = flip addScriptRemoteAttrs []
-
--- | Link to the specified remote script.
-addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
-
--- | Include raw Javascript in the page's script tag.
-addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()
-addJulius = toWidget
-
--- | Add a new script tag to the body with the contents of this 'Julius'
--- template.
-addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master ()
-addJuliusBody = toWidgetBody
-
--- | Content for a web page. By providing this datatype, we can easily create
--- generic site templates, which would have the type signature:
---
--- > PageContent url -> HtmlUrl url
-data PageContent url = PageContent
-    { pageTitle :: Html
-    , pageHead :: HtmlUrl url
-    , pageBody :: HtmlUrl url
-    }
-
-whamlet :: QuasiQuoter
-whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
-
-whamletFile :: FilePath -> Q Exp
-whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
-
-whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp
-whamletFileWithSettings = NP.hamletFileWithSettings rules
-
-rules :: Q NP.HamletRules
-rules = do
-    ah <- [|toWidget|]
-    let helper qg f = do
-            x <- newName "urender"
-            e <- f $ VarE x
-            let e' = LamE [VarP x] e
-            g <- qg
-            bind <- [|(>>=)|]
-            return $ InfixE (Just g) bind (Just e')
-    let ur f = do
-            let env = NP.Env
-                    (Just $ helper [|liftW getUrlRenderParams|])
-                    (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])
-            f env
-    return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
-
--- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
-ihamletToRepHtml :: RenderMessage master message
-                 => HtmlUrlI18n message (Route master)
-                 -> GHandler sub master RepHtml
-ihamletToRepHtml ih = do
-    urender <- getUrlRenderParams
-    mrender <- getMessageRender
-    return $ RepHtml $ toContent $ ih (toHtml . mrender) urender
-
-tell :: GWData (Route master) -> GWidget sub master ()
-tell w = GWidget $ return ((), w)
-
-instance MonadLift (GHandler sub master) (GWidget sub master) where
-    lift = GWidget . fmap (\x -> (x, mempty))
-
--- | Type-restricted version of @lift@
-liftW :: GHandler sub master a -> GWidget sub master a
-liftW = lift
-
--- Instances for GWidget
-instance Functor (GWidget sub master) where
-    fmap f (GWidget x) = GWidget (fmap (first f) x)
-instance Applicative (GWidget sub master) where
-    pure a = GWidget $ pure (a, mempty)
-    GWidget f <*> GWidget v =
-        GWidget $ k <$> f <*> v
-      where
-        k (a, wa) (b, wb) = (a b, wa `mappend` wb)
-instance Monad (GWidget sub master) where
-    return = pure
-    GWidget x >>= f = GWidget $ do
-        (a, wa) <- x
-        (b, wb) <- unGWidget (f a)
-        return (b, wa `mappend` wb)
-instance MonadIO (GWidget sub master) where
-    liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO
-instance MonadBase IO (GWidget sub master) where
-    liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase
-instance MonadBaseControl IO (GWidget sub master) where
-    data StM (GWidget sub master) a =
-        StW (StM (GHandler sub master) (a, GWData (Route master)))
-    liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->
-        liftM (\x -> (x, mempty))
-        (f $ liftM StW . runInBase . unGWidget)
-    restoreM (StW base) = GWidget $ restoreM base
-
-instance MonadUnsafeIO (GWidget sub master) where
-    unsafeLiftIO = liftIO
-instance MonadThrow (GWidget sub master) where
-    monadThrow = liftIO . throwIO
-instance MonadResource (GWidget sub master) where
-#if MIN_VERSION_resourcet(0,4,0)
-    liftResourceT = lift . liftResourceT
-#else
-    allocate a = lift . allocate a
-    register = lift . register
-    release = lift . release
-    resourceMask = lift . resourceMask
-#endif
-
-instance MonadLogger (GWidget sub master) where
-#if MIN_VERSION_monad_logger(0, 3, 0)
-    monadLoggerLog a b c = lift . monadLoggerLog a b c
-#else
-    monadLoggerLog a b = lift . monadLoggerLog a b
-    monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c
-#endif

yesod-core/attic/pong.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
+import Yesod.Core
+import Network.Wai.Handler.Warp
+
+data Pong = Pong
+
+mkYesod "Pong" [parseRoutes|
+/ HomeR GET
+|]
+
+instance Yesod Pong
+
+getHomeR = liftHandlerT $ return "PONG"
+
+main = warp 3000 Pong

yesod-core/helloworld.hs

@@ -17,17 +17,16 @@ mkYesodSub "Subsite" [] [parseRoutes|
 /multi/*Strings SubMultiR
 |]
 
-getSubRootR :: Yesod m => GHandler Subsite m RepPlain
+getSubRootR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepPlain
 getSubRootR = do
-    Subsite s <- getYesodSub
+    Subsite s <- getYesod
-    tm <- getRouteToMaster
     render <- getUrlRender
     $logDebug "I'm in SubRootR"
-    return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
+    return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render SubRootR)
 
-handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
+handleSubMultiR :: Yesod master => Strings -> HandlerT Subsite (HandlerT master IO) RepPlain
 handleSubMultiR x = do
-    Subsite y <- getYesodSub
+    Subsite y <- getYesod
     $logInfo "In SubMultiR"
     return . RepPlain . toContent . show $ (x, y)
 

yesod-core/test/YesodCoreTest.hs

@@ -13,6 +13,11 @@ import qualified YesodCoreTest.WaiSubsite as WaiSubsite
 import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
 import qualified YesodCoreTest.RequestBodySize as RequestBodySize
+import qualified YesodCoreTest.Json as Json
+import qualified YesodCoreTest.Streaming as Streaming
+import qualified YesodCoreTest.Reps as Reps
+import qualified YesodCoreTest.Auth as Auth
+import qualified YesodCoreTest.LiteApp as LiteApp
 
 import Test.Hspec
 
@@ -31,3 +36,8 @@ specs = do
       Redirect.specs
       JsLoader.specs
       RequestBodySize.specs
+      Json.specs
+      Streaming.specs
+      Reps.specs
+      Auth.specs
+      LiteApp.specs

yesod-core/test/YesodCoreTest/Auth.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
+module YesodCoreTest.Auth (specs, Widget) where
+
+import Yesod.Core
+import Test.Hspec
+import Network.Wai.Test
+import Network.Wai
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.Text as T
+import Data.List (isSuffixOf)
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/no-auth NoAuthR
+/needs-login-json NeedsLoginJsonR
+/needs-login-html NeedsLoginHtmlR
+/read-only ReadOnlyR
+/forbidden ForbiddenR
+|]
+
+instance Yesod App where
+    isAuthorized NoAuthR _ = return Authorized
+    isAuthorized NeedsLoginJsonR _ = return AuthenticationRequired
+    isAuthorized NeedsLoginHtmlR _ = return AuthenticationRequired
+    isAuthorized ReadOnlyR False = return Authorized
+    isAuthorized ReadOnlyR True = return $ Unauthorized "Read only"
+    isAuthorized ForbiddenR _ = return $ Unauthorized "Forbidden"
+    authRoute _ = Just NoAuthR
+
+handleNoAuthR, handleReadOnlyR, handleForbiddenR :: Handler ()
+handleNoAuthR     = return ()
+handleReadOnlyR   = return ()
+handleForbiddenR  = return ()
+
+handleNeedsLoginJsonR :: Handler RepJson
+handleNeedsLoginJsonR = return $ repJson $ object []
+handleNeedsLoginHtmlR :: Handler RepHtml
+handleNeedsLoginHtmlR = return ""
+
+test :: String -- ^ method
+     -> String -- ^ path
+     -> (SResponse -> Session ())
+     -> Spec
+test method path f = it (method ++ " " ++ path) $ do
+    app <- toWaiApp App
+    flip runSession app $ do
+        sres <- request defaultRequest
+            { requestMethod = S8.pack method
+            , pathInfo = [T.pack path]
+            , requestHeaders =
+                if not $ isSuffixOf "json" path then [] else
+                  [("Accept", S8.pack "application/json")]
+            }
+        f sres
+
+specs :: Spec
+specs = describe "Auth" $ do
+    test "GET" "no-auth" $ \sres -> assertStatus 200 sres
+    test "POST" "no-auth" $ \sres -> assertStatus 200 sres
+    test "GET" "needs-login-html" $ \sres -> assertStatus 303 sres
+    test "POST" "needs-login-html" $ \sres -> assertStatus 303 sres
+    test "GET" "needs-login-json" $ \sres -> assertStatus 401 sres
+    test "POST" "needs-login-json" $ \sres -> assertStatus 401 sres
+    test "GET" "read-only" $ \sres -> assertStatus 200 sres
+    test "POST" "read-only" $ \sres -> assertStatus 403 sres
+    test "GET" "forbidden" $ \sres -> assertStatus 403 sres
+    test "POST" "forbidden" $ \sres -> assertStatus 403 sres

yesod-core/test/YesodCoreTest/Cache.hs

@@ -1,38 +1,40 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 module YesodCoreTest.Cache (cacheTest, Widget) where
 
 import Test.Hspec
 
-import Network.Wai
 import Network.Wai.Test
 
 import Yesod.Core
+import Data.IORef.Lifted
+import Data.Typeable (Typeable)
+import qualified Data.ByteString.Lazy.Char8 as L8
 
 data C = C
 
-key :: CacheKey Int
+newtype V1 = V1 Int
-key = $(mkCacheKey)
+    deriving Typeable
 
-key2 :: CacheKey Int
+newtype V2 = V2 Int
-key2 = $(mkCacheKey)
+    deriving Typeable
 
 mkYesod "C" [parseRoutes|/ RootR GET|]
 
 instance Yesod C
 
-getRootR :: Handler ()
+getRootR :: Handler RepPlain
 getRootR = do
-    Nothing <- cacheLookup key
+    ref <- newIORef 0
-    cacheInsert key 5
+    V1 v1a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)
-    Just 5 <- cacheLookup key
+    V1 v1b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)
-    cacheInsert key 7
+
-    Just 7 <- cacheLookup key
+    V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
-    Nothing <- cacheLookup key2
+    V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)
-    cacheDelete key
+
-    Nothing <- cacheLookup key
+    return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]
-    return ()
 
 cacheTest :: Spec
 cacheTest =
@@ -44,5 +46,6 @@ runner f = toWaiApp C >>= runSession f
 
 works :: IO ()
 works = runner $ do
-    res <- request defaultRequest { pathInfo = [] }
+    res <- request defaultRequest
     assertStatus 200 res
+    assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -5,7 +5,7 @@ module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
 
 import Test.Hspec
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
 
 import Network.Wai
 import Network.Wai.Test
@@ -28,12 +28,14 @@ instance RenderRoute Subsite where
     data Route Subsite = SubsiteRoute [TS.Text]
         deriving (Eq, Show, Read)
     renderRoute (SubsiteRoute x) = (x, [])
+instance ParseRoute Subsite where
+    parseRoute (x, _) = Just $ SubsiteRoute x
 
-instance YesodDispatch Subsite master where
+instance YesodSubDispatch Subsite master where
-    yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS
+    yesodSubDispatch _ req = return $ responseLBS
         status200
         [ ("Content-Type", "SUBSITE")
-        ] $ L8.pack $ show pieces
+        ] $ L8.pack $ show (pathInfo req)
 
 data Y = Y
 mkYesod "Y" [parseRoutes|
@@ -84,6 +86,11 @@ cleanPathTest =
       it "/foo/something" fooSomething
       it "subsite dispatch" subsiteDispatch
       it "redirect with query string" redQueryString
+      it "parsing" $ do
+        parseRoute (["foo"], []) `shouldBe` Just FooR
+        parseRoute (["foo", "bar"], []) `shouldBe` Just (FooStringR "bar")
+        parseRoute (["subsite", "some", "path"], []) `shouldBe` Just (SubsiteR $ SubsiteRoute ["some", "path"])
+        parseRoute (["ignore", "me"], []) `shouldBe` (Nothing :: Maybe (Route Y))
 
 runner :: Session () -> IO ()
 runner f = toWaiApp Y >>= runSession f

yesod-core/test/YesodCoreTest/Exceptions.hs

@@ -5,7 +5,7 @@ module YesodCoreTest.Exceptions (exceptionsTest, Widget) where
 
 import Test.Hspec
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
 import Network.Wai
 import Network.Wai.Test
 import Network.HTTP.Types (status301)
@@ -18,7 +18,7 @@ mkYesod "Y" [parseRoutes|
 
 instance Yesod Y where
     approot = ApprootStatic "http://test"
-    errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e
+    errorHandler (InternalError e) = return $ toTypedContent e
     errorHandler x = defaultErrorHandler x
 
 getRootR :: Handler ()
@@ -26,7 +26,7 @@ getRootR = error "FOOBAR" >> return ()
 
 getRedirR :: Handler ()
 getRedirR = do
-    setHeader "foo" "bar"
+    addHeader "foo" "bar"
     redirectWith status301 RootR
 
 exceptionsTest :: Spec

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -6,9 +6,12 @@ import System.Random (StdGen, mkStdGen)
 
 import Network.Wai as W
 import Network.Wai.Test
-import Yesod.Internal.TestApi (randomString, parseWaiRequest')
+import Yesod.Core.Internal (randomString, parseWaiRequest)
-import Yesod.Request (Request (..))
 import Test.Hspec
+import Data.Monoid (mempty)
+import Data.Map (singleton)
+import Yesod.Core
+import Data.Word (Word64)
 
 randomStringSpecs :: Spec
 randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@@ -28,6 +31,15 @@ noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n
 g :: StdGen
 g = error "test/YesodCoreTest/InternalRequest.g"
 
+parseWaiRequest' :: Request
+                 -> SessionMap
+                 -> Bool
+                 -> Word64
+                 -> YesodRequest
+parseWaiRequest' a b c d =
+    case parseWaiRequest a b c (Just d) of
+        Left yreq -> yreq
+        Right needGen -> needGen g
 
 tokenSpecs :: Spec
 tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
@@ -38,19 +50,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do
 
 noDisabledToken :: Bool
 noDisabledToken = reqToken r == Nothing where
-  r = parseWaiRequest' defaultRequest [] False 0 1000 g
+  r = parseWaiRequest' defaultRequest mempty False 1000
 
 ignoreDisabledToken :: Bool
 ignoreDisabledToken = reqToken r == Nothing where
-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000
 
 useOldToken :: Bool
 useOldToken = reqToken r == Just "old" where
-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000
 
 generateToken :: Bool
 generateToken = reqToken r /= Nothing where
-  r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000
 
 
 langSpecs :: Spec
@@ -64,21 +76,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do
 respectAcceptLangs :: Bool
 respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where
   r = parseWaiRequest' defaultRequest
-        { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 1000 g
+        { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000
 
 respectSessionLang :: Bool
 respectSessionLang = reqLangs r == ["en"] where
-  r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 1000 g
+  r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000
 
 respectCookieLang :: Bool
 respectCookieLang = reqLangs r == ["en"] where
   r = parseWaiRequest' defaultRequest
         { requestHeaders = [("Cookie", "_LANG=en")]
-        } [] False 0 1000 g
+        } mempty False 1000
 
 respectQueryLang :: Bool
 respectQueryLang = reqLangs r == ["en-US", "en"] where
-  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 1000 g
+  r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000
 
 prioritizeLangs :: Bool
 prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where
@@ -87,8 +99,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e
                            , ("Cookie", "_LANG=en-COOKIE")
                            ]
         , queryString = [("_LANG", Just "en-QUERY")]
-        } [("_LANG", "en-SESSION")] False 0 10000 g
+        } (singleton "_LANG" "en-SESSION") False 10000
-
 
 internalRequestTest :: Spec
 internalRequestTest = describe "Test.InternalRequestTest" $ do

yesod-core/test/YesodCoreTest/JsLoader.hs

@@ -3,12 +3,11 @@
 {-# LANGUAGE FlexibleInstances #-}
 module YesodCoreTest.JsLoader (specs, Widget) where
 
-import YesodCoreTest.JsLoaderSites.HeadAsync (HA(..))
 import YesodCoreTest.JsLoaderSites.Bottom (B(..))
 
 import Test.Hspec
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
 import Network.Wai.Test
 
 data H = H
@@ -27,13 +26,9 @@ specs = describe "Test.JsLoader" $ do
       res <- request defaultRequest
       assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"load.js\"></script></head><body></body></html>" res
 
-    it "link from head async" $ runner HA $ do
-      res <- request defaultRequest
-      assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"yepnope.js\"></script><script>yepnope({load:[\"load.js\"]});</script></head><body></body></html>" res
-
     it "link from bottom" $ runner B $ do
       res <- request defaultRequest
       assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script src=\"load.js\"></script></body></html>" res
 
-runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO ()
+runner :: YesodDispatch master => master -> Session () -> IO ()
 runner app f = toWaiApp app >>= runSession f

yesod-core/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs

@@ -1,16 +0,0 @@
-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
-module YesodCoreTest.JsLoaderSites.HeadAsync (HA(..), Widget) where
-
-import Yesod.Core
-
-data HA = HA
-mkYesod "HA" [parseRoutes|
-/ HeadAsyncR GET
-|]
-instance Yesod HA where
-  jsLoader _ = BottomOfHeadAsync $ loadJsYepnope $ Left "yepnope.js"
-
-getHeadAsyncR :: Handler RepHtml
-getHeadAsyncR = defaultLayout $ addScriptRemote "load.js"

yesod-core/test/YesodCoreTest/Json.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
+module YesodCoreTest.Json (specs, Widget) where
+
+import Yesod.Core
+import Test.Hspec
+import qualified Data.Map as Map
+import Network.Wai.Test
+import Data.Text (Text)
+import Data.ByteString.Lazy (ByteString)
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+/has-multiple-pieces/#Int/#Int MultiplePiecesR GET
+|]
+
+instance Yesod App
+
+getHomeR :: Handler RepPlain
+getHomeR = do
+    val <- parseJsonBody_
+    case Map.lookup ("foo" :: Text) val of
+        Nothing -> invalidArgs ["foo not found"]
+        Just foo -> return $ RepPlain $ toContent (foo :: Text)
+
+getMultiplePiecesR :: Int -> Int -> Handler ()
+getMultiplePiecesR _ _ = return ()
+
+test :: String
+     -> ByteString
+     -> (SResponse -> Session ())
+     -> Spec
+test name rbody f = it name $ do
+    app <- toWaiApp App
+    flip runSession app $ do
+        sres <- srequest SRequest
+            { simpleRequest = defaultRequest
+            , simpleRequestBody = rbody
+            }
+        f sres
+
+specs :: Spec
+specs = describe "Yesod.Json" $ do
+    test "parses valid content" "{\"foo\":\"bar\"}" $ \sres -> do
+        assertStatus 200 sres
+        assertBody "bar" sres
+    test "400 for bad JSON" "{\"foo\":\"bar\"" $ \sres -> do
+        assertStatus 400 sres
+    test "400 for bad structure" "{\"foo2\":\"bar\"}" $ \sres -> do
+        assertStatus 400 sres
+        assertBodyContains "foo not found" sres

yesod-core/test/YesodCoreTest/Links.hs

@@ -5,12 +5,11 @@ module YesodCoreTest.Links (linksTest, Widget) where
 
 import Test.Hspec
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
 import Text.Hamlet
 import Network.Wai
 import Network.Wai.Test
 import Data.Text (Text)
-import Control.Monad.IO.Class (liftIO)
 import Blaze.ByteString.Builder (toByteString)
 
 data Y = Y
@@ -18,8 +17,23 @@ mkYesod "Y" [parseRoutes|
 / RootR GET
 /single/#Text TextR GET
 /multi/*Texts TextsR GET
+
+/route-test-1/+[Text] RT1 GET
+/route-test-2/*Vector-String RT2 GET
+/route-test-3/*Vector-(Maybe-Int) RT3 GET
+/route-test-4/#(Foo-Int-Int) RT4 GET
 |]
 
+data Vector a = Vector
+    deriving (Show, Read, Eq)
+
+instance PathMultiPiece (Vector a)
+
+data Foo x y = Foo
+    deriving (Show, Read, Eq)
+
+instance PathPiece (Foo x y)
+
 instance Yesod Y
 
 getRootR :: Handler RepHtml
@@ -31,6 +45,18 @@ getTextR foo = defaultLayout $ toWidget [hamlet|%#{foo}%|]
 getTextsR :: [Text] -> Handler RepHtml
 getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|]
 
+getRT1 :: [Text] -> Handler ()
+getRT1 _ = return ()
+
+getRT2 :: Vector String -> Handler ()
+getRT2 _ = return ()
+
+getRT3 :: Vector (Maybe Int) -> Handler ()
+getRT3 _ = return ()
+
+getRT4 :: Foo Int Int -> Handler ()
+getRT4 _ = return ()
+
 linksTest :: Spec
 linksTest = describe "Test.Links" $ do
       it "linkToHome" case_linkToHome

yesod-core/test/YesodCoreTest/LiteApp.hs

@@ -0,0 +1,42 @@
+module YesodCoreTest.LiteApp (specs) where
+
+import Yesod.Core
+import Test.Hspec
+import Network.Wai.Test
+import Network.Wai
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+iapp :: IO Application
+iapp = toWaiApp $ liteApp $ do
+    onMethod (S8.pack "GET") (dispatchTo $ return "GetHomepage")
+    onMethod (S8.pack "POST") (dispatchTo $ return "PostHomepage")
+    onStatic (T.pack "string") (withDynamic (\t -> dispatchTo $ return (t :: T.Text)))
+    onStatic (T.pack "multi") (withDynamicMulti (\[_, y] -> dispatchTo $ return (y :: T.Text)))
+
+test :: String -- ^ method
+     -> [String] -- ^ path
+     -> (Either Int String) -- ^ status code or body
+     -> Spec
+test method path expected = it (method ++ " " ++ show path) $ do
+    app <- iapp
+    flip runSession app $ do
+        sres <- request defaultRequest
+            { requestMethod = S8.pack method
+            , pathInfo = map T.pack path
+            }
+        case expected of
+            Left i -> assertStatus i sres
+            Right b -> assertBody (L8.pack b) sres
+
+specs :: Spec
+specs = describe "LiteApp" $ do
+    test "GET" [] $ Right "GetHomepage"
+    test "POST" [] $ Right "PostHomepage"
+    -- test "PUT" [] $ Left 405
+    test "GET" ["string", "foo"] $ Right "foo"
+    test "DELETE" ["string", "bar"] $ Right "bar"
+    test "GET" ["string!", "foo"] $ Left 404
+    test "GET" ["multi", "foo", "bar"] $ Right "bar"
+    test "GET" ["multi", "foo", "bar", "baz"] $ Left 500

yesod-core/test/YesodCoreTest/Media.hs

@@ -5,7 +5,7 @@
 module YesodCoreTest.Media (mediaTest, Widget) where
 
 import Test.Hspec
-import Yesod.Core hiding (Request)
+import Yesod.Core
 import Network.Wai
 import Network.Wai.Test
 import Text.Lucius
@@ -15,9 +15,8 @@ mkYesodDispatch "Y" resourcesY
 
 instance Yesod Y where
     addStaticContent _ _ content = do
-        tm <- getRouteToMaster
         route <- getCurrentRoute
-        case fmap tm route of
+        case route of
             Just StaticR -> return $ Just $ Left $
                         if content == "foo2{bar:baz}"
                             then "screen.css"
@@ -27,7 +26,7 @@ instance Yesod Y where
 getRootR :: Handler RepHtml
 getRootR = defaultLayout $ do
     toWidget [lucius|foo1{bar:baz}|]
-    addCassiusMedia "screen" [lucius|foo2{bar:baz}|]
+    toWidgetMedia "screen" [lucius|foo2{bar:baz}|]
     toWidget [lucius|foo3{bar:baz}|]
 
 getStaticR :: Handler RepHtml

yesod-core/test/YesodCoreTest/MediaData.hs

@@ -8,5 +8,5 @@ import Yesod.Core
 data Y = Y
 mkYesodData "Y" [parseRoutes|
 / RootR GET
-/static StaticR GET
+/static StaticR !IGNORED GET !alsoIgnored
 |]

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -3,22 +3,40 @@
 module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where
 
 import Test.Hspec
+import YesodCoreTest.NoOverloadedStringsSub
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
+import Network.Wai
 import Network.Wai.Test
 import Data.Monoid (mempty)
-
+import qualified Data.Text as T
-data Subsite = Subsite
+import qualified Data.ByteString.Lazy.Char8 as L8
 
 getSubsite :: a -> Subsite
-getSubsite = const Subsite
+getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
 
-mkYesodSub "Subsite" [] [parseRoutes|
+getBarR :: Monad m => m T.Text
-/bar BarR GET
+getBarR = return $ T.pack "BarR"
-|]
 
-getBarR :: GHandler Subsite m ()
+getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml
-getBarR = return ()
+getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
+
+getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml
+getBinR = do
+    widget <- widgetToParentWidget [whamlet|
+        <p>Used defaultLayoutT
+        <a href=@{BazR}>Baz
+    |]
+    lift $ defaultLayout widget
+
+getOnePiecesR :: Monad m => Int -> m ()
+getOnePiecesR _ = return ()
+
+getTwoPiecesR :: Monad m => Int -> Int -> m ()
+getTwoPiecesR _ _ = return ()
+
+getThreePiecesR :: Monad m => Int -> Int -> Int -> m ()
+getThreePiecesR _ _ _ = return ()
 
 data Y = Y
 mkYesod "Y" [parseRoutes|
@@ -43,6 +61,33 @@ case_sanity = runner $ do
     res <- request defaultRequest
     assertBody mempty res
 
+case_subsite :: IO ()
+case_subsite = runner $ do
+    res <- request defaultRequest
+        { pathInfo = map T.pack ["subsite", "bar"]
+        }
+    assertBody (L8.pack "BarR") res
+    assertStatus 200 res
+
+case_deflayout :: IO ()
+case_deflayout = runner $ do
+    res <- request defaultRequest
+        { pathInfo = map T.pack ["subsite", "baz"]
+        }
+    assertBodyContains (L8.pack "Used Default Layout") res
+    assertStatus 200 res
+
+case_deflayoutT :: IO ()
+case_deflayoutT = runner $ do
+    res <- request defaultRequest
+        { pathInfo = map T.pack ["subsite", "bin"]
+        }
+    assertBodyContains (L8.pack "Used defaultLayoutT") res
+    assertStatus 200 res
+
 noOverloadedTest :: Spec
 noOverloadedTest = describe "Test.NoOverloadedStrings" $ do
       it "sanity" case_sanity
+      it "subsite" case_subsite
+      it "deflayout" case_deflayout
+      it "deflayoutT" case_deflayoutT

yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+module YesodCoreTest.NoOverloadedStringsSub where
+
+import Yesod.Core
+import Network.Wai
+import Yesod.Core.Types
+
+data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application)
+
+mkYesodSubData "Subsite" [parseRoutes|
+/bar BarR GET
+/baz BazR GET
+/bin BinR GET
+/has-one-piece/#Int OnePiecesR GET
+/has-two-pieces/#Int/#Int TwoPiecesR GET
+/has-three-pieces/#Int/#Int/#Int ThreePiecesR GET
+|]
+
+instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where
+    yesodSubDispatch ysre =
+        f ysre
+      where
+        Subsite f = ysreGetSub ysre $ yreSite $ ysreParentEnv ysre

yesod-core/test/YesodCoreTest/Redirect.hs

@@ -2,7 +2,7 @@
 module YesodCoreTest.Redirect (specs, Widget) where
 
 import YesodCoreTest.YesodTest
-import Yesod.Handler (redirectWith)
+import Yesod.Core.Handler (redirectWith)
 import qualified Network.HTTP.Types as H
 
 data Y = Y

yesod-core/test/YesodCoreTest/Reps.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
+module YesodCoreTest.Reps (specs, Widget) where
+
+import Yesod.Core
+import Test.Hspec
+import Network.Wai
+import Network.Wai.Test
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Char8 as S8
+import Data.String (IsString)
+import Data.Text (Text)
+import Data.Maybe (fromJust)
+import Data.Monoid (Endo (..))
+import qualified Control.Monad.Trans.Writer    as Writer
+import qualified Data.Set as Set
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/     HomeR GET !home
+/json JsonR GET
+/parent/#Int ParentR:
+    /#Text/child ChildR !child
+|]
+
+instance Yesod App
+
+specialHtml :: IsString a => a
+specialHtml = "text/html; charset=special"
+
+getHomeR :: Handler TypedContent
+getHomeR = selectRep $ do
+    rep typeHtml "HTML"
+    rep specialHtml "HTMLSPECIAL"
+    rep typeXml "XML"
+    rep typeJson "JSON"
+
+rep :: Monad m => ContentType -> Text -> Writer.Writer (Data.Monoid.Endo [ProvidedRep m]) ()
+rep ct t = provideRepType ct $ return (t :: Text)
+
+getJsonR :: Handler TypedContent
+getJsonR = selectRep $ do
+  rep typeHtml "HTML"
+  provideRep $ return $ object ["message" .= ("Invalid Login" :: Text)]
+
+handleChildR :: Int -> Text -> Handler ()
+handleChildR _ _ = return ()
+
+testRequest :: Int -- ^ http status code
+            -> Request
+            -> ByteString -- ^ expected body
+            -> Spec
+testRequest status req expected = it (S8.unpack $ fromJust $ lookup "Accept" $ requestHeaders req) $ do
+    app <- toWaiApp App
+    flip runSession app $ do
+        sres <- request req
+        assertStatus status sres
+        assertBody expected sres
+
+test :: String -- ^ accept header
+     -> ByteString -- ^ expected body
+     -> Spec
+test accept expected =
+    testRequest 200 (acceptRequest accept) expected
+
+acceptRequest :: String -> Request
+acceptRequest accept = defaultRequest
+            { requestHeaders = [("Accept", S8.pack accept)]
+            }
+
+specs :: Spec
+specs = do
+  describe "selectRep" $ do
+    test "application/json" "JSON"
+    test (S8.unpack typeJson) "JSON"
+    test "text/xml" "XML"
+    test (S8.unpack typeXml) "XML"
+    test "text/xml,application/json" "XML"
+    test "text/xml;q=0.9,application/json;q=1.0" "JSON"
+    test (S8.unpack typeHtml) "HTML"
+    test "text/html" "HTML"
+    test specialHtml "HTMLSPECIAL"
+    testRequest 200 (acceptRequest "application/json") { pathInfo = ["json"] } "{\"message\":\"Invalid Login\"}"
+    testRequest 406 (acceptRequest "text/foo") "no match found for accept header"
+    test "text/*" "HTML"
+    test "*/*" "HTML"
+  describe "routeAttrs" $ do
+    it "HomeR" $ routeAttrs HomeR `shouldBe` Set.singleton "home"
+    it "JsonR" $ routeAttrs JsonR `shouldBe` Set.empty
+    it "ChildR" $ routeAttrs (ParentR 5 $ ChildR "ignored") `shouldBe` Set.singleton "child"

yesod-core/test/YesodCoreTest/RequestBodySize.hs

@@ -5,7 +5,7 @@ module YesodCoreTest.RequestBodySize (specs, Widget) where
 
 import Test.Hspec
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
 
 import Network.Wai
 import Network.Wai.Test
@@ -29,7 +29,7 @@ mkYesod "Y" [parseRoutes|
 |]
 
 instance Yesod Y where
-    maximumContentLength _ _ = 10
+    maximumContentLength _ _ = Just 10
 
 postPostR, postConsumeR, postPartialConsumeR, postUnusedR :: Handler RepPlain
 
@@ -38,13 +38,11 @@ postPostR = do
     return $ RepPlain $ toContent $ T.concat val
 
 postConsumeR = do
-    req <- waiRequest
+    body <- rawRequestBody $$ consume
-    body <- lift $ requestBody req $$ consume
     return $ RepPlain $ toContent $ S.concat body
 
 postPartialConsumeR = do
-    req <- waiRequest
+    body <- rawRequestBody $$ isolate 5 =$ consume
-    body <- lift $ requestBody req $$ isolate 5 =$ consume
     return $ RepPlain $ toContent $ S.concat body
 
 postUnusedR = return $ RepPlain ""
@@ -75,6 +73,10 @@ caseHelper name path body statusChunked statusNonChunked = describe name $ do
                 then [("content-length", S8.pack $ show $ S.length body)]
                 else []
         , requestMethod = "POST"
+        , requestBodyLength =
+            if includeLength
+                then KnownLength $ fromIntegral $ S.length body
+                else ChunkedBody
         } $ L.fromChunks $ map S.singleton $ S.unpack body
 
 specs :: Spec

yesod-core/test/YesodCoreTest/Streaming.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+module YesodCoreTest.Streaming (specs) where
+
+import Yesod.Core
+import Test.Hspec
+import Network.Wai.Test
+import Data.Text (Text)
+import Data.ByteString (ByteString)
+
+app :: LiteApp
+app = liteApp $ dispatchTo $ respondSource typeHtml $ do
+    sendChunk ("Hello " :: String)
+    sendChunk ("World" :: ByteString)
+    sendChunk ("!\n" :: Text)
+    sendChunkHtml "<&>"
+
+test :: String
+     -> (SResponse -> Session ())
+     -> Spec
+test name f = it name $ do
+    wapp <- toWaiApp app
+    flip runSession wapp $ do
+        sres <- request defaultRequest
+        f sres
+
+specs :: Spec
+specs = describe "Streaming" $ do
+    test "works" $ \sres -> do
+        assertStatus 200 sres
+        assertBody "Hello World!\n&lt;&amp;&gt;" sres

yesod-core/test/YesodCoreTest/Widget.hs

@@ -5,7 +5,7 @@ module YesodCoreTest.Widget (widgetTest) where
 
 import Test.Hspec
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
 import Text.Julius
 import Text.Lucius
 import Text.Hamlet
@@ -61,18 +61,18 @@ getTowidgetR = defaultLayout $ do
 
 getWhamletR :: Handler RepHtml
 getWhamletR = defaultLayout [whamlet|
-$newline never
+                    $newline never
-<h1>Test
+                    <h1>Test
-<h2>@{WhamletR}
+                    <h2>@{WhamletR}
-<h3>_{Goodbye}
+                    <h3>_{Goodbye}
-<h3>_{MsgAnother}
+                    <h3>_{MsgAnother}
-^{embed}
+                    ^{embed}
-|]
+                |]
   where
     embed = [whamlet|
-$newline never
+                $newline never
-<h4>Embed
+                <h4>Embed
-|]
+                |]
 
 getAutoR :: Handler RepHtml
 getAutoR = defaultLayout [whamlet|

yesod-core/test/YesodCoreTest/YesodTest.hs

@@ -9,10 +9,10 @@ module YesodCoreTest.YesodTest
   , module Test.Hspec
 ) where
 
-import Yesod.Core hiding (Request)
+import Yesod.Core
 import Network.Wai.Test
 import Network.Wai
 import Test.Hspec
 
-yesod :: (YesodDispatch y y, Yesod y) => y -> Session a -> IO a
+yesod :: YesodDispatch y => y -> Session a -> IO a
 yesod app f = toWaiApp app >>= runSession f

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.1.8.3
+version:         1.2.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -22,9 +22,9 @@ extra-source-files:
   test/YesodCoreTest/ErrorHandling.hs
   test/YesodCoreTest/Exceptions.hs
   test/YesodCoreTest/InternalRequest.hs
+  test/YesodCoreTest/Json.hs
   test/YesodCoreTest/JsLoader.hs
   test/YesodCoreTest/JsLoaderSites/Bottom.hs
-  test/YesodCoreTest/JsLoaderSites/HeadAsync.hs
   test/YesodCoreTest/Links.hs
   test/YesodCoreTest/Media.hs
   test/YesodCoreTest/MediaData.hs
@@ -34,23 +34,16 @@ extra-source-files:
   test/YesodCoreTest/WaiSubsite.hs
   test/YesodCoreTest/Widget.hs
   test/YesodCoreTest/YesodTest.hs
+  test/YesodCoreTest/Auth.hs
+  test/YesodCoreTest/LiteApp.hs
   test/en.msg
   test/test.hs
 
-flag test
-  description: Build the executable to run unit tests
-  default: False
-
 library
-    -- Work around a bug in cabal. Without this, wai-test doesn't get built and
-    -- we have a missing dependency during --enable-tests builds.
-    if flag(test)
-        build-depends: wai-test
-
     build-depends:   base                  >= 4.3      && < 5
                    , time                  >= 1.1.4
-                   , yesod-routes          >= 1.1      && < 1.2
+                   , yesod-routes          >= 1.2      && < 1.3
-                   , wai                   >= 1.3      && < 1.5
+                   , wai                   >= 1.4      && < 1.5
                    , wai-extra             >= 1.3      && < 1.4
                    , bytestring            >= 0.9.1.4
                    , text                  >= 0.7      && < 0.12
@@ -63,7 +56,7 @@ library
                    , shakespeare-i18n      >= 1.0      && < 1.1
                    , blaze-builder         >= 0.2.1.4  && < 0.4
                    , transformers          >= 0.2.2    && < 0.4
-                   , clientsession         >= 0.8
+                   , clientsession         >= 0.9      && < 0.10
                    , random                >= 1.0.0.2  && < 1.1
                    , cereal                >= 0.3      && < 0.4
                    , old-locale            >= 1.0.0.2  && < 1.1
@@ -79,26 +72,36 @@ library
                    , vector                >= 0.9      && < 0.11
                    , aeson                 >= 0.5
                    , fast-logger           >= 0.2
-                   , monad-logger          >= 0.2.1    && < 0.4
+                   , monad-logger          >= 0.3.1    && < 0.4
                    , conduit               >= 0.5
-                   , resourcet             >= 0.3      && < 0.5
+                   , resourcet             >= 0.4.6    && < 0.5
                    , lifted-base           >= 0.1
+                   , attoparsec-conduit
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.5.1
+                   , data-default
+                   , safe
+                   , warp                  >= 1.3.8
 
-    exposed-modules: Yesod.Content
+    exposed-modules: Yesod.Core
-                     Yesod.Core
+                     Yesod.Core.Content
-                     Yesod.Dispatch
+                     Yesod.Core.Dispatch
-                     Yesod.Handler
+                     Yesod.Core.Handler
-                     Yesod.Request
+                     Yesod.Core.Json
-                     Yesod.Widget
+                     Yesod.Core.Widget
-                     Yesod.Message
+                     Yesod.Core.Internal
-                     Yesod.Internal.TestApi
+                     Yesod.Core.Types
-    other-modules:   Yesod.Internal
+    other-modules:   Yesod.Core.Internal.Session
-                     Yesod.Internal.Cache
+                     Yesod.Core.Internal.Request
-                     Yesod.Internal.Core
+                     Yesod.Core.Class.Handler
-                     Yesod.Internal.Session
+                     Yesod.Core.Internal.Util
-                     Yesod.Internal.Request
+                     Yesod.Core.Internal.Response
+                     Yesod.Core.Internal.Run
+                     Yesod.Core.Internal.TH
+                     Yesod.Core.Internal.LiteApp
+                     Yesod.Core.Class.Yesod
+                     Yesod.Core.Class.Dispatch
+                     Yesod.Core.Class.Breadcrumbs
                      Paths_yesod_core
     ghc-options:     -Wall
 
@@ -110,7 +113,7 @@ test-suite tests
     cpp-options:   -DTEST
     build-depends: base
                   ,hspec >= 1.3
-                  ,wai-test
+                  ,wai-test >= 1.3.0.5
                   ,wai
                   ,yesod-core
                   ,bytestring
@@ -125,6 +128,9 @@ test-suite tests
                   ,QuickCheck >= 2 && < 3
                   ,transformers
                   , conduit
+                  , containers
+                  , lifted-base
+                  , resourcet
     ghc-options:     -Wall
 
 source-repository head