yesod-core 0.7.0.2 → 0.8.0
raw patch · 13 files changed
+1005/−736 lines, 13 filesdep +case-insensitivedep +http-typesdep +monad-controldep −monad-peeldep −web-routesdep ~basedep ~blaze-builderdep ~clientsession
Dependencies added: case-insensitive, http-types, monad-control
Dependencies removed: monad-peel, web-routes
Dependency ranges changed: base, blaze-builder, clientsession, cookie, enumerator, hamlet, wai, wai-extra, web-routes-quasi
Files
- Yesod/Content.hs +11/−11
- Yesod/Core.hs +43/−435
- Yesod/Dispatch.hs +4/−9
- Yesod/Handler.hs +161/−97
- Yesod/Internal.hs +22/−39
- Yesod/Internal/Core.hs +576/−0
- Yesod/Internal/Dispatch.hs +19/−15
- Yesod/Internal/Request.hs +45/−14
- Yesod/Internal/Session.hs +7/−5
- Yesod/Request.hs +15/−65
- Yesod/Widget.hs +79/−33
- runtests.hs +6/−0
- yesod-core.cabal +17/−13
Yesod/Content.hs view
@@ -44,7 +44,6 @@ 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@@ -62,10 +61,11 @@ 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+ | ContentFile FilePath (Maybe FilePart) -- | Zero-length enumerator. emptyContent :: Content@@ -167,7 +167,7 @@ instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = B.ByteString+type ContentType = B.ByteString -- FIXME Text? typeHtml :: ContentType typeHtml = "text/html; charset=utf-8"@@ -216,17 +216,17 @@ -- -- 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 (/= ';')+simpleContentType :: ContentType -> ContentType+simpleContentType = fst . B.breakByte 59 -- 59 == ; -- | Format a 'UTCTime' in W3 format.-formatW3 :: UTCTime -> String-formatW3 = formatTime defaultTimeLocale "%FT%X-00:00"+formatW3 :: UTCTime -> T.Text+formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00" -- | Format as per RFC 1123.-formatRFC1123 :: UTCTime -> String-formatRFC1123 = formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"+formatRFC1123 :: UTCTime -> T.Text+formatRFC1123 = T.pack . 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"+formatRFC822 :: UTCTime -> T.Text+formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
Yesod/Core.hs view
@@ -1,9 +1,4 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--- | The basic typeclass for a Yesod application.+{-# LANGUAGE TemplateHaskell #-} module Yesod.Core ( -- * Type classes Yesod (..)@@ -19,447 +14,60 @@ , 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 ) where +import Yesod.Internal.Core import Yesod.Content+import Yesod.Dispatch 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.RWS-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 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)+import Yesod.Widget --- | 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))+import Language.Haskell.TH.Syntax+import Data.Text (Text) --- | 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)+logTH :: LogLevel -> Q Exp+logTH level =+ [|messageLoggerHandler $(qLocation >>= liftLoc) $(lift level)|] 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-|]+ liftLoc :: Loc -> Q Exp+ liftLoc (Loc a b c d e) = [|Loc $(lift a) $(lift b) $(lift c) $(lift d) $(lift e)|] --- | Return the same URL if the user is authorized to see it.+-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage: ----- 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 = 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+-- > $(logDebug) "This is a debug log message"+logDebug :: Q Exp+logDebug = logTH LevelDebug -yesodVersion :: String-yesodVersion = showVersion Paths_yesod_core.version+-- | See 'logDebug'+logInfo :: Q Exp+logInfo = logTH LevelInfo+-- | See 'logDebug'+logWarn :: Q Exp+logWarn = logTH LevelWarn+-- | See 'logDebug'+logError :: Q Exp+logError = logTH LevelError -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+-- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage:+--+-- > $(logOther "My new level") "This is a log message"+logOther :: Text -> Q Exp+logOther = logTH . LevelOther
Yesod/Dispatch.hs view
@@ -4,6 +4,7 @@ module Yesod.Dispatch ( -- * Quasi-quoted routing parseRoutes+ , parseRoutesFile , mkYesod , mkYesodSub -- ** More fine-grained@@ -22,7 +23,7 @@ import Data.Either (partitionEithers) import Prelude hiding (exp)-import Yesod.Core+import Yesod.Internal.Core import Yesod.Handler import Yesod.Internal.Dispatch @@ -35,14 +36,11 @@ import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip -import qualified Data.ByteString.Char8 as B import Data.ByteString.Lazy.Char8 () import Web.ClientSession import Data.Char (isUpper) -import Web.Routes (decodePathInfo)- -- | 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.@@ -177,10 +175,7 @@ => y -> Maybe Key -> W.Application-toWaiApp' y key' env = do- let dropSlash ('/':x) = x- dropSlash x = x- let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env- case yesodDispatch y key' segments y id of+toWaiApp' y key' env =+ case yesodDispatch y key' (W.pathInfo env) y id of Just app -> app env Nothing -> yesodRunner y y id key' Nothing notFound env
Yesod/Handler.hs view
@@ -35,12 +35,16 @@ , getUrlRenderParams , getCurrentRoute , getRouteToMaster+ , getRequest+ , waiRequest+ , runRequestBody -- * Special responses -- ** Redirecting , RedirectType (..) , redirect , redirectParams , redirectString+ , redirectText , redirectToPost -- ** Errors , notFound@@ -49,6 +53,7 @@ , invalidArgs -- ** Short-circuit responses. , sendFile+ , sendFilePart , sendResponse , sendResponseStatus , sendResponseCreated@@ -101,7 +106,7 @@ ) where import Prelude hiding (catch)-import Yesod.Request+import Yesod.Internal.Request import Yesod.Internal import Data.Time (UTCTime) @@ -120,15 +125,21 @@ 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 Text.Blaze (preEscapedText)+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.Peel (MonadPeelIO)-import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)+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 qualified Data.ByteString.Char8 as S8 import Data.ByteString (ByteString) import Data.Enumerator (Iteratee (..)) import Network.Wai.Parse (parseHttpAccept)@@ -136,10 +147,14 @@ 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+import Data.Monoid (mappend, mempty)+import qualified Data.ByteString.Char8 as S8+import Data.CaseInsensitive (CI)+import Blaze.ByteString.Builder (toByteString)+import Data.Text (Text) -- | The type-safe URLs associated with a site argument. type family Route a@@ -152,7 +167,7 @@ , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub)- , handlerRender :: (Route master -> [(String, String)] -> String)+ , handlerRender :: (Route master -> [(Text, Text)] -> Text) , handlerToMaster :: Route sub -> Route master } @@ -225,7 +240,7 @@ GHandler { unGHandler :: GHInner sub master m a }- deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)+ deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO) instance MonadTrans (GGHandler s m) where lift = GHandler . lift . lift . lift . lift@@ -238,7 +253,7 @@ , ghsIdent :: Int } -type GHInner s m monad =+type GHInner s m monad = -- FIXME collapse the stack ReaderT (HandlerData s m) ( ErrorT HandlerContents ( WriterT (Endo [Header]) (@@ -246,7 +261,7 @@ monad )))) -type SessionMap = Map.Map String String+type SessionMap = Map.Map Text Text type Endo a = a -> a @@ -264,41 +279,45 @@ data YesodAppResult = YARWai W.Response- | YARPlain W.Status [Header] ContentType Content SessionMap+ | YARPlain H.Status [Header] ContentType Content SessionMap data HandlerContents =- HCContent W.Status ChooseRep+ HCContent H.Status ChooseRep | HCError ErrorResponse- | HCSendFile ContentType FilePath- | HCRedirect RedirectType ByteString- | HCCreated ByteString+ | 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+ 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-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 +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 = bsToChars *** bsToChars+ fix1 = go *** go fix2 (x, NWP.FileInfo a b c) =- (bsToChars x, FileInfo (bsToChars a) (bsToChars 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@@ -309,7 +328,7 @@ getYesod = handlerMaster `liftM` GHandler ask -- | Get the URL rendering function.-getUrlRender :: Monad m => GGHandler sub master m (Route master -> String)+getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text) getUrlRender = do x <- handlerRender `liftM` GHandler ask return $ flip x []@@ -317,7 +336,7 @@ -- | The URL rendering function with query-string parameters. getUrlRenderParams :: Monad m- => GGHandler sub master m (Route master -> [(String, String)] -> String)+ => 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@@ -334,7 +353,7 @@ -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c- -> (Route master -> [(String, String)] -> String)+ -> (Route master -> [(Text, Text)] -> Text) -> Maybe (Route sub) -> (Route sub -> Route master) -> master@@ -345,7 +364,7 @@ let toErrorHandler e = case fromException e of Just x -> x- Nothing -> InternalError $ show e+ Nothing -> InternalError $ T.pack $ show e let hd = HandlerData { handlerRequest = rr , handlerSub = sa@@ -363,7 +382,7 @@ $ flip runReaderT hd $ unGHandler handler ) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession))- let contents = either id (HCContent W.status200 . chooseRep) contents'+ let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do yar <- unYesodApp (eh e) safeEh rr cts finalSession case yar of@@ -371,25 +390,25 @@ 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+ let sendFile' ct fp p =+ return $ YARPlain H.status200 (headers []) ct (ContentFile fp p) 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 []+ let hs = Header "Location" (encodeUtf8 loc) : headers [] return $ YARPlain (getRedirectStatus rt) hs typePlain emptyContent finalSession- HCSendFile ct fp -> catchIter- (sendFile' ct fp)+ HCSendFile ct fp p -> catchIter+ (sendFile' ct fp p) (handleError . toErrorHandler) HCCreated loc -> do- let hs = Header "Location" loc : headers []+ let hs = Header "Location" (encodeUtf8 loc) : headers [] return $ YARPlain- (W.Status 201 (S8.pack "Created"))+ H.status201 hs typePlain emptyContent@@ -406,7 +425,7 @@ safeEh er = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ YARPlain- W.status500+ H.status500 [] typePlain (toContent ("Internal Server Error" :: S.ByteString))@@ -418,17 +437,19 @@ -- | Redirects to the given route with the associated query-string parameters. redirectParams :: Monad mo- => RedirectType -> Route master -> [(String, String)]+ => RedirectType -> Route master -> [(Text, Text)] -> GGHandler sub master mo a redirectParams rt url params = do r <- getUrlRenderParams- redirectString rt $ S8.pack $ r url params+ redirectString rt $ 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+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 :: String+ultDestKey :: Text ultDestKey = "_ULT" -- | Sets the ultimate destination variable to the given route.@@ -441,7 +462,7 @@ setUltDestString $ render dest -- | Same as 'setUltDest', but use the given string.-setUltDestString :: Monad mo => String -> GGHandler sub master mo ()+setUltDestString :: Monad mo => Text -> GGHandler sub master mo () setUltDestString = setSession ultDestKey -- | Same as 'setUltDest', but uses the current page.@@ -470,16 +491,16 @@ redirectUltDest rt def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey- maybe (redirect rt def) (redirectString rt . S8.pack) mdest+ maybe (redirect rt def) (redirectText rt) mdest -msgKey :: String+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 . lbsToChars . renderHtml+setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable.@@ -487,7 +508,7 @@ -- See 'setMessage'. getMessage :: Monad mo => GGHandler sub master mo (Maybe Html) getMessage = do- mmsg <- liftM (fmap preEscapedString) $ lookupSession msgKey+ mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey deleteSession msgKey return mmsg @@ -496,17 +517,27 @@ -- 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+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 W.status200+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) => W.Status -> c -> GGHandler s m mo a+sendResponseStatus :: (Monad mo, HasReps c) => H.Status -> c -> GGHandler s m mo a sendResponseStatus s = GHandler . lift . throwError . HCContent s . chooseRep @@ -515,7 +546,7 @@ sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a sendResponseCreated url = do r <- getUrlRender- GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url+ 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@@ -530,40 +561,40 @@ notFound = failure NotFound -- | Return a 405 method not supported page.-badMethod :: (RequestReader m, Failure ErrorResponse m) => m a+badMethod :: Monad mo => GGHandler s m mo a badMethod = do w <- waiRequest- failure $ BadMethod $ bsToChars $ W.requestMethod w+ failure $ BadMethod $ W.requestMethod w -- | Return a 403 permission denied page.-permissionDenied :: Failure ErrorResponse m => String -> m a+permissionDenied :: Failure ErrorResponse m => Text -> m a permissionDenied = failure . PermissionDenied -- | Return a 400 invalid arguments page.-invalidArgs :: Failure ErrorResponse m => [String] -> m a+invalidArgs :: Failure ErrorResponse m => [Text] -> m a invalidArgs = failure . InvalidArgs ------- Headers -- | Set the cookie on the client. setCookie :: Monad mo => Int -- ^ minutes to timeout- -> ByteString -- ^ key- -> ByteString -- ^ value+ -> 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 => ByteString -> GGHandler sub master mo ()+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 => String -> GGHandler sub master mo ()+setLanguage :: Monad mo => Text -> GGHandler sub master mo () setLanguage = setSession langKey -- | Set an arbitrary response header. setHeader :: Monad mo- => W.ResponseHeader -> ByteString -> GGHandler sub master 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@@ -587,7 +618,7 @@ -- | Set an Expires header to the given date. expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()-expiresAt = setHeader "Expires" . S8.pack . formatRFC1123+expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123 -- | Set a variable in the user's session. --@@ -595,13 +626,13 @@ -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. setSession :: Monad mo- => String -- ^ key- -> String -- ^ value+ => 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 => String -> GGHandler sub master mo ()+deleteSession :: Monad mo => Text -> GGHandler sub master mo () deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete modSession :: (SessionMap -> SessionMap) -> GHState -> GHState@@ -611,17 +642,17 @@ 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+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 -> W.Status-getRedirectStatus RedirectPermanent = W.status301-getRedirectStatus RedirectTemporary = W.status302-getRedirectStatus RedirectSeeOther = W.status303+getRedirectStatus :: RedirectType -> H.Status+getRedirectStatus RedirectPermanent = H.status301+getRedirectStatus RedirectTemporary = H.status302+getRedirectStatus RedirectSeeOther = H.status303 -- | Different types of redirects. data RedirectType = RedirectPermanent@@ -634,7 +665,7 @@ GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler -- | Lookup for session data.-lookupSession :: Monad mo => ParamName -> GGHandler s m mo (Maybe ParamValue)+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@@ -647,7 +678,7 @@ => m -- ^ master site foundation -> s -- ^ sub site foundation -> (Route s -> Route m)- -> (Route m -> [(String, String)] -> String) -- ^ url render+ -> (Route m -> [(Text, Text)] -> Text) -> (ErrorResponse -> GHandler s m a) -> Request -> Maybe (Route s)@@ -665,7 +696,7 @@ type HeaderRenderer = [Header] -> ContentType -> SessionMap- -> [(W.ResponseHeader, ByteString)]+ -> [(CI H.Ascii, H.Ascii)] yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response yarToResponse _ (YARWai a) = a@@ -674,7 +705,7 @@ ContentBuilder b mlen -> let hs' = maybe finalHeaders finalHeaders' mlen in W.ResponseBuilder s hs' b- ContentFile fp -> W.ResponseFile s finalHeaders fp+ ContentFile fp p -> W.ResponseFile s finalHeaders fp p ContentEnum e -> W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders where@@ -703,27 +734,28 @@ httpAccept :: W.Request -> [ContentType] httpAccept = parseHttpAccept- . fromMaybe S.empty+ . fromMaybe mempty . lookup "Accept" . W.requestHeaders -- | Convert Header to a key/value pair.-headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time+headerToPair :: S.ByteString -- ^ cookie path+ -> (Int -> UTCTime) -- ^ minutes -> expiration time -> Header- -> (W.ResponseHeader, ByteString)-headerToPair getExpires (AddCookie minutes key value) =+ -> (CI H.Ascii, H.Ascii)+headerToPair cp getExpires (AddCookie minutes key value) = ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie { setCookieName = key , setCookieValue = value- , setCookiePath = Just "/" -- FIXME make a config option, or use approot?+ , setCookiePath = Just cp , setCookieExpires = Just $ getExpires minutes , setCookieDomain = Nothing })-headerToPair _ (DeleteCookie key) =+headerToPair cp _ (DeleteCookie key) = ( "Set-Cookie"- , key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT"+ , key `mappend` "=; path=" `mappend` cp `mappend` "; expires=Thu, 01-Jan-1970 00:00:00 GMT" )-headerToPair _ (Header key value) = (key, value)+headerToPair _ _ (Header key value) = (key, value) -- | Get a unique identifier. newIdent :: Monad mo => GGHandler sub master mo String@@ -736,15 +768,43 @@ liftIOHandler :: MonadIO mo => GGHandler sub master IO a -> GGHandler sub master mo a-liftIOHandler x = do- k <- peel- join $ liftIO $ k x+liftIOHandler m = GHandler $+ ReaderT $ \r ->+ ErrorT $+ WriterT $+ StateT $ \s ->+ liftIO $ runGGHandler m r s -instance MonadTransPeel (GGHandler s m) where- peel = GHandler $ do- k <- liftPeel $ liftPeel $ liftPeel peel- return $ liftM GHandler . k . unGHandler+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@@ -782,3 +842,7 @@ 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
Yesod/Internal.hs view
@@ -23,10 +23,6 @@ , locationToHamlet , runUniqueList , toUnique- -- * UTF8 helpers- , bsToChars- , lbsToChars- , charsToBs -- * Names , sessionName , nonceKey@@ -38,21 +34,17 @@ import Data.Monoid (Monoid (..), Last) 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 Data.Text (Text) -import qualified Network.Wai as W 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@@ -63,25 +55,25 @@ -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = NotFound- | InternalError String- | InvalidArgs [String]- | PermissionDenied String- | BadMethod String+ | 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 ByteString ByteString- | DeleteCookie ByteString- | Header W.ResponseHeader ByteString+ AddCookie Int A.Ascii A.Ascii+ | DeleteCookie A.Ascii+ | Header (CI A.Ascii) A.Ascii deriving (Eq, Show) -langKey :: String+langKey :: IsString a => a langKey = "_LANG" -data Location url = Local url | Remote String+data Location url = Local url | Remote Text deriving (Show, Eq) locationToHamlet :: Location url -> Hamlet url locationToHamlet (Local url) = [HAMLET|\@{url}@@ -98,9 +90,9 @@ toUnique :: x -> UniqueList x toUnique = UniqueList . (:) -newtype Script url = Script { unScript :: Location url }+data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } deriving (Show, Eq)-newtype Stylesheet url = Stylesheet { unStylesheet :: Location url }+data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } @@ -109,19 +101,10 @@ 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 :: IsString a => a nonceKey = "_NONCE" -sessionName :: ByteString+sessionName :: IsString a => a sessionName = "_SESSION" data GWData a = GWData@@ -129,7 +112,7 @@ !(Last Title) !(UniqueList (Script a)) !(UniqueList (Stylesheet a))- !(Maybe (Cassius a))+ !(Map.Map (Maybe Text) (Cassius a)) -- media type !(Maybe (Julius a)) !(Head a) instance Monoid (GWData a) where@@ -140,6 +123,6 @@ (a2 `mappend` b2) (a3 `mappend` b3) (a4 `mappend` b4)- (a5 `mappend` b5)+ (Map.unionWith mappend a5 b5) (a6 `mappend` b6) (a7 `mappend` b7)
+ Yesod/Internal/Core.hs view
@@ -0,0 +1,576 @@+{-# 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 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 (preEscapedLazyText, (!), 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 (..))++#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 $ 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 -> [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 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+ css <- flip mapM (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 <- scripts+ ^{mkScriptTag s}+$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}+$maybe j <- jscript+ $maybe s <- jsLoc+ <script src="#{s}">+ $nothing+ <script>^{jelper j}+\^{head'}+|]+ return $ PageContent title head'' body++yesodVersion :: String+yesodVersion = showVersion Paths_yesod_core.version++yesodRender :: Yesod y+ => y+ -> Route y+ -> [(Text, Text)]+ -> Text+yesodRender y u qs =+ TE.decodeUtf8 $ toByteString $+ fromMaybe+ (joinPath y (approot y) ps+ $ qs ++ qs')+ (urlRenderOverride y u)+ where+ (ps, qs') = renderRoute u
Yesod/Internal/Dispatch.hs view
@@ -14,13 +14,16 @@ import Yesod.Handler (badMethod) import Yesod.Content (chooseRep) import qualified Network.Wai as W-import Yesod.Core (yesodRunner, yesodDispatch)+import Yesod.Internal.Core (yesodRunner, yesodDispatch) import Data.List (foldl') import Data.Char (toLower)-import qualified Data.ByteString.Char8 as S8-import Data.ByteString.Lazy.Char8 () import qualified Data.ByteString as S-import Yesod.Core (Yesod (joinPath, approot, cleanPath))+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 {-| @@ -75,18 +78,19 @@ -} -sendRedirect :: Yesod master => master -> [String] -> W.Application+sendRedirect :: Yesod master => master -> [Text] -> W.Application sendRedirect y segments' env =- return $ W.responseLBS W.status301+ return $ W.responseLBS status301 [ ("Content-Type", "text/plain")- , ("Location", S8.pack $ dest')+ , ("Location", Blaze.ByteString.Builder.toByteString dest') ] "Redirecting" where dest = joinPath y (approot y) segments' [] dest' =- if S.null (W.queryString env)+ if S.null (W.rawQueryString env) then dest- else dest ++ '?' : S8.unpack (W.queryString env)+ else (dest `mappend`+ Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) mkYesodDispatch' :: [((String, Pieces), Maybe String)] -> [((String, Pieces), Maybe String)]@@ -198,11 +202,11 @@ fsp <- [|fromSinglePiece|] let exp' = CaseE (fsp `AppE` VarE next) [ Match- (ConP (mkName "Left") [WildP])+ (ConP (mkName "Nothing") []) (NormalB nothing) [] , Match- (ConP (mkName "Right") [VarP next'])+ (ConP (mkName "Just") [VarP next']) (NormalB innerExp) [] ]@@ -222,11 +226,11 @@ fmp <- [|fromMultiPiece|] let exp = CaseE (fmp `AppE` segments) [ Match- (ConP (mkName "Left") [WildP])+ (ConP (mkName "Nothing") []) (NormalB nothing) [] , Match- (ConP (mkName "Right") [VarP next'])+ (ConP (mkName "Just") [VarP next']) (NormalB innerExp) [] ]@@ -273,11 +277,11 @@ fsp <- [|fromSinglePiece|] let exp' = CaseE (fsp `AppE` VarE next) [ Match- (ConP (mkName "Left") [WildP])+ (ConP (mkName "Nothing") []) (NormalB nothing) [] , Match- (ConP (mkName "Right") [VarP next'])+ (ConP (mkName "Just") [VarP next']) (NormalB innerExp) [] ]
Yesod/Internal/Request.hs view
@@ -1,37 +1,54 @@ {-# LANGUAGE OverloadedStrings #-} module Yesod.Internal.Request ( parseWaiRequest+ , Request (..)+ , RequestBodyContents+ , FileInfo (..) ) where -import Yesod.Request-import Control.Arrow (first, (***))+import Control.Arrow (first, second) 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)+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- -> [(String, String)] -- ^ session+ -> [(Text, Text)] -- ^ 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"+ let gets' = queryToQueryText $ W.queryString env+ let reqCookie = maybe mempty id $ lookup "Cookie" $ W.requestHeaders env- cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie+ cookies' = parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env- langs = map bsToChars $ maybe [] NWP.parseHttpAccept acceptLang+ 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 lookup langKey gets' of+ langs''' = case join $ lookup langKey gets' of Nothing -> langs'' Just x -> x : langs'' nonce <- case (key', lookup nonceKey session') of@@ -39,8 +56,9 @@ (_, Just x) -> return $ Just x (_, Nothing) -> do g <- newStdGen- return $ Just $ fst $ randomString 10 g- return $ Request gets' cookies' env langs''' nonce+ 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)))@@ -53,3 +71,16 @@ | i < 26 = toEnum $ i + fromEnum 'A' | i < 52 = toEnum $ i + fromEnum 'a' - 26 | otherwise = toEnum $ i + fromEnum '0' - 52++-- | A tuple containing both the POST parameters and submitted files.+type RequestBodyContents =+ ( [(Text, Text)]+ , [(Text, FileInfo)]+ )++data FileInfo = FileInfo+ { fileName :: Text+ , fileContentType :: Text+ , fileContent :: L.ByteString+ }+ deriving (Eq, Show)
Yesod/Internal/Session.hs view
@@ -8,11 +8,13 @@ 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- -> [(String, String)] -- ^ session+ -> [(Text, Text)] -- ^ session -> ByteString -- ^ cookie value encodeSession key expire rhost session' = CS.encrypt key $ encode $ SessionCookie expire rhost session'@@ -21,7 +23,7 @@ -> UTCTime -- ^ current time -> ByteString -- ^ remote host field -> ByteString -- ^ cookie value- -> Maybe [(String, String)]+ -> Maybe [(Text, Text)] decodeSession key now rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie expire rhost' session' <-@@ -30,14 +32,14 @@ guard $ rhost' == rhost return session' -data SessionCookie = SessionCookie UTCTime ByteString [(String, String)]+data SessionCookie = SessionCookie UTCTime ByteString [(Text, Text)] deriving (Show, Read) instance Serialize SessionCookie where- put (SessionCookie a b c) = putTime a >> put b >> put c+ put (SessionCookie a b c) = putTime a >> put b >> put (map (unpack *** unpack) c) get = do a <- getTime b <- get- c <- get+ c <- map (pack *** pack) `fmap` get return $ SessionCookie a b c putTime :: Putter UTCTime
Yesod/Request.hs view
@@ -16,10 +16,8 @@ -- * Request datatype RequestBodyContents , Request (..)- , RequestReader (..) , FileInfo (..) -- * Convenience functions- , waiRequest , languages -- * Lookup parameters , lookupGetParam@@ -31,29 +29,14 @@ , 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 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)--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+import Data.Text (Text) -- | Get the list of supported languages supplied by the user. --@@ -69,83 +52,50 @@ -- * Accept-Language HTTP header. -- -- This is handled by parseWaiRequest (not exposed).-languages :: RequestReader m => m [String]+languages :: Monad mo => GGHandler s m mo [Text] 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 :: Monad mo => Text -> GGHandler s m mo [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters.-lookupGetParam :: RequestReader m => ParamName -> m (Maybe ParamValue)+lookupGetParam :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters.-lookupPostParams :: RequestReader m- => ParamName- -> m [ParamValue]+lookupPostParams :: Text -> GHandler s m [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp -lookupPostParam :: (MonadIO m, RequestReader m)- => ParamName- -> m (Maybe ParamValue)+lookupPostParam :: Text+ -> GHandler s m (Maybe Text) lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files.-lookupFile :: (MonadIO m, RequestReader m)- => ParamName- -> m (Maybe FileInfo)+lookupFile :: Text+ -> GHandler s m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files.-lookupFiles :: RequestReader m- => ParamName- -> m [FileInfo]+lookupFiles :: Text+ -> GHandler s m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data.-lookupCookie :: RequestReader m => ParamName -> m (Maybe ParamValue)+lookupCookie :: Monad mo => Text -> GGHandler s m mo (Maybe Text) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data.-lookupCookies :: RequestReader m => ParamName -> m [ParamValue]+lookupCookies :: Monad mo => Text -> GGHandler s m mo [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr
Yesod/Widget.hs view
@@ -20,13 +20,21 @@ , addSubWidget -- ** CSS , addCassius+ , addCassiusMedia+ , addLucius+ , addLuciusMedia , addStylesheet+ , addStylesheetAttrs , addStylesheetRemote+ , addStylesheetRemoteAttrs , addStylesheetEither -- ** Javascript , addJulius+ , addJuliusBody , addScript+ , addScriptAttrs , addScriptRemote+ , addScriptRemoteAttrs , addScriptEither -- * Utilities , extractBody@@ -34,8 +42,11 @@ import Data.Monoid import Control.Monad.Trans.RWS+import Text.Blaze (preEscapedText, preEscapedLazyText)+import qualified Text.Blaze.Html5 as H import Text.Hamlet import Text.Cassius+import Text.Lucius (Lucius) import Text.Julius import Yesod.Handler (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)@@ -44,35 +55,37 @@ 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 Control.Monad.IO.Peel (MonadPeelIO)+import Control.Monad.IO.Control (MonadControlIO) -- | 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 m monad a } -- FIXME remove s- deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)+newtype GGWidget m monad a = GWidget { unGWidget :: GWInner m monad a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO) -instance MonadTrans (GGWidget s m) where+instance MonadTrans (GGWidget m) where lift = GWidget . lift -type GWidget s m = GGWidget s m (GHandler s m)+type GWidget s m = GGWidget m (GHandler s m) type GWInner master = RWST () (GWData (Route master)) Int -instance (Monad monad, a ~ ()) => Monoid (GGWidget sub master monad a) where+instance (Monad monad, a ~ ()) => Monoid (GGWidget 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+instance (Monad monad, a ~ ()) => HamletValue (GGWidget m monad a) where+ newtype HamletMonad (GGWidget m monad a) b =+ GWidget' { runGWidget' :: GGWidget m monad b }+ type HamletUrl (GGWidget m monad a) = Route m toHamletValue = runGWidget' htmlToHamletMonad = GWidget' . addHtml urlToHamletMonad url params = GWidget' $- addHamlet $ \r -> preEscapedString (r url params)+ addHamlet $ \r -> preEscapedText (r url params) fromHamletValue = GWidget'-instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget s m monad a)) where+instance (Monad monad, a ~ ()) => Monad (HamletMonad (GGWidget m monad a)) where return = GWidget' . return x >>= y = GWidget' $ runGWidget' x >>= runGWidget' . y @@ -88,63 +101,96 @@ -- | Set the page title. Calling 'setTitle' multiple times overrides previously -- set values.-setTitle :: Monad m => Html -> GGWidget sub master m ()+setTitle :: Monad m => Html -> GGWidget master m () setTitle x = GWidget $ tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty -- | Add a 'Hamlet' to the head tag.-addHamletHead :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()+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 sub master m ()+addHtmlHead :: Monad m => Html -> GGWidget master m () addHtmlHead = addHamletHead . const -- | Add a 'Hamlet' to the body tag.-addHamlet :: Monad m => Hamlet (Route master) -> GGWidget sub master m ()+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 sub master m ()+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 s m mo () -> GGWidget s m mo ()+addWidget :: Monad mo => GGWidget m mo () -> GGWidget m mo () addWidget = id --- | Add some raw CSS to the style tag.-addCassius :: Monad m => Cassius (Route master) -> GGWidget sub master m ()-addCassius x = GWidget $ tell $ GWData mempty mempty mempty mempty (Just x) mempty mempty+-- | 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 sub master m ()-addStylesheet x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Local x) mempty mempty mempty+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 => String -> GGWidget sub master m ()-addStylesheetRemote x = GWidget $ tell $ GWData mempty mempty mempty (toUnique $ Stylesheet $ Remote x) mempty mempty mempty+addStylesheetRemote :: Monad m => Text -> GGWidget master m ()+addStylesheetRemote = flip addStylesheetRemoteAttrs [] -addStylesheetEither :: Monad m => Either (Route master) String -> GGWidget sub master m ()+-- | 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) String -> GGWidget sub master m ()+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 sub master m ()-addScript x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Local x) mempty mempty mempty mempty+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 => String -> GGWidget sub master m ()-addScriptRemote x = GWidget $ tell $ GWData mempty mempty (toUnique $ Script $ Remote x) mempty mempty mempty mempty+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 sub master m ()+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+ -- | 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 :: Monad mo => GGWidget m mo () -> GGWidget m mo (Hamlet (Route m)) extractBody (GWidget w) = GWidget $ mapRWST (liftM go) w where
runtests.hs view
@@ -1,9 +1,15 @@ import Test.Framework (defaultMain) import Test.CleanPath import Test.Exceptions+import Test.Widget+import Test.Media+import Test.Links main :: IO () main = defaultMain [ cleanPathTest , exceptionsTest+ , widgetTest+ , mediaTest+ , linksTest ]
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 0.7.0.2+version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -8,12 +8,12 @@ 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.+ 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://docs.yesodweb.com/+homepage: http://www.yesodweb.com/ flag test description: Build the executable to run unit tests@@ -28,26 +28,27 @@ 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+ , 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- , web-routes-quasi >= 0.6.3.1 && < 0.7- , hamlet >= 0.7 && < 0.8- , blaze-builder >= 0.2.1 && < 0.3+ , web-routes-quasi >= 0.7 && < 0.8+ , hamlet >= 0.8 && < 0.9+ , blaze-builder >= 0.2.1 && < 0.4 , transformers >= 0.2 && < 0.3- , clientsession >= 0.4.0 && < 0.5+ , 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- , 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+ , monad-control >= 0.2 && < 0.3+ , enumerator >= 0.4.7 && < 0.5+ , cookie >= 0.2.1 && < 0.3 , blaze-html >= 0.4 && < 0.5+ , http-types >= 0.6 && < 0.7+ , case-insensitive >= 0.2 && < 0.3 exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch@@ -55,11 +56,14 @@ Yesod.Request Yesod.Widget other-modules: Yesod.Internal+ Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request Yesod.Internal.Dispatch Paths_yesod_core ghc-options: -Wall+ if flag(test)+ Buildable: False executable runtests if flag(ghc7)