Add 'yesod-core/' from commit '982d6185bee75b078bee92bd8a2e8743707f1922'

git-subtree-dir: yesod-core
git-subtree-mainline: cd5ee0fb12
git-subtree-split: 982d6185be

yesod-core/.gitignore

@@ -0,0 +1,7 @@
+/dist/
+*.swp
+client_session_key.aes
+*.hi
+*.o
+blog.db3
+static/tmp/

yesod-core/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-core/README

@@ -0,0 +1 @@
+Learn more at http://docs.yesodweb.com/

yesod-core/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

yesod-core/Test/CleanPath.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.CleanPath (cleanPathTest) where
+
+import Yesod.Core hiding (Request)
+import Yesod.Content
+import Yesod.Dispatch
+import Yesod.Handler (Route)
+
+import Test.Framework (defaultMain, testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import Network.Wai
+import Network.Wai.Test
+import Network.HTTP.Types (status200, decodePathSegments)
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.Text as TS
+
+data Subsite = Subsite
+getSubsite = const Subsite
+data SubsiteRoute = SubsiteRoute [TS.Text]
+    deriving (Eq, Show, Read)
+type instance Route Subsite = SubsiteRoute
+instance RenderRoute SubsiteRoute where
+    renderRoute (SubsiteRoute x) = (x, [])
+
+instance YesodDispatch Subsite master where
+    yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS
+        status200
+        [ ("Content-Type", "SUBSITE")
+        ] $ L8.pack $ show pieces
+
+data Y = Y
+mkYesod "Y" [$parseRoutes|
+/foo FooR GET
+/foo/#String FooStringR GET
+/bar BarR GET
+/subsite SubsiteR Subsite getSubsite
+/plain PlainR GET
+|]
+
+instance Yesod Y where
+    approot _ = "http://test"
+    cleanPath _ ["bar", ""] = Right ["bar"]
+    cleanPath _ ["bar"] = Left ["bar", ""]
+    cleanPath _ s =
+        if corrected == s
+            then Right s
+            else Left corrected
+      where
+        corrected = filter (not . TS.null) s
+
+getFooR = return $ RepPlain "foo"
+getFooStringR = return . RepPlain . toContent
+getBarR = return $ RepPlain "bar"
+getPlainR = return $ RepPlain "plain"
+
+cleanPathTest :: Test
+cleanPathTest = testGroup "Test.CleanPath"
+    [ testCase "remove trailing slash" removeTrailingSlash
+    , testCase "noTrailingSlash" noTrailingSlash
+    , testCase "add trailing slash" addTrailingSlash
+    , testCase "has trailing slash" hasTrailingSlash
+    , testCase "/foo/something" fooSomething
+    , testCase "subsite dispatch" subsiteDispatch
+    , testCase "redirect with query string" redQueryString
+    ]
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+    { pathInfo = []
+    , requestHeaders = []
+    , queryString = []
+    , rawQueryString = ""
+    , requestMethod = "GET"
+    }
+
+removeTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = decodePathSegments "/foo/"
+                }
+    assertStatus 301 res
+    assertHeader "Location" "http://test/foo" res
+
+noTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = decodePathSegments "/foo"
+                }
+    assertStatus 200 res
+    assertContentType "text/plain; charset=utf-8" res
+    assertBody "foo" res
+
+addTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = decodePathSegments "/bar"
+                }
+    assertStatus 301 res
+    assertHeader "Location" "http://test/bar/" res
+
+hasTrailingSlash = runner $ do
+    res <- request defaultRequest
+                { pathInfo = decodePathSegments "/bar/"
+                }
+    assertStatus 200 res
+    assertContentType "text/plain; charset=utf-8" res
+    assertBody "bar" res
+
+fooSomething = runner $ do
+    res <- request defaultRequest
+                { pathInfo = decodePathSegments "/foo/something"
+                }
+    assertStatus 200 res
+    assertContentType "text/plain; charset=utf-8" res
+    assertBody "something" res
+
+subsiteDispatch = runner $ do
+    res <- request defaultRequest
+                { pathInfo = decodePathSegments "/subsite/1/2/3/"
+                }
+    assertStatus 200 res
+    assertContentType "SUBSITE" res
+    assertBody "[\"1\",\"2\",\"3\",\"\"]" res
+
+redQueryString = runner $ do
+    res <- request defaultRequest
+                { pathInfo = decodePathSegments "/plain/"
+                , rawQueryString = "?foo=bar"
+                }
+    assertStatus 301 res
+    assertHeader "Location" "http://test/plain?foo=bar" res

yesod-core/Test/Exceptions.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.Exceptions (exceptionsTest) where
+
+import Yesod.Core hiding (Request)
+import Yesod.Content
+import Yesod.Dispatch
+import Yesod.Handler (Route, ErrorResponse (InternalError))
+
+import Test.Framework (defaultMain, testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import Network.Wai
+import Network.Wai.Test
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+data Y = Y
+mkYesod "Y" [$parseRoutes|
+/ RootR GET
+|]
+
+instance Yesod Y where
+    approot _ = "http://test"
+    errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e
+    errorHandler x = defaultErrorHandler x
+
+getRootR = error "FOOBAR" >> return ()
+
+exceptionsTest :: Test
+exceptionsTest = testGroup "Test.Exceptions"
+    [ testCase "500" case500
+    ]
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+    { pathInfo = []
+    , requestHeaders = []
+    , queryString = []
+    , requestMethod = "GET"
+    }
+
+case500 = runner $ do
+    res <- request defaultRequest
+    assertStatus 500 res
+    assertBody "FOOBAR" res

yesod-core/Test/Links.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.Links (linksTest) where
+
+import Yesod.Core hiding (Request)
+import Text.Hamlet
+
+import Test.Framework (defaultMain, testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import Network.Wai
+import Network.Wai.Test
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+data Y = Y
+mkYesod "Y" [$parseRoutes|
+/ RootR GET
+|]
+
+instance Yesod Y where
+    approot _ = ""
+
+getRootR = defaultLayout $ addHamlet [$hamlet|<a href=@{RootR}>|]
+
+linksTest :: Test
+linksTest = testGroup "Test.Links"
+    [ testCase "linkToHome" case_linkToHome
+    ]
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+    { pathInfo = []
+    , requestHeaders = []
+    , queryString = []
+    , requestMethod = "GET"
+    }
+
+case_linkToHome = runner $ do
+    res <- request defaultRequest
+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><a href=\"/\"></a></body></html>" res

yesod-core/Test/Media.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.Media (mediaTest) where
+
+import Yesod.Core hiding (Request)
+
+import Test.Framework (defaultMain, testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import Network.Wai
+import Network.Wai.Test
+import Network.HTTP.Types (status200, decodePathSegments)
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.Text as TS
+import Text.Lucius
+
+data Y = Y
+mkYesod "Y" [$parseRoutes|
+/ RootR GET
+/static StaticR GET
+|]
+
+instance Yesod Y where
+    approot _ = ""
+    addStaticContent _ _ content = do
+        tm <- getRouteToMaster
+        route <- getCurrentRoute
+        case fmap tm route of
+            Just StaticR -> return $ Just $ Left $
+                        if content == "foo2{bar:baz}"
+                            then "screen.css"
+                            else "all.css"
+            _ -> return Nothing
+
+getRootR = defaultLayout $ do
+    addCassius [$lucius|foo1{bar:baz}|]
+    addCassiusMedia "screen" [$lucius|foo2{bar:baz}|]
+    addCassius [$lucius|foo3{bar:baz}|]
+getStaticR = getRootR
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+    { pathInfo = []
+    , requestHeaders = []
+    , queryString = []
+    , requestMethod = "GET"
+    }
+
+caseMedia = runner $ do
+    res <- request defaultRequest
+    assertStatus 200 res
+    flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><style>foo1{bar:baz}foo3{bar:baz}</style><style media=\"screen\">foo2{bar:baz}</style></head><body></body></html>"
+
+caseMediaLink = runner $ do
+    res <- request defaultRequest { pathInfo = ["static"] }
+    assertStatus 200 res
+    flip assertBody res "<!DOCTYPE html>\n<html><head><title></title><link rel=\"stylesheet\" href=\"all.css\"><link rel=\"stylesheet\" media=\"screen\" href=\"screen.css\"></head><body></body></html>"
+
+mediaTest = testGroup "Test.Media"
+    [ testCase "media" caseMedia
+    , testCase "media link" caseMediaLink
+    ]

yesod-core/Test/NoOverloadedStrings.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.NoOverloadedStrings (noOverloadedTest) where
+
+import Yesod.Core hiding (Request)
+import Test.Framework (testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Network.Wai.Test
+import Network.Wai
+import Data.Monoid (mempty)
+import Data.String (fromString)
+
+data Subsite = Subsite
+getSubsite = const Subsite
+mkYesodSub "Subsite" [] [parseRoutes|
+/bar BarR GET
+|]
+
+getBarR :: GHandler Subsite m ()
+getBarR = return ()
+
+data Y = Y
+mkYesod "Y" [parseRoutes|
+/ RootR GET
+/foo FooR GET
+/subsite SubsiteR Subsite getSubsite
+|]
+
+instance Yesod Y where
+    approot _ = fromString ""
+
+getRootR = return ()
+getFooR = return ()
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+    { pathInfo = []
+    , requestHeaders = []
+    , queryString = []
+    , requestMethod = fromString "GET"
+    }
+
+case_sanity = runner $ do
+    res <- request defaultRequest
+    assertBody mempty res
+
+noOverloadedTest :: Test
+noOverloadedTest = testGroup "Test.NoOverloadedStrings"
+    [ testCase "sanity" case_sanity
+    ]

yesod-core/Test/Widget.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Test.Widget (widgetTest) where
+
+import Yesod.Core hiding (Request)
+import Yesod.Content
+import Yesod.Dispatch
+import Yesod.Widget
+import Text.Julius
+
+import Test.Framework (defaultMain, testGroup, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import Network.Wai
+import Network.Wai.Test
+
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+data Y = Y
+
+mkMessage "Y" "test" "en"
+
+mkYesod "Y" [$parseRoutes|
+/ RootR GET
+/foo/*Strings MultiR GET
+/whamlet WhamletR GET
+|]
+
+instance Yesod Y where
+    approot _ = "http://test"
+
+getRootR = defaultLayout $ addJuliusBody [$julius|<not escaped>|]
+getMultiR _ = return ()
+
+data Msg = Hello | Goodbye
+instance RenderMessage Y Msg where
+    renderMessage _ ("en":_) Hello = "Hello"
+    renderMessage _ ("es":_) Hello = "Hola"
+    renderMessage _ ("en":_) Goodbye = "Goodbye"
+    renderMessage _ ("es":_) Goodbye = "Adios"
+    renderMessage a (_:xs) y = renderMessage a xs y
+    renderMessage a [] y = renderMessage a ["en"] y
+
+getWhamletR = defaultLayout [$whamlet|
+<h1>Test
+<h2>@{WhamletR}
+<h3>_{Goodbye}
+<h3>_{MsgAnother}
+^{embed}
+|]
+  where
+    embed = [$whamlet|<h4>Embed|]
+
+widgetTest :: Test
+widgetTest = testGroup "Test.Widget"
+    [ testCase "addJuliusBody" case_addJuliusBody
+    , testCase "whamlet" case_whamlet
+    ]
+
+runner f = toWaiApp Y >>= runSession f
+defaultRequest = Request
+    { pathInfo = []
+    , requestHeaders = []
+    , queryString = []
+    , requestMethod = "GET"
+    }
+
+case_addJuliusBody = runner $ do
+    res <- request defaultRequest
+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script><not escaped></script></body></html>" res
+
+case_whamlet = runner $ do
+    res <- request defaultRequest
+        { pathInfo = ["whamlet"]
+        , requestHeaders = [("Accept-Language", "es")]
+        }
+    assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><h1>Test</h1><h2>http://test/whamlet</h2><h3>Adios</h3><h3>String</h3><h4>Embed</h4></body></html>" res

yesod-core/Yesod/Content.hs

@@ -0,0 +1,232 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Content
+    ( -- * Content
+      Content (..)
+    , emptyContent
+    , ToContent (..)
+      -- * Mime types
+      -- ** Data type
+    , ContentType
+    , typeHtml
+    , typePlain
+    , typeJson
+    , typeXml
+    , typeAtom
+    , typeRss
+    , typeJpeg
+    , typePng
+    , typeGif
+    , typeJavascript
+    , typeCss
+    , typeFlv
+    , typeOgv
+    , typeOctet
+      -- * Utilities
+    , simpleContentType
+      -- * 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 Data.Enumerator (Enumerator)
+import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)
+import Data.Monoid (mempty)
+
+import Text.Hamlet (Html)
+import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
+import Data.String (IsString (fromString))
+import Network.Wai (FilePart)
+
+data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
+             | ContentEnum (forall a. Enumerator Builder IO a)
+             | ContentFile FilePath (Maybe FilePart)
+
+-- | 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"
+
+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"

yesod-core/Yesod/Core.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Core
+    ( -- * Type classes
+      Yesod (..)
+    , YesodDispatch (..)
+    , RenderRoute (..)
+      -- ** Breadcrumbs
+    , YesodBreadcrumbs (..)
+    , breadcrumbs
+      -- * Utitlities
+    , maybeAuthorized
+    , widgetToPageContent
+      -- * Defaults
+    , defaultErrorHandler
+      -- * Data types
+    , AuthResult (..)
+      -- * Logging
+    , LogLevel (..)
+    , formatLogMessage
+    , logDebug
+    , logInfo
+    , logWarn
+    , logError
+    , logOther
+      -- * Misc
+    , yesodVersion
+    , yesodRender
+      -- * Re-exports
+    , module Yesod.Content
+    , module Yesod.Dispatch
+    , module Yesod.Handler
+    , module Yesod.Request
+    , module Yesod.Widget
+    , module Yesod.Message
+    ) where
+
+import Yesod.Internal.Core
+import Yesod.Content
+import Yesod.Dispatch
+import Yesod.Handler
+import Yesod.Request
+import Yesod.Widget
+import Yesod.Message
+
+import Language.Haskell.TH.Syntax
+import Data.Text (Text)
+
+logTH :: LogLevel -> Q Exp
+logTH level =
+    [|messageLoggerHandler $(qLocation >>= liftLoc) $(lift level)|]
+  where
+    liftLoc :: Loc -> Q Exp
+    liftLoc (Loc a b c d e) = [|Loc $(lift a) $(lift b) $(lift c) $(lift d) $(lift e)|]
+
+-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:
+--
+-- > $(logDebug) "This is a debug log message"
+logDebug :: Q Exp
+logDebug = logTH LevelDebug
+
+-- | See 'logDebug'
+logInfo :: Q Exp
+logInfo = logTH LevelInfo
+-- | See 'logDebug'
+logWarn :: Q Exp
+logWarn = logTH LevelWarn
+-- | See 'logDebug'
+logError :: Q Exp
+logError = logTH LevelError
+
+-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:
+--
+-- > $(logOther "My new level") "This is a log message"
+logOther :: Text -> Q Exp
+logOther = logTH . LevelOther

yesod-core/Yesod/Dispatch.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Dispatch
+    ( -- * Quasi-quoted routing
+      parseRoutes
+    , parseRoutesFile
+    , mkYesod
+    , mkYesodSub
+      -- ** More fine-grained
+    , mkYesodData
+    , mkYesodSubData
+    , mkYesodDispatch
+    , mkYesodSubDispatch
+      -- ** Path pieces
+    , SinglePiece (..)
+    , MultiPiece (..)
+    , Texts
+      -- * Convert to WAI
+    , toWaiApp
+    , toWaiAppPlain
+    ) where
+
+import Data.Functor   ((<$>))
+import Data.Either    (partitionEithers)
+import Prelude hiding (exp)
+import Yesod.Internal.Core
+import Yesod.Handler
+import Yesod.Internal.Dispatch
+
+import Web.PathPieces (SinglePiece (..), MultiPiece (..))
+import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesFile)
+import Language.Haskell.TH.Syntax
+
+import qualified Network.Wai as W
+import Network.Wai.Middleware.Jsonp
+import Network.Wai.Middleware.Gzip
+import Network.Wai.Middleware.Autohead
+
+import Data.ByteString.Lazy.Char8 ()
+
+import Web.ClientSession
+import Data.Char (isUpper)
+import Data.Text (Text)
+
+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
+        -> [Resource]
+        -> 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
+           -> [Resource]
+           -> 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 -> [Resource] -> Q [Dec]
+mkYesodData name res = mkYesodDataGeneral name [] False res
+
+mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec]
+mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
+
+mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> 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 ''Resource
+            , FunD rname [Clause [] (NormalB eres) []]
+            ]
+    return $ x ++ y
+
+-- | See 'mkYesodData'.
+mkYesodDispatch :: String -> [Resource] -> Q [Dec]
+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
+
+mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec]
+mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
+  where (name':rest) = words name
+
+mkYesodGeneral :: String -- ^ foundation name
+               -> [String] -- ^ parameters for foundation
+               -> Cxt -- ^ classes
+               -> Bool -- ^ is subsite?
+               -> [Resource]
+               -> Q ([Dec], [Dec])
+mkYesodGeneral name args clazzes isSub res = do
+    let name' = mkName name
+        args' = map mkName args
+        arg = foldl AppT (ConT name') $ map VarT args'
+    th' <- mapM thResourceFromResource res
+    let th = map fst th'
+    w' <- createRoutes th
+    let routesName = mkName $ name ++ "Route"
+    let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
+    let x = TySynInstD ''Route [arg] $ ConT routesName
+
+    render <- createRender th
+    let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)
+                [ FunD (mkName "renderRoute") render
+                ]
+
+    let splitter :: (THResource, Maybe String)
+                 -> Either
+                        (THResource, Maybe String)
+                        (THResource, Maybe String)
+        splitter a@((_, SubSite{}), _) = Left a
+        splitter a = Right a
+    let (resSub, resLoc) = partitionEithers $ map splitter th'
+    yd <- mkYesodDispatch' resSub resLoc
+    let master = mkName "master"
+    let ctx = if isSub
+                then ClassP (mkName "Yesod") [VarT master] : clazzes
+                else []
+    let ytyp = if isSub
+                then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
+                else ConT ''YesodDispatch `AppT` arg `AppT` arg
+    let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
+    return ([w, x, x'], [y])
+
+thResourceFromResource :: Resource -> Q (THResource, Maybe String)
+thResourceFromResource (Resource n ps atts)
+    | all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
+thResourceFromResource (Resource n ps [stype, toSubArg]) = do
+    let stype' = ConT $ mkName stype
+    parse <- [|error "ssParse"|]
+    dispatch <- [|error "ssDispatch"|]
+    render <- [|renderRoute|]
+    tmg <- [|error "ssToMasterArg"|]
+    return ((n, SubSite
+        { ssType = ConT ''Route `AppT` stype'
+        , ssParse = parse
+        , ssRender = render
+        , ssDispatch = dispatch
+        , ssToMasterArg = tmg
+        , ssPieces = ps
+        }), Just toSubArg)
+
+thResourceFromResource (Resource n _ _) =
+    error $ "Invalid attributes for resource: " ++ n
+
+-- | Convert the given argument into a WAI application, executable with any WAI
+-- handler. This is the same as 'toWaiAppPlain', except it includes three
+-- middlewares: GZIP compression, JSON-P and path cleaning. This is the
+-- recommended approach for most users.
+toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
+toWaiApp y = gzip False . jsonp . 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 y, YesodDispatch y y) => y -> IO W.Application
+toWaiAppPlain a = toWaiApp' a <$> encryptKey a
+
+
+toWaiApp' :: (Yesod y, YesodDispatch y y)
+          => y
+          -> Maybe Key
+          -> W.Application
+toWaiApp' y key' env =
+    case yesodDispatch y key' (W.pathInfo env) y id of
+        Just app -> app env
+        Nothing -> yesodRunner y y id key' Nothing notFound env

yesod-core/Yesod/Handler.hs

@@ -0,0 +1,904 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+---------------------------------------------------------
+--
+-- Module        : Yesod.Handler
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- Stability     : unstable
+-- Portability   : portable
+--
+-- Define Handler stuff.
+--
+---------------------------------------------------------
+module Yesod.Handler
+    ( -- * Type families
+      Route
+    , YesodSubRoute (..)
+      -- * Handler monad
+    , GHandler
+    , GGHandler
+      -- ** Read information from handler
+    , getYesod
+    , getYesodSub
+    , getUrlRender
+    , getUrlRenderParams
+    , getCurrentRoute
+    , getRouteToMaster
+    , getRequest
+    , waiRequest
+    , runRequestBody
+      -- * Special responses
+      -- ** Redirecting
+    , RedirectType (..)
+    , redirect
+    , redirectParams
+    , redirectString
+    , redirectText
+    , redirectToPost
+      -- ** Errors
+    , notFound
+    , badMethod
+    , permissionDenied
+    , permissionDeniedI
+    , invalidArgs
+    , invalidArgsI
+      -- ** Short-circuit responses.
+    , sendFile
+    , sendFilePart
+    , sendResponse
+    , sendResponseStatus
+    , sendResponseCreated
+    , sendWaiResponse
+      -- * Setting headers
+    , setCookie
+    , deleteCookie
+    , setHeader
+    , setLanguage
+      -- ** Content caching and expiration
+    , cacheSeconds
+    , neverExpires
+    , alreadyExpired
+    , expiresAt
+      -- * Session
+    , SessionMap
+    , lookupSession
+    , getSession
+    , setSession
+    , deleteSession
+      -- ** Ultimate destination
+    , setUltDest
+    , setUltDestString
+    , setUltDestText
+    , setUltDest'
+    , setUltDestReferer
+    , redirectUltDest
+    , clearUltDest
+      -- ** Messages
+    , setMessage
+    , setMessageI
+    , getMessage
+      -- * Helpers for specific content
+      -- ** Hamlet
+    , hamletToContent
+    , hamletToRepHtml
+      -- ** Misc
+    , newIdent
+    , liftIOHandler
+      -- * i18n
+    , getMessageRender
+      -- * Internal Yesod
+    , runHandler
+    , YesodApp (..)
+    , runSubsiteGetter
+    , toMasterHandler
+    , toMasterHandlerDyn
+    , toMasterHandlerMaybe
+    , localNoCurrent
+    , HandlerData
+    , ErrorResponse (..)
+    , YesodAppResult (..)
+    , handlerToYAR
+    , yarToResponse
+    , headerToPair
+    ) where
+
+import Prelude hiding (catch)
+import Yesod.Internal.Request
+import Yesod.Internal
+import Data.Time (UTCTime)
+
+import Control.Exception hiding (Handler, catch, finally)
+import qualified Control.Exception as E
+import Control.Applicative
+
+import Control.Monad (liftM, join, MonadPlus)
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..))
+
+import System.IO
+import qualified Network.Wai as W
+import qualified Network.HTTP.Types as H
+import Control.Failure (Failure (failure))
+
+import Text.Hamlet
+import qualified Text.Blaze.Renderer.Text
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import qualified Data.Text.Lazy as TL
+
+import Control.Monad.IO.Control (MonadControlIO)
+import Control.Monad.Trans.Control (MonadTransControl, liftControl)
+import qualified Data.Map as Map
+import qualified Data.ByteString as S
+import Data.ByteString (ByteString)
+import Data.Enumerator (Iteratee (..), run_, ($$))
+import Network.Wai.Parse (parseHttpAccept)
+
+import Yesod.Content
+import Data.Maybe (fromMaybe)
+import Web.Cookie (SetCookie (..), renderSetCookie)
+import Control.Arrow (second, (***))
+import qualified Network.Wai.Parse as NWP
+import Data.Monoid (mappend, mempty, Endo (..))
+import qualified Data.ByteString.Char8 as S8
+import Data.CaseInsensitive (CI)
+import Blaze.ByteString.Builder (toByteString)
+import Data.Text (Text)
+import Yesod.Message (RenderMessage (..))
+
+import Text.Blaze (toHtml, preEscapedText)
+
+-- | The type-safe URLs associated with a site argument.
+type family Route a
+
+class YesodSubRoute s y where
+    fromSubRoute :: s -> y -> Route s -> Route y
+
+data HandlerData sub master = HandlerData
+    { handlerRequest  :: Request
+    , handlerSub      :: sub
+    , handlerMaster   :: master
+    , handlerRoute    :: Maybe (Route sub)
+    , handlerRender   :: Route master -> [(Text, Text)] -> Text
+    , handlerToMaster :: Route sub -> Route master
+    }
+
+handlerSubData :: (Route sub -> Route master)
+               -> (master -> sub)
+               -> Route sub
+               -> HandlerData oldSub master
+               -> HandlerData sub master
+handlerSubData tm ts = handlerSubDataMaybe tm ts . Just
+
+handlerSubDataMaybe :: (Route sub -> Route master)
+                    -> (master -> sub)
+                    -> Maybe (Route sub)
+                    -> HandlerData oldSub master
+                    -> HandlerData sub master
+handlerSubDataMaybe tm ts route hd = hd
+    { handlerSub = ts $ handlerMaster hd
+    , handlerToMaster = tm
+    , handlerRoute = route
+    }
+
+-- | Used internally for promoting subsite handler functions to master site
+-- handler functions. Should not be needed by users.
+toMasterHandler :: (Route sub -> Route master)
+                -> (master -> sub)
+                -> Route sub
+                -> GGHandler sub master mo a
+                -> GGHandler sub' master mo a
+toMasterHandler tm ts route (GHandler h) =
+    GHandler $ withReaderT (handlerSubData tm ts route) h
+
+toMasterHandlerDyn :: Monad mo
+                   => (Route sub -> Route master)
+                   -> GGHandler sub' master mo sub
+                   -> Route sub
+                   -> GGHandler sub master mo a
+                   -> GGHandler sub' master mo a
+toMasterHandlerDyn tm getSub route (GHandler h) = do
+    sub <- getSub
+    GHandler $ withReaderT (handlerSubData tm (const sub) route) h
+
+class SubsiteGetter g m s | g -> s where
+  runSubsiteGetter :: g -> m s
+
+instance (master ~ master'
+         ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where
+  runSubsiteGetter getter = getter <$> getYesod
+
+instance (anySub ~ anySub'
+         ,master ~ master'
+         ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where
+  runSubsiteGetter = id
+
+toMasterHandlerMaybe :: (Route sub -> Route master)
+                     -> (master -> sub)
+                     -> Maybe (Route sub)
+                     -> GGHandler sub master mo a
+                     -> GGHandler sub' master mo a
+toMasterHandlerMaybe tm ts route (GHandler h) =
+    GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h
+
+-- | A generic handler monad, which can have a different subsite and master
+-- site. This monad is a combination of 'ReaderT' for basic arguments, a
+-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
+-- special responses. It is declared as a newtype to make compiler errors more
+-- readable.
+newtype GGHandler sub master m a =
+    GHandler
+        { unGHandler :: GHInner sub master m a
+        }
+    deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadPlus)
+
+instance MonadTrans (GGHandler s m) where
+    lift = GHandler . lift . lift . lift . lift
+
+type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)
+
+data GHState = GHState
+    { ghsSession :: SessionMap
+    , ghsRBC :: Maybe RequestBodyContents
+    , ghsIdent :: Int
+    }
+
+type GHInner s m monad = -- FIXME collapse the stack
+    ReaderT (HandlerData s m) (
+    ErrorT HandlerContents (
+    WriterT (Endo [Header]) (
+    StateT GHState (
+    monad
+    ))))
+
+type SessionMap = Map.Map Text Text
+
+-- | 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 'GHandler' monad and template haskell code should hide it away.
+newtype YesodApp = YesodApp
+    { unYesodApp
+    :: (ErrorResponse -> YesodApp)
+    -> Request
+    -> [ContentType]
+    -> SessionMap
+    -> Iteratee ByteString IO YesodAppResult
+    }
+
+data YesodAppResult
+    = YARWai W.Response
+    | YARPlain H.Status [Header] ContentType Content SessionMap
+
+data HandlerContents =
+      HCContent H.Status ChooseRep
+    | HCError ErrorResponse
+    | HCSendFile ContentType FilePath (Maybe W.FilePart) -- FIXME replace FilePath with opaque type from system-filepath?
+    | HCRedirect RedirectType Text
+    | HCCreated Text
+    | HCWai W.Response
+
+instance Error HandlerContents where
+    strMsg = HCError . InternalError . T.pack
+
+getRequest :: Monad mo => GGHandler s m mo Request
+getRequest = handlerRequest `liftM` GHandler ask
+
+instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
+    failure = GHandler . lift . throwError . HCError
+
+runRequestBody :: GHandler s m RequestBodyContents
+runRequestBody = do
+    x <- GHandler $ lift $ lift $ lift get
+    case ghsRBC x of
+        Just rbc -> return rbc
+        Nothing -> do
+            rr <- waiRequest
+            rbc <- lift $ rbHelper rr
+            GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc }
+            return rbc
+
+rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
+rbHelper req =
+    (map fix1 *** map fix2) <$> iter
+  where
+    iter = NWP.parseRequestBody NWP.lbsSink req
+    fix1 = go *** go
+    fix2 (x, NWP.FileInfo a b c) =
+        (go x, FileInfo (go a) (go b) c)
+    go = decodeUtf8With lenientDecode
+
+-- | Get the sub application argument.
+getYesodSub :: Monad m => GGHandler sub master m sub
+getYesodSub = handlerSub `liftM` GHandler ask
+
+-- | Get the master site appliation argument.
+getYesod :: Monad m => GGHandler sub master m master
+getYesod = handlerMaster `liftM` GHandler ask
+
+-- | Get the URL rendering function.
+getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)
+getUrlRender = do
+    x <- handlerRender `liftM` GHandler ask
+    return $ flip x []
+
+-- | The URL rendering function with query-string parameters.
+getUrlRenderParams
+    :: Monad m
+    => GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
+getUrlRenderParams = handlerRender `liftM` GHandler ask
+
+-- | Get the route requested by the user. If this is a 404 response- where the
+-- user requested an invalid route- this function will return 'Nothing'.
+getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))
+getCurrentRoute = handlerRoute `liftM` GHandler ask
+
+-- | Get the function to promote a route for a subsite to a route for the
+-- master site.
+getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)
+getRouteToMaster = handlerToMaster `liftM` GHandler ask
+
+-- | Function used internally by Yesod in the process of converting a
+-- 'GHandler' into an 'W.Application'. Should not be needed by users.
+runHandler :: HasReps c
+           => GHandler sub master c
+           -> (Route master -> [(Text, Text)] -> Text)
+           -> Maybe (Route sub)
+           -> (Route sub -> Route master)
+           -> master
+           -> sub
+           -> YesodApp
+runHandler handler mrender sroute tomr ma sa =
+  YesodApp $ \eh rr cts initSession -> do
+    let toErrorHandler e =
+            case fromException e of
+                Just x -> x
+                Nothing -> InternalError $ T.pack $ show e
+    let hd = HandlerData
+            { handlerRequest = rr
+            , handlerSub = sa
+            , handlerMaster = ma
+            , handlerRoute = sroute
+            , handlerRender = mrender
+            , handlerToMaster = tomr
+            }
+    let initSession' = GHState initSession Nothing 1
+    ((contents', headers), finalSession) <- catchIter (
+        fmap (second ghsSession)
+      $ flip runStateT initSession'
+      $ runWriterT
+      $ runErrorT
+      $ flip runReaderT hd
+      $ unGHandler handler
+        ) (\e -> return ((Left $ HCError $ toErrorHandler e, mempty), initSession))
+    let contents = either id (HCContent H.status200 . chooseRep) contents'
+    let handleError e = do
+            yar <- unYesodApp (eh e) safeEh rr cts finalSession
+            case yar of
+                YARPlain _ hs ct c sess ->
+                    let hs' = appEndo headers hs
+                     in return $ YARPlain (getStatus e) hs' ct c sess
+                YARWai _ -> return yar
+    let sendFile' ct fp p =
+            return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
+    case contents of
+        HCContent status a -> do
+            (ct, c) <- liftIO $ a cts
+            return $ YARPlain status (appEndo headers []) ct c finalSession
+        HCError e -> handleError e
+        HCRedirect rt loc -> do
+            let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
+            return $ YARPlain
+                (getRedirectStatus rt) hs typePlain emptyContent
+                finalSession
+        HCSendFile ct fp p -> catchIter
+            (sendFile' ct fp p)
+            (handleError . toErrorHandler)
+        HCCreated loc -> do
+            let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
+            return $ YARPlain
+                H.status201
+                hs
+                typePlain
+                emptyContent
+                finalSession
+        HCWai r -> return $ YARWai r
+
+catchIter :: Exception e
+          => Iteratee ByteString IO a
+          -> (e -> Iteratee ByteString IO a)
+          -> Iteratee ByteString IO a
+catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f)
+
+safeEh :: ErrorResponse -> YesodApp
+safeEh er = YesodApp $ \_ _ _ session -> do
+    liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
+    return $ YARPlain
+        H.status500
+        []
+        typePlain
+        (toContent ("Internal Server Error" :: S.ByteString))
+        session
+
+-- | Redirect to the given route.
+redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a
+redirect rt url = redirectParams rt url []
+
+-- | Redirects to the given route with the associated query-string parameters.
+redirectParams :: Monad mo
+               => RedirectType -> Route master -> [(Text, Text)]
+               -> GGHandler sub master mo a
+redirectParams rt url params = do
+    r <- getUrlRenderParams
+    redirectString rt $ r url params
+
+-- | Redirect to the given URL.
+redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a
+redirectText rt = GHandler . lift . throwError . HCRedirect rt
+redirectString = redirectText
+{-# DEPRECATED redirectString "Use redirectText instead" #-}
+
+ultDestKey :: Text
+ultDestKey = "_ULT"
+
+-- | Sets the ultimate destination variable to the given route.
+--
+-- An ultimate destination is stored in the user session and can be loaded
+-- later by 'redirectUltDest'.
+setUltDest :: Monad mo => Route master -> GGHandler sub master mo ()
+setUltDest dest = do
+    render <- getUrlRender
+    setUltDestString $ render dest
+
+-- | Same as 'setUltDest', but use the given string.
+setUltDestText :: Monad mo => Text -> GGHandler sub master mo ()
+setUltDestText = setSession ultDestKey
+
+setUltDestString :: Monad mo => Text -> GGHandler sub master mo ()
+setUltDestString = setSession ultDestKey
+{-# DEPRECATED setUltDestString "Use setUltDestText instead" #-}
+
+-- | Same as 'setUltDest', but uses the current page.
+--
+-- If this is a 404 handler, there is no current page, and then this call does
+-- nothing.
+setUltDest' :: Monad mo => GGHandler sub master mo ()
+setUltDest' = do
+    route <- getCurrentRoute
+    case route of
+        Nothing -> return ()
+        Just r -> do
+            tm <- getRouteToMaster
+            gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
+            render <- getUrlRenderParams
+            setUltDestString $ render (tm r) gets'
+
+-- | Sets the ultimate destination to the referer request header, if present.
+--
+-- This function will not overwrite an existing ultdest.
+setUltDestReferer :: Monad mo => GGHandler sub master mo ()
+setUltDestReferer = do
+    mdest <- lookupSession ultDestKey
+    maybe
+        (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)
+        (const $ return ())
+        mdest
+  where
+    setUltDestBS = setUltDestText . T.pack . S8.unpack
+
+-- | Redirect to the ultimate destination in the user's session. Clear the
+-- value from the session.
+--
+-- The ultimate destination is set with 'setUltDest'.
+redirectUltDest :: Monad mo
+                => RedirectType
+                -> Route master -- ^ default destination if nothing in session
+                -> GGHandler sub master mo a
+redirectUltDest rt def = do
+    mdest <- lookupSession ultDestKey
+    deleteSession ultDestKey
+    maybe (redirect rt def) (redirectText rt) mdest
+
+-- | Remove a previously set ultimate destination. See 'setUltDest'.
+clearUltDest :: Monad mo => GGHandler sub master mo ()
+clearUltDest = deleteSession ultDestKey
+
+msgKey :: Text
+msgKey = "_MSG"
+
+-- | Sets a message in the user's session.
+--
+-- See 'getMessage'.
+setMessage :: Monad mo => Html -> GGHandler sub master mo ()
+setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
+
+-- | Sets a message in the user's session.
+--
+-- See 'getMessage'.
+setMessageI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler sub y mo ()
+setMessageI msg = do
+    mr <- getMessageRender
+    setMessage $ toHtml $ mr msg
+
+-- | Gets the message in the user's session, if available, and then clears the
+-- variable.
+--
+-- See 'setMessage'.
+getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
+getMessage = do
+    mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
+    deleteSession msgKey
+    return mmsg
+
+-- | Bypass remaining handler code and output the given file.
+--
+-- For some backends, this is more efficient than reading in the file to
+-- memory, since they can optimize file sending via a system call to sendfile.
+sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a
+sendFile ct fp = GHandler . lift . throwError $ HCSendFile ct fp Nothing
+
+-- | Same as 'sendFile', but only sends part of a file.
+sendFilePart :: Monad mo
+             => ContentType
+             -> FilePath
+             -> Integer -- ^ offset
+             -> Integer -- ^ count
+             -> GGHandler sub master mo a
+sendFilePart ct fp off count =
+    GHandler . lift . throwError $ HCSendFile ct fp $ Just $ W.FilePart off count
+
+-- | Bypass remaining handler code and output the given content with a 200
+-- status code.
+sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a
+sendResponse = GHandler . lift . throwError . HCContent H.status200
+             . chooseRep
+
+-- | Bypass remaining handler code and output the given content with the given
+-- status code.
+sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
+sendResponseStatus s = GHandler . lift . throwError . HCContent s
+                     . chooseRep
+
+-- | Send a 201 "Created" response with the given route as the Location
+-- response header.
+sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
+sendResponseCreated url = do
+    r <- getUrlRender
+    GHandler $ lift $ throwError $ HCCreated $ r url
+
+-- | Send a 'W.Response'. Please note: this function is rarely
+-- necessary, and will /disregard/ any changes to response headers and session
+-- that you have already specified. This function short-circuits. It should be
+-- considered only for very specific needs. If you are not sure if you need it,
+-- you don't.
+sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b
+sendWaiResponse = GHandler . lift . throwError . HCWai
+
+-- | Return a 404 not found page. Also denotes no handler available.
+notFound :: Failure ErrorResponse m => m a
+notFound = failure NotFound
+
+-- | Return a 405 method not supported page.
+badMethod :: Monad mo => GGHandler s m mo a
+badMethod = do
+    w <- waiRequest
+    failure $ BadMethod $ W.requestMethod w
+
+-- | Return a 403 permission denied page.
+permissionDenied :: Failure ErrorResponse m => Text -> m a
+permissionDenied = failure . PermissionDenied
+
+-- | Return a 403 permission denied page.
+permissionDeniedI :: (RenderMessage y msg, Monad mo) => msg -> GGHandler s y mo a
+permissionDeniedI msg = do
+    mr <- getMessageRender
+    permissionDenied $ mr msg
+
+-- | Return a 400 invalid arguments page.
+invalidArgs :: Failure ErrorResponse m => [Text] -> m a
+invalidArgs = failure . InvalidArgs
+
+-- | Return a 400 invalid arguments page.
+invalidArgsI :: (RenderMessage y msg, Monad mo) => [msg] -> GGHandler s y mo a
+invalidArgsI msg = do
+    mr <- getMessageRender
+    invalidArgs $ map mr msg
+
+------- Headers
+-- | Set the cookie on the client.
+setCookie :: Monad mo
+          => Int -- ^ minutes to timeout
+          -> H.Ascii -- ^ key
+          -> H.Ascii -- ^ value
+          -> GGHandler sub master mo ()
+setCookie a b = addHeader . AddCookie a b
+
+-- | Unset the cookie on the client.
+deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo ()
+deleteCookie = addHeader . DeleteCookie
+
+-- | Set the language in the user session. Will show up in 'languages' on the
+-- next request.
+setLanguage :: Monad mo => Text -> GGHandler sub master mo ()
+setLanguage = setSession langKey
+
+-- | Set an arbitrary response header.
+setHeader :: Monad mo
+          => CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
+setHeader a = addHeader . Header a
+
+-- | Set the Cache-Control header to indicate this response should be cached
+-- for the given number of seconds.
+cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
+cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
+    [ "max-age="
+    , show i
+    , ", public"
+    ]
+
+-- | Set the Expires header to some date in 2037. In other words, this content
+-- is never (realistically) expired.
+neverExpires :: Monad mo => GGHandler s m mo ()
+neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
+
+-- | Set an Expires header in the past, meaning this content should not be
+-- cached.
+alreadyExpired :: Monad mo => GGHandler s m mo ()
+alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
+
+-- | Set an Expires header to the given date.
+expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
+expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
+
+-- | Set a variable in the user's session.
+--
+-- The session is handled by the clientsession package: it sets an encrypted
+-- and hashed cookie on the client. This ensures that all data is secure and
+-- not tampered with.
+setSession :: Monad mo
+           => Text -- ^ key
+           -> Text -- ^ value
+           -> GGHandler sub master mo ()
+setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
+
+-- | Unsets a session variable. See 'setSession'.
+deleteSession :: Monad mo => Text -> GGHandler sub master mo ()
+deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete
+
+modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
+modSession f x = x { ghsSession = f $ ghsSession x }
+
+-- | Internal use only, not to be confused with 'setHeader'.
+addHeader :: Monad mo => Header -> GGHandler sub master mo ()
+addHeader = GHandler . lift . lift . tell . Endo . (:)
+
+getStatus :: ErrorResponse -> H.Status
+getStatus NotFound = H.status404
+getStatus (InternalError _) = H.status500
+getStatus (InvalidArgs _) = H.status400
+getStatus (PermissionDenied _) = H.status403
+getStatus (BadMethod _) = H.status405
+
+getRedirectStatus :: RedirectType -> H.Status
+getRedirectStatus RedirectPermanent = H.status301
+getRedirectStatus RedirectTemporary = H.status302
+getRedirectStatus RedirectSeeOther = H.status303
+
+-- | Different types of redirects.
+data RedirectType = RedirectPermanent
+                  | RedirectTemporary
+                  | RedirectSeeOther
+    deriving (Show, Eq)
+
+localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a
+localNoCurrent =
+    GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
+
+-- | Lookup for session data.
+lookupSession :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
+lookupSession n = GHandler $ do
+    m <- liftM ghsSession $ lift $ lift $ lift get
+    return $ Map.lookup n m
+
+-- | Get all session variables.
+getSession :: Monad mo => GGHandler s m mo SessionMap
+getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get
+
+handlerToYAR :: (HasReps a, HasReps b)
+             => m -- ^ master site foundation
+             -> s -- ^ sub site foundation
+             -> (Route s -> Route m)
+             -> (Route m -> [(Text, Text)] -> Text)
+             -> (ErrorResponse -> GHandler s m a)
+             -> Request
+             -> Maybe (Route s)
+             -> SessionMap
+             -> GHandler s m b
+             -> Iteratee ByteString IO YesodAppResult
+handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
+    unYesodApp ya eh' rr types sessionMap
+  where
+    ya = runHandler h render murl toMasterRoute y s
+    eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
+    types = httpAccept $ reqWaiRequest rr
+    errorHandler' = localNoCurrent . errorHandler
+
+type HeaderRenderer = [Header]
+                   -> ContentType
+                   -> SessionMap
+                   -> [(CI H.Ascii, H.Ascii)]
+
+yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
+yarToResponse _ (YARWai a) = a
+yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
+    case c of
+        ContentBuilder b mlen ->
+            let hs' = maybe finalHeaders finalHeaders' mlen
+             in W.ResponseBuilder s hs' b
+        ContentFile fp p -> W.ResponseFile s finalHeaders fp p
+        ContentEnum e ->
+            W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
+  where
+    finalHeaders = renderHeaders hs ct sessionFinal
+    finalHeaders' len = ("Content-Length", S8.pack $ show len)
+                      : finalHeaders
+    {-
+    getExpires m = fromIntegral (m * 60) `addUTCTime` now
+    sessionVal =
+        case key' of
+            Nothing -> B.empty
+            Just key'' -> encodeSession key'' exp' host
+                        $ Map.toList
+                        $ Map.insert nonceKey (reqNonce rr) sessionFinal
+    hs' =
+            case key' of
+                Nothing -> hs
+                Just _ -> AddCookie
+                        (clientSessionDuration y)
+                        sessionName
+                        (bsToChars sessionVal)
+                      : hs
+    hs'' = map (headerToPair getExpires) hs'
+    hs''' = ("Content-Type", charsToBs ct) : hs''
+    -}
+
+httpAccept :: W.Request -> [ContentType]
+httpAccept = parseHttpAccept
+           . fromMaybe mempty
+           . lookup "Accept"
+           . W.requestHeaders
+
+-- | Convert Header to a key/value pair.
+headerToPair :: S.ByteString -- ^ cookie path
+             -> (Int -> UTCTime) -- ^ minutes -> expiration time
+             -> Header
+             -> (CI H.Ascii, H.Ascii)
+headerToPair cp getExpires (AddCookie minutes key value) =
+    ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
+        { setCookieName = key
+        , setCookieValue = value
+        , setCookiePath = Just cp
+        , setCookieExpires =
+            if minutes == 0
+                then Nothing
+                else Just $ getExpires minutes
+        , setCookieDomain = Nothing
+        , setCookieHttpOnly = True
+        })
+headerToPair cp _ (DeleteCookie key) =
+    ( "Set-Cookie"
+    , key `mappend` "=; path=" `mappend` cp `mappend` "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
+    )
+headerToPair _ _ (Header key value) = (key, value)
+
+-- | Get a unique identifier.
+newIdent :: Monad mo => GGHandler sub master mo String -- FIXME use Text
+newIdent = GHandler $ lift $ lift $ lift $ do
+    x <- get
+    let i' = ghsIdent x + 1
+    put x { ghsIdent = i' }
+    return $ 'h' : show i'
+
+liftIOHandler :: MonadIO mo
+              => GGHandler sub master IO a
+              -> GGHandler sub master mo a
+liftIOHandler m = GHandler $
+                   ReaderT $ \r ->
+                     ErrorT $
+                       WriterT $
+                         StateT $ \s ->
+                           liftIO $ runGGHandler m r s
+
+runGGHandler :: GGHandler sub master m a
+            -> HandlerData sub master
+            -> GHState
+            -> m ( ( Either HandlerContents a
+                   , Endo [Header]
+                   )
+                 , GHState
+                 )
+runGGHandler m r s = runStateT
+                      (runWriterT
+                        (runErrorT
+                          (runReaderT
+                            (unGHandler m) r))) s
+
+instance MonadTransControl (GGHandler s m) where
+    liftControl f =
+      GHandler $
+        liftControl $ \runRdr ->
+          liftControl $ \runErr ->
+            liftControl $ \runWrt ->
+              liftControl $ \runSt ->
+                f ( liftM ( GHandler
+                          . join . lift
+                          . join . lift
+                          . join . lift
+                          )
+                  . runSt . runWrt . runErr . runRdr
+                  . unGHandler
+                  )
+
+-- | Redirect to a POST resource.
+--
+-- This is not technically a redirect; instead, it returns an HTML page with a
+-- POST form, and some Javascript to automatically submit the form. This can be
+-- useful when you need to post a plain link somewhere that needs to cause
+-- changes on the server.
+redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a
+redirectToPost dest = hamletToRepHtml
+#if GHC7
+            [hamlet|
+#else
+            [$hamlet|
+#endif
+\<!DOCTYPE html>
+
+<html>
+    <head>
+        <title>Redirecting...
+    <body onload="document.getElementById('form').submit()">
+        <form id="form" method="post" action="@{dest}">
+            <noscript>
+                <p>Javascript has been disabled; please click on the button below to be redirected.
+            <input type="submit" value="Continue">
+|] >>= sendResponse
+
+-- | Converts the given Hamlet template into 'Content', which can be used in a
+-- Yesod 'Response'.
+hamletToContent :: Monad mo
+                => Hamlet (Route master) -> GGHandler sub master mo Content
+hamletToContent h = do
+    render <- getUrlRenderParams
+    return $ toContent $ h render
+
+-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
+hamletToRepHtml :: Monad mo
+                => Hamlet (Route master) -> GGHandler sub master mo RepHtml
+hamletToRepHtml = liftM RepHtml . hamletToContent
+
+-- | Get the request\'s 'W.Request' value.
+waiRequest :: Monad mo => GGHandler sub master mo W.Request
+waiRequest = reqWaiRequest `liftM` getRequest
+
+getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text)
+getMessageRender = do
+    m <- getYesod
+    l <- reqLangs `liftM` getRequest
+    return $ renderMessage m l

yesod-core/Yesod/Internal.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+-- | Normal users should never need access to these.
+module Yesod.Internal
+    ( -- * Error responses
+      ErrorResponse (..)
+      -- * Header
+    , Header (..)
+      -- * Cookie names
+    , langKey
+      -- * Widgets
+    , GWData (..)
+    , Location (..)
+    , UniqueList (..)
+    , Script (..)
+    , Stylesheet (..)
+    , Title (..)
+    , Head (..)
+    , Body (..)
+    , locationToHamlet
+    , runUniqueList
+    , toUnique
+      -- * Names
+    , sessionName
+    , nonceKey
+    ) where
+
+import Text.Hamlet (Hamlet, hamlet, Html)
+import Text.Cassius (Cassius)
+import Text.Julius (Julius)
+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 qualified Network.HTTP.Types as A
+import Data.CaseInsensitive (CI)
+import Data.String (IsString)
+import qualified Data.Map as Map
+
+#if GHC7
+#define HAMLET hamlet
+#else
+#define HAMLET $hamlet
+#endif
+
+-- | 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 Int A.Ascii A.Ascii
+    | DeleteCookie A.Ascii
+    | Header (CI A.Ascii) A.Ascii
+    deriving (Eq, Show)
+
+langKey :: IsString a => a
+langKey = "_LANG"
+
+data Location url = Local url | Remote Text
+    deriving (Show, Eq)
+locationToHamlet :: Location url -> Hamlet url
+locationToHamlet (Local url) = [HAMLET|\@{url}
+|]
+locationToHamlet (Remote s) = [HAMLET|\#{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 (Hamlet url)
+    deriving Monoid
+newtype Body url = Body (Hamlet url)
+    deriving Monoid
+
+nonceKey :: IsString a => a
+nonceKey = "_NONCE"
+
+sessionName :: IsString a => a
+sessionName = "_SESSION"
+
+data GWData a = GWData
+    !(Body a)
+    !(Last Title)
+    !(UniqueList (Script a))
+    !(UniqueList (Stylesheet a))
+    !(Map.Map (Maybe Text) (Cassius a)) -- media type
+    !(Maybe (Julius a))
+    !(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)

yesod-core/Yesod/Internal/Core.hs

@@ -0,0 +1,575 @@
+{-# 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 (..)
+      -- * Logging
+    , LogLevel (..)
+    , formatLogMessage
+    , messageLoggerHandler
+      -- * Misc
+    , yesodVersion
+    , yesodRender
+    ) where
+
+import Yesod.Content
+import Yesod.Handler
+
+import Control.Arrow ((***))
+import Control.Monad (forM)
+import qualified Paths_yesod_core
+import Data.Version (showVersion)
+import Yesod.Widget
+import Yesod.Request
+import qualified Network.Wai as W
+import Yesod.Internal
+import Yesod.Internal.Session
+import Yesod.Internal.Request
+import Web.ClientSession (getKey, defaultKeyFile)
+import qualified Web.ClientSession as CS
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy as L
+import Data.Monoid
+import Control.Monad.Trans.RWS
+import Text.Hamlet
+import Text.Cassius
+import Text.Julius
+import Text.Blaze ((!), customAttribute, textTag, toValue)
+import qualified Text.Blaze.Html5 as TBH
+import Data.Text.Lazy.Builder (toLazyText)
+import Data.Text.Lazy.Encoding (encodeUtf8)
+import Data.Maybe (fromMaybe)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Web.Cookie (parseCookies)
+import qualified Data.Map as Map
+import Data.Time
+import Network.HTTP.Types (encodePath)
+import qualified Data.Text as TS
+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 qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO
+import qualified System.IO
+import qualified Data.Text.Lazy.Builder as TB
+import Language.Haskell.TH.Syntax (Loc (..), Lift (..))
+import Text.Blaze (preEscapedLazyText)
+
+#if GHC7
+#define HAMLET hamlet
+#else
+#define HAMLET $hamlet
+#endif
+
+class Eq u => RenderRoute u where
+    renderRoute :: u -> ([Text], [(Text, Text)])
+
+-- | This class is automatically instantiated when you use the template haskell
+-- mkYesod function. You should never need to deal with it directly.
+class YesodDispatch a master where
+    yesodDispatch
+        :: Yesod master
+        => a
+        -> Maybe CS.Key
+        -> [Text]
+        -> master
+        -> (Route a -> Route master)
+        -> Maybe W.Application
+
+    yesodRunner :: Yesod master
+                => a
+                -> master
+                -> (Route a -> Route master)
+                -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
+    yesodRunner = defaultYesodRunner
+
+-- | Define settings for a Yesod applications. The only required setting is
+-- 'approot'; other than that, there are intelligent defaults.
+class RenderRoute (Route a) => Yesod a where
+    -- | An absolute URL to the root of the application. Do not include
+    -- trailing slash.
+    --
+    -- If you want to be lazy, you can supply an empty string 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.
+    approot :: a -> Text
+
+    -- | The encryption key to be used for encrypting client sessions.
+    -- Returning 'Nothing' disables sessions.
+    encryptKey :: a -> IO (Maybe CS.Key)
+    encryptKey _ = fmap Just $ getKey defaultKeyFile
+
+    -- | Number of minutes before a client session times out. Defaults to
+    -- 120 (2 hours).
+    clientSessionDuration :: a -> Int
+    clientSessionDuration = const 120
+
+    -- | 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|
+!!!
+
+<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 'Nothing' is the request is authorized, 'Just' a message if
+    -- unauthorized. If authentication is required, you should use a redirect;
+    -- the Auth helper provides this functionality automatically.
+    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 s
+            else Left corrected
+      where
+        corrected = filter (not . TS.null) s
+
+    -- | Join the pieces of a path together into an absolute URL. This should
+    -- be the inverse of 'splitPath'.
+    joinPath :: a
+             -> TS.Text -- ^ application root
+             -> [TS.Text] -- ^ path pieces
+             -> [(TS.Text, TS.Text)] -- ^ query string
+             -> Builder
+    joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs
+      where
+        pieces = if null pieces' then [""] else pieces'
+        qs = map (TE.encodeUtf8 *** go) qs'
+        go "" = Nothing
+        go x = Just $ TE.encodeUtf8 x
+
+    -- | 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
+
+    -- | Whether or not to tie a session to a specific IP address. Defaults to
+    -- 'True'.
+    sessionIpAddress :: a -> Bool
+    sessionIpAddress _ = True
+
+    -- | 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 _ = "/"
+
+    -- | Maximum allowed length of the request body, in bytes.
+    maximumContentLength :: a -> Maybe (Route a) -> Int
+    maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes
+
+    -- | Send a message to the log. By default, prints to stderr.
+    messageLogger :: a
+                  -> Loc -- ^ position in source code
+                  -> LogLevel
+                  -> Text -- ^ message
+                  -> IO ()
+    messageLogger _ loc level msg =
+        formatLogMessage loc level msg >>=
+        Data.Text.Lazy.IO.hPutStrLn System.IO.stderr
+
+messageLoggerHandler :: (Yesod m, MonadIO mo)
+                     => Loc -> LogLevel -> Text -> GGHandler s m mo ()
+messageLoggerHandler loc level msg = do
+    y <- getYesod
+    liftIO $ messageLogger y loc level msg
+
+data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text
+    deriving (Eq, Show, Read, Ord)
+
+instance Lift LogLevel where
+    lift LevelDebug = [|LevelDebug|]
+    lift LevelInfo = [|LevelInfo|]
+    lift LevelWarn = [|LevelWarn|]
+    lift LevelError = [|LevelError|]
+    lift (LevelOther x) = [|LevelOther $ TS.pack $(lift $ TS.unpack x)|]
+
+formatLogMessage :: Loc
+                 -> LogLevel
+                 -> Text -- ^ message
+                 -> IO TL.Text
+formatLogMessage loc level msg = do
+    now <- getCurrentTime
+    return $ TB.toLazyText $
+        TB.fromText (TS.pack $ show now)
+        `mappend` TB.fromText ": "
+        `mappend` TB.fromText (TS.pack $ show level)
+        `mappend` TB.fromText "@("
+        `mappend` TB.fromText (TS.pack $ loc_filename loc)
+        `mappend` TB.fromText ":"
+        `mappend` TB.fromText (TS.pack $ show $ fst $ loc_start loc)
+        `mappend` TB.fromText ") "
+        `mappend` TB.fromText msg
+
+defaultYesodRunner :: Yesod master
+                   => a
+                   -> master
+                   -> (Route a -> Route master)
+                   -> Maybe CS.Key
+                   -> Maybe (Route a)
+                   -> GHandler a master ChooseRep
+                   -> W.Application
+defaultYesodRunner _ m toMaster _ murl _ req
+    | maximumContentLength m (fmap toMaster murl) < len =
+        return $ W.responseLBS
+            (H.Status 413 "Too Large")
+            [("Content-Type", "text/plain")]
+            "Request body too large to be processed."
+  where
+    len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay
+    readMay s =
+        case reads $ S8.unpack s of
+            [] -> Nothing
+            (x, _):_ -> Just x
+defaultYesodRunner s master toMasterRoute mkey murl handler req = do
+    now <- liftIO getCurrentTime
+    let getExpires m = fromIntegral (m * 60) `addUTCTime` now
+    let exp' = getExpires $ clientSessionDuration master
+    let rh = takeWhile (/= ':') $ show $ W.remoteHost req
+    let host = if sessionIpAddress master then S8.pack rh else ""
+    let session' =
+            case mkey of
+                Nothing -> []
+                Just key -> fromMaybe [] $ do
+                    raw <- lookup "Cookie" $ W.requestHeaders req
+                    val <- lookup sessionName $ parseCookies raw
+                    decodeSession key now host val
+    rr <- liftIO $ parseWaiRequest req session' mkey
+    let 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
+                                setUltDest'
+                                redirect RedirectTemporary url'
+                    Unauthorized s' -> permissionDenied s'
+                handler
+    let sessionMap = Map.fromList
+                   $ filter (\(x, _) -> x /= nonceKey) session'
+    yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
+    let mnonce = reqNonce rr
+    return $ yarToResponse (hr mnonce getExpires host exp') yar
+  where
+    hr mnonce getExpires host exp' hs ct sm =
+        hs'''
+      where
+        sessionVal =
+            case (mkey, mnonce) of
+                (Just key, Just nonce)
+                    -> encodeSession key exp' host
+                     $ Map.toList
+                     $ Map.insert nonceKey nonce sm
+                _ -> mempty
+        hs' =
+            case mkey of
+                Nothing -> hs
+                Just _ -> AddCookie
+                            (clientSessionDuration master)
+                            sessionName
+                            sessionVal
+                          : hs
+        hs'' = map (headerToPair (cookiePath master) getExpires) hs'
+        hs''' = ("Content-Type", ct) : hs''
+
+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
+             -> Hamlet (Route master) -- ^ body
+             -> GHandler sub master ChooseRep
+applyLayout' title body = fmap chooseRep $ defaultLayout $ do
+    setTitle title
+    addHamlet 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"
+#if GHC7
+        [hamlet|
+#else
+        [$hamlet|
+#endif
+<h1>Not Found
+<p>#{path'}
+|]
+defaultErrorHandler (PermissionDenied msg) =
+    applyLayout' "Permission Denied"
+#if GHC7
+        [hamlet|
+#else
+        [$hamlet|
+#endif
+<h1>Permission denied
+<p>#{msg}
+|]
+defaultErrorHandler (InvalidArgs ia) =
+    applyLayout' "Invalid Arguments"
+#if GHC7
+        [hamlet|
+#else
+        [$hamlet|
+#endif
+<h1>Invalid Arguments
+<ul>
+    $forall msg <- ia
+        <li>#{msg}
+|]
+defaultErrorHandler (InternalError e) =
+    applyLayout' "Internal Server Error"
+#if GHC7
+        [hamlet|
+#else
+        [$hamlet|
+#endif
+<h1>Internal Server Error
+<p>#{e}
+|]
+defaultErrorHandler (BadMethod m) =
+    applyLayout' "Bad Method"
+#if GHC7
+        [hamlet|
+#else
+        [$hamlet|
+#endif
+<h1>Method Not Supported
+<p>Method "#{S8.unpack m}" 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
+
+-- | Convert a widget to a 'PageContent'.
+widgetToPageContent :: (Eq (Route master), Yesod master)
+                    => GWidget sub master ()
+                    -> GHandler sub master (PageContent (Route master))
+widgetToPageContent (GWidget w) = do
+    ((), _, GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- runRWST w () 0
+    let title = maybe mempty unTitle mTitle
+    let scripts = runUniqueList scripts'
+    let stylesheets = runUniqueList stylesheets'
+    let jsToHtml (Javascript b) = preEscapedLazyText $ toLazyText b
+        jelper :: Julius url -> Hamlet url
+        jelper = fmap jsToHtml
+
+    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 = renderCassius render content
+        x <- addStaticContent "css" "text/css; charset=utf-8"
+           $ encodeUtf8 rendered
+        return (mmedia,
+            case x of
+                Nothing -> Left $ preEscapedLazyText 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 $ renderJulius render s
+                return $ renderLoc x
+
+    let addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)
+    let renderLoc' render' (Local url) = render' url []
+        renderLoc' _ (Remote s) = s
+    let mkScriptTag (Script loc attrs) render' =
+            foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()
+    let mkLinkTag (Stylesheet loc attrs) render' =
+            foldl' addAttr TBH.link
+                ( ("rel", "stylesheet")
+                : ("href", renderLoc' render' loc)
+                : attrs
+                )
+    let left (Left x) = Just x
+        left _ = Nothing
+        right (Right x) = Just x
+        right _ = Nothing
+    let head'' =
+#if GHC7
+            [hamlet|
+#else
+            [$hamlet|
+#endif
+$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}
+$forall s <- scripts
+    ^{mkScriptTag s}
+$maybe j <- jscript
+    $maybe s <- jsLoc
+        <script src="#{s}">
+    $nothing
+        <script>^{jelper j}
+\^{head'}
+|]
+    return $ PageContent title head'' body
+
+yesodVersion :: String
+yesodVersion = showVersion Paths_yesod_core.version
+
+yesodRender :: Yesod y
+            => y
+            -> Route y
+            -> [(Text, Text)]
+            -> Text
+yesodRender y u qs =
+    TE.decodeUtf8 $ toByteString $
+    fromMaybe
+        (joinPath y (approot y) ps
+          $ qs ++ qs')
+        (urlRenderOverride y u)
+  where
+    (ps, qs') = renderRoute u

yesod-core/Yesod/Internal/Dispatch.hs

@@ -0,0 +1,322 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | A bunch of Template Haskell used in the Yesod.Dispatch module.
+module Yesod.Internal.Dispatch
+    ( mkYesodDispatch'
+    ) where
+
+import Prelude hiding (exp)
+import Language.Haskell.TH.Syntax
+import Web.PathPieces
+import Yesod.Internal.RouteParsing
+import Control.Monad (foldM)
+import Yesod.Handler (badMethod)
+import Yesod.Content (chooseRep)
+import qualified Network.Wai as W
+import Yesod.Internal.Core (yesodRunner, yesodDispatch)
+import Data.List (foldl')
+import Data.Char (toLower)
+import qualified Data.ByteString as S
+import Yesod.Internal.Core (Yesod (joinPath, approot, cleanPath))
+import Network.HTTP.Types (status301)
+import Data.Text (Text)
+import Data.Monoid (mappend)
+import qualified Blaze.ByteString.Builder
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.Text
+
+{-|
+
+Alright, let's explain how routing works. We want to take a [String] and found
+out which route it applies to. For static pieces, we need to ensure an exact
+match against the segment. For a single or multi piece, we need to check the
+result of fromSinglePiece/fromMultiPiece, respectively.
+
+We want to create a tree of case statements basically resembling:
+
+case testRoute1 of
+    Just app -> Just app
+    Nothing ->
+        case testRoute2 of
+            Just app -> Just app
+            Nothing ->
+                case testRoute3 of
+                    Just app -> Just app
+                    Nothing -> Nothing
+
+Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int):
+
+case segments of
+    "name" : as ->
+        case as of
+            [] -> Nothing
+            b:bs ->
+                case fromSinglePiece b of
+                    Left _ -> Nothing
+                    Right name ->
+                        case bs of
+                            "age":cs ->
+                                case cs of
+                                    [] -> Nothing
+                                    d:ds ->
+                                        case fromSinglePiece d of
+                                            Left _ -> Nothing
+                                            Right age ->
+                                                case ds of
+                                                    [] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)...
+                                                    _ -> Nothing
+                            _ -> Nothing
+    _ -> Nothing
+
+Obviously we would never want to write code by hand like this, but generating it is not too bad.
+
+This function generates a clause for the yesodDispatch function based on a set of routes.
+
+NOTE: We deal with subsites first; if none of those match, we try to apply
+cleanPath. If that indicates a redirect, we perform it. Otherwise, we match
+local routes.
+
+-}
+
+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 (approot y) segments' []
+    dest' =
+        if S.null (W.rawQueryString env)
+            then dest
+            else (dest `mappend`
+                 Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
+
+mkYesodDispatch' :: [((String, Pieces), Maybe String)]
+                 -> [((String, Pieces), Maybe String)]
+                 -> Q Clause
+mkYesodDispatch' resSub resLoc = do
+    sub <- newName "sub"
+    master <- newName "master"
+    mkey <- newName "mkey"
+    segments <- newName "segments"
+    segments' <- newName "segmentsClean"
+    toMasterRoute <- newName "toMasterRoute"
+    nothing <- [|Nothing|]
+    bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc
+    cp <- [|cleanPath|]
+    sr <- [|sendRedirect|]
+    just <- [|Just|]
+    let bodyLoc' =
+            CaseE (cp `AppE` VarE master `AppE` VarE segments)
+                [ Match (ConP (mkName "Left") [VarP segments'])
+                        (NormalB $ just `AppE`
+                           (sr `AppE` VarE master `AppE` VarE segments'))
+                        []
+                , Match (ConP (mkName "Right") [VarP segments'])
+                        (NormalB bodyLoc)
+                        []
+                ]
+    body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub
+    return $ Clause
+        [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
+        (NormalB body)
+        []
+  where
+    go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
+        test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub)
+        app <- newName "app"
+        return $ CaseE test
+            [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
+            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
+            ]
+    go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
+        test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)
+        just <- [|Just|]
+        app <- newName "app"
+        return $ CaseE test
+            [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
+            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
+            ]
+    go _ _ _ _ _ _ _ = error "Invalid combination"
+
+mkSimpleExp :: Exp -- ^ segments
+            -> [Piece]
+            -> ([Exp] -> [Exp]) -- ^ variables already parsed
+            -> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods
+            -> Q Exp
+mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
+    just <- [|Just|]
+    nothing <- [|Nothing|]
+    onSuccess <- newName "onSuccess"
+    req <- newName "req"
+    badMethod' <- [|badMethod|]
+    rm <- [|S8.unpack . W.requestMethod|]
+    let caseExp = rm `AppE` VarE req
+    yr <- [|yesodRunner|]
+    cr <- [|fmap chooseRep|]
+    eq <- [|(==)|]
+    let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
+    let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
+        runHandler' h = yr `AppE` sub
+                           `AppE` VarE master
+                           `AppE` toMasterRoute
+                           `AppE` VarE mkey
+                           `AppE` (just `AppE` url)
+                           `AppE` h
+                           `AppE` VarE req
+    let match :: String -> Q Match
+        match m = do
+            x <- newName "x"
+            return $ Match
+                (VarP x)
+                (GuardedB
+                    [ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ LitE $ StringL m) -- FIXME need to pack, right?
+                      , runHandlerVars $ map toLower m ++ constr
+                      )
+                    ])
+                []
+    clauses <-
+        case methods of
+            [] -> return [Clause [VarP req] (NormalB $ runHandlerVars $ "handle" ++ constr) []]
+            _ -> do
+                matches <- mapM match methods
+                return [Clause [VarP req] (NormalB $ CaseE caseExp $ matches ++
+                                                               [Match WildP (NormalB $ runHandler' badMethod') []]) []]
+    let exp = CaseE segments
+                [ Match
+                    (ConP (mkName "[]") [])
+                    (NormalB $ just `AppE` VarE onSuccess)
+                    [FunD onSuccess clauses]
+                , Match
+                    WildP
+                    (NormalB nothing)
+                    []
+                ]
+    return exp
+mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
+    srest <- newName "segments"
+    innerExp <- mkSimpleExp (VarE srest) pieces frontVars x
+    nothing <- [|Nothing|]
+    y <- newName "y"
+    pack <- [|Data.Text.pack|]
+    eq <- [|(==)|]
+    let exp = CaseE segments
+                [ Match
+                    (InfixP (VarP y) (mkName ":") (VarP srest))
+                    (GuardedB
+                        [ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
+                          , innerExp
+                          )
+                        ])
+                    []
+                , Match WildP (NormalB nothing) []
+                ]
+    return exp
+mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
+    srest <- newName "segments"
+    next' <- newName "next'"
+    innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
+    nothing <- [|Nothing|]
+    next <- newName "next"
+    fsp <- [|fromSinglePiece|]
+    let exp' = CaseE (fsp `AppE` VarE next)
+                [ Match
+                    (ConP (mkName "Nothing") [])
+                    (NormalB nothing)
+                    []
+                , Match
+                    (ConP (mkName "Just") [VarP next'])
+                    (NormalB innerExp)
+                    []
+                ]
+    let exp = CaseE segments
+                [ Match
+                    (InfixP (VarP next) (mkName ":") (VarP srest))
+                    (NormalB exp')
+                    []
+                , Match WildP (NormalB nothing) []
+                ]
+    return exp
+mkSimpleExp segments [MultiPiece _] frontVars x = do
+    next' <- newName "next'"
+    srest <- [|[]|]
+    innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
+    nothing <- [|Nothing|]
+    fmp <- [|fromMultiPiece|]
+    let exp = CaseE (fmp `AppE` segments)
+                [ Match
+                    (ConP (mkName "Nothing") [])
+                    (NormalB nothing)
+                    []
+                , Match
+                    (ConP (mkName "Just") [VarP next'])
+                    (NormalB innerExp)
+                    []
+                ]
+    return exp
+mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"
+
+mkSubsiteExp :: Name -- ^ segments
+             -> [Piece]
+             -> ([Exp] -> [Exp]) -- ^ variables already parsed
+             -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub
+             -> Q Exp
+mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
+    yd <- [|yesodDispatch|]
+    dot <- [|(.)|]
+    let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []
+    -- proper handling for sub-subsites
+    let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars []
+    let app = yd `AppE` sub'
+                 `AppE` VarE mkey
+                 `AppE` VarE segments
+                 `AppE` VarE master
+                 `AppE` con
+    just <- [|Just|]
+    return $ just `AppE` app
+mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece"
+mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
+    srest <- newName "segments"
+    innerExp <- mkSubsiteExp srest pieces frontVars x
+    nothing <- [|Nothing|]
+    y <- newName "y"
+    pack <- [|Data.Text.pack|]
+    eq <- [|(==)|]
+    let exp = CaseE (VarE segments)
+                [ Match
+                    (InfixP (VarP y) (mkName ":") (VarP srest))
+                    (GuardedB
+                        [ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
+                          , innerExp
+                          )
+                        ])
+                    []
+                , Match WildP (NormalB nothing) []
+                ]
+    return exp
+mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
+    srest <- newName "segments"
+    next' <- newName "next'"
+    innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
+    nothing <- [|Nothing|]
+    next <- newName "next"
+    fsp <- [|fromSinglePiece|]
+    let exp' = CaseE (fsp `AppE` VarE next)
+                [ Match
+                    (ConP (mkName "Nothing") [])
+                    (NormalB nothing)
+                    []
+                , Match
+                    (ConP (mkName "Just") [VarP next'])
+                    (NormalB innerExp)
+                    []
+                ]
+    let exp = CaseE (VarE segments)
+                [ Match
+                    (InfixP (VarP next) (mkName ":") (VarP srest))
+                    (NormalB exp')
+                    []
+                , Match WildP (NormalB nothing) []
+                ]
+    return exp

yesod-core/Yesod/Internal/Request.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Internal.Request
+    ( parseWaiRequest
+    , Request (..)
+    , RequestBodyContents
+    , FileInfo (..)
+    ) where
+
+import Control.Arrow (first, second)
+import qualified Network.Wai.Parse as NWP
+import Yesod.Internal
+import qualified Network.Wai as W
+import System.Random (randomR, newStdGen)
+import Web.Cookie (parseCookiesText)
+import Data.Monoid (mempty)
+import qualified Data.ByteString.Char8 as S8
+import Data.Text (Text, pack)
+import Network.HTTP.Types (queryToQueryText)
+import Control.Monad (join)
+import Data.Maybe (fromMaybe)
+import qualified Data.ByteString.Lazy as L
+
+-- | The parsed request information.
+data Request = Request
+    { reqGetParams :: [(Text, Text)]
+    , reqCookies :: [(Text, Text)]
+    , reqWaiRequest :: W.Request
+      -- | Languages which the client supports.
+    , reqLangs :: [Text]
+      -- | A random, session-specific nonce used to prevent CSRF attacks.
+    , reqNonce :: Maybe Text
+    }
+
+parseWaiRequest :: W.Request
+                -> [(Text, Text)] -- ^ session
+                -> Maybe a
+                -> IO Request
+parseWaiRequest env session' key' = do
+    let gets' = queryToQueryText $ W.queryString env
+    let reqCookie = fromMaybe mempty $ lookup "Cookie"
+                  $ W.requestHeaders env
+        cookies' = parseCookiesText reqCookie
+        acceptLang = lookup "Accept-Language" $ W.requestHeaders env
+        langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang
+        langs' = case lookup langKey session' of
+                    Nothing -> langs
+                    Just x -> x : langs
+        langs'' = case lookup langKey cookies' of
+                    Nothing -> langs'
+                    Just x -> x : langs'
+        langs''' = case join $ lookup langKey gets' of
+                     Nothing -> langs''
+                     Just x -> x : langs''
+    nonce <- case (key', lookup nonceKey session') of
+                (Nothing, _) -> return Nothing
+                (_, Just x) -> return $ Just x
+                (_, Nothing) -> do
+                    g <- newStdGen
+                    return $ Just $ pack $ fst $ randomString 10 g
+    let gets'' = map (second $ fromMaybe "") gets'
+    return $ Request gets'' cookies' env langs''' nonce
+  where
+    randomString len =
+        first (map toChar) . sequence' (replicate len (randomR (0, 61)))
+    sequence' [] g = ([], g)
+    sequence' (f:fs) g =
+        let (f', g') = f g
+            (fs', g'') = sequence' fs g'
+         in (f' : fs', g'')
+    toChar i
+        | i < 26 = toEnum $ i + fromEnum 'A'
+        | 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
+    , fileContent :: L.ByteString
+    }
+    deriving (Eq, Show)

yesod-core/Yesod/Internal/RouteParsing.hs

@@ -0,0 +1,349 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module Yesod.Internal.RouteParsing
+    ( createRoutes
+    , createRender
+    , createParse
+    , createDispatch
+    , Pieces (..)
+    , THResource
+    , parseRoutes
+    , parseRoutesFile
+    , parseRoutesNoCheck
+    , parseRoutesFileNoCheck
+    , Resource (..)
+    , Piece (..)
+    ) where
+
+import Web.PathPieces
+import Language.Haskell.TH.Syntax
+import Data.Maybe
+import Data.Either
+import Data.List
+import Data.Char (toLower)
+import qualified Data.Text
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
+import Data.Data
+import Data.Maybe
+import qualified System.IO as SIO
+
+data Pieces =
+    SubSite
+        { ssType :: Type
+        , ssParse :: Exp
+        , ssRender :: Exp
+        , ssDispatch :: Exp
+        , ssToMasterArg :: Exp
+        , ssPieces :: [Piece]
+        }
+  | Simple [Piece] [String] -- ^ methods
+    deriving Show
+type THResource = (String, Pieces)
+
+createRoutes :: [THResource] -> Q [Con]
+createRoutes res =
+    return $ map go res
+  where
+    go (n, SubSite{ssType = s, ssPieces = pieces}) =
+        NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
+    go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
+    go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
+    go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
+    go' (StaticPiece _) = Nothing
+
+-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.
+createParse :: [THResource] -> Q [Clause]
+createParse res = do
+    final' <- final
+    clauses <- mapM go res
+    return $ if areResourcesComplete res
+                then clauses
+                else clauses ++ [final']
+  where
+    cons x y = ConP (mkName ":") [x, y]
+    go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
+        ri <- [|Right|]
+        be <- [|ape|]
+        (pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
+        
+        x <- newName "x"
+        let pat = init pat' ++ [VarP x]
+
+        --let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces
+        let eitherSub = p `AppE` VarE x
+        let bod = be `AppE` parse `AppE` eitherSub
+        --let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub
+        return $ Clause [foldr1 cons pat] (NormalB bod) []
+    go (n, Simple ps _) = do
+        ri <- [|Right|]
+        be <- [|ape|]
+        (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
+        return $ Clause [foldr1 cons pat] (NormalB parse) []
+    final = do
+        no <- [|Left "Invalid URL"|]
+        return $ Clause [WildP] (NormalB no) []
+    mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
+    mkPat' be [MultiPiece s] parse = do
+        v <- newName $ "var" ++ s
+        fmp <- [|fromMultiPiece|]
+        let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
+        return ([VarP v], parse')
+    mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
+    mkPat' be (StaticPiece s:rest) parse = do
+        (x, parse') <- mkPat' be rest parse
+        let sp = LitP $ StringL s
+        return (sp : x, parse')
+    mkPat' be (SinglePiece s:rest) parse = do
+        fsp <- [|fromSinglePiece|]
+        v <- newName $ "var" ++ s
+        let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
+        (x, parse'') <- mkPat' be rest parse'
+        return (VarP v : x, parse'')
+    mkPat' _ [] parse = return ([ListP []], parse)
+
+-- | 'ap' for 'Either'
+ape :: Either String (a -> b) -> Either String a -> Either String b
+ape (Left e) _ = Left e
+ape (Right _) (Left e) = Left e
+ape (Right f) (Right a) = Right $ f a
+
+-- | Generates the set of clauses necesary to render the given 'Resource's. See
+-- 'quasiRender'.
+createRender :: [THResource] -> Q [Clause]
+createRender = mapM go
+  where
+    go (n, Simple ps _) = do
+        let ps' = zip [1..] ps
+        let pat = ConP (mkName n) $ mapMaybe go' ps'
+        bod <- mkBod ps'
+        return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
+    go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
+        cons' <- [|\a (b, c) -> (a ++ b, c)|]
+        let cons a b = cons' `AppE` a `AppE` b
+        x <- newName "x"
+        let r' = r `AppE` VarE x
+        let pieces' = zip [1..] pieces
+        let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
+        bod <- mkBod pieces'
+        return $ Clause [pat] (NormalB $ cons bod r') []
+    go' (_, StaticPiece _) = Nothing
+    go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
+    mkBod :: (Show t) => [(t, Piece)] -> Q Exp
+    mkBod [] = lift ([] :: [String])
+    mkBod ((_, StaticPiece x):xs) = do
+        x' <- lift x
+        pack <- [|Data.Text.pack|]
+        xs' <- mkBod xs
+        return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
+    mkBod ((i, SinglePiece _):xs) = do
+        let x' = VarE $ mkName $ "var" ++ show i
+        tsp <- [|toSinglePiece|]
+        let x'' = tsp `AppE` x'
+        xs' <- mkBod xs
+        return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
+    mkBod ((i, MultiPiece _):_) = do
+        let x' = VarE $ mkName $ "var" ++ show i
+        tmp <- [|toMultiPiece|]
+        return $ tmp `AppE` x'
+
+-- | Whether the set of resources cover all possible URLs.
+areResourcesComplete :: [THResource] -> Bool
+areResourcesComplete res =
+    let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
+     in case slurps of
+            [] -> False
+            _ -> let minSlurp = minimum slurps
+                  in helper minSlurp $ reverse $ sort noSlurps
+  where
+    go :: THResource -> Maybe (Either Int Int)
+    go (_, Simple ps _) =
+        case reverse ps of
+            [] -> Just $ Right 0
+            (MultiPiece _:rest) -> go' Left rest
+            x -> go' Right x
+    go (n, SubSite{ssPieces = ps}) =
+        go (n, Simple (ps ++ [MultiPiece ""]) [])
+    go' b x = if all isSingle x then Just (b $ length x) else Nothing
+    helper 0 _ = True
+    helper _ [] = False
+    helper m (i:is)
+        | i >= m = helper m is
+        | i + 1 == m = helper i is
+        | otherwise = False
+    isSingle (SinglePiece _) = True
+    isSingle _ = False
+
+notStatic :: Piece -> Bool
+notStatic StaticPiece{} = False
+notStatic _ = True
+
+createDispatch :: Exp -- ^ modify a master handler
+               -> Exp -- ^ convert a subsite handler to a master handler
+               -> [THResource]
+               -> Q [Clause]
+createDispatch modMaster toMaster = mapM go
+  where
+    go :: (String, Pieces) -> Q Clause
+    go (n, Simple ps methods) = do
+        meth <- newName "method"
+        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
+        let pat = [ ConP (mkName n) $ map VarP xs
+                  , if null methods then WildP else VarP meth
+                  ]
+        bod <- go' n meth xs methods
+        return $ Clause pat (NormalB bod) []
+    go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
+        meth <- newName "method"
+        x <- newName "x"
+        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
+        let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
+        let bod = d `AppE` VarE x `AppE` VarE meth
+        fmap' <- [|fmap|]
+        let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
+            tma' = foldl AppE tma $ map VarE xs
+        let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
+        let bod' = InfixE (Just toMaster') fmap' (Just bod)
+        let bod'' = InfixE (Just modMaster) fmap' (Just bod')
+        return $ Clause pat (NormalB bod'') []
+    go' n _ xs [] = do
+        jus <- [|Just|]
+        let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
+        return $ jus `AppE` (modMaster `AppE` bod)
+    go' n meth xs methods = do
+        noth <- [|Nothing|]
+        j <- [|Just|]
+        let noMatch = Match WildP (NormalB noth) []
+        return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
+    go'' n xs j method =
+        let pat = LitP $ StringL method
+            func = map toLower method ++ n
+            bod = foldl AppE (VarE $ mkName func) $ map VarE xs
+         in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []
+
+-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
+-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
+-- checking. See documentation site for details on syntax.
+parseRoutes :: QuasiQuoter
+parseRoutes = QuasiQuoter
+    { quoteExp = x
+    , quotePat = y
+    }
+  where
+    x s = do
+        let res = resourcesFromString s
+        case findOverlaps res of
+            [] -> lift res
+            z -> error $ "Overlapping routes: " ++ unlines (map show z)
+    y = dataToPatQ (const Nothing) . resourcesFromString
+
+parseRoutesFile :: FilePath -> Q Exp
+parseRoutesFile fp = do
+    s <- qRunIO $ readUtf8File fp
+    quoteExp parseRoutes s
+
+parseRoutesFileNoCheck :: FilePath -> Q Exp
+parseRoutesFileNoCheck fp = do
+    s <- qRunIO $ readUtf8File fp
+    quoteExp parseRoutesNoCheck s
+
+readUtf8File :: FilePath -> IO String
+readUtf8File fp = do
+    h <- SIO.openFile fp SIO.ReadMode
+    SIO.hSetEncoding h SIO.utf8_bom
+    SIO.hGetContents h
+
+-- | Same as 'parseRoutes', but performs no overlap checking.
+parseRoutesNoCheck :: QuasiQuoter
+parseRoutesNoCheck = QuasiQuoter
+    { quoteExp = x
+    , quotePat = y
+    }
+  where
+    x = lift . resourcesFromString
+    y = dataToPatQ (const Nothing) . resourcesFromString
+
+instance Lift Resource where
+    lift (Resource s ps h) = do
+        r <- [|Resource|]
+        s' <- lift s
+        ps' <- lift ps
+        h' <- lift h
+        return $ r `AppE` s' `AppE` ps' `AppE` h'
+
+-- | A single resource pattern.
+--
+-- First argument is the name of the constructor, second is the URL pattern to
+-- match, third is how to dispatch.
+data Resource = Resource String [Piece] [String]
+    deriving (Read, Show, Eq, Data, Typeable)
+
+-- | A single piece of a URL, delimited by slashes.
+--
+-- In the case of StaticPiece, the argument is the value of the piece; for the
+-- other constructors, it is the name of the parameter represented by this
+-- piece. That value is not used here, but may be useful elsewhere.
+data Piece = StaticPiece String
+           | SinglePiece String
+           | MultiPiece String
+    deriving (Read, Show, Eq, Data, Typeable)
+
+instance Lift Piece where
+    lift (StaticPiece s) = do
+        c <- [|StaticPiece|]
+        s' <- lift s
+        return $ c `AppE` s'
+    lift (SinglePiece s) = do
+        c <- [|SinglePiece|]
+        s' <- lift s
+        return $ c `AppE` s'
+    lift (MultiPiece s) = do
+        c <- [|MultiPiece|]
+        s' <- lift s
+        return $ c `AppE` s'
+
+-- | Convert a multi-line string to a set of resources. See documentation for
+-- the format of this string. This is a partial function which calls 'error' on
+-- invalid input.
+resourcesFromString :: String -> [Resource]
+resourcesFromString =
+    mapMaybe go . lines
+  where
+    go s =
+        case takeWhile (/= "--") $ words s of
+            (pattern:constr:rest) ->
+                let pieces = piecesFromString $ drop1Slash pattern
+                 in Just $ Resource constr pieces rest
+            [] -> Nothing
+            _ -> error $ "Invalid resource line: " ++ s
+
+drop1Slash :: String -> String
+drop1Slash ('/':x) = x
+drop1Slash x = x
+
+piecesFromString :: String -> [Piece]
+piecesFromString "" = []
+piecesFromString x =
+    let (y, z) = break (== '/') x
+     in pieceFromString y : piecesFromString (drop1Slash z)
+
+pieceFromString :: String -> Piece
+pieceFromString ('#':x) = SinglePiece x
+pieceFromString ('*':x) = MultiPiece x
+pieceFromString x = StaticPiece x
+
+findOverlaps :: [Resource] -> [(Resource, Resource)]
+findOverlaps = gos . map justPieces
+  where
+    justPieces r@(Resource _ ps _) = (ps, r)
+    gos [] = []
+    gos (x:xs) = mapMaybe (go x) xs ++ gos xs
+    go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
+        | x == y = go (xs, xr) (ys, yr)
+        | otherwise = Nothing
+    go (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
+    go (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
+    go ([], xr) ([], yr) = Just (xr, yr)
+    go ([], _) (_, _) = Nothing
+    go (_, _) ([], _) = Nothing
+    go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)

yesod-core/Yesod/Internal/Session.hs

@@ -0,0 +1,55 @@
+module Yesod.Internal.Session
+    ( encodeSession
+    , decodeSession
+    ) where
+
+import qualified Web.ClientSession as CS
+import Data.Serialize
+import Data.Time
+import Data.ByteString (ByteString)
+import Control.Monad (guard)
+import Data.Text (Text, pack, unpack)
+import Control.Arrow ((***))
+
+encodeSession :: CS.Key
+              -> UTCTime -- ^ expire time
+              -> ByteString -- ^ remote host
+              -> [(Text, Text)] -- ^ session
+              -> ByteString -- ^ cookie value
+encodeSession key expire rhost session' =
+    CS.encrypt key $ encode $ SessionCookie expire rhost session'
+
+decodeSession :: CS.Key
+              -> UTCTime -- ^ current time
+              -> ByteString -- ^ remote host field
+              -> ByteString -- ^ cookie value
+              -> Maybe [(Text, Text)]
+decodeSession key now rhost encrypted = do
+    decrypted <- CS.decrypt key encrypted
+    SessionCookie expire rhost' session' <-
+        either (const Nothing) Just $ decode decrypted
+    guard $ expire > now
+    guard $ rhost' == rhost
+    return session'
+
+data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)]
+    deriving (Show, Read)
+instance Serialize SessionCookie where
+    put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c)
+    get = do
+        a <- getTime
+        b <- get
+        c <- map (pack *** pack) `fmap` get
+        return $ SessionCookie a b c
+
+putTime :: Putter UTCTime
+putTime t@(UTCTime d _) = do
+    put $ toModifiedJulianDay d
+    let ndt = diffUTCTime t $ UTCTime d 0
+    put $ toRational ndt
+
+getTime :: Get UTCTime
+getTime = do
+    d <- get
+    ndt <- get
+    return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0

yesod-core/Yesod/Message.hs

@@ -0,0 +1,250 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+module Yesod.Message
+    ( mkMessage
+    , RenderMessage (..)
+    , ToMessage (..)
+    ) where
+
+import Language.Haskell.TH.Syntax
+import Data.Text (Text, pack, unpack)
+import System.Directory
+import Data.Maybe (catMaybes)
+import Data.List (isSuffixOf, sortBy, foldl')
+import qualified Data.ByteString as S
+import Data.Text.Encoding (decodeUtf8)
+import Data.Char (isSpace, toLower, toUpper)
+import Data.Ord (comparing)
+import Text.Shakespeare (Deref (..), Ident (..), parseHash, derefToExp)
+import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))
+import Control.Arrow ((***))
+import Data.Monoid (mempty, mappend)
+
+class ToMessage a where
+    toMessage :: a -> Text
+instance ToMessage Text where
+    toMessage = id
+instance ToMessage String where
+    toMessage = Data.Text.pack
+
+class RenderMessage master message where
+    renderMessage :: master
+                  -> [Text] -- ^ languages
+                  -> message
+                  -> Text
+
+instance RenderMessage master Text where
+    renderMessage _ _ = id
+
+type Lang = Text
+
+mkMessage :: String
+          -> FilePath
+          -> Lang
+          -> Q [Dec]
+mkMessage dt folder lang = do
+    files <- qRunIO $ getDirectoryContents folder
+    contents <- qRunIO $ fmap catMaybes $ mapM (loadLang folder) files
+    sdef <-
+        case lookup lang contents of
+            Nothing -> error $ "Did not find main language file: " ++ unpack lang
+            Just def -> toSDefs def
+    mapM_ (checkDef sdef) $ map snd contents
+    let dt' = ConT $ mkName dt
+    let mname = mkName $ dt ++ "Message"
+    c1 <- fmap concat $ mapM (toClauses dt) contents
+    c2 <- mapM (sToClause dt) sdef
+    c3 <- defClause
+    return
+        [ DataD [] mname [] (map (toCon dt) sdef) []
+        , InstanceD
+            []
+            (ConT ''RenderMessage `AppT` dt' `AppT` ConT mname)
+            [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]
+            ]
+        ]
+
+toClauses :: String -> (Lang, [Def]) -> Q [Clause]
+toClauses dt (lang, defs) =
+    mapM go defs
+  where
+    go def = do
+        a <- newName "lang"
+        (pat, bod) <- mkBody dt (constr def) (map fst $ vars def) (content def)
+        guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]
+        return $ Clause
+            [WildP, ConP (mkName ":") [VarP a, WildP], pat]
+            (GuardedB [(guard, bod)])
+            []
+
+mkBody :: String -- ^ datatype
+       -> String -- ^ constructor
+       -> [String] -- ^ variable names
+       -> [Content]
+       -> Q (Pat, Exp)
+mkBody dt cs vs ct = do
+    vp <- mapM go vs
+    let pat = RecP (mkName $ "Msg" ++ cs) (map (varName dt *** VarP) vp)
+    let ct' = map (fixVars vp) ct
+    pack' <- [|Data.Text.pack|]
+    tomsg <- [|toMessage|]
+    let ct'' = map (toH pack' tomsg) ct'
+    mapp <- [|mappend|]
+    let app a b = InfixE (Just a) mapp (Just b)
+    e <-
+        case ct'' of
+            [] -> [|mempty|]
+            [x] -> return x
+            (x:xs) -> return $ foldl' app x xs
+    return (pat, e)
+  where
+    toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)
+    toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d
+    go x = do
+        let y = mkName $ '_' : x
+        return (x, y)
+    fixVars vp (Var d) = Var $ fixDeref vp d
+    fixVars _ (Raw s) = Raw s
+    fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i
+    fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)
+    fixDeref _ d = d
+    fixIdent vp i =
+        case lookup i vp of
+            Nothing -> i
+            Just y -> nameBase y
+
+sToClause :: String -> SDef -> Q Clause
+sToClause dt sdef = do
+    (pat, bod) <- mkBody dt (sconstr sdef) (map fst $ svars sdef) (scontent sdef)
+    return $ Clause
+        [WildP, ConP (mkName "[]") [], pat]
+        (NormalB bod)
+        []
+
+defClause :: Q Clause
+defClause = do
+    a <- newName "sub"
+    c <- newName "langs"
+    d <- newName "msg"
+    rm <- [|renderMessage|]
+    return $ Clause
+        [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]
+        (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)
+        []
+
+toCon :: String -> SDef -> Con
+toCon dt (SDef c vs _) =
+    RecC (mkName $ "Msg" ++ c) $ map go vs
+  where
+    go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)
+
+varName :: String -> String -> Name
+varName a y =
+    mkName $ concat [lower a, "Message", upper y]
+  where
+    lower (x:xs) = toLower x : xs
+    lower [] = []
+    upper (x:xs) = toUpper x : xs
+    upper [] = []
+
+checkDef :: [SDef] -> [Def] -> Q ()
+checkDef x y =
+    go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)
+  where
+    go _ [] = return ()
+    go [] (b:_) = error $ "Extra message constructor: " ++ constr b
+    go (a:as) (b:bs)
+        | sconstr a < constr b = go as (b:bs)
+        | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b
+        | otherwise = do
+            go' (svars a) (vars b)
+            go as bs
+    go' ((an, at):as) ((bn, mbt):bs)
+        | an /= bn = error "Mismatched variable names"
+        | otherwise =
+            case mbt of
+                Nothing -> go' as bs
+                Just bt
+                    | at == bt -> go' as bs
+                    | otherwise -> error "Mismatched variable types"
+    go' [] [] = return ()
+    go' _ _ = error "Mistmached variable count"
+
+toSDefs :: [Def] -> Q [SDef]
+toSDefs = mapM toSDef
+
+toSDef :: Def -> Q SDef
+toSDef d = do
+    vars' <- mapM go $ vars d
+    return $ SDef (constr d) vars' (content d)
+  where
+    go (a, Just b) = return (a, b)
+    go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)
+
+data SDef = SDef
+    { sconstr :: String
+    , svars :: [(String, String)]
+    , scontent :: [Content]
+    }
+
+data Def = Def
+    { constr :: String
+    , vars :: [(String, Maybe String)]
+    , content :: [Content]
+    }
+
+loadLang :: FilePath -> FilePath -> IO (Maybe (Lang, [Def]))
+loadLang folder file = do
+    let file' = folder ++ '/' : file
+    e <- doesFileExist file'
+    if e && ".msg" `isSuffixOf` file
+        then do
+            let lang = pack $ reverse $ drop 4 $ reverse file
+            bs <- S.readFile file'
+            let s = unpack $ decodeUtf8 bs
+            defs <- fmap catMaybes $ mapM parseDef $ lines s
+            return $ Just (lang, defs)
+        else return Nothing
+
+parseDef :: String -> IO (Maybe Def)
+parseDef "" = return Nothing
+parseDef ('#':_) = return Nothing
+parseDef s =
+    case end of
+        ':':end' -> do
+            content' <- fmap compress $ parseContent $ dropWhile isSpace end'
+            case words begin of
+                [] -> error $ "Missing constructor: " ++ s
+                (w:ws) -> return $ Just Def
+                            { constr = w
+                            , vars = map parseVar ws
+                            , content = content'
+                            }
+        _ -> error $ "Missing colon: " ++ s
+  where
+    (begin, end) = break (== ':') s
+
+data Content = Var Deref | Raw String
+
+compress :: [Content] -> [Content]
+compress [] = []
+compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest
+compress (x:y) = x : compress y
+
+parseContent :: String -> IO [Content]
+parseContent s =
+    either (error . show) return $ parse go s s
+  where
+    go = do
+        x <- many go'
+        eof
+        return x
+    go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)
+
+parseVar :: String -> (String, Maybe String)
+parseVar s =
+    case break (== '@') s of
+        (x, '@':y) -> (x, Just y)
+        _ -> (s, Nothing)

yesod-core/Yesod/Request.hs

@@ -0,0 +1,101 @@
+---------------------------------------------------------
+--
+-- 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 (..)
+      -- * 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.
+--
+-- This is handled by parseWaiRequest (not exposed).
+languages :: Monad mo => GGHandler s m mo [Text]
+languages = reqLangs `liftM` getRequest
+
+lookup' :: Eq a => a -> [(a, b)] -> [b]
+lookup' a = map snd . filter (\x -> a == fst x)
+
+-- | Lookup for GET parameters.
+lookupGetParams :: Monad mo => Text -> GGHandler s m mo [Text]
+lookupGetParams pn = do
+    rr <- getRequest
+    return $ lookup' pn $ reqGetParams rr
+
+-- | Lookup for GET parameters.
+lookupGetParam :: Monad mo => Text -> GGHandler s m mo (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 :: Monad mo => Text -> GGHandler s m mo (Maybe Text)
+lookupCookie = liftM listToMaybe . lookupCookies
+
+-- | Lookup for cookie data.
+lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text]
+lookupCookies pn = do
+    rr <- getRequest
+    return $ lookup' pn $ reqCookies rr

yesod-core/Yesod/Widget.hs

@@ -0,0 +1,267 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier
+-- generator, allowing you to create truly modular HTML components.
+module Yesod.Widget
+    ( -- * Datatype
+      GWidget
+    , GGWidget (..)
+    , PageContent (..)
+      -- * Special Hamlet quasiquoter/TH for Widgets
+    , whamlet
+    , whamletFile
+    , ihamletToRepHtml
+      -- * Creating
+      -- ** Head of page
+    , setTitle
+    , setTitleI
+    , addHamletHead
+    , addHtmlHead
+      -- ** Body
+    , addHamlet
+    , addHtml
+    , addWidget
+    , addSubWidget
+      -- ** CSS
+    , addCassius
+    , addCassiusMedia
+    , addLucius
+    , addLuciusMedia
+    , addStylesheet
+    , addStylesheetAttrs
+    , addStylesheetRemote
+    , addStylesheetRemoteAttrs
+    , addStylesheetEither
+      -- ** Javascript
+    , addJulius
+    , addJuliusBody
+    , addCoffee
+    , addCoffeeBody
+    , addScript
+    , addScriptAttrs
+    , addScriptRemote
+    , addScriptRemoteAttrs
+    , addScriptEither
+      -- * Utilities
+    , extractBody
+    ) where
+
+import Data.Monoid
+import Control.Monad.Trans.RWS
+import qualified Text.Blaze.Html5 as H
+import Text.Hamlet
+import Text.Cassius
+import Text.Lucius (Lucius)
+import Text.Julius
+import Text.Coffee
+import Yesod.Handler
+    (Route, GHandler, GGHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
+    , getMessageRender, getUrlRenderParams
+    )
+import Yesod.Message (RenderMessage)
+import Yesod.Content (RepHtml (..), toContent)
+import Control.Applicative (Applicative)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Class (MonadTrans (lift))
+import Yesod.Internal
+import Control.Monad (liftM)
+import Data.Text (Text)
+import qualified Data.Map as Map
+import Language.Haskell.TH.Quote (QuasiQuoter)
+import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE), Pat (VarP), newName)
+
+import Control.Monad.IO.Control (MonadControlIO)
+import qualified Text.Hamlet as NP
+import Data.Text.Lazy.Builder (fromLazyText)
+import Text.Blaze (toHtml, preEscapedLazyText)
+
+-- | A generic widget, allowing specification of both the subsite and master
+-- site datatypes. This is basically a large 'WriterT' stack keeping track of
+-- dependencies along with a 'StateT' to track unique identifiers.
+newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a }
+    deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO)
+
+instance MonadTrans (GGWidget m) where
+    lift = GWidget . lift
+
+type GWidget s m = GGWidget m (GHandler s m)
+type GWInner master = RWST () (GWData (Route master)) Int
+
+instance (Monad monad, a ~ ()) => Monoid (GGWidget master monad 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
+    s <- GWidget get
+    (a, s', w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ runRWST w () s
+    GWidget $ put s'
+    GWidget $ tell w'
+    return a
+
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- set values.
+setTitle :: Monad m => Html -> GGWidget master m ()
+setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
+
+-- | Set the page title. Calling 'setTitle' multiple times overrides previously
+-- set values.
+setTitleI :: (RenderMessage master msg, Monad m) => msg -> GGWidget master (GGHandler sub master m) ()
+setTitleI msg = do
+    mr <- lift getMessageRender
+    setTitle $ toHtml $ mr msg
+
+-- | Add a 'Hamlet' to the head tag.
+addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget master m ()
+addHamletHead = GWidget . tell . GWData mempty mempty mempty mempty mempty mempty . Head
+
+-- | Add a 'Html' to the head tag.
+addHtmlHead :: Monad m => Html -> GGWidget master m ()
+addHtmlHead = addHamletHead . const
+
+-- | Add a 'Hamlet' to the body tag.
+addHamlet :: Monad m => Hamlet (Route master) -> GGWidget master m ()
+addHamlet x = GWidget $ tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
+
+-- | Add a 'Html' to the body tag.
+addHtml :: Monad m => Html -> GGWidget master m ()
+addHtml = addHamlet . const
+
+-- | Add another widget. This is defined as 'id', by can help with types, and
+-- makes widget blocks look more consistent.
+addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo ()
+addWidget = id
+
+-- | Add some raw CSS to the style tag. Applies to all media types.
+addCassius :: Monad m => Cassius (Route master) -> GGWidget master m ()
+addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing x) mempty mempty
+
+-- | Identical to 'addCassius'.
+addLucius :: Monad m => Lucius (Route master) -> GGWidget master m ()
+addLucius = addCassius
+
+-- | Add some raw CSS to the style tag, for a specific media type.
+addCassiusMedia :: Monad m => Text -> Cassius (Route master) -> GGWidget master m ()
+addCassiusMedia m x = GWidget $ tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) x) mempty mempty
+
+-- | Identical to 'addCassiusMedia'.
+addLuciusMedia :: Monad m => Text -> Lucius (Route master) -> GGWidget master m ()
+addLuciusMedia = addCassiusMedia
+
+-- | Link to the specified local stylesheet.
+addStylesheet :: Monad m => Route master -> GGWidget master m ()
+addStylesheet = flip addStylesheetAttrs []
+
+-- | Link to the specified local stylesheet.
+addStylesheetAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
+addStylesheetAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
+
+-- | Link to the specified remote stylesheet.
+addStylesheetRemote :: Monad m => Text -> GGWidget master m ()
+addStylesheetRemote = flip addStylesheetRemoteAttrs []
+
+-- | Link to the specified remote stylesheet.
+addStylesheetRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
+addStylesheetRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
+
+addStylesheetEither :: Monad m => Either (Route master) Text -> GGWidget master m ()
+addStylesheetEither = either addStylesheet addStylesheetRemote
+
+addScriptEither :: Monad m => Either (Route master) Text -> GGWidget master m ()
+addScriptEither = either addScript addScriptRemote
+
+-- | Link to the specified local script.
+addScript :: Monad m => Route master -> GGWidget master m ()
+addScript = flip addScriptAttrs []
+
+-- | Link to the specified local script.
+addScriptAttrs :: Monad m => Route master -> [(Text, Text)] -> GGWidget master m ()
+addScriptAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
+
+-- | Link to the specified remote script.
+addScriptRemote :: Monad m => Text -> GGWidget master m ()
+addScriptRemote = flip addScriptRemoteAttrs []
+
+-- | Link to the specified remote script.
+addScriptRemoteAttrs :: Monad m => Text -> [(Text, Text)] -> GGWidget master m ()
+addScriptRemoteAttrs x y = GWidget $ tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
+
+-- | Include raw Javascript in the page's script tag.
+addJulius :: Monad m => Julius (Route master) -> GGWidget master m ()
+addJulius x = GWidget $ tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
+
+-- | Add a new script tag to the body with the contents of this 'Julius'
+-- template.
+addJuliusBody :: Monad m => Julius (Route master) -> GGWidget master m ()
+addJuliusBody j = addHamlet $ \r -> H.script $ preEscapedLazyText $ renderJulius r j
+
+-- | Add Coffesscript to the page's script tag. Requires the coffeescript
+-- executable to be present at runtime.
+addCoffee :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
+addCoffee c = do
+    render <- lift getUrlRenderParams
+    t <- liftIO $ renderCoffee render c
+    addJulius $ const $ Javascript $ fromLazyText t
+
+-- | Add a new script tag to the body with the contents of this Coffesscript
+-- template. Requires the coffeescript executable to be present at runtime.
+addCoffeeBody :: MonadIO m => Coffee (Route master) -> GGWidget master (GGHandler sub master m) ()
+addCoffeeBody c = do
+    render <- lift getUrlRenderParams
+    t <- liftIO $ renderCoffee render c
+    addJuliusBody $ const $ Javascript $ fromLazyText t
+
+-- | Pull out the HTML tag contents and return it. Useful for performing some
+-- manipulations. It can be easier to use this sometimes than 'wrapWidget'.
+extractBody :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m))
+extractBody (GWidget w) =
+    GWidget $ mapRWST (liftM go) w
+  where
+    go ((), s, GWData (Body h) b c d e f g) = (h, s, GWData (Body mempty) b c d e f g)
+
+-- | Content for a web page. By providing this datatype, we can easily create
+-- generic site templates, which would have the type signature:
+--
+-- > PageContent url -> Hamlet url
+data PageContent url = PageContent
+    { pageTitle :: Html
+    , pageHead :: Hamlet url
+    , pageBody :: Hamlet url
+    }
+
+whamlet :: QuasiQuoter
+whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings
+
+whamletFile :: FilePath -> Q Exp
+whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings
+
+rules :: Q NP.HamletRules
+rules = do
+    ah <- [|addHtml|]
+    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 [|lift getUrlRenderParams|])
+                    (Just $ helper [|liftM (toHtml .) $ lift getMessageRender|])
+            f env
+    return $ NP.HamletRules ah ur $ \_ b -> return b
+
+-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
+ihamletToRepHtml :: (Monad mo, RenderMessage master message)
+                 => NP.IHamlet message (Route master)
+                 -> GGHandler sub master mo RepHtml
+ihamletToRepHtml ih = do
+    urender <- getUrlRenderParams
+    mrender <- getMessageRender
+    return $ RepHtml $ toContent $ ih (toHtml . mrender) urender

yesod-core/helloworld.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Yesod.Core
+import Network.Wai.Handler.Warp (run)
+import Data.Text (unpack)
+
+data Subsite = Subsite String
+
+mkYesodSub "Subsite" [] [$parseRoutes|
+/ SubRootR GET
+/multi/*Strings SubMultiR
+|]
+
+getSubRootR :: Yesod m => GHandler Subsite m RepPlain
+getSubRootR = do
+    Subsite s <- getYesodSub
+    tm <- getRouteToMaster
+    render <- getUrlRender
+    $(logDebug) "I'm in SubRootR"
+    return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR))
+
+handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain
+handleSubMultiR x = do
+    Subsite y <- getYesodSub
+    $(logInfo) "In SubMultiR"
+    return . RepPlain . toContent . show $ (x, y)
+
+data HelloWorld = HelloWorld { getSubsite :: String -> Subsite }
+mkYesod "HelloWorld" [$parseRoutes|
+/ RootR GET
+/subsite/#String SubsiteR Subsite getSubsite
+|]
+instance Yesod HelloWorld where approot _ = ""
+-- getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig
+getRootR = do
+    $(logOther "HAHAHA") "Here I am"
+    return $ RepPlain "Hello World"
+main = toWaiApp (HelloWorld Subsite) >>= run 3000

yesod-core/runtests.hs

@@ -0,0 +1,17 @@
+import Test.Framework (defaultMain)
+import Test.CleanPath
+import Test.Exceptions
+import Test.Widget
+import Test.Media
+import Test.Links
+import Test.NoOverloadedStrings
+
+main :: IO ()
+main = defaultMain
+    [ cleanPathTest
+    , exceptionsTest
+    , widgetTest
+    , mediaTest
+    , linksTest
+    , noOverloadedTest
+    ]

yesod-core/static/script.js

@@ -0,0 +1,3 @@
+$(function(){
+    $("p.noscript").hide();
+});

yesod-core/static/style.css

@@ -0,0 +1,12 @@
+body {
+    font-family: sans-serif;
+    background: #eee;
+}
+
+#wrapper {
+    width: 760px;
+    margin: 1em auto;
+    border: 2px solid #000;
+    padding: 0.5em;
+    background: #fff;
+}

yesod-core/static/style2.css

@@ -0,0 +1,3 @@
+body {
+    font-family: sans-serif;
+}

yesod-core/test/en.msg

@@ -0,0 +1 @@
+Another: String

yesod-core/widget-benchmark.hs

@@ -0,0 +1,79 @@
+-- | BigTable benchmark implemented using Hamlet.
+--
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+import Criterion.Main
+import Text.Hamlet
+import Numeric (showInt)
+import qualified Data.ByteString.Lazy as L
+import qualified Text.Blaze.Renderer.Utf8 as Utf8
+import Data.Monoid (mconcat)
+import Text.Blaze.Html5 (table, tr, td)
+import Yesod.Widget
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.RWS
+import Data.Functor.Identity
+import Yesod.Internal
+
+main = defaultMain
+    [ bench "bigTable html" $ nf bigTableHtml bigTableData
+    , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
+    , bench "bigTable widget" $ nf bigTableWidget bigTableData
+    , bench "bigTable blaze" $ nf bigTableBlaze bigTableData
+    ]
+  where
+    rows :: Int
+    rows = 1000
+
+    bigTableData :: [[Int]]
+    bigTableData = replicate rows [1..10]
+    {-# NOINLINE bigTableData #-}
+
+bigTableHtml rows = L.length $ renderHtml [$hamlet|
+<table
+    $forall row <- rows
+        <tr
+            $forall cell <- row
+                <td>#{show cell}
+|]
+
+bigTableHamlet rows = L.length $ renderHamlet id [$hamlet|
+<table
+    $forall row <- rows
+        <tr
+            $forall cell <- row
+                <td>#{show cell}
+|]
+
+bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet|
+<table
+    $forall row <- rows
+        <tr
+            $forall cell <- row
+                <td>#{show cell}
+|]) (\_ _ -> "foo")
+  where
+  run (GWidget w) =
+    let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0
+     in x
+  {-
+  run (GWidget w) = runIdentity $ do
+    w' <- flip evalStateT 0
+        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
+        $ runWriterT $ runWriterT $ runWriterT w
+    let ((((((((),
+         Body body),
+         _),
+         _),
+         _),
+         _),
+         _),
+         _) = w'
+
+    return body
+    -}
+
+bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t
+  where
+    row r = tr $ mconcat $ map (td . string . show) r

yesod-core/yesod-core.cabal

@@ -0,0 +1,94 @@
+name:            yesod-core
+version:         0.9.0
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        Creation of type-safe, RESTful web applications.
+description:
+    Yesod is a framework designed to foster creation of RESTful web application that have strong compile-time guarantees of correctness. It also affords space efficient code and portability to many deployment backends, from CGI to stand-alone serving.
+    .
+    The Yesod documentation site <http://www.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and Persistent.
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+
+flag test
+  description: Build the executable to run unit tests
+  default: False
+
+flag ghc7
+
+library
+    if flag(ghc7)
+        build-depends:   base                      >= 4.3      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                      >= 4        && < 4.3
+    build-depends:   time                      >= 1.1.4    && < 1.3
+                   , wai                       >= 0.4      && < 0.5
+                   , wai-extra                 >= 0.4      && < 0.5
+                   , bytestring                >= 0.9.1.4  && < 0.10
+                   , text                      >= 0.5      && < 0.12
+                   , template-haskell
+                   , path-pieces               >= 0.0      && < 0.1
+                   , hamlet                    >= 0.9      && < 0.10
+                   , blaze-builder             >= 0.2.1    && < 0.4
+                   , transformers              >= 0.2      && < 0.3
+                   , clientsession             >= 0.6      && < 0.7
+                   , random                    >= 1.0.0.2  && < 1.1
+                   , cereal                    >= 0.2      && < 0.4
+                   , old-locale                >= 1.0.0.2  && < 1.1
+                   , failure                   >= 0.1      && < 0.2
+                   , containers                >= 0.2      && < 0.5
+                   , monad-control             >= 0.2      && < 0.3
+                   , enumerator                >= 0.4.7    && < 0.5
+                   , cookie                    >= 0.3      && < 0.4
+                   , blaze-html                >= 0.4      && < 0.5
+                   , http-types                >= 0.6      && < 0.7
+                   , case-insensitive          >= 0.2      && < 0.4
+                   , parsec                    >= 2        && < 3.2
+                   , directory                 >= 1        && < 1.2
+    exposed-modules: Yesod.Content
+                     Yesod.Core
+                     Yesod.Dispatch
+                     Yesod.Handler
+                     Yesod.Request
+                     Yesod.Widget
+                     Yesod.Message
+    other-modules:   Yesod.Internal
+                     Yesod.Internal.Core
+                     Yesod.Internal.Session
+                     Yesod.Internal.Request
+                     Yesod.Internal.Dispatch
+                     Yesod.Internal.RouteParsing
+                     Paths_yesod_core
+    ghc-options:     -Wall
+    if flag(test)
+        Buildable: False
+
+executable             runtests
+    if flag(ghc7)
+        build-depends:   base                      >= 4.3      && < 5
+        cpp-options:     -DGHC7
+    else
+        build-depends:   base                      >= 4        && < 4.3
+    if flag(test)
+        Buildable: True
+        cpp-options:   -DTEST
+        build-depends: test-framework,
+                       test-framework-quickcheck2,
+                       test-framework-hunit,
+                       HUnit,
+                       wai-test,
+                       QuickCheck >= 2 && < 3
+    else
+        Buildable: False
+    ghc-options:     -Wall
+    main-is:         runtests.hs
+
+source-repository head
+  type:     git
+  location: git://github.com/snoyberg/yesod-core.git