diff --git a/yesod-core/.gitignore b/yesod-core/.gitignore
new file mode 100644
index 00000000..08e46243
--- /dev/null
+++ b/yesod-core/.gitignore
@@ -0,0 +1,7 @@
+/dist/
+*.swp
+client_session_key.aes
+*.hi
+*.o
+blog.db3
+static/tmp/
diff --git a/yesod-core/LICENSE b/yesod-core/LICENSE
new file mode 100644
index 00000000..8643e5d8
--- /dev/null
+++ b/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.
diff --git a/yesod-core/README b/yesod-core/README
new file mode 100644
index 00000000..987fd1b3
--- /dev/null
+++ b/yesod-core/README
@@ -0,0 +1 @@
+Learn more at http://docs.yesodweb.com/
diff --git a/yesod-core/Setup.lhs b/yesod-core/Setup.lhs
new file mode 100755
index 00000000..06e2708f
--- /dev/null
+++ b/yesod-core/Setup.lhs
@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
diff --git a/yesod-core/Test/CleanPath.hs b/yesod-core/Test/CleanPath.hs
new file mode 100644
index 00000000..9c7306cf
--- /dev/null
+++ b/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
diff --git a/yesod-core/Test/Exceptions.hs b/yesod-core/Test/Exceptions.hs
new file mode 100644
index 00000000..e64900a8
--- /dev/null
+++ b/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
diff --git a/yesod-core/Test/Links.hs b/yesod-core/Test/Links.hs
new file mode 100644
index 00000000..a060eadc
--- /dev/null
+++ b/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||]
+
+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 "\n" res
diff --git a/yesod-core/Test/Media.hs b/yesod-core/Test/Media.hs
new file mode 100644
index 00000000..75d8c447
--- /dev/null
+++ b/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 "\n"
+
+caseMediaLink = runner $ do
+ res <- request defaultRequest { pathInfo = ["static"] }
+ assertStatus 200 res
+ flip assertBody res "\n"
+
+mediaTest = testGroup "Test.Media"
+ [ testCase "media" caseMedia
+ , testCase "media link" caseMediaLink
+ ]
diff --git a/yesod-core/Test/NoOverloadedStrings.hs b/yesod-core/Test/NoOverloadedStrings.hs
new file mode 100644
index 00000000..dfd83120
--- /dev/null
+++ b/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
+ ]
diff --git a/yesod-core/Test/Widget.hs b/yesod-core/Test/Widget.hs
new file mode 100644
index 00000000..4cd92a5c
--- /dev/null
+++ b/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||]
+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|
+Test
+@{WhamletR}
+_{Goodbye}
+_{MsgAnother}
+^{embed}
+|]
+ where
+ embed = [$whamlet|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 "\n" res
+
+case_whamlet = runner $ do
+ res <- request defaultRequest
+ { pathInfo = ["whamlet"]
+ , requestHeaders = [("Accept-Language", "es")]
+ }
+ assertBody "\nTest
http://test/whamlet
Adios
String
Embed
" res
diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs
new file mode 100644
index 00000000..6244474c
--- /dev/null
+++ b/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"
diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs
new file mode 100644
index 00000000..67ed22e0
--- /dev/null
+++ b/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
diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs
new file mode 100644
index 00000000..de219d05
--- /dev/null
+++ b/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
diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs
new file mode 100644
index 00000000..34cfcc51
--- /dev/null
+++ b/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
+-- 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
+\
+
+
+
+ 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
diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs
new file mode 100644
index 00000000..5fba8c79
--- /dev/null
+++ b/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)
diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs
new file mode 100644
index 00000000..67de5592
--- /dev/null
+++ b/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
diff --git a/yesod-core/Yesod/Internal/Dispatch.hs b/yesod-core/Yesod/Internal/Dispatch.hs
new file mode 100644
index 00000000..5be1fc0e
--- /dev/null
+++ b/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
diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs
new file mode 100644
index 00000000..d9ec7d74
--- /dev/null
+++ b/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)
diff --git a/yesod-core/Yesod/Internal/RouteParsing.hs b/yesod-core/Yesod/Internal/RouteParsing.hs
new file mode 100644
index 00000000..82489351
--- /dev/null
+++ b/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)
diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs
new file mode 100644
index 00000000..7e840136
--- /dev/null
+++ b/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
diff --git a/yesod-core/Yesod/Message.hs b/yesod-core/Yesod/Message.hs
new file mode 100644
index 00000000..db6fd023
--- /dev/null
+++ b/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)
diff --git a/yesod-core/Yesod/Request.hs b/yesod-core/Yesod/Request.hs
new file mode 100644
index 00000000..3d42e3cb
--- /dev/null
+++ b/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
diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs
new file mode 100644
index 00000000..6bc4490c
--- /dev/null
+++ b/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
diff --git a/yesod-core/helloworld.hs b/yesod-core/helloworld.hs
new file mode 100644
index 00000000..7c974a30
--- /dev/null
+++ b/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
diff --git a/yesod-core/runtests.hs b/yesod-core/runtests.hs
new file mode 100644
index 00000000..0dfb7564
--- /dev/null
+++ b/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
+ ]
diff --git a/yesod-core/static/script.js b/yesod-core/static/script.js
new file mode 100644
index 00000000..43c21a53
--- /dev/null
+++ b/yesod-core/static/script.js
@@ -0,0 +1,3 @@
+$(function(){
+ $("p.noscript").hide();
+});
diff --git a/yesod-core/static/style.css b/yesod-core/static/style.css
new file mode 100644
index 00000000..d09c6b08
--- /dev/null
+++ b/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;
+}
diff --git a/yesod-core/static/style2.css b/yesod-core/static/style2.css
new file mode 100644
index 00000000..853ac29a
--- /dev/null
+++ b/yesod-core/static/style2.css
@@ -0,0 +1,3 @@
+body {
+ font-family: sans-serif;
+}
diff --git a/yesod-core/test/en.msg b/yesod-core/test/en.msg
new file mode 100644
index 00000000..68584a13
--- /dev/null
+++ b/yesod-core/test/en.msg
@@ -0,0 +1 @@
+Another: String
diff --git a/yesod-core/widget-benchmark.hs b/yesod-core/widget-benchmark.hs
new file mode 100644
index 00000000..9be4acd8
--- /dev/null
+++ b/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
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
new file mode 100644
index 00000000..35794f2f
--- /dev/null
+++ b/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