yesod-core (empty) → 0.7.0
raw patch · 14 files changed
+2757/−0 lines, 14 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, blaze-builder, blaze-html, bytestring, cereal, clientsession, containers, cookie, enumerator, failure, hamlet, monad-peel, old-locale, random, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, wai, wai-extra, web-routes, web-routes-quasi
Files
- LICENSE +25/−0
- Setup.lhs +7/−0
- Yesod/Content.hs +232/−0
- Yesod/Core.hs +539/−0
- Yesod/Dispatch.hs +234/−0
- Yesod/Handler.hs +800/−0
- Yesod/Internal.hs +122/−0
- Yesod/Internal/Dispatch.hs +251/−0
- Yesod/Internal/Request.hs +55/−0
- Yesod/Internal/Session.hs +53/−0
- Yesod/Request.hs +151/−0
- Yesod/Widget.hs +191/−0
- runtests.hs +12/−0
- yesod-core.cabal +85/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ Yesod/Content.hs view
@@ -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.Char8 as S8+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))++data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.+ | ContentEnum (forall a. Enumerator Builder IO a)+ | ContentFile FilePath++-- | 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++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 :: B.ByteString -> B.ByteString+simpleContentType = S8.takeWhile (/= ';')++-- | Format a 'UTCTime' in W3 format.+formatW3 :: UTCTime -> String+formatW3 = formatTime defaultTimeLocale "%FT%X-00:00"++-- | Format as per RFC 1123.+formatRFC1123 :: UTCTime -> String+formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"++-- | Format as per RFC 822.+formatRFC822 :: UTCTime -> String+formatRFC822 = formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
+ Yesod/Core.hs view
@@ -0,0 +1,539 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+-- | The basic typeclass for a Yesod application.+module Yesod.Core+ ( -- * Type classes+ Yesod (..)+ , YesodDispatch (..)+ , RenderRoute (..)+ -- ** Breadcrumbs+ , YesodBreadcrumbs (..)+ , breadcrumbs+ -- * Utitlities+ , maybeAuthorized+ , widgetToPageContent+ -- * Defaults+ , defaultErrorHandler+ -- * Data types+ , AuthResult (..)+ -- * Misc+ , yesodVersion+ , yesodRender+#if TEST+ , coreTestSuite+#endif+ ) where++import Yesod.Content+import Yesod.Handler++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 as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.Monoid+import Control.Monad.Trans.Writer+import Control.Monad.Trans.State hiding (get, put)+import Text.Hamlet+import Text.Cassius+import Text.Julius+import Web.Routes+import Text.Blaze (preEscapedLazyText)+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Maybe (fromMaybe)+import Control.Monad.IO.Class (liftIO)+import Web.Cookie (parseCookies)+import qualified Data.Map as Map+import Data.Time++#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit hiding (Test)+import qualified Data.Text+import qualified Data.Text.Encoding+#endif++#if GHC7+#define HAMLET hamlet+#else+#define HAMLET $hamlet+#endif++class Eq u => RenderRoute u where+ renderRoute :: u -> ([String], [(String, String)])++-- | 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+ -> [String]+ -> 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 -> String++ -- | 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 String+ 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 $ not $ W.requestMethod wai `elem`+ ["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 -> [String] -> Either [String] [String]+ cleanPath _ s =+ if corrected == s+ then Right s+ else Left corrected+ where+ corrected = filter (not . null) s++ -- | Join the pieces of a path together into an absolute URL. This should+ -- be the inverse of 'splitPath'.+ joinPath :: a+ -> String -- ^ application root+ -> [String] -- ^ path pieces+ -> [(String, String)] -- ^ query string+ -> String+ joinPath _ ar pieces qs = ar ++ '/' : encodePathInfo pieces qs++ -- | 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 :: String -- ^ filename extension+ -> String -- ^ mime-type+ -> L.ByteString -- ^ content+ -> GHandler sub a (Maybe (Either String (Route a, [(String, String)])))+ addStaticContent _ _ _ = return Nothing++ -- | Whether or not to tie a session to a specific IP address. Defaults to+ -- 'True'.+ sessionIpAddress :: a -> Bool+ sessionIpAddress _ = True++defaultYesodRunner :: Yesod master+ => a+ -> master+ -> (Route a -> Route master)+ -> Maybe CS.Key+ -> Maybe (Route a)+ -> GHandler a master ChooseRep+ -> W.Application+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+ _ -> S.empty+ hs' =+ case mkey of+ Nothing -> hs+ Just _ -> AddCookie+ (clientSessionDuration master)+ sessionName+ sessionVal+ : hs+ hs'' = map (headerToPair getExpires) hs'+ hs''' = ("Content-Type", ct) : hs''++data AuthResult = Authorized | AuthenticationRequired | Unauthorized String+ 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 (String, 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 (String, [(Route y, String)])+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' = bsToChars $ W.pathInfo 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 "#{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+ w' <- flip evalStateT 0+ $ runWriterT $ runWriterT $ runWriterT $ runWriterT+ $ runWriterT $ runWriterT $ runWriterT w+ let ((((((((),+ Body body),+ Last mTitle),+ scripts'),+ stylesheets'),+ style),+ jscript),+ Head head') = w'+ let title = maybe mempty unTitle mTitle+ let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'+ let stylesheets = map (locationToHamlet . unStylesheet)+ $ runUniqueList stylesheets'+ let cssToHtml = preEscapedLazyText . renderCss+ celper :: Cassius url -> Hamlet url+ celper = fmap cssToHtml+ 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+ cssLoc <-+ case style of+ Nothing -> return Nothing+ Just s -> do+ x <- addStaticContent "css" "text/css; charset=utf-8"+ $ encodeUtf8 $ renderCassius render s+ return $ renderLoc x+ 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 head'' =+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+$forall s <- scripts+ <script src="^{s}">+$forall s <- stylesheets+ <link rel="stylesheet" href="^{s}">+$maybe s <- style+ $maybe s <- cssLoc+ <link rel="stylesheet" href="#{s}">+ $nothing+ <style>^{celper 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+ -> [(String, String)]+ -> String+yesodRender y u qs =+ fromMaybe+ (joinPath y (approot y) ps $ qs ++ qs')+ (urlRenderOverride y u)+ where+ (ps, qs') = renderRoute u++#if TEST+coreTestSuite :: Test+coreTestSuite = testGroup "Yesod.Yesod"+ [ testProperty "join/split path" propJoinSplitPath+ , testCase "join/split path [\".\"]" caseJoinSplitPathDquote+ , testCase "utf8 split path" caseUtf8SplitPath+ , testCase "utf8 join path" caseUtf8JoinPath+ ]++data TmpYesod = TmpYesod+data TmpRoute = TmpRoute deriving Eq+type instance Route TmpYesod = TmpRoute+instance Yesod TmpYesod where approot _ = ""++fromString :: String -> S8.ByteString+fromString = Data.Text.Encoding.encodeUtf8 . Data.Text.pack++propJoinSplitPath :: [String] -> Bool+propJoinSplitPath ss =+ splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' [])+ == Right ss'+ where+ ss' = filter (not . null) ss++caseJoinSplitPathDquote :: Assertion+caseJoinSplitPathDquote = do+ splitPath TmpYesod (fromString "/x%2E/") @?= Right ["x."]+ splitPath TmpYesod (fromString "/y./") @?= Right ["y."]+ joinPath TmpYesod "" ["z."] [] @?= "/z./"+ x @?= Right ss+ where+ x = splitPath TmpYesod (fromString $ joinPath TmpYesod "" ss' [])+ ss' = filter (not . null) ss+ ss = ["a."]++caseUtf8SplitPath :: Assertion+caseUtf8SplitPath = do+ Right ["שלום"] @=?+ splitPath TmpYesod (fromString "/שלום/")+ Right ["page", "Fooé"] @=?+ splitPath TmpYesod (fromString "/page/Fooé/")+ Right ["\156"] @=?+ splitPath TmpYesod (fromString "/\156/")+ Right ["ð"] @=?+ splitPath TmpYesod (fromString "/%C3%B0/")++caseUtf8JoinPath :: Assertion+caseUtf8JoinPath = do+ "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []+#endif
+ Yesod/Dispatch.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Dispatch+ ( -- * Quasi-quoted routing+ parseRoutes+ , mkYesod+ , mkYesodSub+ -- ** More fine-grained+ , mkYesodData+ , mkYesodSubData+ , mkYesodDispatch+ , mkYesodSubDispatch+ -- ** Path pieces+ , SinglePiece (..)+ , MultiPiece (..)+ , Strings+ -- * Convert to WAI+ , toWaiApp+ , toWaiAppPlain+#if TEST+ , dispatchTestSuite+#endif+ ) where++import Prelude hiding (exp)+import Yesod.Core+import Yesod.Handler+import Yesod.Internal.Dispatch++import Web.Routes.Quasi+import Web.Routes.Quasi.Parse+import Web.Routes.Quasi.TH+import Language.Haskell.TH.Syntax++import qualified Network.Wai as W+import Network.Wai.Middleware.Jsonp+import Network.Wai.Middleware.Gzip++import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString as S+import Data.ByteString.Lazy.Char8 ()++import Web.ClientSession+import Data.Char (isUpper)++import Web.Routes (decodePathInfo)++#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck+import System.IO.Unsafe+#endif++-- | 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+ ]++ yd <- mkYesodDispatch' th'+ 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 = do+ a <- toWaiAppPlain y+ return $ gzip False+ $ jsonp+ a++-- | 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 = do+ key' <- encryptKey a+ return $ toWaiApp' a key'++toWaiApp' :: (Yesod y, YesodDispatch y y)+ => y+ -> Maybe Key+ -> W.Application+toWaiApp' y key' env = do+ let segments =+ case decodePathInfo $ B.unpack $ W.pathInfo env of+ "":x -> x+ x -> x+ case yesodDispatch y key' segments y id of+ Just app -> app env+ Nothing ->+ case cleanPath y segments of+ Right segments' ->+ case yesodDispatch y key' segments' y id of+ Just app -> app env+ Nothing -> yesodRunner y y id key' Nothing notFound env+ Left segments' ->+ let dest = joinPath y (approot y) segments' []+ dest' =+ if S.null (W.queryString env)+ then dest+ else dest ++ '?' : B.unpack (W.queryString env)+ in return $ W.responseLBS W.status301+ [ ("Content-Type", "text/plain")+ , ("Location", B.pack $ dest')+ ] "Redirecting"++#if TEST++dispatchTestSuite :: Test+dispatchTestSuite = testGroup "Yesod.Dispatch"+ [ testProperty "encode/decode session" propEncDecSession+ , testProperty "get/put time" propGetPutTime+ ]++propEncDecSession :: [(String, String)] -> Bool+propEncDecSession session' = unsafePerformIO $ do+ key <- getDefaultKey+ now <- getCurrentTime+ let expire = addUTCTime 1 now+ let rhost = B.pack "some host"+ let val = encodeSession key expire rhost session'+ return $ Just session' == decodeSession key now rhost val++propGetPutTime :: UTCTime -> Bool+propGetPutTime t = Right t == runGet getTime (runPut $ putTime t)++instance Arbitrary UTCTime where+ arbitrary = do+ a <- arbitrary+ b <- arbitrary+ return $ addUTCTime (fromRational b)+ $ UTCTime (ModifiedJulianDay a) 0++#endif
+ Yesod/Handler.hs view
@@ -0,0 +1,800 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+---------------------------------------------------------+--+-- Module : Yesod.Handler+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : unstable+-- Portability : portable+--+-- Define Handler stuff.+--+---------------------------------------------------------+module Yesod.Handler+ ( -- * Type families+ Route+ , YesodSubRoute (..)+ -- * Handler monad+ , GHandler+ , GGHandler+ -- ** Read information from handler+ , getYesod+ , getYesodSub+ , getUrlRender+ , getUrlRenderParams+ , getCurrentRoute+ , getRouteToMaster+ -- * Special responses+ -- ** Redirecting+ , RedirectType (..)+ , redirect+ , redirectParams+ , redirectString+ , redirectToPost+ -- ** Errors+ , notFound+ , badMethod+ , permissionDenied+ , invalidArgs+ -- ** Short-circuit responses.+ , sendFile+ , 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+ , setUltDest'+ , redirectUltDest+ -- ** Messages+ , setMessage+ , getMessage+ -- * Helpers for specific content+ -- ** Hamlet+ , hamletToContent+ , hamletToRepHtml+ -- ** Misc+ , newIdent+ , liftIOHandler+ -- * Internal Yesod+ , runHandler+ , YesodApp (..)+ , runSubsiteGetter+ , toMasterHandler+ , toMasterHandlerDyn+ , toMasterHandlerMaybe+ , localNoCurrent+ , HandlerData+ , ErrorResponse (..)+ , YesodAppResult (..)+ , handlerToYAR+ , yarToResponse+ , headerToPair+#if TEST+ , handlerTestSuite+#endif+ ) where++import Prelude hiding (catch)+import Yesod.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)++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 Control.Failure (Failure (failure))++import Text.Hamlet++import Control.Monad.IO.Peel (MonadPeelIO)+import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)+import qualified Data.Map as Map+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.ByteString (ByteString)+import Data.Enumerator (Iteratee (..))+import Network.Wai.Parse (parseHttpAccept)++#if TEST+import Test.Framework (testGroup, Test)+#endif++import Yesod.Content+import Data.Maybe (fromMaybe)+import Web.Cookie (SetCookie (..), renderSetCookie)+import Blaze.ByteString.Builder (toByteString)+import Data.Enumerator (run_, ($$))+import Control.Arrow (second, (***))+import qualified Network.Wai.Parse as NWP++-- | 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 -> [(String, String)] -> String)+ , 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 = do+ y <- getYesod+ return $ getter y++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, MonadPeelIO)++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 =+ ReaderT (HandlerData s m) (+ ErrorT HandlerContents (+ WriterT (Endo [Header]) (+ StateT GHState (+ monad+ ))))++type SessionMap = Map.Map String String++type Endo a = a -> a++-- | 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 W.Status [Header] ContentType Content SessionMap++data HandlerContents =+ HCContent W.Status ChooseRep+ | HCError ErrorResponse+ | HCSendFile ContentType FilePath+ | HCRedirect RedirectType ByteString+ | HCCreated ByteString+ | HCWai W.Response++instance Error HandlerContents where+ strMsg = HCError . InternalError++instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where+ failure = GHandler . lift . throwError . HCError+instance RequestReader (GHandler sub master) where -- FIXME kill this typeclass, does not work for GGHandler+ getRequest = handlerRequest <$> GHandler ask+ 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 = bsToChars *** bsToChars+ fix2 (x, NWP.FileInfo a b c) =+ (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c)++-- | 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 -> String)+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 -> [(String, String)] -> String)+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 -> [(String, String)] -> String)+ -> 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 $ 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, id), initSession))+ let contents = either id (HCContent W.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' = headers hs+ in return $ YARPlain (getStatus e) hs' ct c sess+ YARWai _ -> return yar+ let sendFile' ct fp =+ return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession+ case contents of+ HCContent status a -> do+ (ct, c) <- liftIO $ chooseRep a cts+ return $ YARPlain status (headers []) ct c finalSession+ HCError e -> handleError e+ HCRedirect rt loc -> do+ let hs = Header "Location" loc : headers []+ return $ YARPlain+ (getRedirectStatus rt) hs typePlain emptyContent+ finalSession+ HCSendFile ct fp -> catchIter+ (sendFile' ct fp)+ (handleError . toErrorHandler)+ HCCreated loc -> do+ let hs = Header "Location" loc : headers []+ return $ YARPlain+ (W.Status 201 (S8.pack "Created"))+ 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+ W.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 -> [(String, String)]+ -> GGHandler sub master mo a+redirectParams rt url params = do+ r <- getUrlRenderParams+ redirectString rt $ S8.pack $ r url params++-- | Redirect to the given URL.+redirectString :: Monad mo => RedirectType -> ByteString -> GGHandler sub master mo a+redirectString rt = GHandler . lift . throwError . HCRedirect rt++ultDestKey :: String+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.+setUltDestString :: Monad mo => String -> GGHandler sub master mo ()+setUltDestString = setSession ultDestKey++-- | 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'++-- | 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 ()+redirectUltDest rt def = do+ mdest <- lookupSession ultDestKey+ deleteSession ultDestKey+ maybe (redirect rt def) (redirectString rt . S8.pack) mdest++msgKey :: String+msgKey = "_MSG"++-- | Sets a message in the user's session.+--+-- See 'getMessage'.+setMessage :: Monad mo => Html -> GGHandler sub master mo ()+setMessage = setSession msgKey . lbsToChars . renderHtml++-- | 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 preEscapedString) $ 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 = GHandler . lift . throwError . HCSendFile ct++-- | 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 W.status200+ . chooseRep++-- | Bypass remaining handler code and output the given content with the given+-- status code.+sendResponseStatus :: (Monad mo, HasReps c) => W.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 $ S8.pack $ 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 :: (RequestReader m, Failure ErrorResponse m) => m a+badMethod = do+ w <- waiRequest+ failure $ BadMethod $ bsToChars $ W.requestMethod w++-- | Return a 403 permission denied page.+permissionDenied :: Failure ErrorResponse m => String -> m a+permissionDenied = failure . PermissionDenied++-- | Return a 400 invalid arguments page.+invalidArgs :: Failure ErrorResponse m => [String] -> m a+invalidArgs = failure . InvalidArgs++------- Headers+-- | Set the cookie on the client.+setCookie :: Monad mo+ => Int -- ^ minutes to timeout+ -> ByteString -- ^ key+ -> ByteString -- ^ value+ -> GGHandler sub master mo ()+setCookie a b = addHeader . AddCookie a b++-- | Unset the cookie on the client.+deleteCookie :: Monad mo => ByteString -> 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 => String -> GGHandler sub master mo ()+setLanguage = setSession langKey++-- | Set an arbitrary response header.+setHeader :: Monad mo+ => W.ResponseHeader -> ByteString -> 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" . S8.pack . 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+ => String -- ^ key+ -> String -- ^ 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 => String -> 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 . (:)++getStatus :: ErrorResponse -> W.Status+getStatus NotFound = W.status404+getStatus (InternalError _) = W.status500+getStatus (InvalidArgs _) = W.status400+getStatus (PermissionDenied _) = W.status403+getStatus (BadMethod _) = W.status405++getRedirectStatus :: RedirectType -> W.Status+getRedirectStatus RedirectPermanent = W.status301+getRedirectStatus RedirectTemporary = W.status302+getRedirectStatus RedirectSeeOther = W.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 => ParamName -> GGHandler s m mo (Maybe ParamValue)+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++#if TEST++handlerTestSuite :: Test+handlerTestSuite = testGroup "Yesod.Handler"+ [+ ]++#endif++handlerToYAR :: (HasReps a, HasReps b)+ => m -- ^ master site foundation+ -> s -- ^ sub site foundation+ -> (Route s -> Route m)+ -> (Route m -> [(String, String)] -> String) -- ^ url render+ -> (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+ -> [(W.ResponseHeader, ByteString)]++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 -> W.ResponseFile s finalHeaders fp+ 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 S.empty+ . lookup "Accept"+ . W.requestHeaders++-- | Convert Header to a key/value pair.+headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time+ -> Header+ -> (W.ResponseHeader, ByteString)+headerToPair getExpires (AddCookie minutes key value) =+ ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie+ { setCookieName = key+ , setCookieValue = value+ , setCookiePath = Just "/" -- FIXME make a config option, or use approot?+ , setCookieExpires = Just $ getExpires minutes+ , setCookieDomain = Nothing+ })+headerToPair _ (DeleteCookie key) =+ ( "Set-Cookie"+ , key `S.append` "=; path=/; 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+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 x = do+ k <- peel+ join $ liftIO $ k x++instance MonadTransPeel (GGHandler s m) where+ peel = GHandler $ do+ k <- liftPeel $ liftPeel $ liftPeel peel+ return $ liftM GHandler . k . unGHandler++-- | Redirect to a POST resource.+--+-- This is not technically a redirect; instead, it returns an HTML page with a+-- POST form, and some Javascript to automatically submit the form. This can be+-- useful when you need to post a plain link somewhere that needs to cause+-- changes on the server.+redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a+redirectToPost dest = hamletToRepHtml+#if GHC7+ [hamlet|+#else+ [$hamlet|+#endif+\<!DOCTYPE html>++<html>+ <head>+ <title>Redirecting...+ <body onload="document.getElementById('form').submit()">+ <form id="form" method="post" action="@{dest}">+ <noscript>+ <p>Javascript has been disabled; please click on the button below to be redirected.+ <input type="submit" value="Continue">+|] >>= sendResponse++-- | Converts the given Hamlet template into 'Content', which can be used in a+-- Yesod 'Response'.+hamletToContent :: Monad mo+ => Hamlet (Route master) -> GGHandler sub master mo Content+hamletToContent h = do+ render <- getUrlRenderParams+ return $ toContent $ h render++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+hamletToRepHtml :: Monad mo+ => Hamlet (Route master) -> GGHandler sub master mo RepHtml+hamletToRepHtml = liftM RepHtml . hamletToContent
+ Yesod/Internal.hs view
@@ -0,0 +1,122 @@+{-# 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+ , Location (..)+ , UniqueList (..)+ , Script (..)+ , Stylesheet (..)+ , Title (..)+ , Head (..)+ , Body (..)+ , locationToHamlet+ , runUniqueList+ , toUnique+ -- * UTF8 helpers+ , bsToChars+ , lbsToChars+ , charsToBs+ -- * Names+ , sessionName+ , nonceKey+ ) where++import Text.Hamlet (Hamlet, hamlet, Html)+import Data.Monoid (Monoid (..))+import Data.List (nub)++import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Encoding.Error as T++import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT++import qualified Network.Wai as W+import Data.Typeable (Typeable)+import Control.Exception (Exception)++#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 String+ | InvalidArgs [String]+ | PermissionDenied String+ | BadMethod String+ deriving (Show, Eq, Typeable)+instance Exception ErrorResponse++----- header stuff+-- | Headers to be added to a 'Result'.+data Header =+ AddCookie Int ByteString ByteString+ | DeleteCookie ByteString+ | Header W.ResponseHeader ByteString+ deriving (Eq, Show)++langKey :: String+langKey = "_LANG"++data Location url = Local url | Remote String+ 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 . (:)++newtype Script url = Script { unScript :: Location url }+ deriving (Show, Eq)+newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }+ deriving (Show, Eq)+newtype Title = Title { unTitle :: Html }++newtype Head url = Head (Hamlet url)+ deriving Monoid+newtype Body url = Body (Hamlet url)+ deriving Monoid++lbsToChars :: L.ByteString -> String+lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode++bsToChars :: S.ByteString -> String+bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode++charsToBs :: String -> S.ByteString+charsToBs = T.encodeUtf8 . T.pack++nonceKey :: String+nonceKey = "_NONCE"++sessionName :: ByteString+sessionName = "_SESSION"
+ Yesod/Internal/Dispatch.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE TemplateHaskell #-}+-- | 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.Routes.Quasi+import Web.Routes.Quasi.Parse+import Web.Routes.Quasi.TH+import Control.Monad (foldM)+import Yesod.Handler (badMethod)+import Yesod.Content (chooseRep)+import qualified Network.Wai as W+import Yesod.Core (yesodRunner, yesodDispatch)+import Data.List (foldl')+import Data.Char (toLower)+import qualified Data.ByteString.Char8 as S8++{-|++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.+-}+mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> Q Clause+mkYesodDispatch' res = do+ sub <- newName "sub"+ master <- newName "master"+ mkey <- newName "mkey"+ segments <- newName "segments"+ toMasterRoute <- newName "toMasterRoute"+ nothing <- [|Nothing|]+ body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) nothing res+ 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|]+ let url = foldl' AppE (ConE $ mkName constr) $ frontVars []+ let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])+ runHandler' h = NormalB $ yr `AppE` sub+ `AppE` VarE master+ `AppE` toMasterRoute+ `AppE` VarE mkey+ `AppE` (just `AppE` url)+ `AppE` h+ `AppE` VarE req+ let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) []+ let clauses =+ case methods of+ [] -> [Clause [VarP req] (runHandlerVars $ "handle" ++ constr) []]+ _ -> [Clause [VarP req] (NormalB $ CaseE caseExp $ map match methods +++ [Match WildP (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|]+ let exp = CaseE segments+ [ Match+ (InfixP (LitP $ StringL s) (mkName ":") (VarP srest))+ (NormalB 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 "Left") [WildP])+ (NormalB nothing)+ []+ , Match+ (ConP (mkName "Right") [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 "Left") [WildP])+ (NormalB nothing)+ []+ , Match+ (ConP (mkName "Right") [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|]+ let exp = CaseE (VarE segments)+ [ Match+ (InfixP (LitP $ StringL s) (mkName ":") (VarP srest))+ (NormalB 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 "Left") [WildP])+ (NormalB nothing)+ []+ , Match+ (ConP (mkName "Right") [VarP next'])+ (NormalB innerExp)+ []+ ]+ let exp = CaseE (VarE segments)+ [ Match+ (InfixP (VarP next) (mkName ":") (VarP srest))+ (NormalB exp')+ []+ , Match WildP (NormalB nothing) []+ ]+ return exp
+ Yesod/Internal/Request.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Internal.Request+ ( parseWaiRequest+ ) where++import Yesod.Request+import Control.Arrow (first, (***))+import qualified Network.Wai.Parse as NWP+import Data.Maybe (fromMaybe)+import Yesod.Internal+import qualified Network.Wai as W+import qualified Data.ByteString as S+import System.Random (randomR, newStdGen)+import Web.Cookie (parseCookies)++parseWaiRequest :: W.Request+ -> [(String, String)] -- ^ session+ -> Maybe a+ -> IO Request+parseWaiRequest env session' key' = do+ let gets' = map (bsToChars *** bsToChars)+ $ NWP.parseQueryString $ W.queryString env+ let reqCookie = fromMaybe S.empty $ lookup "Cookie"+ $ W.requestHeaders env+ cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie+ acceptLang = lookup "Accept-Language" $ W.requestHeaders env+ langs = map bsToChars $ 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 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 $ fst $ randomString 10 g+ 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
+ Yesod/Internal/Session.hs view
@@ -0,0 +1,53 @@+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)++encodeSession :: CS.Key+ -> UTCTime -- ^ expire time+ -> ByteString -- ^ remote host+ -> [(String, String)] -- ^ 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 [(String, String)]+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 [(String, String)]+ deriving (Show, Read)+instance Serialize SessionCookie where+ put (SessionCookie a b c) = putTime a >> put b >> put c+ get = do+ a <- getTime+ b <- get+ c <- get+ return $ SessionCookie a b c++putTime :: Putter UTCTime+putTime t@(UTCTime d _) = do+ put $ toModifiedJulianDay d+ let ndt = diffUTCTime t $ UTCTime d 0+ put $ toRational ndt++getTime :: Get UTCTime+getTime = do+ d <- get+ ndt <- get+ return $ fromRational ndt `addUTCTime` UTCTime (ModifiedJulianDay d) 0
+ Yesod/Request.hs view
@@ -0,0 +1,151 @@+---------------------------------------------------------+--+-- 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 (..)+ , RequestReader (..)+ , FileInfo (..)+ -- * Convenience functions+ , waiRequest+ , languages+ -- * Lookup parameters+ , lookupGetParam+ , lookupPostParam+ , lookupCookie+ , lookupFile+ -- ** Multi-lookup+ , lookupGetParams+ , lookupPostParams+ , lookupCookies+ , lookupFiles+ -- * Parameter type synonyms+ , ParamName+ , ParamValue+ , ParamError+ ) where++import qualified Network.Wai as W+import qualified Data.ByteString.Lazy as BL+import Control.Monad.IO.Class+import Control.Monad (liftM)+import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r+import Data.Maybe (listToMaybe)++type ParamName = String+type ParamValue = String+type ParamError = String++-- FIXME perhaps remove RequestReader typeclass, include Request datatype in Handler++-- | The reader monad specialized for 'Request'.+class Monad m => RequestReader m where+ getRequest :: m Request+ runRequestBody :: m RequestBodyContents++-- | 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 :: RequestReader m => m [String]+languages = reqLangs `liftM` getRequest++-- | Get the request\'s 'W.Request' value.+waiRequest :: RequestReader m => m W.Request+waiRequest = reqWaiRequest `liftM` getRequest++-- | A tuple containing both the POST parameters and submitted files.+type RequestBodyContents =+ ( [(ParamName, ParamValue)]+ , [(ParamName, FileInfo)]+ )++data FileInfo = FileInfo+ { fileName :: String+ , fileContentType :: String+ , fileContent :: BL.ByteString+ }+ deriving (Eq, Show)++-- | The parsed request information.+data Request = Request+ { reqGetParams :: [(ParamName, ParamValue)]+ , reqCookies :: [(ParamName, ParamValue)]+ , reqWaiRequest :: W.Request+ -- | Languages which the client supports.+ , reqLangs :: [String]+ -- | A random, session-specific nonce used to prevent CSRF attacks.+ , reqNonce :: Maybe String+ }++lookup' :: Eq a => a -> [(a, b)] -> [b]+lookup' a = map snd . filter (\x -> a == fst x)++-- | Lookup for GET parameters.+lookupGetParams :: RequestReader m => ParamName -> m [ParamValue]+lookupGetParams pn = do+ rr <- getRequest+ return $ lookup' pn $ reqGetParams rr++-- | Lookup for GET parameters.+lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)+lookupGetParam = liftM listToMaybe . lookupGetParams++-- | Lookup for POST parameters.+lookupPostParams :: RequestReader m+ => ParamName+ -> m [ParamValue]+lookupPostParams pn = do+ (pp, _) <- runRequestBody+ return $ lookup' pn pp++lookupPostParam :: (MonadIO m, RequestReader m)+ => ParamName+ -> m (Maybe ParamValue)+lookupPostParam = liftM listToMaybe . lookupPostParams++-- | Lookup for POSTed files.+lookupFile :: (MonadIO m, RequestReader m)+ => ParamName+ -> m (Maybe FileInfo)+lookupFile = liftM listToMaybe . lookupFiles++-- | Lookup for POSTed files.+lookupFiles :: RequestReader m+ => ParamName+ -> m [FileInfo]+lookupFiles pn = do+ (_, files) <- runRequestBody+ return $ lookup' pn files++-- | Lookup for cookie data.+lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue)+lookupCookie = liftM listToMaybe . lookupCookies++-- | Lookup for cookie data.+lookupCookies :: RequestReader m => ParamName -> m [ParamValue]+lookupCookies pn = do+ rr <- getRequest+ return $ lookup' pn $ reqCookies rr
+ Yesod/Widget.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+-- | 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 (..)+ -- * Creating+ -- ** Head of page+ , setTitle+ , addHamletHead+ , addHtmlHead+ -- ** Body+ , addHamlet+ , addHtml+ , addWidget+ , addSubWidget+ -- ** CSS+ , addCassius+ , addStylesheet+ , addStylesheetRemote+ , addStylesheetEither+ -- ** Javascript+ , addJulius+ , addScript+ , addScriptRemote+ , addScriptEither+ -- * Utilities+ , extractBody+ ) where++import Data.Monoid+import Control.Monad.Trans.Writer+import Control.Monad.Trans.State+import Text.Hamlet+import Text.Cassius+import Text.Julius+import Yesod.Handler+ (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)+import Control.Applicative (Applicative)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.Class (MonadTrans (lift))+import Yesod.Internal+import Control.Monad (liftM)++import Control.Monad.IO.Peel (MonadPeelIO)++-- | 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 s m monad a = GWidget { unGWidget :: GWInner s m monad a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)++instance MonadTrans (GGWidget s m) where+ lift = GWidget . lift . lift . lift . lift . lift . lift . lift . lift++type GWidget s m = GGWidget s m (GHandler s m)+type GWInner sub master monad =+ WriterT (Body (Route master)) (+ WriterT (Last Title) (+ WriterT (UniqueList (Script (Route master))) (+ WriterT (UniqueList (Stylesheet (Route master))) (+ WriterT (Maybe (Cassius (Route master))) (+ WriterT (Maybe (Julius (Route master))) (+ WriterT (Head (Route master)) (+ StateT Int (+ monad+ ))))))))+instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where+ mempty = return ()+ mappend x y = x >> y++instance (Monad monad, a ~ ()) => HamletValue (GGWidget s m monad a) where+ newtype HamletMonad (GGWidget s m monad a) b =+ GWidget' { runGWidget' :: GGWidget s m monad b }+ type HamletUrl (GGWidget s m monad a) = Route m+ toHamletValue = runGWidget'+ htmlToHamletMonad = GWidget' . addHtml+ urlToHamletMonad url params = GWidget' $+ addHamlet $ \r -> preEscapedString (r url params)+ fromHamletValue = GWidget'+instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where+ return = GWidget' . return+ x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y++addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a+addSubWidget sub w = do master <- lift getYesod+ let sr = fromSubRoute sub master+ i <- GWidget $ lift $ lift $ lift $ lift $ lift $ lift $ lift get+ w' <- lift $ toMasterHandlerMaybe sr (const sub) Nothing $ flip runStateT i+ $ runWriterT $ runWriterT $ runWriterT $ runWriterT+ $ runWriterT $ runWriterT $ runWriterT + $ unGWidget w+ let ((((((((a,+ body),+ title),+ scripts),+ stylesheets),+ style),+ jscript),+ h),+ i') = w'+ GWidget $ do+ tell body+ lift $ tell title+ lift $ lift $ tell scripts+ lift $ lift $ lift $ tell stylesheets+ lift $ lift $ lift $ lift $ tell style+ lift $ lift $ lift $ lift $ lift $ tell jscript+ lift $ lift $ lift $ lift $ lift $ lift $ tell h+ lift $ lift $ lift $ lift $ lift $ lift $ lift $ put i'+ return a++-- | Set the page title. Calling 'setTitle' multiple times overrides previously+-- set values.+setTitle :: Monad m => Html -> GGWidget sub master m ()+setTitle = GWidget . lift . tell . Last . Just . Title++-- | Add a 'Hamlet' to the head tag.+addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()+addHamletHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head++-- | Add a 'Html' to the head tag.+addHtmlHead :: Monad m => Html -> GGWidget sub master m ()+addHtmlHead = GWidget . lift . lift . lift . lift . lift . lift . tell . Head . const++-- | Add a 'Hamlet' to the body tag.+addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()+addHamlet = GWidget . tell . Body++-- | Add a 'Html' to the body tag.+addHtml :: Monad m => Html -> GGWidget sub master m ()+addHtml = GWidget . tell . Body . 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 s m mo () -> GGWidget s m mo ()+addWidget = id++-- | Add some raw CSS to the style tag.+addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m ()+addCassius = GWidget . lift . lift . lift . lift . tell . Just++-- | Link to the specified local stylesheet.+addStylesheet :: Monad m => Route master -> GGWidget sub master m ()+addStylesheet = GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Local++-- | Link to the specified remote stylesheet.+addStylesheetRemote :: Monad m => String -> GGWidget sub master m ()+addStylesheetRemote =+ GWidget . lift . lift . lift . tell . toUnique . Stylesheet . Remote++addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()+addStylesheetEither = either addStylesheet addStylesheetRemote++addScriptEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()+addScriptEither = either addScript addScriptRemote++-- | Link to the specified local script.+addScript :: Monad m => Route master -> GGWidget sub master m ()+addScript = GWidget . lift . lift . tell . toUnique . Script . Local++-- | Link to the specified remote script.+addScriptRemote :: Monad m => String -> GGWidget sub master m ()+addScriptRemote =+ GWidget . lift . lift . tell . toUnique . Script . Remote++-- | Include raw Javascript in the page's script tag.+addJulius :: Monad m => Julius (Route master) -> GGWidget sub master m ()+addJulius = GWidget . lift . lift . lift . lift . lift. tell . Just++-- | 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 s m mo () -> GGWidget s m mo (Hamlet (Route m))+extractBody (GWidget w) =+ GWidget $ mapWriterT (liftM go) w+ where+ go ((), Body h) = (h, Body mempty)++-- | 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+ }
+ runtests.hs view
@@ -0,0 +1,12 @@+import Test.Framework (defaultMain)++import Yesod.Content+import Yesod.Dispatch+import Yesod.Handler++main :: IO ()+main = defaultMain+ [ contentTestSuite+ , dispatchTestSuite+ , handlerTestSuite+ ]
+ yesod-core.cabal view
@@ -0,0 +1,85 @@+name: yesod-core+version: 0.7.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://docs.yesodweb.com/> has much more information, tutorials and information on some of the supporting packages, like Hamlet and web-routes-quasi.+category: Web, Yesod+stability: Stable+cabal-version: >= 1.6+build-type: Simple+homepage: http://docs.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.3 && < 0.4+ , wai-extra >= 0.3 && < 0.4+ , bytestring >= 0.9.1.4 && < 0.10+ , text >= 0.5 && < 0.12+ , template-haskell+ , web-routes-quasi >= 0.6.3 && < 0.7+ , hamlet >= 0.7 && < 0.8+ , blaze-builder >= 0.2.1 && < 0.3+ , transformers >= 0.2 && < 0.3+ , clientsession >= 0.4.0 && < 0.5+ , random >= 1.0.0.2 && < 1.1+ , cereal >= 0.2 && < 0.4+ , old-locale >= 1.0.0.2 && < 1.1+ , web-routes >= 0.23 && < 0.24+ , failure >= 0.1 && < 0.2+ , containers >= 0.2 && < 0.5+ , monad-peel >= 0.1 && < 0.2+ , enumerator >= 0.4 && < 0.5+ , cookie >= 0.0 && < 0.1+ , blaze-html >= 0.4 && < 0.5+ exposed-modules: Yesod.Content+ Yesod.Core+ Yesod.Dispatch+ Yesod.Handler+ Yesod.Request+ Yesod.Widget+ other-modules: Yesod.Internal+ Yesod.Internal.Session+ Yesod.Internal.Request+ Yesod.Internal.Dispatch+ Paths_yesod_core+ ghc-options: -Wall++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,+ 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