yesod-core 1.1.8.3 → 1.2.0
raw patch · 50 files changed
+4436/−3642 lines, 50 filesdep +attoparsec-conduitdep +data-defaultdep +safedep ~clientsessiondep ~containersdep ~lifted-base
Dependencies added: attoparsec-conduit, data-default, safe, warp
Dependency ranges changed: clientsession, containers, lifted-base, monad-logger, resourcet, wai, wai-test, yesod-routes
Files
- Yesod/Content.hs +0/−263
- Yesod/Core.hs +82/−19
- Yesod/Core/Class/Breadcrumbs.hs +31/−0
- Yesod/Core/Class/Dispatch.hs +43/−0
- Yesod/Core/Class/Handler.hs +92/−0
- Yesod/Core/Class/Yesod.hs +603/−0
- Yesod/Core/Content.hs +278/−0
- Yesod/Core/Dispatch.hs +193/−0
- Yesod/Core/Handler.hs +1028/−0
- Yesod/Core/Internal.hs +7/−0
- Yesod/Core/Internal/LiteApp.hs +82/−0
- Yesod/Core/Internal/Request.hs +176/−0
- Yesod/Core/Internal/Response.hs +85/−0
- Yesod/Core/Internal/Run.hs +286/−0
- Yesod/Core/Internal/Session.hs +68/−0
- Yesod/Core/Internal/TH.hs +136/−0
- Yesod/Core/Internal/Util.hs +46/−0
- Yesod/Core/Json.hs +112/−0
- Yesod/Core/Types.hs +444/−0
- Yesod/Core/Widget.hs +270/−0
- Yesod/Dispatch.hs +0/−223
- Yesod/Handler.hs +0/−1071
- Yesod/Internal.hs +0/−138
- Yesod/Internal/Cache.hs +0/−38
- Yesod/Internal/Core.hs +0/−928
- Yesod/Internal/Request.hs +0/−183
- Yesod/Internal/Session.hs +0/−161
- Yesod/Internal/TestApi.hs +0/−11
- Yesod/Message.hs +0/−6
- Yesod/Request.hs +0/−108
- Yesod/Widget.hs +0/−369
- test/YesodCoreTest.hs +10/−0
- test/YesodCoreTest/Auth.hs +68/−0
- test/YesodCoreTest/Cache.hs +19/−16
- test/YesodCoreTest/CleanPath.hs +11/−4
- test/YesodCoreTest/Exceptions.hs +3/−3
- test/YesodCoreTest/InternalRequest.hs +23/−12
- test/YesodCoreTest/JsLoader.hs +2/−7
- test/YesodCoreTest/JsLoaderSites/HeadAsync.hs +0/−16
- test/YesodCoreTest/Json.hs +52/−0
- test/YesodCoreTest/Links.hs +28/−2
- test/YesodCoreTest/LiteApp.hs +42/−0
- test/YesodCoreTest/Media.hs +3/−4
- test/YesodCoreTest/MediaData.hs +1/−1
- test/YesodCoreTest/NoOverloadedStrings.hs +54/−9
- test/YesodCoreTest/Redirect.hs +1/−1
- test/YesodCoreTest/RequestBodySize.hs +8/−6
- test/YesodCoreTest/Widget.hs +11/−11
- test/YesodCoreTest/YesodTest.hs +2/−2
- yesod-core.cabal +36/−30
− Yesod/Content.hs
@@ -1,263 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Yesod.Content- ( -- * Content- Content (..)- , emptyContent- , ToContent (..)- -- * Mime types- -- ** Data type- , ContentType- , typeHtml- , typePlain- , typeJson- , typeXml- , typeAtom- , typeRss- , typeJpeg- , typePng- , typeGif- , typeSvg- , typeJavascript- , typeCss- , typeFlv- , typeOgv- , typeOctet- -- * Utilities- , simpleContentType- -- * Evaluation strategy- , DontFullyEvaluate (..)- -- * Representations- , ChooseRep- , HasReps (..)- , defChooseRep- -- ** Specific content types- , RepHtml (..)- , RepJson (..)- , RepHtmlJson (..)- , RepPlain (..)- , RepXml (..)- -- * Utilities- , formatW3- , formatRFC1123- , formatRFC822- ) where--import Data.Maybe (mapMaybe)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Text.Lazy (Text, pack)-import qualified Data.Text as T--import Data.Time-import System.Locale--import qualified Data.Text.Encoding-import qualified Data.Text.Lazy.Encoding--import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)-import Data.Monoid (mempty)--import Text.Hamlet (Html)-import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)-import Data.String (IsString (fromString))-import Network.Wai (FilePart)-import Data.Conduit (Source, ResourceT, Flush)--import qualified Data.Aeson as J-import Data.Aeson.Encode (fromValue)-import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze-import Data.Text.Lazy.Builder (toLazyText)--data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length.- | ContentSource !(Source (ResourceT IO) (Flush Builder))- | ContentFile !FilePath !(Maybe FilePart)- | ContentDontEvaluate !Content---- | Zero-length enumerator.-emptyContent :: Content-emptyContent = ContentBuilder mempty $ Just 0--instance IsString Content where- fromString = toContent---- | Anything which can be converted into 'Content'. Most of the time, you will--- want to use the 'ContentBuilder' constructor. An easier approach will be to use--- a pre-defined 'toContent' function, such as converting your data into a lazy--- bytestring and then calling 'toContent' on that.------ Please note that the built-in instances for lazy data structures ('String',--- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include--- the content length for the 'ContentBuilder' constructor.-class ToContent a where- toContent :: a -> Content--instance ToContent Builder where- toContent = flip ContentBuilder Nothing-instance ToContent B.ByteString where- toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs-instance ToContent L.ByteString where- toContent = flip ContentBuilder Nothing . fromLazyByteString-instance ToContent T.Text where- toContent = toContent . Data.Text.Encoding.encodeUtf8-instance ToContent Text where- toContent = toContent . Data.Text.Lazy.Encoding.encodeUtf8-instance ToContent String where- toContent = toContent . pack-instance ToContent Html where- toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing---- | A function which gives targetted representations of content based on the--- content-types the user accepts.-type ChooseRep =- [ContentType] -- ^ list of content-types user accepts, ordered by preference- -> IO (ContentType, Content)---- | Any type which can be converted to representations.-class HasReps a where- chooseRep :: a -> ChooseRep---- | A helper method for generating 'HasReps' instances.------ This function should be given a list of pairs of content type and conversion--- functions. If none of the content types match, the first pair is used.-defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep-defChooseRep reps a ts = do- let (ct, c) =- case mapMaybe helper ts of- (x:_) -> x- [] -> case reps of- [] -> error "Empty reps to defChooseRep"- (x:_) -> x- c' <- c a- return (ct, c')- where- helper ct = do- c <- lookup ct reps- return (ct, c)--instance HasReps ChooseRep where- chooseRep = id--instance HasReps () where- chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)]--instance HasReps (ContentType, Content) where- chooseRep = const . return--instance HasReps [(ContentType, Content)] where- chooseRep a cts = return $- case filter (\(ct, _) -> go ct `elem` map go cts) a of- ((ct, c):_) -> (ct, c)- _ -> case a of- (x:_) -> x- _ -> error "chooseRep [(ContentType, Content)] of empty"- where- go = simpleContentType--newtype RepHtml = RepHtml Content-instance HasReps RepHtml where- chooseRep (RepHtml c) _ = return (typeHtml, c)-newtype RepJson = RepJson Content-instance HasReps RepJson where- chooseRep (RepJson c) _ = return (typeJson, c)-data RepHtmlJson = RepHtmlJson Content Content-instance HasReps RepHtmlJson where- chooseRep (RepHtmlJson html json) = chooseRep- [ (typeHtml, html)- , (typeJson, json)- ]-newtype RepPlain = RepPlain Content-instance HasReps RepPlain where- chooseRep (RepPlain c) _ = return (typePlain, c)-newtype RepXml = RepXml Content-instance HasReps RepXml where- chooseRep (RepXml c) _ = return (typeXml, c)--type ContentType = B.ByteString -- FIXME Text?--typeHtml :: ContentType-typeHtml = "text/html; charset=utf-8"--typePlain :: ContentType-typePlain = "text/plain; charset=utf-8"--typeJson :: ContentType-typeJson = "application/json; charset=utf-8"--typeXml :: ContentType-typeXml = "text/xml"--typeAtom :: ContentType-typeAtom = "application/atom+xml"--typeRss :: ContentType-typeRss = "application/rss+xml"--typeJpeg :: ContentType-typeJpeg = "image/jpeg"--typePng :: ContentType-typePng = "image/png"--typeGif :: ContentType-typeGif = "image/gif"--typeSvg :: ContentType-typeSvg = "image/svg+xml"--typeJavascript :: ContentType-typeJavascript = "text/javascript; charset=utf-8"--typeCss :: ContentType-typeCss = "text/css; charset=utf-8"--typeFlv :: ContentType-typeFlv = "video/x-flv"--typeOgv :: ContentType-typeOgv = "video/ogg"--typeOctet :: ContentType-typeOctet = "application/octet-stream"---- | Removes \"extra\" information at the end of a content type string. In--- particular, removes everything after the semicolon, if present.------ For example, \"text/html; charset=utf-8\" is commonly used to specify the--- character encoding for HTML data. This function would return \"text/html\".-simpleContentType :: ContentType -> ContentType-simpleContentType = fst . B.breakByte 59 -- 59 == ;---- | Format a 'UTCTime' in W3 format.-formatW3 :: UTCTime -> T.Text-formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"---- | Format as per RFC 1123.-formatRFC1123 :: UTCTime -> T.Text-formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"---- | Format as per RFC 822.-formatRFC822 :: UTCTime -> T.Text-formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"---- | Prevents a response body from being fully evaluated before sending the--- request.------ Since 1.1.0-newtype DontFullyEvaluate a = DontFullyEvaluate a--instance HasReps a => HasReps (DontFullyEvaluate a) where- chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a--instance ToContent a => ToContent (DontFullyEvaluate a) where- toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a--instance ToContent J.Value where- toContent = flip ContentBuilder Nothing- . Blaze.fromLazyText- . toLazyText- . fromValue
Yesod/Core.hs view
@@ -1,16 +1,24 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module Yesod.Core ( -- * Type classes Yesod (..) , YesodDispatch (..)+ , YesodSubDispatch (..) , RenderRoute (..)+ , ParseRoute (..)+ , RouteAttrs (..) -- ** Breadcrumbs , YesodBreadcrumbs (..) , breadcrumbs -- * Types , Approot (..) , FileUpload (..)+ , ErrorResponse (..) -- * Utitlities , maybeAuthorized , widgetToPageContent@@ -35,41 +43,96 @@ , SessionBackend (..) , defaultClientSessionBackend , clientSessionBackend- , clientSessionBackend2 , clientSessionDateCacher , loadClientSession , Header(..)- , BackendSession -- * JS loaders- , loadJsYepnope , ScriptLoadPosition (..) , BottomOfHeadAsync+ -- * Subsites+ , MonadHandler (..)+ , MonadWidget (..)+ , getRouteToParent+ , defaultLayoutSub -- * Misc , yesodVersion , yesodRender , runFakeHandler+ -- * LiteApp+ , module Yesod.Core.Internal.LiteApp+ -- * Low-level+ , yesodRunner -- * Re-exports- , module Yesod.Content- , module Yesod.Dispatch- , module Yesod.Handler- , module Yesod.Request- , module Yesod.Widget- , module Yesod.Message+ , module Yesod.Core.Content+ , module Yesod.Core.Dispatch+ , module Yesod.Core.Handler+ , module Yesod.Core.Widget+ , module Yesod.Core.Json+ , module Text.Shakespeare.I18N+ , module Yesod.Core.Internal.Util+ , module Text.Blaze.Html+ , MonadTrans (..)+ , MonadIO (..)+ , MonadBase (..)+ , MonadBaseControl+ , MonadResource (..)+ , MonadLogger ) where -import Yesod.Internal.Core-import Yesod.Internal (Header(..))-import Yesod.Content-import Yesod.Dispatch-import Yesod.Handler-import Yesod.Request-import Yesod.Widget-import Yesod.Message+import Yesod.Core.Content+import Yesod.Core.Dispatch+import Yesod.Core.Handler+import Yesod.Core.Class.Handler+import Yesod.Core.Widget+import Yesod.Core.Json+import Yesod.Core.Types+import Text.Shakespeare.I18N+import Yesod.Core.Internal.Util (formatW3 , formatRFC1123 , formatRFC822)+import Text.Blaze.Html (Html, toHtml, preEscapedToMarkup) import Control.Monad.Logger+import Control.Monad.Trans.Class (MonadTrans (..))+import Yesod.Core.Internal.Session+import Yesod.Core.Internal.Run (yesodRunner)+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Class.Breadcrumbs+import Yesod.Core.Internal.Run (yesodRender, runFakeHandler)+import qualified Paths_yesod_core+import Data.Version (showVersion)+import Yesod.Routes.Class+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Base (MonadBase (..))+import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Resource (MonadResource (..))+import Yesod.Core.Internal.LiteApp+ -- | Return an 'Unauthorized' value, with the given i18n message.-unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult-unauthorizedI msg =do+unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult+unauthorizedI msg = do mr <- getMessageRender return $ Unauthorized $ mr msg++yesodVersion :: String+yesodVersion = showVersion Paths_yesod_core.version++-- | Return the same URL if the user is authorized to see it.+--+-- Built on top of 'isAuthorized'. This is useful for building page that only+-- contain links to pages the user is allowed to see.+maybeAuthorized :: Yesod site+ => Route site+ -> Bool -- ^ is this a write request?+ -> HandlerT site IO (Maybe (Route site))+maybeAuthorized r isWrite = do+ x <- isAuthorized r isWrite+ return $ if x == Authorized then Just r else Nothing++getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)+getRouteToParent = HandlerT $ return . handlerToParent++defaultLayoutSub :: Yesod parent+ => WidgetT child IO ()+ -> HandlerT child (HandlerT parent IO) Html+defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout
+ Yesod/Core/Class/Breadcrumbs.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+module Yesod.Core.Class.Breadcrumbs where++import Yesod.Core.Handler+import Yesod.Routes.Class+import Data.Text (Text)++-- | A type-safe, concise method of creating breadcrumbs for pages. For each+-- resource, you declare the title of the page and the parent resource (if+-- present).+class YesodBreadcrumbs site where+ -- | Returns the title and the parent resource, if available. If you return+ -- a 'Nothing', then this is considered a top-level page.+ breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site))++-- | Gets the title of the current page and the hierarchy of parent pages,+-- along with their respective titles.+breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)])+breadcrumbs = do+ x <- getCurrentRoute+ case x of+ Nothing -> return ("Not found", [])+ Just y -> do+ (title, next) <- breadcrumb y+ z <- go [] next+ return (title, z)+ where+ go back Nothing = return back+ go back (Just this) = do+ (title, next) <- breadcrumb this+ go ((this, title) : back) next
+ Yesod/Core/Class/Dispatch.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Core.Class.Dispatch where++import Yesod.Routes.Class+import qualified Network.Wai as W+import Yesod.Core.Types+import Yesod.Core.Content+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Handler+import Yesod.Core.Internal.Run++-- | This class is automatically instantiated when you use the template haskell+-- mkYesod function. You should never need to deal with it directly.+class Yesod site => YesodDispatch site where+ yesodDispatch :: YesodRunnerEnv site -> W.Application++class YesodSubDispatch sub m where+ yesodSubDispatch :: YesodSubRunnerEnv sub (HandlerSite m) m+ -> W.Application++instance YesodSubDispatch WaiSubsite master where+ yesodSubDispatch YesodSubRunnerEnv {..} req =+ app req+ where+ WaiSubsite app = ysreGetSub $ yreSite $ ysreParentEnv++-- | A helper function for creating YesodSubDispatch instances, used by the+-- internal generated code.+subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.+ => HandlerT child (HandlerT parent m) TypedContent+ -> YesodSubRunnerEnv child parent (HandlerT parent m)+ -> Maybe (Route child)+ -> W.Application+subHelper handlert YesodSubRunnerEnv {..} route =+ ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)+ where+ base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route
+ Yesod/Core/Class/Handler.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module Yesod.Core.Class.Handler+ ( MonadHandler (..)+ , MonadWidget (..)+ ) where++import Yesod.Core.Types+import Data.Monoid (mempty)+import Control.Monad (liftM)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..))+import Control.Monad.Trans.Class (lift)+import Data.Monoid (Monoid)+import Data.Conduit.Internal (Pipe, ConduitM)++import Control.Monad.Trans.Identity ( IdentityT)+import Control.Monad.Trans.List ( ListT )+import Control.Monad.Trans.Maybe ( MaybeT )+import Control.Monad.Trans.Error ( ErrorT, Error)+import Control.Monad.Trans.Reader ( ReaderT )+import Control.Monad.Trans.State ( StateT )+import Control.Monad.Trans.Writer ( WriterT )+import Control.Monad.Trans.RWS ( RWST )+import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )+import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )++class MonadResource m => MonadHandler m where+ type HandlerSite m+ liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a++replaceToParent :: HandlerData site route -> HandlerData site ()+replaceToParent hd = hd { handlerToParent = const () }++instance MonadResourceBase m => MonadHandler (HandlerT site m) where+ type HandlerSite (HandlerT site m) = site+ liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent+{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-}++instance MonadResourceBase m => MonadHandler (WidgetT site m) where+ type HandlerSite (WidgetT site m) = site+ liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent+{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-}++#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+GO(ExceptionT)+GO(Pipe l i o u)+GO(ConduitM i o)+#undef GO+#undef GOX++class MonadHandler m => MonadWidget m where+ liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a+instance MonadResourceBase m => MonadWidget (WidgetT site m) where+ liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent++#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT+#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT+GO(IdentityT)+GO(ListT)+GO(MaybeT)+GOX(Error e, ErrorT e)+GO(ReaderT r)+GO(StateT s)+GOX(Monoid w, WriterT w)+GOX(Monoid w, RWST r w s)+GOX(Monoid w, Strict.RWST r w s)+GO(Strict.StateT s)+GOX(Monoid w, Strict.WriterT w)+GO(ExceptionT)+GO(Pipe l i o u)+GO(ConduitM i o)+#undef GO+#undef GOX
+ Yesod/Core/Class/Yesod.hs view
@@ -0,0 +1,603 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Core.Class.Yesod where++import Control.Monad.Logger (logErrorS)+import Yesod.Core.Content+import Yesod.Core.Handler++import Yesod.Routes.Class++import Blaze.ByteString.Builder (Builder)+import Blaze.ByteString.Builder.Char.Utf8 (fromText)+import Control.Arrow ((***))+import Control.Monad (forM, when, void)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),+ LogSource)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import Data.Aeson (object, (.=))+import Data.List (foldl')+import Data.List (nub)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Encoding (encodeUtf8)+import Data.Word (Word64)+import Language.Haskell.TH.Syntax (Loc (..))+import Network.HTTP.Types (encodePath)+import qualified Network.Wai as W+import Data.Default (def)+import Network.Wai.Parse (lbsBackEnd,+ tempFileBackEnd)+import System.IO (stdout)+import System.Log.FastLogger (LogStr (..), Logger,+ loggerDate, loggerPutStr,+ mkLogger)+import System.Log.FastLogger.Date (ZonedDate)+import Text.Blaze (customAttribute, textTag,+ toValue, (!))+import Text.Blaze (preEscapedToMarkup)+import qualified Text.Blaze.Html5 as TBH+import Text.Hamlet+import Text.Julius+import qualified Web.ClientSession as CS+import Web.Cookie (parseCookies)+import Web.Cookie (SetCookie (..))+import Yesod.Core.Types+import Yesod.Core.Internal.Session+import Yesod.Core.Widget+import Control.Monad.Trans.Class (lift)++-- | Define settings for a Yesod applications. All methods have intelligent+-- defaults, and therefore no implementation is required.+class RenderRoute site => Yesod site where+ -- | An absolute URL to the root of the application. Do not include+ -- trailing slash.+ --+ -- Default value: 'ApprootRelative'. This is valid under the following+ -- conditions:+ --+ -- * Your application is served from the root of the domain.+ --+ -- * You do not use any features that require absolute URLs, such as Atom+ -- feeds and XML sitemaps.+ --+ -- If this is not true, you should override with a different+ -- implementation.+ approot :: Approot site+ approot = ApprootRelative++ -- | Output error response pages.+ --+ -- Default value: 'defaultErrorHandler'.+ errorHandler :: ErrorResponse -> HandlerT site IO TypedContent+ errorHandler = defaultErrorHandler++ -- | Applies some form of layout to the contents of a page.+ defaultLayout :: WidgetT site IO () -> HandlerT site IO RepHtml+ defaultLayout w = do+ p <- widgetToPageContent w+ mmsg <- getMessage+ hamletToRepHtml [hamlet|+ $newline never+ $doctype 5+ <html>+ <head>+ <title>#{pageTitle p}+ ^{pageHead p}+ <body>+ $maybe msg <- mmsg+ <p .message>#{msg}+ ^{pageBody p}+ |]++ -- | Override the rendering function for a particular URL. One use case for+ -- this is to offload static hosting to a different domain name to avoid+ -- sending cookies.+ urlRenderOverride :: site -> Route site -> Maybe Builder+ urlRenderOverride _ _ = Nothing++ -- | Determine if a request is authorized or not.+ --+ -- Return 'Authorized' if the request is authorized,+ -- 'Unauthorized' a message if unauthorized.+ -- If authentication is required, return 'AuthenticationRequired'.+ isAuthorized :: Route site+ -> Bool -- ^ is this a write request?+ -> HandlerT site IO AuthResult+ isAuthorized _ _ = return Authorized++ -- | Determines whether the current request is a write request. By default,+ -- this assumes you are following RESTful principles, and determines this+ -- from request method. In particular, all except the following request+ -- methods are considered write: GET HEAD OPTIONS TRACE.+ --+ -- This function is used to determine if a request is authorized; see+ -- 'isAuthorized'.+ isWriteRequest :: Route site -> HandlerT site IO Bool+ isWriteRequest _ = do+ wai <- waiRequest+ return $ W.requestMethod wai `notElem`+ ["GET", "HEAD", "OPTIONS", "TRACE"]++ -- | The default route for authentication.+ --+ -- Used in particular by 'isAuthorized', but library users can do whatever+ -- they want with it.+ authRoute :: site -> Maybe (Route site)+ authRoute _ = Nothing++ -- | A function used to clean up path segments. It returns 'Right' with a+ -- clean path or 'Left' with a new set of pieces the user should be+ -- redirected to. The default implementation enforces:+ --+ -- * No double slashes+ --+ -- * There is no trailing slash.+ --+ -- Note that versions of Yesod prior to 0.7 used a different set of rules+ -- involing trailing slashes.+ cleanPath :: site -> [Text] -> Either [Text] [Text]+ cleanPath _ s =+ if corrected == s+ then Right $ map dropDash s+ else Left corrected+ where+ corrected = filter (not . T.null) s+ dropDash t+ | T.all (== '-') t = T.drop 1 t+ | otherwise = t++ -- | Builds an absolute URL by concatenating the application root with the+ -- pieces of a path and a query string, if any.+ -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.+ joinPath :: site+ -> T.Text -- ^ application root+ -> [T.Text] -- ^ path pieces+ -> [(T.Text, T.Text)] -- ^ query string+ -> Builder+ joinPath _ ar pieces' qs' =+ fromText ar `mappend` encodePath pieces qs+ where+ pieces = if null pieces' then [""] else map addDash pieces'+ qs = map (TE.encodeUtf8 *** go) qs'+ go "" = Nothing+ go x = Just $ TE.encodeUtf8 x+ addDash t+ | T.all (== '-') t = T.cons '-' t+ | otherwise = t++ -- | This function is used to store some static content to be served as an+ -- external file. The most common case of this is stashing CSS and+ -- JavaScript content in an external file; the "Yesod.Widget" module uses+ -- this feature.+ --+ -- The return value is 'Nothing' if no storing was performed; this is the+ -- default implementation. A 'Just' 'Left' gives the absolute URL of the+ -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is+ -- necessary when you are serving the content outside the context of a+ -- Yesod application, such as via memcached.+ addStaticContent :: Text -- ^ filename extension+ -> Text -- ^ mime-type+ -> L.ByteString -- ^ content+ -> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)])))+ addStaticContent _ _ _ = return Nothing++ -- | Maximum allowed length of the request body, in bytes.+ --+ -- If @Nothing@, no maximum is applied.+ --+ -- Default: 2 megabytes.+ maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64+ maximumContentLength _ _ = Just $ 2 * 1024 * 1024 -- 2 megabytes++ -- | Creates a @Logger@ to use for log messages.+ --+ -- Note that a common technique (endorsed by the scaffolding) is to create+ -- a @Logger@ value and place it in your foundation datatype, and have this+ -- method return that already created value. That way, you can use that+ -- same @Logger@ for printing messages during app initialization.+ --+ -- Default: Sends to stdout and automatically flushes on each write.+ makeLogger :: site -> IO Logger+ makeLogger _ = mkLogger True stdout++ -- | Send a message to the @Logger@ provided by @getLogger@.+ --+ -- Default implementation: checks if the message should be logged using+ -- 'shouldLog' and, if so, formats using 'formatLogMessage'.+ messageLoggerSource :: site+ -> Logger+ -> Loc -- ^ position in source code+ -> LogSource+ -> LogLevel+ -> LogStr -- ^ message+ -> IO ()+ messageLoggerSource a logger loc source level msg =+ when (shouldLog a source level) $+ formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger++ -- | Where to Load sripts from. We recommend the default value,+ -- 'BottomOfBody'. Alternatively use the built in async yepnope loader:+ --+ -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js+ --+ -- Or write your own async js loader.+ jsLoader :: site -> ScriptLoadPosition site+ jsLoader _ = BottomOfBody++ -- | Create a session backend. Returning `Nothing' disables sessions.+ --+ -- Default: Uses clientsession with a 2 hour timeout.+ makeSessionBackend :: site -> IO (Maybe SessionBackend)+ makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 CS.defaultKeyFile++ -- | How to store uploaded files.+ --+ -- Default: When the request body is greater than 50kb, store in a temp+ -- file. For chunked request bodies, store in a temp file. Otherwise, store+ -- in memory.+ fileUpload :: site -> W.RequestBodyLength -> FileUpload+ fileUpload _ (W.KnownLength size)+ | size <= 50000 = FileUploadMemory lbsBackEnd+ fileUpload _ _ = FileUploadDisk tempFileBackEnd++ -- | Should we log the given log source/level combination.+ --+ -- Default: Logs everything at or above 'logLevel'+ shouldLog :: site -> LogSource -> LogLevel -> Bool+ shouldLog _ _ level = level >= LevelInfo++ -- | A Yesod middleware, which will wrap every handler function. This+ -- allows you to run code before and after a normal handler.+ --+ -- Default: the 'defaultYesodMiddleware' function.+ --+ -- Since: 1.1.6+ yesodMiddleware :: HandlerT site IO res -> HandlerT site IO res+ yesodMiddleware = defaultYesodMiddleware++-- | Default implementation of 'yesodMiddleware'. Adds the response header+-- \"Vary: Accept, Accept-Language\" and performs authorization checks.+--+-- Since 1.2.0+defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res+defaultYesodMiddleware handler = do+ addHeader "Vary" "Accept, Accept-Language"+ authorizationCheck+ handler++-- | Check if a given request is authorized via 'isAuthorized' and+-- 'isWriteRequest'.+--+-- Since 1.2.0+authorizationCheck :: Yesod site => HandlerT site IO ()+authorizationCheck = do+ getCurrentRoute >>= maybe (return ()) checkUrl+ where+ checkUrl url = do+ isWrite <- isWriteRequest url+ ar <- isAuthorized url isWrite+ case ar of+ Authorized -> return ()+ AuthenticationRequired -> do+ master <- getYesod+ case authRoute master of+ Nothing -> void $ notAuthenticated+ Just url' -> do+ void $ selectRep $ do+ provideRepType typeHtml $ do+ setUltDestCurrent+ void $ redirect url'+ provideRepType typeJson $+ void $ notAuthenticated+ Unauthorized s' -> permissionDenied s'++-- | Convert a widget to a 'PageContent'.+widgetToPageContent :: (Eq (Route site), Yesod site)+ => WidgetT site IO ()+ -> HandlerT site IO (PageContent (Route site))+widgetToPageContent w = do+ master <- getYesod+ hd <- HandlerT return+ ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- lift $ unWidgetT w hd+ let title = maybe mempty unTitle mTitle+ scripts = runUniqueList scripts'+ stylesheets = runUniqueList stylesheets'++ render <- getUrlRenderParams+ let renderLoc x =+ case x of+ Nothing -> Nothing+ Just (Left s) -> Just s+ Just (Right (u, p)) -> Just $ render u p+ css <- forM (Map.toList style) $ \(mmedia, content) -> do+ let rendered = toLazyText $ content render+ x <- addStaticContent "css" "text/css; charset=utf-8"+ $ encodeUtf8 rendered+ return (mmedia,+ case x of+ Nothing -> Left $ preEscapedToMarkup rendered+ Just y -> Right $ either id (uncurry render) y)+ jsLoc <-+ case jscript of+ Nothing -> return Nothing+ Just s -> do+ x <- addStaticContent "js" "text/javascript; charset=utf-8"+ $ encodeUtf8 $ renderJavascriptUrl render s+ return $ renderLoc x++ -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing+ -- the asynchronous loader means your page doesn't have to wait for all the js to load+ let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc+ regularScriptLoad = [hamlet|+ $newline never+ $forall s <- scripts+ ^{mkScriptTag s}+ $maybe j <- jscript+ $maybe s <- jsLoc+ <script src="#{s}">+ $nothing+ <script>^{jelper j}+ |]++ headAll = [hamlet|+ $newline never+ \^{head'}+ $forall s <- stylesheets+ ^{mkLinkTag s}+ $forall s <- css+ $maybe t <- right $ snd s+ $maybe media <- fst s+ <link rel=stylesheet media=#{media} href=#{t}>+ $nothing+ <link rel=stylesheet href=#{t}>+ $maybe content <- left $ snd s+ $maybe media <- fst s+ <style media=#{media}>#{content}+ $nothing+ <style>#{content}+ $case jsLoader master+ $of BottomOfBody+ $of BottomOfHeadAsync asyncJsLoader+ ^{asyncJsLoader asyncScripts mcomplete}+ $of BottomOfHeadBlocking+ ^{regularScriptLoad}+ |]+ let bodyScript = [hamlet|+ $newline never+ ^{body}+ ^{regularScriptLoad}+ |]++ return $ PageContent title headAll $+ case jsLoader master of+ BottomOfBody -> bodyScript+ _ -> body+ where+ renderLoc' render' (Local url) = render' url []+ renderLoc' _ (Remote s) = s++ addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)+ mkScriptTag (Script loc attrs) render' =+ foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()+ mkLinkTag (Stylesheet loc attrs) render' =+ foldl' addAttr TBH.link+ ( ("rel", "stylesheet")+ : ("href", renderLoc' render' loc)+ : attrs+ )++ runUniqueList :: Eq x => UniqueList x -> [x]+ runUniqueList (UniqueList x) = nub $ x []++-- | The default error handler for 'errorHandler'.+defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent+defaultErrorHandler NotFound = selectRep $ do+ provideRep $ defaultLayout $ do+ r <- waiRequest+ let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r+ setTitle "Not Found"+ toWidget [hamlet|+ <h1>Not Found+ <p>#{path'}+ |]+ provideRep $ return $ object ["message" .= ("Not Found" :: Text)]++-- For API requests.+-- For a user with a browser,+-- if you specify an authRoute the user will be redirected there and+-- this page will not be shown.+defaultErrorHandler NotAuthenticated = selectRep $ do+ provideRep $ defaultLayout $ do+ setTitle "Not logged in"+ toWidget [hamlet|+ <h1>Not logged in+ <p style="display:none;">Set the authRoute and the user will be redirected there.+ |]++ provideRep $ do+ -- 401 *MUST* include a WWW-Authenticate header+ -- however, there is no standard to indicate a redirection+ --+ -- change this to Basic or Digest if you allow those forms of authentications+ addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\""++ -- The client will just use the authentication_url in the JSON+ site <- getYesod+ rend <- getUrlRender+ return $ object $ [+ "message" .= ("Not logged in"::Text)+ ] +++ case authRoute site of+ Nothing -> []+ Just url -> ["authentication_url" .= rend url]++defaultErrorHandler (PermissionDenied msg) = selectRep $ do+ provideRep $ defaultLayout $ do+ setTitle "Permission Denied"+ toWidget [hamlet|+ <h1>Permission denied+ <p>#{msg}+ |]+ provideRep $+ return $ object $ [+ "message" .= ("Permission Denied. " <> msg)+ ]++defaultErrorHandler (InvalidArgs ia) = selectRep $ do+ provideRep $ defaultLayout $ do+ setTitle "Invalid Arguments"+ toWidget [hamlet|+ <h1>Invalid Arguments+ <ul>+ $forall msg <- ia+ <li>#{msg}+ |]+ provideRep $ return $ object ["message" .= ("Invalid Arguments" :: Text), "errors" .= ia]+defaultErrorHandler (InternalError e) = do+ $logErrorS "yesod-core" e+ selectRep $ do+ provideRep $ defaultLayout $ do+ setTitle "Internal Server Error"+ toWidget [hamlet|+ <h1>Internal Server Error+ <pre>#{e}+ |]+ provideRep $ return $ object ["message" .= ("Internal Server Error" :: Text), "error" .= e]+defaultErrorHandler (BadMethod m) = selectRep $ do+ provideRep $ defaultLayout $ do+ setTitle"Bad Method"+ toWidget [hamlet|+ <h1>Method Not Supported+ <p>Method <code>#{S8.unpack m}</code> not supported+ |]+ provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]++asyncHelper :: (url -> [x] -> Text)+ -> [Script (url)]+ -> Maybe (JavascriptUrl (url))+ -> Maybe Text+ -> (Maybe (HtmlUrl url), [Text])+asyncHelper render scripts jscript jsLoc =+ (mcomplete, scripts'')+ where+ scripts' = map goScript scripts+ scripts'' =+ case jsLoc of+ Just s -> scripts' ++ [s]+ Nothing -> scripts'+ goScript (Script (Local url) _) = render url []+ goScript (Script (Remote s) _) = s+ mcomplete =+ case jsLoc of+ Just{} -> Nothing+ Nothing ->+ case jscript of+ Nothing -> Nothing+ Just j -> Just $ jelper j++formatLogMessage :: IO ZonedDate+ -> Loc+ -> LogSource+ -> LogLevel+ -> LogStr -- ^ message+ -> IO [LogStr]+formatLogMessage getdate loc src level msg = do+ now <- getdate+ return+ [ LB now+ , LB " ["+ , LS $+ case level of+ LevelOther t -> T.unpack t+ _ -> drop 5 $ show level+ , LS $+ if T.null src+ then ""+ else "#" ++ T.unpack src+ , LB "] "+ , msg+ , LB " @("+ , LS $ fileLocationToString loc+ , LB ")\n"+ ]++defaultClientSessionBackend :: Int -- ^ minutes+ -> FilePath -- ^ key file+ -> IO SessionBackend+defaultClientSessionBackend minutes fp = do+ key <- CS.getKey fp+ let timeout = fromIntegral (minutes * 60)+ (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout+ return $ clientSessionBackend key getCachedDate++jsToHtml :: Javascript -> Html+jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b++jelper :: JavascriptUrl url -> HtmlUrl url+jelper = fmap jsToHtml++left :: Either a b -> Maybe a+left (Left x) = Just x+left _ = Nothing++right :: Either a b -> Maybe b+right (Right x) = Just x+right _ = Nothing++clientSessionBackend :: CS.Key -- ^ The encryption key+ -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'+ -> SessionBackend+clientSessionBackend key getCachedDate =+ SessionBackend {+ sbLoadSession = loadClientSession key getCachedDate "_SESSION"+ }++loadClientSession :: CS.Key+ -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'+ -> S8.ByteString -- ^ session name+ -> W.Request+ -> IO (SessionMap, SaveSession)+loadClientSession key getCachedDate sessionName req = load+ where+ load = do+ date <- getCachedDate+ return (sess date, save date)+ sess date = fromMaybe Map.empty $ do+ raw <- lookup "Cookie" $ W.requestHeaders req+ val <- lookup sessionName $ parseCookies raw+ let host = "" -- fixme, properly lock sessions to client address+ decodeClientSession key date host val+ save date sess' = do+ -- We should never cache the IV! Be careful!+ iv <- liftIO CS.randomIV+ return [AddCookie def+ { setCookieName = sessionName+ , setCookieValue = encodeClientSession key iv date host sess'+ , setCookiePath = Just "/"+ , setCookieExpires = Just (csdcExpires date)+ , setCookieDomain = Nothing+ , setCookieHttpOnly = True+ }]+ where+ host = "" -- fixme, properly lock sessions to client address++-- taken from file-location package+-- turn the TH Loc loaction information into a human readable string+-- leaving out the loc_end parameter+fileLocationToString :: Loc -> String+fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) +++ ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)+ where+ line = show . fst . loc_start+ char = show . snd . loc_start
+ Yesod/Core/Content.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Yesod.Core.Content+ ( -- * Content+ Content (..)+ , emptyContent+ , ToContent (..)+ , ToFlushBuilder (..)+ -- * Mime types+ -- ** Data type+ , ContentType+ , typeHtml+ , typePlain+ , typeJson+ , typeXml+ , typeAtom+ , typeRss+ , typeJpeg+ , typePng+ , typeGif+ , typeSvg+ , typeJavascript+ , typeCss+ , typeFlv+ , typeOgv+ , typeOctet+ -- * Utilities+ , simpleContentType+ , contentTypeTypes+ -- * Evaluation strategy+ , DontFullyEvaluate (..)+ -- * Representations+ , TypedContent (..)+ , ToTypedContent (..)+ , HasContentType (..)+ -- ** Specific content types+ , RepHtml+ , RepJson (..)+ , RepPlain (..)+ , RepXml (..)+ -- ** Smart constructors+ , repJson+ , repPlain+ , repXml+ ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Text.Lazy (Text, pack)+import qualified Data.Text as T+import Control.Monad (liftM)++import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)+import Data.Monoid (mempty)++import Text.Hamlet (Html)+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)+import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput)+import Data.Conduit.Internal (ResumableSource (ResumableSource))++import qualified Data.Aeson as J+import Data.Aeson.Encode (fromValue)+import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze+import Data.Text.Lazy.Builder (toLazyText)+import Yesod.Core.Types++-- | Zero-length enumerator.+emptyContent :: Content+emptyContent = ContentBuilder mempty $ Just 0++-- | Anything which can be converted into 'Content'. Most of the time, you will+-- want to use the 'ContentBuilder' constructor. An easier approach will be to use+-- a pre-defined 'toContent' function, such as converting your data into a lazy+-- bytestring and then calling 'toContent' on that.+--+-- Please note that the built-in instances for lazy data structures ('String',+-- lazy 'L.ByteString', lazy 'Text' and 'Html') will not automatically include+-- the content length for the 'ContentBuilder' constructor.+class ToContent a where+ toContent :: a -> Content++instance ToContent Content where+ toContent = id+instance ToContent Builder where+ toContent = flip ContentBuilder Nothing+instance ToContent B.ByteString where+ toContent bs = ContentBuilder (fromByteString bs) $ Just $ B.length bs+instance ToContent L.ByteString where+ toContent = flip ContentBuilder Nothing . fromLazyByteString+instance ToContent T.Text where+ toContent = toContent . Blaze.fromText+instance ToContent Text where+ toContent = toContent . Blaze.fromLazyText+instance ToContent String where+ toContent = toContent . Blaze.fromString+instance ToContent Html where+ toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing+instance ToContent () where+ toContent () = toContent B.empty+instance ToContent (ContentType, Content) where+ toContent = snd+instance ToContent TypedContent where+ toContent (TypedContent _ c) = c++instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where+ toContent src = ContentSource $ mapOutput toFlushBuilder src+instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where+ toContent (ResumableSource src _) = toContent src++-- | A class for all data which can be sent in a streaming response. Note that+-- for textual data, instances must use UTF-8 encoding.+--+-- Since 1.2.0+class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder+instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id+instance ToFlushBuilder Builder where toFlushBuilder = Chunk+instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString+instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString+instance ToFlushBuilder (Flush L.ByteString) where toFlushBuilder = fmap fromLazyByteString+instance ToFlushBuilder L.ByteString where toFlushBuilder = Chunk . fromLazyByteString+instance ToFlushBuilder (Flush Text) where toFlushBuilder = fmap Blaze.fromLazyText+instance ToFlushBuilder Text where toFlushBuilder = Chunk . Blaze.fromLazyText+instance ToFlushBuilder (Flush T.Text) where toFlushBuilder = fmap Blaze.fromText+instance ToFlushBuilder T.Text where toFlushBuilder = Chunk . Blaze.fromText+instance ToFlushBuilder (Flush String) where toFlushBuilder = fmap Blaze.fromString+instance ToFlushBuilder String where toFlushBuilder = Chunk . Blaze.fromString+instance ToFlushBuilder (Flush Html) where toFlushBuilder = fmap renderHtmlBuilder+instance ToFlushBuilder Html where toFlushBuilder = Chunk . renderHtmlBuilder++repJson :: ToContent a => a -> RepJson+repJson = RepJson . toContent++repPlain :: ToContent a => a -> RepPlain+repPlain = RepPlain . toContent++repXml :: ToContent a => a -> RepXml+repXml = RepXml . toContent++class ToTypedContent a => HasContentType a where+ getContentType :: Monad m => m a -> ContentType++instance HasContentType RepJson where+ getContentType _ = typeJson+deriving instance ToContent RepJson++instance HasContentType RepPlain where+ getContentType _ = typePlain+deriving instance ToContent RepPlain++instance HasContentType RepXml where+ getContentType _ = typeXml+deriving instance ToContent RepXml+++typeHtml :: ContentType+typeHtml = "text/html; charset=utf-8"++typePlain :: ContentType+typePlain = "text/plain; charset=utf-8"++typeJson :: ContentType+typeJson = "application/json; charset=utf-8"++typeXml :: ContentType+typeXml = "text/xml"++typeAtom :: ContentType+typeAtom = "application/atom+xml"++typeRss :: ContentType+typeRss = "application/rss+xml"++typeJpeg :: ContentType+typeJpeg = "image/jpeg"++typePng :: ContentType+typePng = "image/png"++typeGif :: ContentType+typeGif = "image/gif"++typeSvg :: ContentType+typeSvg = "image/svg+xml"++typeJavascript :: ContentType+typeJavascript = "text/javascript; charset=utf-8"++typeCss :: ContentType+typeCss = "text/css; charset=utf-8"++typeFlv :: ContentType+typeFlv = "video/x-flv"++typeOgv :: ContentType+typeOgv = "video/ogg"++typeOctet :: ContentType+typeOctet = "application/octet-stream"++-- | Removes \"extra\" information at the end of a content type string. In+-- particular, removes everything after the semicolon, if present.+--+-- For example, \"text/html; charset=utf-8\" is commonly used to specify the+-- character encoding for HTML data. This function would return \"text/html\".+simpleContentType :: ContentType -> ContentType+simpleContentType = fst . B.breakByte 59 -- 59 == ;++-- Give just the media types as a pair.+-- For example, \"text/html; charset=utf-8\" returns ("text", "html")+contentTypeTypes :: ContentType -> (B.ByteString, B.ByteString)+contentTypeTypes ct = (main, fst $ B.breakByte semicolon (tailEmpty sub))+ where+ tailEmpty x = if B.null x then "" else B.tail x+ (main, sub) = B.breakByte slash ct+ slash = 47+ semicolon = 59+++instance HasContentType a => HasContentType (DontFullyEvaluate a) where+ getContentType = getContentType . liftM unDontFullyEvaluate++instance ToContent a => ToContent (DontFullyEvaluate a) where+ toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a++instance ToContent J.Value where+ toContent = flip ContentBuilder Nothing+ . Blaze.fromLazyText+ . toLazyText+ . fromValue+instance HasContentType J.Value where+ getContentType _ = typeJson++instance HasContentType Html where+ getContentType _ = typeHtml++instance HasContentType Text where+ getContentType _ = typePlain++instance HasContentType T.Text where+ getContentType _ = typePlain++-- | Any type which can be converted to 'TypedContent'.+--+-- Since 1.2.0+class ToContent a => ToTypedContent a where+ toTypedContent :: a -> TypedContent++instance ToTypedContent TypedContent where+ toTypedContent = id+instance ToTypedContent () where+ toTypedContent () = TypedContent typePlain (toContent ())+instance ToTypedContent (ContentType, Content) where+ toTypedContent (ct, content) = TypedContent ct content+instance ToTypedContent RepJson where+ toTypedContent (RepJson c) = TypedContent typeJson c+instance ToTypedContent RepPlain where+ toTypedContent (RepPlain c) = TypedContent typePlain c+instance ToTypedContent RepXml where+ toTypedContent (RepXml c) = TypedContent typeXml c+instance ToTypedContent J.Value where+ toTypedContent v = TypedContent typeJson (toContent v)+instance ToTypedContent Html where+ toTypedContent h = TypedContent typeHtml (toContent h)+instance ToTypedContent T.Text where+ toTypedContent t = TypedContent typePlain (toContent t)+instance ToTypedContent [Char] where+ toTypedContent = toTypedContent . pack+instance ToTypedContent Text where+ toTypedContent t = TypedContent typePlain (toContent t)+instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where+ toTypedContent (DontFullyEvaluate a) =+ let TypedContent ct c = toTypedContent a+ in TypedContent ct (ContentDontEvaluate c)
+ Yesod/Core/Dispatch.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Yesod.Core.Dispatch+ ( -- * Quasi-quoted routing+ parseRoutes+ , parseRoutesNoCheck+ , parseRoutesFile+ , parseRoutesFileNoCheck+ , mkYesod+ -- ** More fine-grained+ , mkYesodData+ , mkYesodSubData+ , mkYesodDispatch+ , mkYesodSubDispatch+ -- ** Path pieces+ , PathPiece (..)+ , PathMultiPiece (..)+ , Texts+ -- * Convert to WAI+ , toWaiApp+ , toWaiAppPlain+ , warp+ , warpDebug+ , warpEnv+ , mkDefaultMiddlewares+ -- * WAI subsites+ , WaiSubsite (..)+ ) where++import Prelude hiding (exp)+import Yesod.Core.Internal.TH+import Language.Haskell.TH.Syntax (qLocation)++import Web.PathPieces++import qualified Network.Wai as W++import Data.ByteString.Lazy.Char8 ()++import Data.Text (Text)+import Data.Monoid (mappend)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Blaze.ByteString.Builder+import Network.HTTP.Types (status301)+import Yesod.Routes.Parse+import Yesod.Core.Types+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Internal.Run+import Safe (readMay)+import System.Environment (getEnvironment)++import Network.Wai.Middleware.Autohead+import Network.Wai.Middleware.AcceptOverride+import Network.Wai.Middleware.RequestLogger+import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.MethodOverride++import qualified Network.Wai.Handler.Warp+import System.Log.FastLogger+import Control.Monad.Logger+import qualified Paths_yesod_core+import Data.Version (showVersion)++-- | Convert the given argument into a WAI application, executable with any WAI+-- handler. This function will provide no middlewares; if you want commonly+-- used middlewares, please use 'toWaiApp'.+toWaiAppPlain :: YesodDispatch site => site -> IO W.Application+toWaiAppPlain site = do+ logger <- makeLogger site+ sb <- makeSessionBackend site+ return $ toWaiAppYre $ YesodRunnerEnv+ { yreLogger = logger+ , yreSite = site+ , yreSessionBackend = sb+ }++toWaiAppYre :: YesodDispatch site => YesodRunnerEnv site -> W.Application+toWaiAppYre yre req =+ case cleanPath site $ W.pathInfo req of+ Left pieces -> sendRedirect site pieces req+ Right pieces -> yesodDispatch yre req+ { W.pathInfo = pieces+ }+ where+ site = yreSite yre+ sendRedirect :: Yesod master => master -> [Text] -> W.Application+ sendRedirect y segments' env =+ return $ W.responseLBS status301+ [ ("Content-Type", "text/plain")+ , ("Location", Blaze.ByteString.Builder.toByteString dest')+ ] "Redirecting"+ where+ dest = joinPath y (resolveApproot y env) segments' []+ dest' =+ if S.null (W.rawQueryString env)+ then dest+ else (dest `mappend`+ Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))++-- | Same as 'toWaiAppPlain', but provides a default set of middlewares. This+-- set may change with future releases, but currently covers:+--+-- * Logging+--+-- * GZIP compression+--+-- * Automatic HEAD method handling+--+-- * Request method override with the _method query string parameter+--+-- * Accept header override with the _accept query string parameter+toWaiApp :: YesodDispatch site => site -> IO W.Application+toWaiApp site = do+ logger <- makeLogger site+ sb <- makeSessionBackend site+ let yre = YesodRunnerEnv+ { yreLogger = logger+ , yreSite = site+ , yreSessionBackend = sb+ }+ messageLoggerSource+ site+ logger+ $(qLocation >>= liftLoc)+ "yesod-core"+ LevelInfo+ (toLogStr ("Application launched" :: S.ByteString))+ middleware <- mkDefaultMiddlewares logger+ return $ middleware $ toWaiAppYre yre++-- | A convenience method to run an application using the Warp webserver on the+-- specified port. Automatically calls 'toWaiApp'. Provides a default set of+-- middlewares. This set may change at any point without a breaking version+-- number. Currently, it includes:+--+-- If you need more fine-grained control of middlewares, please use 'toWaiApp'+-- directly.+--+-- Since 1.2.0+warp :: YesodDispatch site => Int -> site -> IO ()+warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings+ Network.Wai.Handler.Warp.defaultSettings+ { Network.Wai.Handler.Warp.settingsPort = port+ , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat+ [ "Warp/"+ , Network.Wai.Handler.Warp.warpVersion+ , " + Yesod/"+ , showVersion Paths_yesod_core.version+ , " (core)"+ ]+ }++-- | A default set of middlewares.+--+-- Since 1.2.0+mkDefaultMiddlewares :: Logger -> IO W.Middleware+mkDefaultMiddlewares logger = do+ logWare <- mkRequestLogger def+ { destination = Logger logger+ , outputFormat = Apache FromSocket+ }+ return $ logWare+ . acceptOverride+ . autohead+ . gzip def+ . methodOverride++-- | Deprecated synonym for 'warp'.+warpDebug :: YesodDispatch site => Int -> site -> IO ()+warpDebug = warp+{-# DEPRECATED warpDebug "Please use warp instead" #-}++-- | Runs your application using default middlewares (i.e., via 'toWaiApp'). It+-- reads port information from the PORT environment variable, as used by tools+-- such as Keter and the FP Complete School of Haskell.+--+-- Note that the exact behavior of this function may be modified slightly over+-- time to work correctly with external tools, without a change to the type+-- signature.+warpEnv :: YesodDispatch site => site -> IO ()+warpEnv site = do+ env <- getEnvironment+ case lookup "PORT" env of+ Nothing -> error $ "warpEnv: no PORT environment variable found"+ Just portS ->+ case readMay portS of+ Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS+ Just port -> warp port site
+ Yesod/Core/Handler.hs view
@@ -0,0 +1,1028 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+---------------------------------------------------------+--+-- Module : Yesod.Handler+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : stable+-- Portability : portable+--+-- Define Handler stuff.+--+---------------------------------------------------------+module Yesod.Core.Handler+ ( -- * Handler monad+ HandlerT+ -- ** Read information from handler+ , getYesod+ , getUrlRender+ , getUrlRenderParams+ , getCurrentRoute+ , getRequest+ , waiRequest+ , runRequestBody+ , rawRequestBody+ -- ** Request information+ -- *** Request datatype+ , RequestBodyContents+ , YesodRequest (..)+ , FileInfo+ , fileName+ , fileContentType+ , fileSource+ , fileMove+ -- *** Convenience functions+ , languages+ -- *** Lookup parameters+ , lookupGetParam+ , lookupPostParam+ , lookupCookie+ , lookupFile+ -- **** Multi-lookup+ , lookupGetParams+ , lookupPostParams+ , lookupCookies+ , lookupFiles+ -- * Responses+ -- ** Pure+ , respond+ -- ** Streaming+ , respondSource+ , sendChunk+ , sendFlush+ , sendChunkBS+ , sendChunkLBS+ , sendChunkText+ , sendChunkLazyText+ , sendChunkHtml+ -- ** Redirecting+ , RedirectUrl (..)+ , redirect+ , redirectWith+ , redirectToPost+ -- ** Errors+ , notFound+ , badMethod+ , notAuthenticated+ , permissionDenied+ , permissionDeniedI+ , invalidArgs+ , invalidArgsI+ -- ** Short-circuit responses.+ , sendFile+ , sendFilePart+ , sendResponse+ , sendResponseStatus+ , sendResponseCreated+ , sendWaiResponse+ -- * Different representations+ -- $representations+ , selectRep+ , provideRep+ , provideRepType+ , ProvidedRep+ -- * Setting headers+ , setCookie+ , getExpires+ , deleteCookie+ , addHeader+ , setHeader+ , setLanguage+ -- ** Content caching and expiration+ , cacheSeconds+ , neverExpires+ , alreadyExpired+ , expiresAt+ -- * Session+ , SessionMap+ , lookupSession+ , lookupSessionBS+ , getSession+ , setSession+ , setSessionBS+ , deleteSession+ , clearSession+ -- ** Ultimate destination+ , setUltDest+ , setUltDestCurrent+ , setUltDestReferer+ , redirectUltDest+ , clearUltDest+ -- ** Messages+ , setMessage+ , setMessageI+ , getMessage+ -- * Helpers for specific content+ -- ** Hamlet+ , hamletToRepHtml+ , giveUrlRenderer+ -- ** Misc+ , newIdent+ -- * Lifting+ , handlerToIO+ -- * i18n+ , getMessageRender+ -- * Per-request caching+ , cached+ ) where++import Data.Time (UTCTime, addUTCTime,+ getCurrentTime)+import Yesod.Core.Internal.Request (langKey, mkFileInfoFile,+ mkFileInfoLBS, mkFileInfoSource)++import Control.Applicative ((<$>), (<|>))++import Control.Monad (liftM)+import qualified Control.Monad.Trans.Writer as Writer++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Resource (MonadResource, liftResourceT)++import qualified Network.HTTP.Types as H+import qualified Network.Wai as W+import Control.Monad.Trans.Class (lift)+import Data.Conduit (transPipe, Flush (Flush), yield, Producer)++import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Text.Lazy as TL+import qualified Text.Blaze.Html.Renderer.Text as RenderText+import Text.Hamlet (Html, HtmlUrl, hamlet)++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map++import Data.Conduit (Source)+import Control.Arrow ((***))+import qualified Data.ByteString.Char8 as S8+import Data.Maybe (mapMaybe)+import Data.Monoid (Endo (..), mappend, mempty)+import Data.Text (Text)+import qualified Network.Wai.Parse as NWP+import Text.Shakespeare.I18N (RenderMessage (..))+import Web.Cookie (SetCookie (..))+import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))+import Yesod.Core.Internal.Util (formatRFC1123)+import Text.Blaze.Html (preEscapedToMarkup, toHtml)++import Control.Monad.Trans.Resource (ResourceT)+import Data.Dynamic (fromDynamic, toDyn)+import qualified Data.IORef.Lifted as I+import Data.Maybe (listToMaybe)+import Data.Typeable (Typeable, typeOf)+import Yesod.Core.Class.Handler+import Yesod.Core.Types+import Yesod.Routes.Class (Route)+import Control.Failure (failure)+import Blaze.ByteString.Builder (Builder)+import Safe (headMay)++get :: MonadHandler m => m GHState+get = liftHandlerT $ HandlerT $ I.readIORef . handlerState++put :: MonadHandler m => GHState -> m ()+put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState++modify :: MonadHandler m => (GHState -> GHState) -> m ()+modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState++tell :: MonadHandler m => Endo [Header] -> m ()+tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }++handlerError :: MonadHandler m => HandlerContents -> m a+handlerError = liftHandlerT . failure++hcError :: MonadHandler m => ErrorResponse -> m a+hcError = handlerError . HCError++getRequest :: MonadHandler m => m YesodRequest+getRequest = liftHandlerT $ HandlerT $ return . handlerRequest++runRequestBody :: MonadHandler m => m RequestBodyContents+runRequestBody = do+ HandlerData+ { handlerEnv = RunHandlerEnv {..}+ , handlerRequest = req+ } <- liftHandlerT $ HandlerT return+ let len = W.requestBodyLength $ reqWaiRequest req+ upload = rheUpload len+ x <- get+ case ghsRBC x of+ Just rbc -> return rbc+ Nothing -> do+ rr <- waiRequest+ rbc <- liftResourceT $ rbHelper upload rr+ put x { ghsRBC = Just rbc }+ return rbc++rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents+rbHelper upload =+ case upload of+ FileUploadMemory s -> rbHelper' s mkFileInfoLBS+ FileUploadDisk s -> rbHelper' s mkFileInfoFile+ FileUploadSource s -> rbHelper' s mkFileInfoSource++rbHelper' :: NWP.BackEnd x+ -> (Text -> Text -> x -> FileInfo)+ -> W.Request+ -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])+rbHelper' backend mkFI req =+ (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)+ where+ fix1 = go *** go+ fix2 (x, NWP.FileInfo a' b c)+ | S.null a = Nothing+ | otherwise = Just (go x, mkFI (go a) (go b) c)+ where+ a+ | S.length a' < 2 = a'+ | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a'+ | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a'+ | otherwise = a'+ go = decodeUtf8With lenientDecode++askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))+askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv++-- | Get the master site appliation argument.+getYesod :: MonadHandler m => m (HandlerSite m)+getYesod = rheSite `liftM` askHandlerEnv++-- | Get the URL rendering function.+getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)+getUrlRender = do+ x <- rheRender `liftM` askHandlerEnv+ return $ flip x []++-- | The URL rendering function with query-string parameters.+getUrlRenderParams+ :: MonadHandler m+ => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)+getUrlRenderParams = rheRender `liftM` askHandlerEnv++-- | 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 :: MonadHandler m => m (Maybe (Route (HandlerSite m)))+getCurrentRoute = rheRoute `liftM` askHandlerEnv++-- | Returns a function that runs 'HandlerT' actions inside @IO@.+--+-- Sometimes you want to run an inner 'HandlerT' action outside+-- the control flow of an HTTP request (on the outer 'HandlerT'+-- action). For example, you may want to spawn a new thread:+--+-- @+-- getFooR :: Handler RepHtml+-- getFooR = do+-- runInnerHandler <- handlerToIO+-- liftIO $ forkIO $ runInnerHandler $ do+-- /Code here runs inside GHandler but on a new thread./+-- /This is the inner GHandler./+-- ...+-- /Code here runs inside the request's control flow./+-- /This is the outer GHandler./+-- ...+-- @+--+-- Another use case for this function is creating a stream of+-- server-sent events using 'GHandler' actions (see+-- @yesod-eventsource@).+--+-- Most of the environment from the outer 'GHandler' is preserved+-- on the inner 'GHandler', however:+--+-- * The request body is cleared (otherwise it would be very+-- difficult to prevent huge memory leaks).+--+-- * The cache is cleared (see 'CacheKey').+--+-- Changes to the response made inside the inner 'GHandler' are+-- ignored (e.g., session variables, cookies, response headers).+-- This allows the inner 'GHandler' to outlive the outer+-- 'GHandler' (e.g., on the @forkIO@ example above, a response+-- may be sent to the client without killing the new thread).+handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a)+handlerToIO =+ HandlerT $ \oldHandlerData -> do+ -- Let go of the request body, cache and response headers.+ let oldReq = handlerRequest oldHandlerData+ oldWaiReq = reqWaiRequest oldReq+ newWaiReq = oldWaiReq { W.requestBody = mempty+ , W.requestBodyLength = W.KnownLength 0+ }+ newReq = oldReq { reqWaiRequest = newWaiReq }+ clearedOldHandlerData =+ oldHandlerData { handlerRequest = err "handlerRequest never here"+ , handlerState = err "handlerState never here"+ , handlerToParent = const () }+ where+ err :: String -> a+ err = error . ("handlerToIO: clearedOldHandlerData/" ++)+ newState <- liftIO $ do+ oldState <- I.readIORef (handlerState oldHandlerData)+ return $ oldState { ghsRBC = Nothing+ , ghsIdent = 1+ , ghsCache = mempty+ , ghsHeaders = mempty }++ -- Return GHandler running function.+ return $ \(HandlerT f) -> liftIO $ do+ -- The state IORef needs to be created here, otherwise it+ -- will be shared by different invocations of this function.+ newStateIORef <- I.newIORef newState+ -- FIXME previously runResourceT was used here, but that could mean resources might vanish...+ -- Check if this new behavior is correct.+ f clearedOldHandlerData+ { handlerRequest = newReq+ , handlerState = newStateIORef }+++-- | Redirect to the given route.+-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0+-- This is the appropriate choice for a get-following-post+-- technique, which should be the usual use case.+--+-- If you want direct control of the final status code, or need a different+-- status code, please use 'redirectWith'.+redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => url -> m a+redirect url = do+ req <- waiRequest+ let status =+ if W.httpVersion req == H.http11+ then H.status303+ else H.status302+ redirectWith status url++-- | Redirect to the given URL with the specified status code.+redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => H.Status+ -> url+ -> m a+redirectWith status url = do+ urlText <- toTextUrl url+ handlerError $ HCRedirect status urlText++ultDestKey :: Text+ultDestKey = "_ULT"++-- | Sets the ultimate destination variable to the given route.+--+-- An ultimate destination is stored in the user session and can be loaded+-- later by 'redirectUltDest'.+setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => url+ -> m ()+setUltDest url = do+ urlText <- toTextUrl url+ setSession ultDestKey urlText++-- | 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.+setUltDestCurrent :: MonadHandler m => m ()+setUltDestCurrent = do+ route <- getCurrentRoute+ case route of+ Nothing -> return ()+ Just r -> do+ gets' <- reqGetParams `liftM` getRequest+ setUltDest (r, gets')++-- | Sets the ultimate destination to the referer request header, if present.+--+-- This function will not overwrite an existing ultdest.+setUltDestReferer :: MonadHandler m => m ()+setUltDestReferer = do+ mdest <- lookupSession ultDestKey+ maybe+ (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)+ (const $ return ())+ mdest+ where+ setUltDestBS = setUltDest . T.pack . S8.unpack++-- | Redirect to the ultimate destination in the user's session. Clear the+-- value from the session.+--+-- The ultimate destination is set with 'setUltDest'.+--+-- This function uses 'redirect', and thus will perform a temporary redirect to+-- a GET request.+redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)+ => url -- ^ default destination if nothing in session+ -> m a+redirectUltDest def = do+ mdest <- lookupSession ultDestKey+ deleteSession ultDestKey+ maybe (redirect def) redirect mdest++-- | Remove a previously set ultimate destination. See 'setUltDest'.+clearUltDest :: MonadHandler m => m ()+clearUltDest = deleteSession ultDestKey++msgKey :: Text+msgKey = "_MSG"++-- | Sets a message in the user's session.+--+-- See 'getMessage'.+setMessage :: MonadHandler m => Html -> m ()+setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml++-- | Sets a message in the user's session.+--+-- See 'getMessage'.+setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)+ => msg -> m ()+setMessageI msg = do+ mr <- getMessageRender+ setMessage $ toHtml $ mr msg++-- | Gets the message in the user's session, if available, and then clears the+-- variable.+--+-- See 'setMessage'.+getMessage :: MonadHandler m => m (Maybe Html)+getMessage = do+ mmsg <- liftM (fmap preEscapedToMarkup) $ 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 :: MonadHandler m => ContentType -> FilePath -> m a+sendFile ct fp = handlerError $ HCSendFile ct fp Nothing++-- | Same as 'sendFile', but only sends part of a file.+sendFilePart :: MonadHandler m+ => ContentType+ -> FilePath+ -> Integer -- ^ offset+ -> Integer -- ^ count+ -> m a+sendFilePart ct fp off count =+ handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count++-- | Bypass remaining handler code and output the given content with a 200+-- status code.+sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a+sendResponse = handlerError . HCContent H.status200 . toTypedContent++-- | Bypass remaining handler code and output the given content with the given+-- status code.+sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a+sendResponseStatus s = handlerError . HCContent s . toTypedContent++-- | Send a 201 "Created" response with the given route as the Location+-- response header.+sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a+sendResponseCreated url = do+ r <- getUrlRender+ handlerError $ HCCreated $ r url++-- | Send a 'W.Response'. Please note: this function is rarely+-- necessary, and will /disregard/ any changes to response headers and session+-- that you have already specified. This function short-circuits. It should be+-- considered only for very specific needs. If you are not sure if you need it,+-- you don't.+sendWaiResponse :: MonadHandler m => W.Response -> m b+sendWaiResponse = handlerError . HCWai++-- | Return a 404 not found page. Also denotes no handler available.+notFound :: MonadHandler m => m a+notFound = hcError NotFound++-- | Return a 405 method not supported page.+badMethod :: MonadHandler m => m a+badMethod = do+ w <- waiRequest+ hcError $ BadMethod $ W.requestMethod w++-- | Return a 401 status code+notAuthenticated :: MonadHandler m => m a+notAuthenticated = hcError NotAuthenticated++-- | Return a 403 permission denied page.+permissionDenied :: MonadHandler m => Text -> m a+permissionDenied = hcError . PermissionDenied++-- | Return a 403 permission denied page.+permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)+ => msg+ -> m a+permissionDeniedI msg = do+ mr <- getMessageRender+ permissionDenied $ mr msg++-- | Return a 400 invalid arguments page.+invalidArgs :: MonadHandler m => [Text] -> m a+invalidArgs = hcError . InvalidArgs++-- | Return a 400 invalid arguments page.+invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a+invalidArgsI msg = do+ mr <- getMessageRender+ invalidArgs $ map mr msg++------- Headers+-- | Set the cookie on the client.++setCookie :: MonadHandler m => SetCookie -> m ()+setCookie = addHeaderInternal . AddCookie++-- | Helper function for setCookieExpires value+getExpires :: MonadIO m+ => Int -- ^ minutes+ -> m UTCTime+getExpires m = do+ now <- liftIO getCurrentTime+ return $ fromIntegral (m * 60) `addUTCTime` now+++-- | Unset the cookie on the client.+--+-- Note: although the value used for key and path is 'Text', you should only+-- use ASCII values to be HTTP compliant.+deleteCookie :: MonadHandler m+ => Text -- ^ key+ -> Text -- ^ path+ -> m ()+deleteCookie a = addHeaderInternal . DeleteCookie (encodeUtf8 a) . encodeUtf8+++-- | Set the language in the user session. Will show up in 'languages' on the+-- next request.+setLanguage :: MonadHandler m => Text -> m ()+setLanguage = setSession langKey++-- | Set an arbitrary response header.+--+-- Note that, while the data type used here is 'Text', you must provide only+-- ASCII value to be HTTP compliant.+--+-- Since 1.2.0+addHeader :: MonadHandler m => Text -> Text -> m ()+addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8++-- | Deprecated synonym for addHeader.+setHeader :: MonadHandler m => Text -> Text -> m ()+setHeader = addHeader+{-# DEPRECATED setHeader "Please use addHeader instead" #-}++-- | Set the Cache-Control header to indicate this response should be cached+-- for the given number of seconds.+cacheSeconds :: MonadHandler m => Int -> m ()+cacheSeconds i = setHeader "Cache-Control" $ T.concat+ [ "max-age="+ , T.pack $ show i+ , ", public"+ ]++-- | Set the Expires header to some date in 2037. In other words, this content+-- is never (realistically) expired.+neverExpires :: MonadHandler m => m ()+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 :: MonadHandler m => m ()+alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"++-- | Set an Expires header to the given date.+expiresAt :: MonadHandler m => UTCTime -> m ()+expiresAt = setHeader "Expires" . 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 :: MonadHandler m+ => Text -- ^ key+ -> Text -- ^ value+ -> m ()+setSession k = setSessionBS k . encodeUtf8++-- | Same as 'setSession', but uses binary data for the value.+setSessionBS :: MonadHandler m+ => Text+ -> S.ByteString+ -> m ()+setSessionBS k = modify . modSession . Map.insert k++-- | Unsets a session variable. See 'setSession'.+deleteSession :: MonadHandler m => Text -> m ()+deleteSession = modify . modSession . Map.delete++-- | Clear all session variables.+--+-- Since: 1.0.1+clearSession :: MonadHandler m => m ()+clearSession = modify $ \x -> x { ghsSession = Map.empty }++modSession :: (SessionMap -> SessionMap) -> GHState -> GHState+modSession f x = x { ghsSession = f $ ghsSession x }++-- | Internal use only, not to be confused with 'setHeader'.+addHeaderInternal :: MonadHandler m => Header -> m ()+addHeaderInternal = tell . Endo . (:)++-- | Some value which can be turned into a URL for redirects.+class RedirectUrl master a where+ -- | Converts the value to the URL and a list of query-string parameters.+ toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text++instance RedirectUrl master Text where+ toTextUrl = return++instance RedirectUrl master String where+ toTextUrl = toTextUrl . T.pack++instance RedirectUrl master (Route master) where+ toTextUrl url = do+ r <- getUrlRender+ return $ r url++instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where+ toTextUrl (url, params) = do+ r <- getUrlRenderParams+ return $ r url params++instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where+ toTextUrl (url, params) = toTextUrl (url, Map.toList params)++-- | Lookup for session data.+lookupSession :: MonadHandler m => Text -> m (Maybe Text)+lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS++-- | Lookup for session data in binary format.+lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)+lookupSessionBS n = do+ m <- liftM ghsSession get+ return $ Map.lookup n m++-- | Get all session variables.+getSession :: MonadHandler m => m SessionMap+getSession = liftM ghsSession get++-- | Get a unique identifier.+newIdent :: MonadHandler m => m Text+newIdent = do+ x <- get+ let i' = ghsIdent x + 1+ put x { ghsIdent = i' }+ return $ T.pack $ 'h' : show i'++-- | 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 :: (MonadHandler m, RedirectUrl (HandlerSite m) url)+ => url+ -> m a+redirectToPost url = do+ urlText <- toTextUrl url+ hamletToRepHtml [hamlet|+$newline never+$doctype 5++<html>+ <head>+ <title>Redirecting...+ <body onload="document.getElementById('form').submit()">+ <form id="form" method="post" action=#{urlText}>+ <noscript>+ <p>Javascript has been disabled; please click on the button below to be redirected.+ <input type="submit" value="Continue">+|] >>= sendResponse++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html+hamletToRepHtml = giveUrlRenderer++-- | Provide a URL rendering function to the given function and return the+-- result. Useful for processing Shakespearean templates.+--+-- Since 1.2.0+giveUrlRenderer :: MonadHandler m+ => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)+ -> m output+giveUrlRenderer f = do+ render <- getUrlRenderParams+ return $ f render++-- | Get the request\'s 'W.Request' value.+waiRequest :: MonadHandler m => m W.Request+waiRequest = reqWaiRequest `liftM` getRequest++getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)+ => m (message -> Text)+getMessageRender = do+ env <- askHandlerEnv+ l <- reqLangs `liftM` getRequest+ return $ renderMessage (rheSite env) l++-- | Use a per-request cache to avoid performing the same action multiple+-- times. Note that values are stored by their type. Therefore, you should use+-- newtype wrappers to distinguish logically different types.+--+-- Since 1.2.0+cached :: (MonadHandler m, Typeable a)+ => m a+ -> m a+cached f = do+ gs <- get+ let cache = ghsCache gs+ case clookup cache of+ Just val -> return val+ Nothing -> do+ val <- f+ put $ gs { ghsCache = cinsert val cache }+ return val+ where+ clookup :: Typeable a => Cache -> Maybe a+ clookup (Cache m) =+ res+ where+ res = Map.lookup (typeOf $ fromJust res) m >>= fromDynamic+ fromJust :: Maybe a -> a+ fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated"++ cinsert :: Typeable a => a -> Cache -> Cache+ cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m)++-- | Get the list of supported languages supplied by the user.+--+-- Languages are determined based on the following three (in descending order+-- of preference):+--+-- * The _LANG get parameter.+--+-- * The _LANG cookie.+--+-- * The _LANG user session variable.+--+-- * Accept-Language HTTP header.+--+-- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.+-- If a matching language is not found the default language will be used.+--+-- This is handled by parseWaiRequest (not exposed).+languages :: MonadHandler m => m [Text]+languages = reqLangs `liftM` getRequest++lookup' :: Eq a => a -> [(a, b)] -> [b]+lookup' a = map snd . filter (\x -> a == fst x)++-- | Lookup for GET parameters.+lookupGetParams :: MonadHandler m => Text -> m [Text]+lookupGetParams pn = do+ rr <- getRequest+ return $ lookup' pn $ reqGetParams rr++-- | Lookup for GET parameters.+lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)+lookupGetParam = liftM listToMaybe . lookupGetParams++-- | Lookup for POST parameters.+lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]+lookupPostParams pn = do+ (pp, _) <- runRequestBody+ return $ lookup' pn pp++lookupPostParam :: (MonadResource m, MonadHandler m)+ => Text+ -> m (Maybe Text)+lookupPostParam = liftM listToMaybe . lookupPostParams++-- | Lookup for POSTed files.+lookupFile :: (MonadHandler m, MonadResource m)+ => Text+ -> m (Maybe FileInfo)+lookupFile = liftM listToMaybe . lookupFiles++-- | Lookup for POSTed files.+lookupFiles :: (MonadHandler m, MonadResource m)+ => Text+ -> m [FileInfo]+lookupFiles pn = do+ (_, files) <- runRequestBody+ return $ lookup' pn files++-- | Lookup for cookie data.+lookupCookie :: MonadHandler m => Text -> m (Maybe Text)+lookupCookie = liftM listToMaybe . lookupCookies++-- | Lookup for cookie data.+lookupCookies :: MonadHandler m => Text -> m [Text]+lookupCookies pn = do+ rr <- getRequest+ return $ lookup' pn $ reqCookies rr++-- $representations+--+-- HTTP allows content negotation to determine what /representation/ of data+-- you would like to use. The most common example of this is providing both a+-- user-facing HTML page and an API facing JSON response from the same URL. The+-- means of achieving this is the Accept HTTP header, which provides a list of+-- content types the client will accept, sorted by preference.+--+-- By using 'selectRep' and 'provideRep', you can provide a number of different+-- representations, e.g.:+--+-- > selectRep $ do+-- > provideRep typeHtml $ produceHtmlOutput+-- > provideRep typeJson $ produceJsonOutput+--+-- The first provided representation will be used if no matches are found.++-- | Select a representation to send to the client based on the representations+-- provided inside this do-block. Should be used together with 'provideRep'.+--+-- Since 1.2.0+selectRep :: MonadHandler m+ => Writer.Writer (Endo [ProvidedRep m]) ()+ -> m TypedContent+selectRep w = do+ -- the content types are already sorted by q values+ -- which have been stripped+ cts <- liftM reqAccept getRequest++ case mapMaybe tryAccept cts of+ [] ->+ case reps of+ [] -> sendResponseStatus H.status500 ("No reps provided to selectRep" :: Text)+ rep:_ ->+ if null cts+ then returnRep rep+ else sendResponseStatus H.status406 explainUnaccepted+ rep:_ -> returnRep rep+ where+ explainUnaccepted :: Text+ explainUnaccepted = "no match found for accept header"++ returnRep (ProvidedRep ct mcontent) =+ mcontent >>= return . TypedContent ct++ reps = appEndo (Writer.execWriter w) []++ repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList+ [ (k, v)+ , (noSpace k, v)+ , (simpleContentType k, v)+ ]) reps++ -- match on the type for sub-type wildcards.+ -- If the accept is text/* it should match a provided text/html+ mainTypeMap = Map.fromList $ reverse $ map+ (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps++ tryAccept ct =+ if subType == "*"+ then if mainType == "*"+ then headMay reps+ else Map.lookup mainType mainTypeMap+ else lookupAccept ct+ where+ (mainType, subType) = contentTypeTypes ct++ lookupAccept ct = Map.lookup ct repMap <|>+ Map.lookup (noSpace ct) repMap <|>+ Map.lookup (simpleContentType ct) repMap++ -- Mime types such as "text/html; charset=foo" get converted to+ -- "text/html;charset=foo"+ noSpace = S8.filter (/= ' ')++-- | Internal representation of a single provided representation.+--+-- Since 1.2.0+data ProvidedRep m = ProvidedRep !ContentType !(m Content)++-- | Provide a single representation to be used, based on the request of the+-- client. Should be used together with 'selectRep'.+--+-- Since 1.2.0+provideRep :: (Monad m, HasContentType a)+ => m a+ -> Writer.Writer (Endo [ProvidedRep m]) ()+provideRep handler = provideRepType (getContentType handler) handler++-- | Same as 'provideRep', but instead of determining the content type from the+-- type of the value itself, you provide the content type separately. This can+-- be a convenience instead of creating newtype wrappers for uncommonly used+-- content types.+--+-- > provideRepType "application/x-special-format" "This is the content"+--+-- Since 1.2.0+provideRepType :: (Monad m, ToContent a)+ => ContentType+ -> m a+ -> Writer.Writer (Endo [ProvidedRep m]) ()+provideRepType ct handler =+ Writer.tell $ Endo $ (ProvidedRep ct (liftM toContent handler):)++-- | Stream in the raw request body without any parsing.+--+-- Since 1.2.0+rawRequestBody :: MonadHandler m => Source m S.ByteString+rawRequestBody = do+ req <- lift waiRequest+ transPipe liftResourceT $ W.requestBody req++-- | Stream the data from the file. Since Yesod 1.2, this has been generalized+-- to work in any @MonadResource@.+fileSource :: MonadResource m => FileInfo -> Source m S.ByteString+fileSource = transPipe liftResourceT . fileSourceRaw++-- | Provide a pure value for the response body.+--+-- > respond ct = return . TypedContent ct . toContent+--+-- Since 1.2.0+respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent+respond ct = return . TypedContent ct . toContent++-- | Use a @Source@ for the response body.+--+-- Note that, for ease of use, the underlying monad is a @HandlerT@. This+-- implies that you can run any @HandlerT@ action. However, since a streaming+-- response occurs after the response headers have already been sent, some+-- actions make no sense here. For example: short-circuit responses, setting+-- headers, changing status codes, etc.+--+-- Since 1.2.0+respondSource :: ContentType+ -> Source (HandlerT site IO) (Flush Builder)+ -> HandlerT site IO TypedContent+respondSource ctype src = HandlerT $ \hd ->+ -- Note that this implementation relies on the fact that the ResourceT+ -- environment provided by the server is the same one used in HandlerT.+ -- This is a safe assumption assuming the HandlerT is run correctly.+ return $ TypedContent ctype $ ContentSource+ $ transPipe (lift . flip unHandlerT hd) src++-- | In a streaming response, send a single chunk of data. This function works+-- on most datatypes, such as @ByteString@ and @Html@.+--+-- Since 1.2.0+sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder)+sendChunk = yield . toFlushBuilder++-- | In a streaming response, send a flush command, causing all buffered data+-- to be immediately sent to the client.+--+-- Since 1.2.0+sendFlush :: Monad m => Producer m (Flush Builder)+sendFlush = yield Flush++-- | Type-specialized version of 'sendChunk' for strict @ByteString@s.+--+-- Since 1.2.0+sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder)+sendChunkBS = sendChunk++-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.+--+-- Since 1.2.0+sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder)+sendChunkLBS = sendChunk++-- | Type-specialized version of 'sendChunk' for strict @Text@s.+--+-- Since 1.2.0+sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder)+sendChunkText = sendChunk++-- | Type-specialized version of 'sendChunk' for lazy @Text@s.+--+-- Since 1.2.0+sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder)+sendChunkLazyText = sendChunk++-- | Type-specialized version of 'sendChunk' for @Html@s.+--+-- Since 1.2.0+sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)+sendChunkHtml = sendChunk
+ Yesod/Core/Internal.hs view
@@ -0,0 +1,7 @@+-- | Exposed mostly for testing. These functions provide an unstable API and+-- should not be relied upon.+module Yesod.Core.Internal+ ( module X+ ) where++import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest)
+ Yesod/Core/Internal/LiteApp.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternGuards #-}+module Yesod.Core.Internal.LiteApp where++import Yesod.Routes.Class+import Data.Monoid+import Yesod.Core.Class.Yesod+import Yesod.Core.Class.Dispatch+import Yesod.Core.Types+import Yesod.Core.Content+import Data.Text (Text)+import Web.PathPieces+import Network.Wai+import Yesod.Core.Handler+import Yesod.Core.Internal.Run+import Network.HTTP.Types (Method)+import Data.Maybe (fromMaybe)+import Control.Applicative ((<|>))+import Control.Monad.Trans.Writer++newtype LiteApp = LiteApp+ { unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent)+ }++instance Yesod LiteApp++instance YesodDispatch LiteApp where+ yesodDispatch yre req =+ yesodRunner+ (fromMaybe notFound $ f (requestMethod req) (pathInfo req))+ yre+ (Just $ LiteAppRoute $ pathInfo req)+ req+ where+ LiteApp f = yreSite yre++instance RenderRoute LiteApp where+ data Route LiteApp = LiteAppRoute [Text]+ deriving (Show, Eq, Read, Ord)+ renderRoute (LiteAppRoute x) = (x, [])+instance ParseRoute LiteApp where+ parseRoute (x, _) = Just $ LiteAppRoute x++instance Monoid LiteApp where+ mempty = LiteApp $ \_ _ -> Nothing+ mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps++type LiteHandler = HandlerT LiteApp IO+type LiteWidget = WidgetT LiteApp IO++liteApp :: Writer LiteApp () -> LiteApp+liteApp = execWriter++dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp ()+dispatchTo handler = tell $ LiteApp $ \_ ps ->+ if null ps+ then Just $ fmap toTypedContent handler+ else Nothing++onMethod :: Method -> Writer LiteApp () -> Writer LiteApp ()+onMethod method f = tell $ LiteApp $ \m ps ->+ if method == m+ then unLiteApp (liteApp f) m ps+ else Nothing++onStatic :: Text -> Writer LiteApp () -> Writer LiteApp ()+onStatic p0 f = tell $ LiteApp $ \m ps0 ->+ case ps0 of+ p:ps | p == p0 -> unLiteApp (liteApp f) m ps+ _ -> Nothing++withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp ()+withDynamic f = tell $ LiteApp $ \m ps0 ->+ case ps0 of+ p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps+ _ -> Nothing++withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp ()+withDynamicMulti f = tell $ LiteApp $ \m ps ->+ case fromPathMultiPiece ps of+ Nothing -> Nothing+ Just v -> unLiteApp (liteApp $ f v) m []
+ Yesod/Core/Internal/Request.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Yesod.Core.Internal.Request+ ( parseWaiRequest+ , RequestBodyContents+ , FileInfo+ , fileName+ , fileContentType+ , fileMove+ , mkFileInfoLBS+ , mkFileInfoFile+ , mkFileInfoSource+ , FileUpload (..)+ , tooLargeResponse+ , tokenKey+ , langKey+ , textQueryString+ -- The below are exported for testing.+ , randomString+ ) where++import Data.String (IsString)+import Control.Arrow (second)+import qualified Network.Wai.Parse as NWP+import qualified Network.Wai as W+import System.Random (RandomGen, randomRs)+import Web.Cookie (parseCookiesText)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Data.Text (Text, pack)+import Network.HTTP.Types (queryToQueryText, Status (Status))+import Data.Maybe (fromMaybe, catMaybes)+import qualified Data.ByteString.Lazy as L+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Conduit+import Data.Conduit.List (sourceList)+import Data.Conduit.Binary (sourceFile, sinkFile)+import Data.Word (Word64)+import Control.Monad.IO.Class (liftIO)+import Control.Exception (throwIO)+import Yesod.Core.Types+import qualified Data.Map as Map++-- | Impose a limit on the size of the request body.+limitRequestBody :: Word64 -> W.Request -> W.Request+limitRequestBody maxLen req =+ req { W.requestBody = W.requestBody req $= limit maxLen }+ where+ tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse++ limit 0 = tooLarge+ limit remaining =+ await >>= maybe (return ()) go+ where+ go bs = do+ let len = fromIntegral $ S8.length bs+ if len > remaining+ then tooLarge+ else do+ yield bs+ limit $ remaining - len++tooLargeResponse :: W.Response+tooLargeResponse = W.responseLBS+ (Status 413 "Too Large")+ [("Content-Type", "text/plain")]+ "Request body too large to be processed."++parseWaiRequest :: RandomGen g+ => W.Request+ -> SessionMap+ -> Bool+ -> Maybe Word64 -- ^ max body size+ -> (Either YesodRequest (g -> YesodRequest))+parseWaiRequest env session useToken mmaxBodySize =+ -- In most cases, we won't need to generate any random values. Therefore,+ -- we split our results: if we need a random generator, return a Right+ -- value, otherwise return a Left and avoid the relatively costly generator+ -- acquisition.+ case etoken of+ Left token -> Left $ mkRequest token+ Right mkToken -> Right $ mkRequest . mkToken+ where+ mkRequest token' = YesodRequest+ { reqGetParams = gets+ , reqCookies = cookies+ , reqWaiRequest = maybe id limitRequestBody mmaxBodySize env+ , reqLangs = langs''+ , reqToken = token'+ , reqSession = if useToken+ then Map.delete tokenKey session+ else session+ , reqAccept = httpAccept env+ }+ gets = textQueryString env+ reqCookie = lookup "Cookie" $ W.requestHeaders env+ cookies = maybe [] parseCookiesText reqCookie+ acceptLang = lookup "Accept-Language" $ W.requestHeaders env+ langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang++ lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k++ -- The language preferences are prioritized as follows:+ langs' = catMaybes [ lookup langKey gets -- Query _LANG+ , lookup langKey cookies -- Cookie _LANG+ , lookupText langKey session -- Session _LANG+ ] ++ langs -- Accept-Language(s)++ -- Github issue #195. We want to add an extra two-letter version of any+ -- language in the list.+ langs'' = addTwoLetters (id, Set.empty) langs'++ -- If sessions are disabled tokens should not be used (any+ -- tokenKey present in the session is ignored). If sessions+ -- are enabled and a session has no tokenKey a new one is+ -- generated.+ etoken+ | useToken =+ case Map.lookup tokenKey session of+ -- Already have a token, use it.+ Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs+ -- Don't have a token, get a random generator and make a new one.+ Nothing -> Right $ Just . pack . randomString 10+ | otherwise = Left Nothing++textQueryString :: W.Request -> [(Text, Text)]+textQueryString = map (second $ fromMaybe "") . queryToQueryText . W.queryString++-- | Get the list of accepted content types from the WAI Request\'s Accept+-- header.+--+-- Since 1.2.0+httpAccept :: W.Request -> [ContentType]+httpAccept = NWP.parseHttpAccept+ . fromMaybe S8.empty+ . lookup "Accept"+ . W.requestHeaders++addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]+addTwoLetters (toAdd, exist) [] =+ filter (flip Set.notMember exist) $ toAdd []+addTwoLetters (toAdd, exist) (l:ls) =+ l : addTwoLetters (toAdd', exist') ls+ where+ (toAdd', exist')+ | T.length l > 2 = (toAdd . (T.take 2 l:), exist)+ | otherwise = (toAdd, Set.insert l exist)++-- | Generate a random String of alphanumerical characters+-- (a-z, A-Z, and 0-9) of the given length using the given+-- random number generator.+randomString :: RandomGen g => Int -> g -> String+randomString len = take len . map toChar . randomRs (0, 61)+ where+ toChar i+ | i < 26 = toEnum $ i + fromEnum 'A'+ | i < 52 = toEnum $ i + fromEnum 'a' - 26+ | otherwise = toEnum $ i + fromEnum '0' - 52++mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo+mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)++mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo+mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)++mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo+mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)++tokenKey :: IsString a => a+tokenKey = "_TOKEN"++langKey :: IsString a => a+langKey = "_LANG"
+ Yesod/Core/Internal/Response.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Core.Internal.Response where++import Blaze.ByteString.Builder (toByteString)+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import Network.Wai+import Prelude hiding (catch)+import Web.Cookie (renderSetCookie)+import Yesod.Core.Content+import Yesod.Core.Types+import qualified Network.HTTP.Types as H+import qualified Data.Text as T+import Control.Exception (SomeException, handle)+import Blaze.ByteString.Builder (fromLazyByteString,+ toLazyByteString)+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import Yesod.Core.Internal.Request (tokenKey)+import Data.Text.Encoding (encodeUtf8)++yarToResponse :: Monad m+ => YesodResponse+ -> (SessionMap -> m [Header]) -- ^ save session+ -> YesodRequest+ -> m Response+yarToResponse (YRWai a) _ _ = return a+yarToResponse (YRPlain s hs ct c newSess) saveSession yreq = do+ extraHeaders <- do+ let nsToken = maybe+ newSess+ (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)+ (reqToken yreq)+ sessionHeaders <- saveSession nsToken+ return $ ("Content-Type", ct) : map headerToPair sessionHeaders+ let finalHeaders = extraHeaders ++ map headerToPair hs+ finalHeaders' len = ("Content-Length", S8.pack $ show len)+ : finalHeaders+ let go (ContentBuilder b mlen) =+ let hs' = maybe finalHeaders finalHeaders' mlen+ in ResponseBuilder s hs' b+ go (ContentFile fp p) = ResponseFile s finalHeaders fp p+ go (ContentSource body) = ResponseSource s finalHeaders body+ go (ContentDontEvaluate c') = go c'+ return $ go c++-- | Convert Header to a key/value pair.+headerToPair :: Header+ -> (CI ByteString, ByteString)+headerToPair (AddCookie sc) =+ ("Set-Cookie", toByteString $ renderSetCookie $ sc)+headerToPair (DeleteCookie key path) =+ ( "Set-Cookie"+ , S.concat+ [ key+ , "=; path="+ , path+ , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"+ ]+ )+headerToPair (Header key value) = (CI.mk key, value)++evaluateContent :: Content -> IO (Either ErrorResponse Content)+evaluateContent (ContentBuilder b mlen) = handle f $ do+ let lbs = toLazyByteString b+ L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)+ where+ f :: SomeException -> IO (Either ErrorResponse Content)+ f = return . Left . InternalError . T.pack . show+evaluateContent c = return (Right c)++getStatus :: ErrorResponse -> H.Status+getStatus NotFound = H.status404+getStatus (InternalError _) = H.status500+getStatus (InvalidArgs _) = H.status400+getStatus NotAuthenticated = H.status401+getStatus (PermissionDenied _) = H.status403+getStatus (BadMethod _) = H.status405
+ Yesod/Core/Internal/Run.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Core.Internal.Run where++import Yesod.Core.Internal.Response+import Blaze.ByteString.Builder (toByteString)+import Control.Applicative ((<$>))+import Control.Exception (fromException)+import Control.Exception.Lifted (catch)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger (LogLevel (LevelError), LogSource,+ liftLoc)+import Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.IORef as I+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Maybe (fromMaybe)+import Data.Monoid (appEndo, mempty)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Language.Haskell.TH.Syntax (Loc, qLocation)+import qualified Network.HTTP.Types as H+import Network.Wai+import Prelude hiding (catch)+import System.Log.FastLogger (Logger)+import System.Log.FastLogger (LogStr, toLogStr)+import System.Random (newStdGen)+import Yesod.Core.Content+import Yesod.Core.Class.Yesod+import Yesod.Core.Types+import Yesod.Core.Internal.Request (parseWaiRequest,+ tooLargeResponse)+import Yesod.Routes.Class (Route, renderRoute)++-- | Function used internally by Yesod in the process of converting a+-- 'HandlerT' into an 'Application'. Should not be needed by users.+runHandler :: ToTypedContent c+ => RunHandlerEnv site+ -> HandlerT site IO c+ -> YesodApp+runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do+ let toErrorHandler e =+ case fromException e of+ Just (HCError x) -> x+ _ -> InternalError $ T.pack $ show e+ istate <- liftIO $ I.newIORef GHState+ { ghsSession = reqSession yreq+ , ghsRBC = Nothing+ , ghsIdent = 1+ , ghsCache = mempty+ , ghsHeaders = mempty+ }+ let hd = HandlerData+ { handlerRequest = yreq+ , handlerEnv = rhe+ , handlerState = istate+ , handlerToParent = const ()+ , handlerResource = resState+ }+ contents' <- catch (fmap Right $ unHandlerT handler hd)+ (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id+ $ fromException e)+ state <- liftIO $ I.readIORef istate+ let finalSession = ghsSession state+ let headers = ghsHeaders state+ let contents = either id (HCContent H.status200 . toTypedContent) contents'+ let handleError e = flip runInternalState resState $ do+ yar <- rheOnError e yreq+ { reqSession = finalSession+ }+ case yar of+ YRPlain _ hs ct c sess ->+ let hs' = appEndo headers hs+ in return $ YRPlain (getStatus e) hs' ct c sess+ YRWai _ -> return yar+ let sendFile' ct fp p =+ return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession+ case contents of+ HCContent status (TypedContent ct c) -> do+ ec' <- liftIO $ evaluateContent c+ case ec' of+ Left e -> handleError e+ Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession+ HCError e -> handleError e+ HCRedirect status loc -> do+ let disable_caching x =+ Header "Cache-Control" "no-cache, must-revalidate"+ : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"+ : x+ hs = (if status /= H.movedPermanently301 then disable_caching else id)+ $ Header "Location" (encodeUtf8 loc) : appEndo headers []+ return $ YRPlain+ status hs typePlain emptyContent+ finalSession+ HCSendFile ct fp p -> catch+ (sendFile' ct fp p)+ (handleError . toErrorHandler)+ HCCreated loc -> do+ let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []+ return $ YRPlain+ H.status201+ hs+ typePlain+ emptyContent+ finalSession+ HCWai r -> return $ YRWai r++safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())+ -> ErrorResponse+ -> YesodApp+safeEh log' er req = do+ liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError+ $ toLogStr $ "Error handler errored out: " ++ show er+ return $ YRPlain+ H.status500+ []+ typePlain+ (toContent ("Internal Server Error" :: S.ByteString))+ (reqSession req)++-- | Run a 'HandlerT' completely outside of Yesod. This+-- function comes with many caveats and you shouldn't use it+-- unless you fully understand what it's doing and how it works.+--+-- As of now, there's only one reason to use this function at+-- all: in order to run unit tests of functions inside 'HandlerT'+-- but that aren't easily testable with a full HTTP request.+-- Even so, it's better to use @wai-test@ or @yesod-test@ instead+-- of using this function.+--+-- This function will create a fake HTTP request (both @wai@'s+-- 'Request' and @yesod@'s 'Request') and feed it to the+-- @HandlerT@. The only useful information the @HandlerT@ may+-- get from the request is the session map, which you must supply+-- as argument to @runFakeHandler@. All other fields contain+-- fake information, which means that they can be accessed but+-- won't have any useful information. The response of the+-- @HandlerT@ is completely ignored, including changes to the+-- session, cookies or headers. We only return you the+-- @HandlerT@'s return value.+runFakeHandler :: (Yesod site, MonadIO m) =>+ SessionMap+ -> (site -> Logger)+ -> site+ -> HandlerT site IO a+ -> m (Either ErrorResponse a)+runFakeHandler fakeSessionMap logger site handler = liftIO $ do+ ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")+ let handler' = do liftIO . I.writeIORef ret . Right =<< handler+ return ()+ let yapp = runHandler+ RunHandlerEnv+ { rheRender = yesodRender site $ resolveApproot site fakeWaiRequest+ , rheRoute = Nothing+ , rheSite = site+ , rheUpload = fileUpload site+ , rheLog = messageLoggerSource site $ logger site+ , rheOnError = errHandler+ }+ handler'+ errHandler err req = do+ liftIO $ I.writeIORef ret (Left err)+ return $ YRPlain+ H.status500+ []+ typePlain+ (toContent ("runFakeHandler: errHandler" :: S8.ByteString))+ (reqSession req)+ fakeWaiRequest =+ Request+ { requestMethod = "POST"+ , httpVersion = H.http11+ , rawPathInfo = "/runFakeHandler/pathInfo"+ , rawQueryString = ""+ , serverName = "runFakeHandler-serverName"+ , serverPort = 80+ , requestHeaders = []+ , isSecure = False+ , remoteHost = error "runFakeHandler-remoteHost"+ , pathInfo = ["runFakeHandler", "pathInfo"]+ , queryString = []+ , requestBody = mempty+ , vault = mempty+ , requestBodyLength = KnownLength 0+ }+ fakeRequest =+ YesodRequest+ { reqGetParams = []+ , reqCookies = []+ , reqWaiRequest = fakeWaiRequest+ , reqLangs = []+ , reqToken = Just "NaN" -- not a nonce =)+ , reqAccept = []+ , reqSession = fakeSessionMap+ }+ _ <- runResourceT $ yapp fakeRequest+ I.readIORef ret+{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}++yesodRunner :: (ToTypedContent res, Yesod site)+ => HandlerT site IO res+ -> YesodRunnerEnv site+ -> Maybe (Route site)+ -> Application+yesodRunner handler' YesodRunnerEnv {..} route req+ | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse+ | otherwise = do+ let dontSaveSession _ = return []+ (session, saveSession) <- liftIO $ do+ maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb req) yreSessionBackend+ let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) mmaxLen+ yreq <-+ case mkYesodReq of+ Left yreq -> return yreq+ Right needGen -> liftIO $ needGen <$> newStdGen+ let ra = resolveApproot yreSite req+ let log' = messageLoggerSource yreSite yreLogger+ -- We set up two environments: the first one has a "safe" error handler+ -- which will never throw an exception. The second one uses the+ -- user-provided errorHandler function. If that errorHandler function+ -- errors out, it will use the safeEh below to recover.+ rheSafe = RunHandlerEnv+ { rheRender = yesodRender yreSite ra+ , rheRoute = route+ , rheSite = yreSite+ , rheUpload = fileUpload yreSite+ , rheLog = log'+ , rheOnError = safeEh log'+ }+ rhe = rheSafe+ { rheOnError = runHandler rheSafe . errorHandler+ }+ yar <- runHandler rhe handler yreq+ liftIO $ yarToResponse yar saveSession yreq+ where+ mmaxLen = maximumContentLength yreSite route+ handler = yesodMiddleware handler'++yesodRender :: Yesod y+ => y+ -> ResolvedApproot+ -> Route y+ -> [(Text, Text)] -- ^ url query string+ -> Text+yesodRender y ar url params =+ decodeUtf8With lenientDecode $ toByteString $+ fromMaybe+ (joinPath y ar ps+ $ params ++ params')+ (urlRenderOverride y url)+ where+ (ps, params') = renderRoute url++resolveApproot :: Yesod master => master -> Request -> ResolvedApproot+resolveApproot master req =+ case approot of+ ApprootRelative -> ""+ ApprootStatic t -> t+ ApprootMaster f -> f master+ ApprootRequest f -> f master req++stripHandlerT :: HandlerT child (HandlerT parent m) a+ -> (parent -> child)+ -> (Route child -> Route parent)+ -> Maybe (Route child)+ -> HandlerT parent m a+stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do+ let env = handlerEnv hd+ ($ hd) $ unHandlerT $ f hd+ { handlerEnv = env+ { rheSite = getSub $ rheSite env+ , rheRoute = newRoute+ , rheRender = \url params -> rheRender env (toMaster url) params+ }+ , handlerToParent = toMaster+ }
+ Yesod/Core/Internal/Session.hs view
@@ -0,0 +1,68 @@+module Yesod.Core.Internal.Session+ ( encodeClientSession+ , decodeClientSession+ , clientSessionDateCacher+ , ClientSessionDateCache(..)+ , SaveSession+ , SessionBackend(..)+ ) where++import qualified Web.ClientSession as CS+import Data.Serialize+import Data.Time+import Data.ByteString (ByteString)+import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Monad (forever, guard)+import Yesod.Core.Types+import Yesod.Core.Internal.Util+import qualified Data.IORef as I++encodeClientSession :: CS.Key+ -> CS.IV+ -> ClientSessionDateCache -- ^ expire time+ -> ByteString -- ^ remote host+ -> SessionMap -- ^ session+ -> ByteString -- ^ cookie value+encodeClientSession key iv date rhost session' =+ CS.encrypt key iv $ encode $ SessionCookie expires rhost session'+ where expires = Right (csdcExpiresSerialized date)++decodeClientSession :: CS.Key+ -> ClientSessionDateCache -- ^ current time+ -> ByteString -- ^ remote host field+ -> ByteString -- ^ cookie value+ -> Maybe SessionMap+decodeClientSession key date rhost encrypted = do+ decrypted <- CS.decrypt key encrypted+ SessionCookie (Left expire) rhost' session' <-+ either (const Nothing) Just $ decode decrypted+ guard $ expire > csdcNow date+ guard $ rhost' == rhost+ return session'+++----------------------------------------------------------------------+++-- Mostly copied from Kazu's date-cache, but with modifications+-- that better suit our needs.+--+-- The cached date is updated every 10s, we don't need second+-- resolution for session expiration times.++clientSessionDateCacher ::+ NominalDiffTime -- ^ Inactive session valitity.+ -> IO (IO ClientSessionDateCache, IO ())+clientSessionDateCacher validity = do+ ref <- getUpdated >>= I.newIORef+ tid <- forkIO $ forever (doUpdate ref)+ return $! (I.readIORef ref, killThread tid)+ where+ getUpdated = do+ now <- getCurrentTime+ let expires = validity `addUTCTime` now+ expiresS = runPut (putTime expires)+ return $! ClientSessionDateCache now expires expiresS+ doUpdate ref = do+ threadDelay 10000000 -- 10s+ I.writeIORef ref =<< getUpdated
+ Yesod/Core/Internal/TH.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Yesod.Core.Internal.TH where++import Prelude hiding (exp)+import Yesod.Core.Handler++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import qualified Network.Wai as W++import Data.ByteString.Lazy.Char8 ()+import Data.List (foldl')++import Yesod.Routes.TH+import Yesod.Routes.Parse+import Yesod.Core.Types+import Yesod.Core.Content+import Yesod.Core.Class.Dispatch+import Yesod.Core.Internal.Run++-- | Generates URL datatype and site function for the given 'Resource's. This+-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.+-- Use 'parseRoutes' to create the 'Resource's.+mkYesod :: String -- ^ name of the argument datatype+ -> [ResourceTree String]+ -> Q [Dec]+mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False++-- | Sometimes, you will want to declare your routes in one file and define+-- your handlers elsewhere. For example, this is the only way to break up a+-- monolithic file into smaller parts. Use this function, paired with+-- 'mkYesodDispatch', to do just that.+mkYesodData :: String -> [ResourceTree String] -> Q [Dec]+mkYesodData name res = mkYesodDataGeneral name False res++mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec]+mkYesodSubData name res = mkYesodDataGeneral name True res++mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]+mkYesodDataGeneral name isSub res = do+ let (name':rest) = words name+ fmap fst $ mkYesodGeneral name' rest isSub res++-- | See 'mkYesodData'.+mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False++-- | Get the Handler and Widget type synonyms for the given site.+masterTypeSyns :: Type -> [Dec]+masterTypeSyns site =+ [ TySynD (mkName "Handler") []+ $ ConT ''HandlerT `AppT` site `AppT` ConT ''IO+ , TySynD (mkName "Widget") []+ $ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''()+ ]++mkYesodGeneral :: String -- ^ foundation type+ -> [String] -- ^ arguments for the type+ -> Bool -- ^ it this a subsite+ -> [ResourceTree String]+ -> Q([Dec],[Dec])+mkYesodGeneral name args isSub resS = do+ renderRouteDec <- mkRenderRouteInstance site res+ routeAttrsDec <- mkRouteAttrsInstance site res+ dispatchDec <- mkDispatchInstance site res+ parse <- mkParseRouteInstance site res+ let rname = mkName $ "resources" ++ name+ eres <- lift resS+ let resourcesDec =+ [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)+ , FunD rname [Clause [] (NormalB eres) []]+ ]+ let dataDec = concat+ [ [parse]+ , renderRouteDec+ , [routeAttrsDec]+ , resourcesDec+ , if isSub then [] else masterTypeSyns site+ ]+ return (dataDec, dispatchDec)+ where site = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args)+ res = map (fmap parseType) resS++mkMDS :: Q Exp -> MkDispatchSettings+mkMDS rh = MkDispatchSettings+ { mdsRunHandler = rh+ , mdsSubDispatcher =+ [|\parentRunner getSub toParent env -> yesodSubDispatch+ YesodSubRunnerEnv+ { ysreParentRunner = parentRunner+ , ysreGetSub = getSub+ , ysreToParentRoute = toParent+ , ysreParentEnv = env+ }+ |]+ , mdsGetPathInfo = [|W.pathInfo|]+ , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]+ , mdsMethod = [|W.requestMethod|]+ , mds404 = [|notFound >> return ()|]+ , mds405 = [|badMethod >> return ()|]+ , mdsGetHandler = defaultGetHandler+ }++-- | If the generation of @'YesodDispatch'@ instance require finer+-- control of the types, contexts etc. using this combinator. You will+-- hardly need this generality. However, in certain situations, like+-- when writing library/plugin for yesod, this combinator becomes+-- handy.+mkDispatchInstance :: Type -- ^ The master site type+ -> [ResourceTree a] -- ^ The resource+ -> DecsQ+mkDispatchInstance master res = do+ clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res+ let thisDispatch = FunD 'yesodDispatch [clause']+ return [InstanceD [] yDispatch [thisDispatch]]+ where+ yDispatch = ConT ''YesodDispatch `AppT` master++mkYesodSubDispatch :: [ResourceTree a] -> Q Exp+mkYesodSubDispatch res = do+ clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res+ inner <- newName "inner"+ let innerFun = FunD inner [clause']+ helper <- newName "helper"+ let fun = FunD helper+ [ Clause+ []+ (NormalB $ VarE inner)+ [innerFun]+ ]+ return $ LetE [fun] (VarE helper)
+ Yesod/Core/Internal/Util.hs view
@@ -0,0 +1,46 @@+module Yesod.Core.Internal.Util+ ( putTime+ , getTime+ , formatW3+ , formatRFC1123+ , formatRFC822+ ) where++import Data.Int (Int64)+import Data.Serialize (Get, Put, Serialize (..))+import qualified Data.Text as T+import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay),+ DiffTime, UTCTime (..), formatTime)+import System.Locale (defaultTimeLocale)++putTime :: UTCTime -> Put+putTime (UTCTime d t) =+ let d' = fromInteger $ toModifiedJulianDay d+ t' = fromIntegral $ fromEnum (t / diffTimeScale)+ in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')++getTime :: Get UTCTime+getTime = do+ val <- get+ let (d, t) = val `divMod` posixDayLength_int64+ d' = ModifiedJulianDay $! fromIntegral d+ t' = fromIntegral t+ d' `seq` t' `seq` return (UTCTime d' t')++posixDayLength_int64 :: Int64+posixDayLength_int64 = 86400++diffTimeScale :: DiffTime+diffTimeScale = 1e12++-- | Format a 'UTCTime' in W3 format.+formatW3 :: UTCTime -> T.Text+formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00"++-- | Format as per RFC 1123.+formatRFC1123 :: UTCTime -> T.Text+formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"++-- | Format as per RFC 822.+formatRFC822 :: UTCTime -> T.Text+formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
+ Yesod/Core/Json.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Yesod.Core.Json+ ( -- * Convert from a JSON value+ defaultLayoutJson+ , jsonToRepJson++ -- * Convert to a JSON value+ , parseJsonBody+ , parseJsonBody_++ -- * Produce JSON values+ , J.Value (..)+ , J.ToJSON (..)+ , J.FromJSON (..)+ , array+ , object+ , (.=)+ , (J..:)++ -- * Convenience functions+ , jsonOrRedirect+ , acceptsJson+ ) where++import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody)+import Yesod.Core.Content (TypedContent)+import Yesod.Core.Types (reqAccept)+import Yesod.Core.Class.Yesod (defaultLayout, Yesod)+import Yesod.Core.Class.Handler+import Yesod.Core.Widget (WidgetT)+import Yesod.Routes.Class+import qualified Data.Aeson as J+import qualified Data.Aeson.Parser as JP+import Data.Aeson ((.=), object)+import Data.Conduit.Attoparsec (sinkParser)+import Data.Text (pack)+import qualified Data.Vector as V+import Data.Conduit+import qualified Data.ByteString.Char8 as B8+import Data.Maybe (listToMaybe)+import Control.Monad (liftM)++-- | Provide both an HTML and JSON representation for a piece of+-- data, using the default layout for the HTML output+-- ('defaultLayout').+--+-- /Since: 0.3.0/+defaultLayoutJson :: (Yesod site, J.ToJSON a)+ => WidgetT site IO () -- ^ HTML+ -> HandlerT site IO a -- ^ JSON+ -> HandlerT site IO TypedContent+defaultLayoutJson w json = selectRep $ do+ provideRep $ defaultLayout w+ provideRep $ fmap J.toJSON json++-- | Wraps a data type in a 'RepJson'. The data type must+-- support conversion to JSON via 'J.ToJSON'.+--+-- /Since: 0.3.0/+jsonToRepJson :: (Monad m, J.ToJSON a) => a -> m J.Value+jsonToRepJson = return . J.toJSON++-- | Parse the request body to a data type as a JSON value. The+-- data type must support conversion from JSON via 'J.FromJSON'.+-- If you want the raw JSON value, just ask for a @'J.Result'+-- 'J.Value'@.+--+-- /Since: 0.3.0/+parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)+parseJsonBody = do+ eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'+ return $ case eValue of+ Left e -> J.Error $ show e+ Right value -> J.fromJSON value++-- | Same as 'parseJsonBody', but return an invalid args response on a parse+-- error.+parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a+parseJsonBody_ = do+ ra <- parseJsonBody+ case ra of+ J.Error s -> invalidArgs [pack s]+ J.Success a -> return a++-- | Convert a list of values to an 'J.Array'.+array :: J.ToJSON a => [a] -> J.Value+array = J.Array . V.fromList . map J.toJSON++-- | jsonOrRedirect simplifies the scenario where a POST handler sends a different+-- response based on Accept headers:+--+-- 1. 200 with JSON data if the client prefers+-- @application\/json@ (e.g. AJAX, see 'acceptsJSON').+--+-- 2. 3xx otherwise, following the PRG pattern.+jsonOrRedirect :: (MonadHandler m, J.ToJSON a)+ => Route (HandlerSite m) -- ^ Redirect target+ -> a -- ^ Data to send via JSON+ -> m J.Value+jsonOrRedirect r j = do+ q <- acceptsJson+ if q then return (J.toJSON j)+ else redirect r++-- | Returns @True@ if the client prefers @application\/json@ as+-- indicated by the @Accept@ HTTP header.+acceptsJson :: MonadHandler m => m Bool+acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';'))+ . listToMaybe+ . reqAccept)+ `liftM` getRequest
+ Yesod/Core/Types.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Yesod.Core.Types where++import qualified Blaze.ByteString.Builder as BBuilder+import qualified Blaze.ByteString.Builder.Char.Utf8+import Control.Applicative (Applicative (..))+import Control.Applicative ((<$>))+import Control.Arrow (first)+import Control.Exception (Exception)+import Control.Monad (liftM, ap)+import Control.Monad.Base (MonadBase (liftBase))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Logger (LogLevel, LogSource,+ MonadLogger (..))+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.Conduit (Flush, MonadThrow (..),+ MonadUnsafeIO (..),+ ResourceT, Source)+import Data.Dynamic (Dynamic)+import Data.IORef (IORef)+import Data.Map (Map, unionWith)+import qualified Data.Map as Map+import Data.Monoid (Endo (..), Last (..),+ Monoid (..))+import Data.Serialize (Serialize (..),+ putByteString)+import Data.String (IsString (fromString))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TBuilder+import Data.Time (UTCTime)+import Data.Typeable (Typeable)+import Data.Typeable (TypeRep)+import Language.Haskell.TH.Syntax (Loc)+import qualified Network.HTTP.Types as H+import Network.Wai (FilePart,+ RequestBodyLength)+import qualified Network.Wai as W+import qualified Network.Wai.Parse as NWP+import System.Log.FastLogger (LogStr, Logger, toLogStr)+import Text.Blaze.Html (Html)+import Text.Hamlet (HtmlUrl)+import Text.Julius (JavascriptUrl)+import Web.Cookie (SetCookie)+import Yesod.Core.Internal.Util (getTime, putTime)+import Control.Monad.Trans.Class (MonadTrans (..))+import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))++-- Sessions+type SessionMap = Map Text ByteString++type SaveSession = SessionMap -- ^ The session contents after running the handler+ -> IO [Header]++newtype SessionBackend = SessionBackend+ { sbLoadSession :: W.Request+ -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session+ }++data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap+ deriving (Show, Read)+instance Serialize SessionCookie where+ put (SessionCookie a b c) = do+ either putTime putByteString a+ put b+ put (map (first T.unpack) $ Map.toList c)++ get = do+ a <- getTime+ b <- get+ c <- map (first T.pack) <$> get+ return $ SessionCookie (Left a) b (Map.fromList c)++data ClientSessionDateCache =+ ClientSessionDateCache {+ csdcNow :: !UTCTime+ , csdcExpires :: !UTCTime+ , csdcExpiresSerialized :: !ByteString+ } deriving (Eq, Show)++-- | The parsed request information. This type augments the standard WAI+-- 'W.Request' with additional information.+data YesodRequest = YesodRequest+ { reqGetParams :: ![(Text, Text)]+ -- ^ Same as 'W.queryString', but decoded to @Text@.+ , reqCookies :: ![(Text, Text)]+ , reqWaiRequest :: !W.Request+ , reqLangs :: ![Text]+ -- ^ Languages which the client supports. This is an ordered list by preference.+ , reqToken :: !(Maybe Text)+ -- ^ A random, session-specific token used to prevent CSRF attacks.+ , reqSession :: !SessionMap+ -- ^ Initial session sent from the client.+ --+ -- Since 1.2.0+ , reqAccept :: ![ContentType]+ -- ^ An ordered list of the accepted content types.+ --+ -- Since 1.2.0+ }++-- | An augmented WAI 'W.Response'. This can either be a standard @Response@,+-- or a higher-level data structure which Yesod will turn into a @Response@.+data YesodResponse+ = YRWai !W.Response+ | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap++-- | A tuple containing both the POST parameters and submitted files.+type RequestBodyContents =+ ( [(Text, Text)]+ , [(Text, FileInfo)]+ )++data FileInfo = FileInfo+ { fileName :: !Text+ , fileContentType :: !Text+ , fileSourceRaw :: !(Source (ResourceT IO) ByteString)+ , fileMove :: !(FilePath -> IO ())+ }++data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)+ | FileUploadDisk !(NWP.BackEnd FilePath)+ | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))++-- | How to determine the root of the application for constructing URLs.+--+-- Note that future versions of Yesod may add new constructors without bumping+-- the major version number. As a result, you should /not/ pattern match on+-- @Approot@ values.+data Approot master = ApprootRelative -- ^ No application root.+ | ApprootStatic !Text+ | ApprootMaster !(master -> Text)+ | ApprootRequest !(master -> W.Request -> Text)++type ResolvedApproot = Text++data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text+ deriving (Eq, Show, Read)++data ScriptLoadPosition master+ = BottomOfBody+ | BottomOfHeadBlocking+ | BottomOfHeadAsync (BottomOfHeadAsync master)++type BottomOfHeadAsync master+ = [Text] -- ^ urls to load asynchronously+ -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion+ -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>++newtype Cache = Cache (Map TypeRep Dynamic)+ deriving Monoid++type Texts = [Text]++-- | Wrap up a normal WAI application as a Yesod subsite.+newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }++data RunHandlerEnv site = RunHandlerEnv+ { rheRender :: !(Route site -> [(Text, Text)] -> Text)+ , rheRoute :: !(Maybe (Route site))+ , rheSite :: !site+ , rheUpload :: !(RequestBodyLength -> FileUpload)+ , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())+ , rheOnError :: !(ErrorResponse -> YesodApp)+ -- ^ How to respond when an error is thrown internally.+ --+ -- Since 1.2.0+ }++data HandlerData site parentRoute = HandlerData+ { handlerRequest :: !YesodRequest+ , handlerEnv :: !(RunHandlerEnv site)+ , handlerState :: !(IORef GHState)+ , handlerToParent :: !(Route site -> parentRoute)+ , handlerResource :: !InternalState+ }++data YesodRunnerEnv site = YesodRunnerEnv+ { yreLogger :: !Logger+ , yreSite :: !site+ , yreSessionBackend :: !(Maybe SessionBackend)+ }++data YesodSubRunnerEnv sub parent parentMonad = YesodSubRunnerEnv+ { ysreParentRunner :: !(ParentRunner parent parentMonad)+ , ysreGetSub :: !(parent -> sub)+ , ysreToParentRoute :: !(Route sub -> Route parent)+ , ysreParentEnv :: !(YesodRunnerEnv parent) -- FIXME maybe get rid of this and remove YesodRunnerEnv in ParentRunner?+ }++type ParentRunner parent m+ = m TypedContent+ -> YesodRunnerEnv parent+ -> Maybe (Route parent)+ -> W.Application++-- | A generic handler monad, which can have a different subsite and master+-- site. We define a newtype for better error message.+newtype HandlerT site m a = HandlerT+ { unHandlerT :: HandlerData site (MonadRoute m) -> m a+ }++type family MonadRoute (m :: * -> *)+type instance MonadRoute IO = ()+type instance MonadRoute (HandlerT site m) = (Route site)++data GHState = GHState+ { ghsSession :: SessionMap+ , ghsRBC :: Maybe RequestBodyContents+ , ghsIdent :: Int+ , ghsCache :: Cache+ , ghsHeaders :: Endo [Header]+ }++-- | An extension of the basic WAI 'W.Application' datatype to provide extra+-- features needed by Yesod. Users should never need to use this directly, as+-- the 'HandlerT' monad and template haskell code should hide it away.+type YesodApp = YesodRequest -> ResourceT IO YesodResponse++-- | A generic widget, allowing specification of both the subsite and master+-- site datatypes. While this is simply a @WriterT@, we define a newtype for+-- better error messages.+newtype WidgetT site m a = WidgetT+ { unWidgetT :: HandlerData site (MonadRoute m) -> m (a, GWData (Route site))+ }++instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where+ mempty = return ()+ mappend x y = x >> y++type RY master = Route master -> [(Text, Text)] -> Text++-- | Newtype wrapper allowing injection of arbitrary content into CSS.+--+-- Usage:+--+-- > toWidget $ CssBuilder "p { color: red }"+--+-- Since: 1.1.3+newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }++-- | Content for a web page. By providing this datatype, we can easily create+-- generic site templates, which would have the type signature:+--+-- > PageContent url -> HtmlUrl url+data PageContent url = PageContent+ { pageTitle :: Html+ , pageHead :: HtmlUrl url+ , pageBody :: HtmlUrl url+ }++data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length.+ | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder))+ | ContentFile !FilePath !(Maybe FilePart)+ | ContentDontEvaluate !Content++data TypedContent = TypedContent !ContentType !Content++type RepHtml = Html+newtype RepJson = RepJson Content+newtype RepPlain = RepPlain Content+newtype RepXml = RepXml Content++type ContentType = ByteString -- FIXME Text?++-- | Prevents a response body from being fully evaluated before sending the+-- request.+--+-- Since 1.1.0+newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }++-- | Responses to indicate some form of an error occurred. These are different+-- from 'SpecialResponse' in that they allow for custom error pages.+data ErrorResponse =+ NotFound+ | InternalError Text+ | InvalidArgs [Text]+ | NotAuthenticated+ | PermissionDenied Text+ | BadMethod H.Method+ deriving (Show, Eq, Typeable)++----- header stuff+-- | Headers to be added to a 'Result'.+data Header =+ AddCookie SetCookie+ | DeleteCookie ByteString ByteString+ | Header ByteString ByteString+ deriving (Eq, Show)++data Location url = Local url | Remote Text+ deriving (Show, Eq)++newtype UniqueList x = UniqueList ([x] -> [x])++data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }+ deriving (Show, Eq)+data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }+ deriving (Show, Eq)+newtype Title = Title { unTitle :: Html }++newtype Head url = Head (HtmlUrl url)+ deriving Monoid+newtype Body url = Body (HtmlUrl url)+ deriving Monoid++type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder++data GWData a = GWData+ { gwdBody :: !(Body a)+ , gwdTitle :: !(Last Title)+ , gwdScripts :: !(UniqueList (Script a))+ , gwdStylesheets :: !(UniqueList (Stylesheet a))+ , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type+ , gwdJavascript :: !(Maybe (JavascriptUrl a))+ , gwdHead :: !(Head a)+ }+instance Monoid (GWData a) where+ mempty = GWData mempty mempty mempty mempty mempty mempty mempty+ mappend (GWData a1 a2 a3 a4 a5 a6 a7)+ (GWData b1 b2 b3 b4 b5 b6 b7) = GWData+ (a1 `mappend` b1)+ (a2 `mappend` b2)+ (a3 `mappend` b3)+ (a4 `mappend` b4)+ (unionWith mappend a5 b5)+ (a6 `mappend` b6)+ (a7 `mappend` b7)++data HandlerContents =+ HCContent H.Status !TypedContent+ | HCError ErrorResponse+ | HCSendFile ContentType FilePath (Maybe FilePart)+ | HCRedirect H.Status Text+ | HCCreated Text+ | HCWai W.Response+ deriving Typeable++instance Show HandlerContents where+ show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)+ show (HCError e) = "HCError " ++ show e+ show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)+ show (HCRedirect s t) = "HCRedirect " ++ show (s, t)+ show (HCCreated t) = "HCCreated " ++ show t+ show (HCWai _) = "HCWai"+instance Exception HandlerContents++-- Instances for WidgetT+instance Monad m => Functor (WidgetT site m) where+ fmap = liftM+instance Monad m => Applicative (WidgetT site m) where+ pure = return+ (<*>) = ap+instance Monad m => Monad (WidgetT site m) where+ return a = WidgetT $ const $ return (a, mempty)+ WidgetT x >>= f = WidgetT $ \r -> do+ (a, wa) <- x r+ (b, wb) <- unWidgetT (f a) r+ return (b, wa `mappend` wb)+instance MonadIO m => MonadIO (WidgetT site m) where+ liftIO = lift . liftIO+instance MonadBase b m => MonadBase b (WidgetT site m) where+ liftBase = WidgetT . const . liftBase . fmap (, mempty)+instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where+ data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))+ liftBaseWith f = WidgetT $ \reader ->+ liftBaseWith $ \runInBase ->+ liftM (\x -> (x, mempty))+ (f $ liftM StW . runInBase . flip unWidgetT reader)+ restoreM (StW base) = WidgetT $ const $ restoreM base++instance MonadTrans (WidgetT site) where+ lift = WidgetT . const . liftM (, mempty)+instance MonadThrow m => MonadThrow (WidgetT site m) where+ monadThrow = lift . monadThrow+instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where+ liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)++instance MonadIO m => MonadLogger (WidgetT site m) where+ monadLoggerLog a b c d = WidgetT $ \hd ->+ liftIO $ fmap (, mempty) $ rheLog (handlerEnv hd) a b c (toLogStr d)++instance MonadTrans (HandlerT site) where+ lift = HandlerT . const++-- Instances for HandlerT+instance Monad m => Functor (HandlerT site m) where+ fmap = liftM+instance Monad m => Applicative (HandlerT site m) where+ pure = return+ (<*>) = ap+instance Monad m => Monad (HandlerT site m) where+ return = HandlerT . const . return+ HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r+instance MonadIO m => MonadIO (HandlerT site m) where+ liftIO = lift . liftIO+instance MonadBase b m => MonadBase b (HandlerT site m) where+ liftBase = lift . liftBase+-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s+-- @fork@ function is incompatible with the underlying @ResourceT@ system.+-- Instead, if you must fork a separate thread, you should use+-- @resourceForkIO@.+--+-- Using fork usually leads to an exception that says+-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed+-- after cleanup. Please contact the maintainers.\"+instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where+ data StM (HandlerT site m) a = StH (StM m a)+ liftBaseWith f = HandlerT $ \reader ->+ liftBaseWith $ \runInBase ->+ f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)+ restoreM (StH base) = HandlerT $ const $ restoreM base++instance MonadThrow m => MonadThrow (HandlerT site m) where+ monadThrow = lift . monadThrow+instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where+ liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)++instance MonadIO m => MonadLogger (HandlerT site m) where+ monadLoggerLog a b c d = HandlerT $ \hd ->+ liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)++instance Monoid (UniqueList x) where+ mempty = UniqueList id+ UniqueList x `mappend` UniqueList y = UniqueList $ x . y++instance IsString Content where+ fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString++instance RenderRoute WaiSubsite where+ data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]+ deriving (Show, Eq, Read, Ord)+ renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)+instance ParseRoute WaiSubsite where+ parseRoute (x, y) = Just $ WaiSubsiteRoute x y
+ Yesod/Core/Widget.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CPP #-}+-- | Widgets combine HTML with JS and CSS dependencies with a unique identifier+-- generator, allowing you to create truly modular HTML components.+module Yesod.Core.Widget+ ( -- * Datatype+ WidgetT+ , PageContent (..)+ -- * Special Hamlet quasiquoter/TH for Widgets+ , whamlet+ , whamletFile+ , ihamletToRepHtml+ -- * Convert to Widget+ , ToWidget (..)+ , ToWidgetHead (..)+ , ToWidgetBody (..)+ , ToWidgetMedia (..)+ -- * Creating+ -- ** Head of page+ , setTitle+ , setTitleI+ -- ** CSS+ , addStylesheet+ , addStylesheetAttrs+ , addStylesheetRemote+ , addStylesheetRemoteAttrs+ , addStylesheetEither+ , CssBuilder (..)+ -- ** Javascript+ , addScript+ , addScriptAttrs+ , addScriptRemote+ , addScriptRemoteAttrs+ , addScriptEither+ -- * Subsites+ , widgetToParentWidget+ , handlerToWidget+ -- * Internal+ , whamletFileWithSettings+ ) where++import Data.Monoid+import qualified Text.Blaze.Html5 as H+import Text.Hamlet+import Text.Cassius+import Text.Julius+import Yesod.Routes.Class+import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Text.Shakespeare.I18N (RenderMessage)+import Control.Monad (liftM)+import Data.Text (Text)+import qualified Data.Map as Map+import Language.Haskell.TH.Quote (QuasiQuoter)+import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)++import qualified Text.Hamlet as NP+import Data.Text.Lazy.Builder (fromLazyText)+import Text.Blaze.Html (toHtml, preEscapedToMarkup)+import qualified Data.Text.Lazy as TL++import Yesod.Core.Types+import Yesod.Core.Class.Handler++preEscapedLazyText :: TL.Text -> Html+preEscapedLazyText = preEscapedToMarkup++class ToWidget site a where+ toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidget site (render -> Html) where+ toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty+instance render ~ RY site => ToWidget site (render -> Css) where+ toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x+instance render ~ RY site => ToWidget site (render -> CssBuilder) where+ toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty+instance render ~ RY site => ToWidget site (render -> Javascript) where+ toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty+instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where+ toWidget = liftWidgetT+instance ToWidget site Html where+ toWidget = toWidget . const++-- | Allows adding some CSS to the page with a specific media type.+--+-- Since 1.2+class ToWidgetMedia site a where+ -- | Add the given content to the page, but only for the given media type.+ --+ -- Since 1.2+ toWidgetMedia :: (MonadWidget m, HandlerSite m ~ site)+ => Text -- ^ media value+ -> a+ -> m ()+instance render ~ RY site => ToWidgetMedia site (render -> Css) where+ toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x+instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where+ toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty++class ToWidgetBody site a where+ toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidgetBody site (render -> Html) where+ toWidgetBody = toWidget+instance render ~ RY site => ToWidgetBody site (render -> Javascript) where+ toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j+instance ToWidgetBody site Html where+ toWidgetBody = toWidget++class ToWidgetHead site a where+ toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()++instance render ~ RY site => ToWidgetHead site (render -> Html) where+ toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head+instance render ~ RY site => ToWidgetHead site (render -> Css) where+ toWidgetHead = toWidget+instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where+ toWidgetHead = toWidget+instance render ~ RY site => ToWidgetHead site (render -> Javascript) where+ toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j+instance ToWidgetHead site Html where+ toWidgetHead = toWidgetHead . const++-- | Set the page title. Calling 'setTitle' multiple times overrides previously+-- set values.+setTitle :: MonadWidget m => Html -> m ()+setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty++-- | Set the page title. Calling 'setTitle' multiple times overrides previously+-- set values.+setTitleI :: (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m ()+setTitleI msg = do+ mr <- getMessageRender+ setTitle $ toHtml $ mr msg++-- | Link to the specified local stylesheet.+addStylesheet :: MonadWidget m => Route (HandlerSite m) -> m ()+addStylesheet = flip addStylesheetAttrs []++-- | Link to the specified local stylesheet.+addStylesheetAttrs :: MonadWidget m+ => Route (HandlerSite m)+ -> [(Text, Text)]+ -> m ()+addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty++-- | Link to the specified remote stylesheet.+addStylesheetRemote :: MonadWidget m => Text -> m ()+addStylesheetRemote = flip addStylesheetRemoteAttrs []++-- | Link to the specified remote stylesheet.+addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()+addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty++addStylesheetEither :: MonadWidget m+ => Either (Route (HandlerSite m)) Text+ -> m ()+addStylesheetEither = either addStylesheet addStylesheetRemote++addScriptEither :: MonadWidget m+ => Either (Route (HandlerSite m)) Text+ -> m ()+addScriptEither = either addScript addScriptRemote++-- | Link to the specified local script.+addScript :: MonadWidget m => Route (HandlerSite m) -> m ()+addScript = flip addScriptAttrs []++-- | Link to the specified local script.+addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m ()+addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty++-- | Link to the specified remote script.+addScriptRemote :: MonadWidget m => Text -> m ()+addScriptRemote = flip addScriptRemoteAttrs []++-- | Link to the specified remote script.+addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m ()+addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty++whamlet :: QuasiQuoter+whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings++whamletFile :: FilePath -> Q Exp+whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings++whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp+whamletFileWithSettings = NP.hamletFileWithSettings rules++asWidgetT :: WidgetT site m () -> WidgetT site m ()+asWidgetT = id++rules :: Q NP.HamletRules+rules = do+ ah <- [|asWidgetT . toWidget|]+ let helper qg f = do+ x <- newName "urender"+ e <- f $ VarE x+ let e' = LamE [VarP x] e+ g <- qg+ bind <- [|(>>=)|]+ return $ InfixE (Just g) bind (Just e')+ let ur f = do+ let env = NP.Env+ (Just $ helper [|getUrlRenderParams|])+ (Just $ helper [|liftM (toHtml .) getMessageRender|])+ f env+ return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b++-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.+ihamletToRepHtml :: (MonadHandler m, RenderMessage (HandlerSite m) message)+ => HtmlUrlI18n message (Route (HandlerSite m))+ -> m Html+ihamletToRepHtml ih = do+ urender <- getUrlRenderParams+ mrender <- getMessageRender+ return $ ih (toHtml . mrender) urender++tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()+tell w = liftWidgetT $ WidgetT $ const $ return ((), w)++toUnique :: x -> UniqueList x+toUnique = UniqueList . (:)++handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a+handlerToWidget (HandlerT f) = WidgetT $ liftM (, mempty) . f++widgetToParentWidget :: MonadIO m+ => WidgetT child IO a+ -> HandlerT child (HandlerT parent m) (WidgetT parent m a)+widgetToParentWidget (WidgetT f) = HandlerT $ \hd -> do+ (a, gwd) <- liftIO $ f hd { handlerToParent = const () }+ return $ WidgetT $ const $ return (a, liftGWD (handlerToParent hd) gwd)++liftGWD :: (child -> parent) -> GWData child -> GWData parent+liftGWD tp gwd = GWData+ { gwdBody = fixBody $ gwdBody gwd+ , gwdTitle = gwdTitle gwd+ , gwdScripts = fixUnique fixScript $ gwdScripts gwd+ , gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd+ , gwdCss = fmap fixCss $ gwdCss gwd+ , gwdJavascript = fmap fixJS $ gwdJavascript gwd+ , gwdHead = fixHead $ gwdHead gwd+ }+ where+ fixRender f route params = f (tp route) params++ fixBody (Body h) = Body $ h . fixRender+ fixHead (Head h) = Head $ h . fixRender++ fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)++ fixScript (Script loc attrs) = Script (fixLoc loc) attrs+ fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs++ fixLoc (Local url) = Local $ tp url+ fixLoc (Remote t) = Remote t++ fixCss f = f . fixRender++ fixJS f = f . fixRender
− Yesod/Dispatch.hs
@@ -1,223 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Yesod.Dispatch- ( -- * Quasi-quoted routing- parseRoutes- , parseRoutesNoCheck- , parseRoutesFile- , parseRoutesFileNoCheck- , mkYesod- , mkYesodSub- -- ** More fine-grained- , mkYesodData- , mkYesodSubData- , mkYesodDispatch- , mkYesodSubDispatch- , mkDispatchInstance- -- ** Path pieces- , PathPiece (..)- , PathMultiPiece (..)- , Texts- -- * Convert to WAI- , toWaiApp- , toWaiAppPlain- -- * WAI subsites- , WaiSubsite (..)- ) where--import Control.Applicative ((<$>), (<*>))-import Prelude hiding (exp)-import Yesod.Internal.Core-import Yesod.Handler hiding (lift)-import Yesod.Widget (GWidget)--import Web.PathPieces-import Language.Haskell.TH-import Language.Haskell.TH.Syntax--import qualified Network.Wai as W-import Network.Wai.Middleware.Gzip-import Network.Wai.Middleware.Autohead--import Data.ByteString.Lazy.Char8 ()--import Data.Text (Text)-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Monoid (mappend)-import qualified Data.ByteString as S-import qualified Blaze.ByteString.Builder-import Network.HTTP.Types (status301)-import Yesod.Routes.TH-import Yesod.Content (chooseRep)-import Yesod.Routes.Parse-import System.Log.FastLogger (Logger)--type Texts = [Text]---- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.--- Use 'parseRoutes' to create the 'Resource's.-mkYesod :: String -- ^ name of the argument datatype- -> [ResourceTree String]- -> Q [Dec]-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False---- | Generates URL datatype and site function for the given 'Resource's. This--- is used for creating subsites, /not/ sites. See 'mkYesod' for the latter.--- Use 'parseRoutes' to create the 'Resource's. In general, a subsite is not--- executable by itself, but instead provides functionality to--- be embedded in other sites.-mkYesodSub :: String -- ^ name of the argument datatype- -> Cxt- -> [ResourceTree String]- -> Q [Dec]-mkYesodSub name clazzes =- fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True- where- (name':rest) = words name---- | Sometimes, you will want to declare your routes in one file and define--- your handlers elsewhere. For example, this is the only way to break up a--- monolithic file into smaller parts. Use this function, paired with--- 'mkYesodDispatch', to do just that.-mkYesodData :: String -> [ResourceTree String] -> Q [Dec]-mkYesodData name res = mkYesodDataGeneral name [] False res--mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec]-mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res--mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec]-mkYesodDataGeneral name clazzes isSub res = do- let (name':rest) = words name- (x, _) <- mkYesodGeneral name' rest clazzes isSub res- let rname = mkName $ "resources" ++ name- eres <- lift res- let y = [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)- , FunD rname [Clause [] (NormalB eres) []]- ]- return $ x ++ y---- | See 'mkYesodData'.-mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False--mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec]-mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True - where (name':rest) = words name--mkYesodGeneral :: String -- ^ foundation type- -> [String] -- ^ arguments for the type- -> Cxt -- ^ the type constraints- -> Bool -- ^ it this a subsite- -> [ResourceTree String]- -> Q([Dec],[Dec])-mkYesodGeneral name args clazzes isSub resS = do- subsite <- sub- masterTypeSyns <- if isSub then return [] - else sequence [handler, widget]- renderRouteDec <- mkRenderRouteInstance subsite res- dispatchDec <- mkDispatchInstance context sub master res- return (renderRouteDec ++ masterTypeSyns, dispatchDec)- where sub = foldl appT subCons subArgs- master = if isSub then (varT $ mkName "master") else sub- context = if isSub then cxt $ yesod : map return clazzes- else return []- yesod = classP ''Yesod [master]- handler = tySynD (mkName "Handler") [] [t| GHandler $master $master |]- widget = tySynD (mkName "Widget") [] [t| GWidget $master $master () |]- res = map (fmap parseType) resS- subCons = conT $ mkName name- subArgs = map (varT. mkName) args- --- | If the generation of @'YesodDispatch'@ instance require finer--- control of the types, contexts etc. using this combinator. You will--- hardly need this generality. However, in certain situations, like--- when writing library/plugin for yesod, this combinator becomes--- handy.-mkDispatchInstance :: CxtQ -- ^ The context- -> TypeQ -- ^ The subsite type- -> TypeQ -- ^ The master site type- -> [ResourceTree a] -- ^ The resource- -> DecsQ-mkDispatchInstance context sub master res = do- logger <- newName "logger"- let loggerE = varE logger- loggerP = VarP logger- yDispatch = conT ''YesodDispatch `appT` sub `appT` master- thisDispatch = do- Clause pat body decs <- mkDispatchClause- [|yesodRunner $loggerE |]- [|yesodDispatch $loggerE |]- [|fmap chooseRep|]- res- return $ FunD 'yesodDispatch- [ Clause (loggerP:pat)- body- decs- ]- in sequence [instanceD context yDispatch [thisDispatch]]- ---- | Convert the given argument into a WAI application, executable with any WAI--- handler. This is the same as 'toWaiAppPlain', except it includes two--- middlewares: GZIP compression and autohead. This is the--- recommended approach for most users.-toWaiApp :: ( Yesod master- , YesodDispatch master master- ) => master -> IO W.Application-toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y---- | Convert the given argument into a WAI application, executable with any WAI--- handler. This differs from 'toWaiApp' in that it uses no middlewares.-toWaiAppPlain :: ( Yesod master- , YesodDispatch master master- ) => master -> IO W.Application-toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a---toWaiApp' :: ( Yesod master- , YesodDispatch master master- )- => master- -> Logger- -> Maybe (SessionBackend master)- -> W.Application-toWaiApp' y logger sb env =- case cleanPath y $ W.pathInfo env of- Left pieces -> sendRedirect y pieces env- Right pieces ->- yesodDispatch logger y y id app404 handler405 method pieces sb env- where- app404 = yesodRunner logger notFound y y Nothing id- handler405 route = yesodRunner logger badMethod y y (Just route) id- method = decodeUtf8With lenientDecode $ W.requestMethod env--sendRedirect :: Yesod master => master -> [Text] -> W.Application-sendRedirect y segments' env =- return $ W.responseLBS status301- [ ("Content-Type", "text/plain")- , ("Location", Blaze.ByteString.Builder.toByteString dest')- ] "Redirecting"- where- dest = joinPath y (resolveApproot y env) segments' []- dest' =- if S.null (W.rawQueryString env)- then dest- else (dest `mappend`- Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))---- | Wrap up a normal WAI application as a Yesod subsite.-newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }--instance RenderRoute WaiSubsite where- data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)]- deriving (Show, Eq, Read, Ord)- renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)--instance YesodDispatch WaiSubsite master where- yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
− Yesod/Handler.hs
@@ -1,1071 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE DeriveDataTypeable #-}---------------------------------------------------------------- Module : Yesod.Handler--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : stable--- Portability : portable------ Define Handler stuff.--------------------------------------------------------------module Yesod.Handler- ( -- * Type families- YesodSubRoute (..)- -- * Handler monad- , GHandler- -- ** Read information from handler- , getYesod- , getYesodSub- , getUrlRender- , getUrlRenderParams- , getCurrentRoute- , getRouteToMaster- , getRequest- , waiRequest- , runRequestBody- -- * Special responses- -- ** Redirecting- , RedirectUrl (..)- , redirect- , redirectWith- , redirectToPost- -- ** Errors- , notFound- , badMethod- , permissionDenied- , permissionDeniedI- , invalidArgs- , invalidArgsI- -- ** Short-circuit responses.- , sendFile- , sendFilePart- , sendResponse- , sendResponseStatus- , sendResponseCreated- , sendWaiResponse- -- * Setting headers- , setCookie- , getExpires- , deleteCookie- , setHeader- , setLanguage- -- ** Content caching and expiration- , cacheSeconds- , neverExpires- , alreadyExpired- , expiresAt- -- * Session- , SessionMap- , lookupSession- , lookupSessionBS- , getSession- , setSession- , setSessionBS- , deleteSession- , clearSession- -- ** Ultimate destination- , setUltDest- , setUltDestCurrent- , setUltDestReferer- , redirectUltDest- , clearUltDest- -- ** Messages- , setMessage- , setMessageI- , getMessage- -- * Helpers for specific content- -- ** Hamlet- , hamletToContent- , hamletToRepHtml- -- ** Misc- , newIdent- -- * Lifting- , MonadLift (..)- , handlerToIO- -- * i18n- , getMessageRender- -- * Per-request caching- , CacheKey- , mkCacheKey- , cacheLookup- , cacheInsert- , cacheDelete- -- * Internal Yesod- , runHandler- , YesodApp (..)- , runSubsiteGetter- , toMasterHandler- , toMasterHandlerDyn- , toMasterHandlerMaybe- , localNoCurrent- , HandlerData- , ErrorResponse (..)- , YesodAppResult (..)- , handlerToYAR- , yarToResponse- , headerToPair- ) where--import Prelude hiding (catch)-import Yesod.Internal.Request-import Yesod.Internal-import Data.Time (UTCTime, getCurrentTime, addUTCTime)--import Control.Exception hiding (Handler, catch, finally)-import Control.Applicative--import Control.Monad (liftM)-import Control.Failure (Failure (failure))--import Control.Monad.IO.Class-import Control.Monad.Trans.Class (MonadTrans)-import qualified Control.Monad.Trans.Class--import System.IO-import qualified Network.Wai as W-import qualified Network.HTTP.Types as H--import Text.Hamlet-import qualified Text.Blaze.Html.Renderer.Text as RenderText-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 qualified Data.Map as Map-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Network.Wai.Parse (parseHttpAccept)--import Yesod.Content-import Data.Maybe (fromMaybe, mapMaybe)-import Web.Cookie (SetCookie (..), renderSetCookie)-import Control.Arrow ((***))-import qualified Network.Wai.Parse as NWP-import Data.Monoid (mappend, mempty, Endo (..))-import qualified Data.ByteString.Char8 as S8-import Data.ByteString (ByteString)-import Data.CaseInsensitive (CI)-import qualified Data.CaseInsensitive as CI-import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString)-import Data.Text (Text)-import Yesod.Message (RenderMessage (..))--import Text.Blaze.Html (toHtml, preEscapedToMarkup)-#define preEscapedText preEscapedToMarkup--import System.Log.FastLogger-import Control.Monad.Logger--import qualified Yesod.Internal.Cache as Cache-import Yesod.Internal.Cache (mkCacheKey, CacheKey)-import qualified Data.IORef as I-import Control.Exception.Lifted (catch)-import Control.Monad.Trans.Control-import Control.Monad.Trans.Resource-import Control.Monad.Base-import Yesod.Routes.Class-import Data.Word (Word64)-import Language.Haskell.TH.Syntax (Loc)--class YesodSubRoute s y where- fromSubRoute :: s -> y -> Route s -> Route y--data HandlerData sub master = HandlerData- { handlerRequest :: Request- , handlerSub :: sub- , handlerMaster :: master- , handlerRoute :: Maybe (Route sub)- , handlerRender :: Route master -> [(Text, Text)] -> Text- , handlerToMaster :: Route sub -> Route master- , handlerState :: I.IORef GHState- , handlerUpload :: Word64 -> FileUpload- , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()- }--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- }--get :: GHandler sub master GHState-get = do- hd <- ask- liftIO $ I.readIORef $ handlerState hd--put :: GHState -> GHandler sub master ()-put g = do- hd <- ask- liftIO $ I.writeIORef (handlerState hd) g--modify :: (GHState -> GHState) -> GHandler sub master ()-modify f = do- hd <- ask- liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())--tell :: Endo [Header] -> GHandler sub master ()-tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }---- | 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- -> GHandler sub master a- -> GHandler sub' master a-toMasterHandler tm ts route = local (handlerSubData tm ts route)---- | FIXME do we need this?-toMasterHandlerDyn :: (Route sub -> Route master)- -> GHandler sub' master sub- -> Route sub- -> GHandler sub master a- -> GHandler sub' master a-toMasterHandlerDyn tm getSub route h = do- sub <- getSub- local (handlerSubData tm (const sub) route) h--class SubsiteGetter g m s | g -> s where- runSubsiteGetter :: g -> m s--instance (master ~ master'- ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where- runSubsiteGetter getter = getter <$> getYesod--instance (anySub ~ anySub'- ,master ~ master'- ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where- runSubsiteGetter = id--toMasterHandlerMaybe :: (Route sub -> Route master)- -> (master -> sub)- -> Maybe (Route sub)- -> GHandler sub master a- -> GHandler sub' master a-toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)---- | A generic handler monad, which can have a different subsite and master--- site. We define a newtype for better error message.-newtype GHandler sub master a = GHandler- { unGHandler :: HandlerData sub master -> ResourceT IO a- }--data GHState = GHState- { ghsSession :: SessionMap- , ghsRBC :: Maybe RequestBodyContents- , ghsIdent :: Int- , ghsCache :: Cache.Cache- , ghsHeaders :: Endo [Header]- }--type SessionMap = Map.Map Text S.ByteString---- | 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- -> ResourceT IO YesodAppResult- }--data YesodAppResult- = YARWai W.Response- | YARPlain H.Status [Header] ContentType Content SessionMap--getRequest :: GHandler s m Request-getRequest = handlerRequest `liftM` ask--hcError :: ErrorResponse -> GHandler sub master a-hcError = liftIO . throwIO . HCError--runRequestBody :: GHandler s m RequestBodyContents-runRequestBody = do- hd <- ask- let getUpload = handlerUpload hd- len = reqBodySize $ handlerRequest hd- upload = getUpload len- x <- get- case ghsRBC x of- Just rbc -> return rbc- Nothing -> do- rr <- waiRequest- rbc <- lift $ rbHelper upload rr- put x { ghsRBC = Just rbc }- return rbc--rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents-rbHelper upload =- case upload of- FileUploadMemory s -> rbHelper' s mkFileInfoLBS- FileUploadDisk s -> rbHelper' s mkFileInfoFile- FileUploadSource s -> rbHelper' s mkFileInfoSource--rbHelper' :: NWP.BackEnd x- -> (Text -> Text -> x -> FileInfo)- -> W.Request- -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])-rbHelper' backend mkFI req =- (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)- where- fix1 = go *** go- fix2 (x, NWP.FileInfo a' b c)- | S.null a = Nothing- | otherwise = Just (go x, mkFI (go a) (go b) c)- where- a- | S.length a' < 2 = a'- | S8.head a' == '"' && S8.last a' == '"' = S.tail $ S.init a'- | S8.head a' == '\'' && S8.last a' == '\'' = S.tail $ S.init a'- | otherwise = a'- go = decodeUtf8With lenientDecode---- | Get the sub application argument.-getYesodSub :: GHandler sub master sub-getYesodSub = handlerSub `liftM` ask---- | Get the master site appliation argument.-getYesod :: GHandler sub master master-getYesod = handlerMaster `liftM` ask---- | Get the URL rendering function.-getUrlRender :: GHandler sub master (Route master -> Text)-getUrlRender = do- x <- handlerRender `liftM` ask- return $ flip x []---- | The URL rendering function with query-string parameters.-getUrlRenderParams- :: GHandler sub master (Route master -> [(Text, Text)] -> Text)-getUrlRenderParams = handlerRender `liftM` 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 :: GHandler sub master (Maybe (Route sub))-getCurrentRoute = handlerRoute `liftM` ask---- | Get the function to promote a route for a subsite to a route for the--- master site.-getRouteToMaster :: GHandler sub master (Route sub -> Route master)-getRouteToMaster = handlerToMaster `liftM` ask----- | Returns a function that runs 'GHandler' actions inside @IO@.------ Sometimes you want to run an inner 'GHandler' action outside--- the control flow of an HTTP request (on the outer 'GHandler'--- action). For example, you may want to spawn a new thread:------ @--- getFooR :: Handler RepHtml--- getFooR = do--- runInnerHandler <- handlerToIO--- liftIO $ forkIO $ runInnerHandler $ do--- /Code here runs inside GHandler but on a new thread./--- /This is the inner GHandler./--- ...--- /Code here runs inside the request's control flow./--- /This is the outer GHandler./--- ...--- @------ Another use case for this function is creating a stream of--- server-sent events using 'GHandler' actions (see--- @yesod-eventsource@).------ Most of the environment from the outer 'GHandler' is preserved--- on the inner 'GHandler', however:------ * The request body is cleared (otherwise it would be very--- difficult to prevent huge memory leaks).------ * The cache is cleared (see 'CacheKey').------ Changes to the response made inside the inner 'GHandler' are--- ignored (e.g., session variables, cookies, response headers).--- This allows the inner 'GHandler' to outlive the outer--- 'GHandler' (e.g., on the @forkIO@ example above, a response--- may be sent to the client without killing the new thread).-handlerToIO :: MonadIO m => GHandler sub master (GHandler sub master a -> m a)-handlerToIO =- GHandler $ \oldHandlerData -> do- -- Let go of the request body, cache and response headers.- let oldReq = handlerRequest oldHandlerData- oldWaiReq = reqWaiRequest oldReq- newWaiReq = oldWaiReq { W.requestBody = mempty }- newReq = oldReq { reqWaiRequest = newWaiReq- , reqBodySize = 0 }- clearedOldHandlerData =- oldHandlerData { handlerRequest = err "handlerRequest never here"- , handlerState = err "handlerState never here" }- where- err :: String -> a- err = error . ("handlerToIO: clearedOldHandlerData/" ++)- newState <- liftIO $ do- oldState <- I.readIORef (handlerState oldHandlerData)- return $ oldState { ghsRBC = Nothing- , ghsIdent = 1- , ghsCache = mempty- , ghsHeaders = mempty }-- -- Return GHandler running function.- return $ \(GHandler f) -> liftIO $ do- -- The state IORef needs to be created here, otherwise it- -- will be shared by different invocations of this function.- newStateIORef <- I.newIORef newState- runResourceT $ f clearedOldHandlerData- { handlerRequest = newReq- , handlerState = newStateIORef }----- | Function used internally by Yesod in the process of converting a--- 'GHandler' into an 'W.Application'. Should not be needed by users.-runHandler :: HasReps c- => GHandler sub master c- -> (Route master -> [(Text, Text)] -> Text)- -> Maybe (Route sub)- -> (Route sub -> Route master)- -> master- -> sub- -> (Word64 -> FileUpload)- -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())- -> YesodApp-runHandler handler mrender sroute tomr master sub upload log' =- YesodApp $ \eh rr cts initSession -> do- let toErrorHandler e =- case fromException e of- Just x -> x- Nothing -> InternalError $ T.pack $ show e- istate <- liftIO $ I.newIORef GHState- { ghsSession = initSession- , ghsRBC = Nothing- , ghsIdent = 1- , ghsCache = mempty- , ghsHeaders = mempty- }- let hd = HandlerData- { handlerRequest = rr- , handlerSub = sub- , handlerMaster = master- , handlerRoute = sroute- , handlerRender = mrender- , handlerToMaster = tomr- , handlerState = istate- , handlerUpload = upload- , handlerLog = log'- }- contents' <- catch (fmap Right $ unGHandler handler hd)- (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id- $ fromException e)- state <- liftIO $ I.readIORef istate- let finalSession = ghsSession state- let headers = ghsHeaders state- let contents = either id (HCContent H.status200 . chooseRep) contents'- let handleError e = do- yar <- unYesodApp (eh e) safeEh rr cts finalSession- case yar of- YARPlain _ hs ct c sess ->- let hs' = appEndo headers hs- in return $ YARPlain (getStatus e) hs' ct c sess- YARWai _ -> return yar- let sendFile' ct fp p =- return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession- case contents of- HCContent status a -> do- (ct, c) <- liftIO $ a cts- ec' <- liftIO $ evaluateContent c- case ec' of- Left e -> handleError e- Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession- HCError e -> handleError e- HCRedirect status loc -> do- let disable_caching x =- Header "Cache-Control" "no-cache, must-revalidate"- : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"- : x- hs = (if status /= H.movedPermanently301 then disable_caching else id)- $ Header "Location" (encodeUtf8 loc) : appEndo headers []- return $ YARPlain- status hs typePlain emptyContent- finalSession- HCSendFile ct fp p -> catch- (sendFile' ct fp p)- (handleError . toErrorHandler)- HCCreated loc -> do- let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []- return $ YARPlain- H.status201- hs- typePlain- emptyContent- finalSession- HCWai r -> return $ YARWai r--evaluateContent :: Content -> IO (Either ErrorResponse Content)-evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do- let lbs = toLazyByteString b- L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)- where- f :: SomeException -> IO (Either ErrorResponse Content)- f = return . Left . InternalError . T.pack . show-evaluateContent c = return (Right c)--safeEh :: ErrorResponse -> YesodApp-safeEh er = YesodApp $ \_ _ _ session -> do- liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er- return $ YARPlain- H.status500- []- typePlain- (toContent ("Internal Server Error" :: S.ByteString))- session---- | Redirect to the given route.--- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0--- This is the appropriate choice for a get-following-post--- technique, which should be the usual use case.------ If you want direct control of the final status code, or need a different--- status code, please use 'redirectWith'.-redirect :: RedirectUrl master url => url -> GHandler sub master a-redirect url = do- req <- waiRequest- let status =- if W.httpVersion req == H.http11- then H.status303- else H.status302- redirectWith status url---- | Redirect to the given URL with the specified status code.-redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a-redirectWith status url = do- urlText <- toTextUrl url- liftIO $ throwIO $ HCRedirect status urlText--ultDestKey :: Text-ultDestKey = "_ULT"---- | Sets the ultimate destination variable to the given route.------ An ultimate destination is stored in the user session and can be loaded--- later by 'redirectUltDest'.-setUltDest :: RedirectUrl master url => url -> GHandler sub master ()-setUltDest url = do- urlText <- toTextUrl url- setSession ultDestKey urlText---- | 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.-setUltDestCurrent :: GHandler sub master ()-setUltDestCurrent = do- route <- getCurrentRoute- case route of- Nothing -> return ()- Just r -> do- tm <- getRouteToMaster- gets' <- reqGetParams `liftM` handlerRequest `liftM` ask- setUltDest (tm r, gets')---- | Sets the ultimate destination to the referer request header, if present.------ This function will not overwrite an existing ultdest.-setUltDestReferer :: GHandler sub master ()-setUltDestReferer = do- mdest <- lookupSession ultDestKey- maybe- (waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)- (const $ return ())- mdest- where- setUltDestBS = setUltDest . T.pack . S8.unpack---- | Redirect to the ultimate destination in the user's session. Clear the--- value from the session.------ The ultimate destination is set with 'setUltDest'.------ This function uses 'redirect', and thus will perform a temporary redirect to--- a GET request.-redirectUltDest :: RedirectUrl master url- => url -- ^ default destination if nothing in session- -> GHandler sub master a-redirectUltDest def = do- mdest <- lookupSession ultDestKey- deleteSession ultDestKey- maybe (redirect def) redirect mdest---- | Remove a previously set ultimate destination. See 'setUltDest'.-clearUltDest :: GHandler sub master ()-clearUltDest = deleteSession ultDestKey--msgKey :: Text-msgKey = "_MSG"---- | Sets a message in the user's session.------ See 'getMessage'.-setMessage :: Html -> GHandler sub master ()-setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml---- | Sets a message in the user's session.------ See 'getMessage'.-setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y ()-setMessageI msg = do- mr <- getMessageRender- setMessage $ toHtml $ mr msg---- | Gets the message in the user's session, if available, and then clears the--- variable.------ See 'setMessage'.-getMessage :: GHandler sub master (Maybe Html)-getMessage = do- mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey- deleteSession msgKey- return mmsg---- | Bypass remaining handler code and output the given file.------ For some backends, this is more efficient than reading in the file to--- memory, since they can optimize file sending via a system call to sendfile.-sendFile :: ContentType -> FilePath -> GHandler sub master a-sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing---- | Same as 'sendFile', but only sends part of a file.-sendFilePart :: ContentType- -> FilePath- -> Integer -- ^ offset- -> Integer -- ^ count- -> GHandler sub master a-sendFilePart ct fp off count =- liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count---- | Bypass remaining handler code and output the given content with a 200--- status code.-sendResponse :: HasReps c => c -> GHandler sub master a-sendResponse = liftIO . throwIO . HCContent H.status200- . chooseRep---- | Bypass remaining handler code and output the given content with the given--- status code.-sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a-sendResponseStatus s = liftIO . throwIO . HCContent s- . chooseRep---- | Send a 201 "Created" response with the given route as the Location--- response header.-sendResponseCreated :: Route m -> GHandler s m a-sendResponseCreated url = do- r <- getUrlRender- liftIO . throwIO $ HCCreated $ r url---- | Send a 'W.Response'. Please note: this function is rarely--- necessary, and will /disregard/ any changes to response headers and session--- that you have already specified. This function short-circuits. It should be--- considered only for very specific needs. If you are not sure if you need it,--- you don't.-sendWaiResponse :: W.Response -> GHandler s m b-sendWaiResponse = liftIO . throwIO . HCWai---- | Return a 404 not found page. Also denotes no handler available.-notFound :: GHandler sub master a-notFound = hcError NotFound---- | Return a 405 method not supported page.-badMethod :: GHandler sub master a-badMethod = do- w <- waiRequest- hcError $ BadMethod $ W.requestMethod w---- | Return a 403 permission denied page.-permissionDenied :: Text -> GHandler sub master a-permissionDenied = hcError . PermissionDenied---- | Return a 403 permission denied page.-permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a-permissionDeniedI msg = do- mr <- getMessageRender- permissionDenied $ mr msg---- | Return a 400 invalid arguments page.-invalidArgs :: [Text] -> GHandler sub master a-invalidArgs = hcError . InvalidArgs---- | Return a 400 invalid arguments page.-invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a-invalidArgsI msg = do- mr <- getMessageRender- invalidArgs $ map mr msg--------- Headers--- | Set the cookie on the client.--setCookie :: SetCookie- -> GHandler sub master ()-setCookie = addHeader . AddCookie---- | Helper function for setCookieExpires value-getExpires :: Int -- ^ minutes- -> IO UTCTime-getExpires m = do- now <- liftIO getCurrentTime- return $ fromIntegral (m * 60) `addUTCTime` now----- | Unset the cookie on the client.------ Note: although the value used for key and path is 'Text', you should only--- use ASCII values to be HTTP compliant.-deleteCookie :: Text -- ^ key- -> Text -- ^ path- -> GHandler sub master ()-deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8----- | Set the language in the user session. Will show up in 'languages' on the--- next request.-setLanguage :: Text -> GHandler sub master ()-setLanguage = setSession langKey---- | Set an arbitrary response header.------ Note that, while the data type used here is 'Text', you must provide only--- ASCII value to be HTTP compliant.-setHeader :: Text -> Text -> GHandler sub master ()-setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8---- | Set the Cache-Control header to indicate this response should be cached--- for the given number of seconds.-cacheSeconds :: Int -> GHandler s m ()-cacheSeconds i = setHeader "Cache-Control" $ T.concat- [ "max-age="- , T.pack $ show i- , ", public"- ]---- | Set the Expires header to some date in 2037. In other words, this content--- is never (realistically) expired.-neverExpires :: GHandler s m ()-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 :: GHandler s m ()-alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"---- | Set an Expires header to the given date.-expiresAt :: UTCTime -> GHandler s m ()-expiresAt = setHeader "Expires" . 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 :: Text -- ^ key- -> Text -- ^ value- -> GHandler sub master ()-setSession k = setSessionBS k . encodeUtf8---- | Same as 'setSession', but uses binary data for the value.-setSessionBS :: Text- -> S.ByteString- -> GHandler sub master ()-setSessionBS k = modify . modSession . Map.insert k---- | Unsets a session variable. See 'setSession'.-deleteSession :: Text -> GHandler sub master ()-deleteSession = modify . modSession . Map.delete---- | Clear all session variables.------ Since: 1.0.1-clearSession :: GHandler sub master ()-clearSession = modify $ \x -> x { ghsSession = Map.empty }--modSession :: (SessionMap -> SessionMap) -> GHState -> GHState-modSession f x = x { ghsSession = f $ ghsSession x }---- | Internal use only, not to be confused with 'setHeader'.-addHeader :: Header -> GHandler sub master ()-addHeader = tell . Endo . (:)--getStatus :: ErrorResponse -> H.Status-getStatus NotFound = H.status404-getStatus (InternalError _) = H.status500-getStatus (InvalidArgs _) = H.status400-getStatus (PermissionDenied _) = H.status403-getStatus (BadMethod _) = H.status405---- | Some value which can be turned into a URL for redirects.-class RedirectUrl master a where- -- | Converts the value to the URL and a list of query-string parameters.- toTextUrl :: a -> GHandler sub master Text--instance RedirectUrl master Text where- toTextUrl = return--instance RedirectUrl master String where- toTextUrl = toTextUrl . T.pack--instance RedirectUrl master (Route master) where- toTextUrl url = do- r <- getUrlRender- return $ r url--instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where- toTextUrl (url, params) = do- r <- getUrlRenderParams- return $ r url params--localNoCurrent :: GHandler s m a -> GHandler s m a-localNoCurrent =- local (\hd -> hd { handlerRoute = Nothing })---- | Lookup for session data.-lookupSession :: Text -> GHandler s m (Maybe Text)-lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS---- | Lookup for session data in binary format.-lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString)-lookupSessionBS n = do- m <- liftM ghsSession get- return $ Map.lookup n m---- | Get all session variables.-getSession :: GHandler sub master SessionMap-getSession = liftM ghsSession get--handlerToYAR :: (HasReps a, HasReps b)- => master -- ^ master site foundation- -> sub -- ^ sub site foundation- -> (Word64 -> FileUpload)- -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())- -> (Route sub -> Route master)- -> (Route master -> [(Text, Text)] -> Text) -- route renderer- -> (ErrorResponse -> GHandler sub master a)- -> Request- -> Maybe (Route sub)- -> SessionMap- -> GHandler sub master b- -> ResourceT IO YesodAppResult-handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h =- unYesodApp ya eh' rr types sessionMap- where- ya = runHandler h render murl toMasterRoute y s upload log'- eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log'- types = httpAccept $ reqWaiRequest rr- errorHandler' = localNoCurrent . errorHandler--yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response-yarToResponse (YARWai a) _ = a-yarToResponse (YARPlain s hs _ c _) extraHeaders =- go c- where- finalHeaders = extraHeaders ++ map headerToPair hs- finalHeaders' len = ("Content-Length", S8.pack $ show len)- : finalHeaders-- go (ContentBuilder b mlen) =- W.ResponseBuilder s hs' b- where- hs' = maybe finalHeaders finalHeaders' mlen- go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p- go (ContentSource body) = W.ResponseSource s finalHeaders body- go (ContentDontEvaluate c') = go c'--httpAccept :: W.Request -> [ContentType]-httpAccept = parseHttpAccept- . fromMaybe mempty- . lookup "Accept"- . W.requestHeaders---- | Convert Header to a key/value pair.-headerToPair :: Header- -> (CI ByteString, ByteString)-headerToPair (AddCookie sc) =- ("Set-Cookie", toByteString $ renderSetCookie $ sc)-headerToPair (DeleteCookie key path) =- ( "Set-Cookie"- , S.concat- [ key- , "=; path="- , path- , "; expires=Thu, 01-Jan-1970 00:00:00 GMT"- ]- )-headerToPair (Header key value) = (CI.mk key, value)---- | Get a unique identifier.-newIdent :: GHandler sub master Text-newIdent = do- x <- get- let i' = ghsIdent x + 1- put x { ghsIdent = i' }- return $ T.pack $ 'h' : show i'---- | 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 :: RedirectUrl master url => url -> GHandler sub master a-redirectToPost url = do- urlText <- toTextUrl url- hamletToRepHtml [hamlet|-$newline never-$doctype 5--<html>- <head>- <title>Redirecting...- <body onload="document.getElementById('form').submit()">- <form id="form" method="post" action=#{urlText}>- <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 :: HtmlUrl (Route master) -> GHandler sub master Content-hamletToContent h = do- render <- getUrlRenderParams- return $ toContent $ h render---- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml-hamletToRepHtml = liftM RepHtml . hamletToContent---- | Get the request\'s 'W.Request' value.-waiRequest :: GHandler sub master W.Request-waiRequest = reqWaiRequest `liftM` getRequest--getMessageRender :: RenderMessage master message => GHandler s master (message -> Text)-getMessageRender = do- m <- getYesod- l <- reqLangs `liftM` getRequest- return $ renderMessage m l--cacheLookup :: CacheKey a -> GHandler sub master (Maybe a)-cacheLookup k = do- gs <- get- return $ Cache.lookup k $ ghsCache gs--cacheInsert :: CacheKey a -> a -> GHandler sub master ()-cacheInsert k v = modify $ \gs ->- gs { ghsCache = Cache.insert k v $ ghsCache gs }--cacheDelete :: CacheKey a -> GHandler sub master ()-cacheDelete k = modify $ \gs ->- gs { ghsCache = Cache.delete k $ ghsCache gs }--ask :: GHandler sub master (HandlerData sub master)-ask = GHandler return--local :: (HandlerData sub' master' -> HandlerData sub master)- -> GHandler sub master a- -> GHandler sub' master' a-local f (GHandler x) = GHandler $ \r -> x $ f r---- | The standard @MonadTrans@ class only allows lifting for monad--- transformers. While @GHandler@ and @GWidget@ should allow lifting, their--- types do not express that they actually are transformers. This replacement--- class accounts for this.-class MonadLift base m | m -> base where- lift :: base a -> m a-instance (Monad m, MonadTrans t) => MonadLift m (t m) where- lift = Control.Monad.Trans.Class.lift-instance MonadLift (ResourceT IO) (GHandler sub master) where- lift = GHandler . const---- Instances for GHandler-instance Functor (GHandler sub master) where- fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)-instance Applicative (GHandler sub master) where- pure = GHandler . const . pure- GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r-instance Monad (GHandler sub master) where- return = pure- GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r-instance MonadIO (GHandler sub master) where- liftIO = GHandler . const . lift-instance MonadBase IO (GHandler sub master) where- liftBase = GHandler . const . lift--- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s--- @fork@ function is incompatible with the underlying @ResourceT@ system.--- Instead, if you must fork a separate thread, you should use--- @resourceForkIO@.------ Using fork usually leads to an exception that says--- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed--- after cleanup. Please contact the maintainers.\"-instance MonadBaseControl IO (GHandler sub master) where- data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)- liftBaseWith f = GHandler $ \reader ->- liftBaseWith $ \runInBase ->- f $ liftM StH . runInBase . (\(GHandler r) -> r reader)- restoreM (StH base) = GHandler $ const $ restoreM base--instance MonadUnsafeIO (GHandler sub master) where- unsafeLiftIO = liftIO-instance MonadThrow (GHandler sub master) where- monadThrow = liftIO . throwIO-instance MonadResource (GHandler sub master) where-#if MIN_VERSION_resourcet(0,4,0)- liftResourceT = lift . liftResourceT-#else- allocate a = lift . allocate a- register = lift . register- release = lift . release- resourceMask = lift . resourceMask-#endif--instance MonadLogger (GHandler sub master) where-#if MIN_VERSION_monad_logger(0, 3, 0)- monadLoggerLog a b c d = do- hd <- ask- liftIO $ handlerLog hd a b c (toLogStr d)-#else- monadLoggerLog a c d = monadLoggerLogSource a "" c d- monadLoggerLogSource a b c d = do- hd <- ask- liftIO $ handlerLog hd a b c (toLogStr d)-#endif--instance Exception e => Failure e (GHandler sub master) where- failure = liftIO . throwIO
− Yesod/Internal.hs
@@ -1,138 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}--- | Normal users should never need access to these.------ Note that no guarantees of API stability are provided on this module. Use at your own risk.-module Yesod.Internal- ( -- * Error responses- ErrorResponse (..)- , HandlerContents (..)- -- * Header- , Header (..)- -- * Cookie names- , langKey- -- * Widgets- , GWData (..)- , Location (..)- , UniqueList (..)- , Script (..)- , Stylesheet (..)- , Title (..)- , Head (..)- , Body (..)- , locationToHtmlUrl- , runUniqueList- , toUnique- -- * Names- , tokenKey- ) where--import Text.Hamlet (HtmlUrl, Html)-import Text.Blaze.Html (toHtml)-import Text.Julius (JavascriptUrl)-import Data.Monoid (Monoid (..), Last)-import Data.List (nub)--import Data.Text (Text)--import Data.Typeable (Typeable)-import Control.Exception (Exception)--import qualified Network.HTTP.Types as H-import Data.String (IsString)-import qualified Data.Map as Map-import Data.Text.Lazy.Builder (Builder)-import Web.Cookie (SetCookie (..))-import Data.ByteString (ByteString)-import qualified Network.Wai as W-import Yesod.Content (ChooseRep, ContentType)---- | Responses to indicate some form of an error occurred. These are different--- from 'SpecialResponse' in that they allow for custom error pages.-data ErrorResponse =- NotFound- | InternalError Text- | InvalidArgs [Text]- | PermissionDenied Text- | BadMethod H.Method- deriving (Show, Eq, Typeable)-instance Exception ErrorResponse------- header stuff--- | Headers to be added to a 'Result'.-data Header =- AddCookie SetCookie- | DeleteCookie ByteString ByteString- | Header ByteString ByteString- deriving (Eq, Show)--langKey :: IsString a => a-langKey = "_LANG"--data Location url = Local url | Remote Text- deriving (Show, Eq)-locationToHtmlUrl :: Location url -> HtmlUrl url-locationToHtmlUrl (Local url) render = toHtml $ render url []-locationToHtmlUrl (Remote s) _ = toHtml s--newtype UniqueList x = UniqueList ([x] -> [x])-instance Monoid (UniqueList x) where- mempty = UniqueList id- UniqueList x `mappend` UniqueList y = UniqueList $ x . y-runUniqueList :: Eq x => UniqueList x -> [x]-runUniqueList (UniqueList x) = nub $ x []-toUnique :: x -> UniqueList x-toUnique = UniqueList . (:)--data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }- deriving (Show, Eq)-data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }- deriving (Show, Eq)-newtype Title = Title { unTitle :: Html }--newtype Head url = Head (HtmlUrl url)- deriving Monoid-newtype Body url = Body (HtmlUrl url)- deriving Monoid--tokenKey :: IsString a => a-tokenKey = "_TOKEN"--type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder--data GWData a = GWData- { gwdBody :: !(Body a)- , gwdTitle :: !(Last Title)- , gwdScripts :: !(UniqueList (Script a))- , gwdStylesheets :: !(UniqueList (Stylesheet a))- , gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type- , gwdJavascript :: !(Maybe (JavascriptUrl a))- , gwdHead :: !(Head a)- }-instance Monoid (GWData a) where- mempty = GWData mempty mempty mempty mempty mempty mempty mempty- mappend (GWData a1 a2 a3 a4 a5 a6 a7)- (GWData b1 b2 b3 b4 b5 b6 b7) = GWData- (a1 `mappend` b1)- (a2 `mappend` b2)- (a3 `mappend` b3)- (a4 `mappend` b4)- (Map.unionWith mappend a5 b5)- (a6 `mappend` b6)- (a7 `mappend` b7)--data HandlerContents =- HCContent H.Status ChooseRep- | HCError ErrorResponse- | HCSendFile ContentType FilePath (Maybe W.FilePart)- | HCRedirect H.Status Text- | HCCreated Text- | HCWai W.Response- deriving Typeable--instance Show HandlerContents where- show _ = "Cannot show a HandlerContents"-instance Exception HandlerContents
− Yesod/Internal/Cache.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-module Yesod.Internal.Cache- ( Cache- , CacheKey- , mkCacheKey- , lookup- , insert- , delete- ) where--import Prelude hiding (lookup)-import qualified Data.IntMap as Map-import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL))-import Language.Haskell.TH (appE)-import Data.Unique (hashUnique, newUnique)-import GHC.Exts (Any)-import Unsafe.Coerce (unsafeCoerce)-import Data.Monoid (Monoid)-import Control.Applicative ((<$>))--newtype Cache = Cache (Map.IntMap Any)- deriving Monoid--newtype CacheKey a = CacheKey Int---- | Generate a new 'CacheKey'. Be sure to give a full type signature.-mkCacheKey :: Q Exp-mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique)--lookup :: CacheKey a -> Cache -> Maybe a-lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m--insert :: CacheKey a -> a -> Cache -> Cache-insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m)--delete :: CacheKey a -> Cache -> Cache-delete (CacheKey k) (Cache m) = Cache (Map.delete k m)
− Yesod/Internal/Core.hs
@@ -1,928 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}--- | The basic typeclass for a Yesod application.-module Yesod.Internal.Core- ( -- * Type classes- Yesod (..)- , YesodDispatch (..)- , RenderRoute (..)- -- ** Breadcrumbs- , YesodBreadcrumbs (..)- , breadcrumbs- -- * Utitlities- , maybeAuthorized- , widgetToPageContent- -- * Defaults- , defaultErrorHandler- -- * Data types- , AuthResult (..)- -- * Sessions- , SessionBackend (..)- , defaultClientSessionBackend- , clientSessionBackend- , loadClientSession- , clientSessionBackend2- , loadClientSession2- , clientSessionDateCacher- , BackendSession- -- * jsLoader- , ScriptLoadPosition (..)- , BottomOfHeadAsync- , loadJsYepnope- -- * Misc- , yesodVersion- , yesodRender- , resolveApproot- , Approot (..)- , FileUpload (..)- , runFakeHandler- ) where--import Yesod.Content-import Yesod.Handler hiding (lift, getExpires)-import Control.Monad.Logger (logErrorS)--import Yesod.Routes.Class-import Data.Time (UTCTime, addUTCTime, getCurrentTime)--import Data.Word (Word64)-import Control.Arrow ((***))-import Control.Monad (forM)-import Yesod.Widget-import Yesod.Request-import qualified Network.Wai as W-import Yesod.Internal-import Yesod.Internal.Session-import Yesod.Internal.Request-import qualified Web.ClientSession as CS-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L-import qualified Data.IORef as I-import Data.Monoid-import Text.Hamlet-import Text.Julius-import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString)-import qualified Text.Blaze.Html5 as TBH-import Data.Text.Lazy.Builder (toLazyText)-import Data.Text.Lazy.Encoding (encodeUtf8)-import Data.Maybe (fromMaybe, isJust)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Resource (runResourceT)-import Web.Cookie (parseCookies)-import qualified Data.Map as Map-import Network.HTTP.Types (encodePath)-import qualified Data.Text as T-import Data.Text (Text)-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Encoding.Error as TEE-import Blaze.ByteString.Builder (Builder, toByteString)-import Blaze.ByteString.Builder.Char.Utf8 (fromText)-import Data.List (foldl')-import qualified Network.HTTP.Types as H-import Web.Cookie (SetCookie (..))-import Language.Haskell.TH.Syntax (Loc (..))-import Text.Blaze (preEscapedToMarkup)-import Data.Aeson (Value (Array, String))-import Data.Aeson.Encode (encode)-import qualified Data.Vector as Vector-import Network.Wai.Middleware.Gzip (GzipSettings, def)-import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd)-import qualified Paths_yesod_core-import Data.Version (showVersion)-import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr)-import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource)-import System.Log.FastLogger.Date (ZonedDate)-import System.IO (stdout)--yesodVersion :: String-yesodVersion = showVersion Paths_yesod_core.version---- | This class is automatically instantiated when you use the template haskell--- mkYesod function. You should never need to deal with it directly.-class YesodDispatch sub master where- yesodDispatch- :: Yesod master- => Logger- -> master- -> sub- -> (Route sub -> Route master)- -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler- -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler- -> Text -- ^ request method- -> [Text] -- ^ pieces- -> Maybe (SessionBackend master)- -> W.Application-- yesodRunner :: Yesod master- => Logger- -> GHandler sub master ChooseRep- -> master- -> sub- -> Maybe (Route sub)- -> (Route sub -> Route master)- -> Maybe (SessionBackend master)- -> W.Application- yesodRunner = defaultYesodRunner---- | How to determine the root of the application for constructing URLs.------ Note that future versions of Yesod may add new constructors without bumping--- the major version number. As a result, you should /not/ pattern match on--- @Approot@ values.-data Approot master = ApprootRelative -- ^ No application root.- | ApprootStatic Text- | ApprootMaster (master -> Text)- | ApprootRequest (master -> W.Request -> Text)--type ResolvedApproot = Text---- | Define settings for a Yesod applications. All methods have intelligent--- defaults, and therefore no implementation is required.-class RenderRoute a => Yesod a where- -- | An absolute URL to the root of the application. Do not include- -- trailing slash.- --- -- Default value: 'ApprootRelative'. This is valid under the following- -- conditions:- --- -- * Your application is served from the root of the domain.- --- -- * You do not use any features that require absolute URLs, such as Atom- -- feeds and XML sitemaps.- --- -- If this is not true, you should override with a different- -- implementation.- approot :: Approot a- approot = ApprootRelative-- -- | Output error response pages.- errorHandler :: ErrorResponse -> GHandler sub a ChooseRep- errorHandler = defaultErrorHandler-- -- | Applies some form of layout to the contents of a page.- defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml- defaultLayout w = do- p <- widgetToPageContent w- mmsg <- getMessage- hamletToRepHtml [hamlet|-$newline never-$doctype 5--<html>- <head>- <title>#{pageTitle p}- ^{pageHead p}- <body>- $maybe msg <- mmsg- <p .message>#{msg}- ^{pageBody p}-|]-- -- | Override the rendering function for a particular URL. One use case for- -- this is to offload static hosting to a different domain name to avoid- -- sending cookies.- urlRenderOverride :: a -> Route a -> Maybe Builder- urlRenderOverride _ _ = Nothing-- -- | Determine if a request is authorized or not.- --- -- Return 'Authorized' if the request is authorized,- -- 'Unauthorized' a message if unauthorized.- -- If authentication is required, return 'AuthenticationRequired'.- isAuthorized :: Route a- -> Bool -- ^ is this a write request?- -> GHandler s a AuthResult- isAuthorized _ _ = return Authorized-- -- | Determines whether the current request is a write request. By default,- -- this assumes you are following RESTful principles, and determines this- -- from request method. In particular, all except the following request- -- methods are considered write: GET HEAD OPTIONS TRACE.- --- -- This function is used to determine if a request is authorized; see- -- 'isAuthorized'.- isWriteRequest :: Route a -> GHandler s a Bool- isWriteRequest _ = do- wai <- waiRequest- return $ W.requestMethod wai `notElem`- ["GET", "HEAD", "OPTIONS", "TRACE"]-- -- | The default route for authentication.- --- -- Used in particular by 'isAuthorized', but library users can do whatever- -- they want with it.- authRoute :: a -> Maybe (Route a)- authRoute _ = Nothing-- -- | A function used to clean up path segments. It returns 'Right' with a- -- clean path or 'Left' with a new set of pieces the user should be- -- redirected to. The default implementation enforces:- --- -- * No double slashes- --- -- * There is no trailing slash.- --- -- Note that versions of Yesod prior to 0.7 used a different set of rules- -- involing trailing slashes.- cleanPath :: a -> [Text] -> Either [Text] [Text]- cleanPath _ s =- if corrected == s- then Right $ map dropDash s- else Left corrected- where- corrected = filter (not . T.null) s- dropDash t- | T.all (== '-') t = T.drop 1 t- | otherwise = t-- -- | Builds an absolute URL by concatenating the application root with the- -- pieces of a path and a query string, if any.- -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'.- joinPath :: a- -> T.Text -- ^ application root- -> [T.Text] -- ^ path pieces- -> [(T.Text, T.Text)] -- ^ query string- -> Builder- joinPath _ ar pieces' qs' =- fromText ar `mappend` encodePath pieces qs- where- pieces = if null pieces' then [""] else map addDash pieces'- qs = map (TE.encodeUtf8 *** go) qs'- go "" = Nothing- go x = Just $ TE.encodeUtf8 x- addDash t- | T.all (== '-') t = T.cons '-' t- | otherwise = t-- -- | This function is used to store some static content to be served as an- -- external file. The most common case of this is stashing CSS and- -- JavaScript content in an external file; the "Yesod.Widget" module uses- -- this feature.- --- -- The return value is 'Nothing' if no storing was performed; this is the- -- default implementation. A 'Just' 'Left' gives the absolute URL of the- -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is- -- necessary when you are serving the content outside the context of a- -- Yesod application, such as via memcached.- addStaticContent :: Text -- ^ filename extension- -> Text -- ^ mime-type- -> L.ByteString -- ^ content- -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))- addStaticContent _ _ _ = return Nothing-- {- Temporarily disabled until we have a better interface.- -- | Whether or not to tie a session to a specific IP address. Defaults to- -- 'False'.- --- -- Note: This setting has two known problems: it does not work correctly- -- when behind a reverse proxy (including load balancers), and it may not- -- function correctly if the user is behind a proxy.- sessionIpAddress :: a -> Bool- sessionIpAddress _ = False- -}-- -- | The path value to set for cookies. By default, uses \"\/\", meaning- -- cookies will be sent to every page on the current domain.- cookiePath :: a -> S8.ByteString- cookiePath _ = "/"-- -- | The domain value to set for cookies. By default, the- -- domain is not set, meaning cookies will be sent only to- -- the current domain.- cookieDomain :: a -> Maybe S8.ByteString- cookieDomain _ = Nothing-- -- | Maximum allowed length of the request body, in bytes.- --- -- Default: 2 megabytes.- maximumContentLength :: a -> Maybe (Route a) -> Word64- maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes-- -- | Returns a @Logger@ to use for log messages.- --- -- Default: Sends to stdout and automatically flushes on each write.- getLogger :: a -> IO Logger- getLogger _ = mkLogger True stdout-- -- | Send a message to the @Logger@ provided by @getLogger@.- --- -- Note: This method is no longer used. Instead, you should override- -- 'messageLoggerSource'.- messageLogger :: a- -> Logger- -> Loc -- ^ position in source code- -> LogLevel- -> LogStr -- ^ message- -> IO ()- messageLogger a logger loc = messageLoggerSource a logger loc ""-- -- | Send a message to the @Logger@ provided by @getLogger@.- messageLoggerSource :: a- -> Logger- -> Loc -- ^ position in source code- -> LogSource- -> LogLevel- -> LogStr -- ^ message- -> IO ()- messageLoggerSource a logger loc source level msg =- if shouldLog a source level- then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger- else return ()-- -- | The logging level in place for this application. Any messages below- -- this level will simply be ignored.- logLevel :: a -> LogLevel- logLevel _ = LevelInfo-- -- | GZIP settings.- gzipSettings :: a -> GzipSettings- gzipSettings _ = def-- -- | Where to Load sripts from. We recommend the default value,- -- 'BottomOfBody'. Alternatively use the built in async yepnope loader:- --- -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js- --- -- Or write your own async js loader: see 'loadJsYepnope'- jsLoader :: a -> ScriptLoadPosition a- jsLoader _ = BottomOfBody-- -- | Create a session backend. Returning `Nothing' disables sessions.- --- -- Default: Uses clientsession with a 2 hour timeout.- makeSessionBackend :: a -> IO (Maybe (SessionBackend a))- makeSessionBackend _ = fmap Just defaultClientSessionBackend-- -- | How to store uploaded files.- --- -- Default: When the request body is greater than 50kb, store in a temp- -- file. Otherwise, store in memory.- fileUpload :: a- -> Word64 -- ^ request body size- -> FileUpload- fileUpload _ size- | size > 50000 = FileUploadDisk tempFileBackEnd- | otherwise = FileUploadMemory lbsBackEnd-- -- | Should we log the given log source/level combination.- --- -- Default: Logs everything at or above 'logLevel'- shouldLog :: a -> LogSource -> LogLevel -> Bool- shouldLog a _ level = level >= logLevel a-- -- | A Yesod middleware, which will wrap every handler function. This- -- allows you to run code before and after a normal handler.- --- -- Default: Adds the response header \"Vary: Accept, Accept-Language\".- --- -- Since: 1.1.6- yesodMiddleware :: GHandler sub a res -> GHandler sub a res- yesodMiddleware handler = do- setHeader "Vary" "Accept, Accept-Language"- handler--{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-}--formatLogMessage :: IO ZonedDate- -> Loc- -> LogSource- -> LogLevel- -> LogStr -- ^ message- -> IO [LogStr]-formatLogMessage getdate loc src level msg = do- now <- getdate- return- [ LB now- , LB " ["- , LS $- case level of- LevelOther t -> T.unpack t- _ -> drop 5 $ show level- , LS $- if T.null src- then ""- else "#" ++ T.unpack src- , LB "] "- , msg- , LB " @("- , LS $ fileLocationToString loc- , LB ")\n"- ]---- taken from file-location package--- turn the TH Loc loaction information into a human readable string--- leaving out the loc_end parameter-fileLocationToString :: Loc -> String-fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++- ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)- where- line = show . fst . loc_start- char = show . snd . loc_start--defaultYesodRunner :: Yesod master- => Logger- -> GHandler sub master ChooseRep- -> master- -> sub- -> Maybe (Route sub)- -> (Route sub -> Route master)- -> Maybe (SessionBackend master)- -> W.Application-defaultYesodRunner logger handler' master sub murl toMasterRoute msb req- | maxLen < len = return tooLargeResponse- | otherwise = do- let dontSaveSession _ _ = return []- now <- liftIO getCurrentTime -- FIXME remove in next major version bump- (session, saveSession) <- liftIO $ do- maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb- rr <- liftIO $ parseWaiRequest req session (isJust msb) len maxLen- let h = {-# SCC "h" #-} do- case murl of- Nothing -> handler- Just url -> do- isWrite <- isWriteRequest $ toMasterRoute url- ar <- isAuthorized (toMasterRoute url) isWrite- case ar of- Authorized -> return ()- AuthenticationRequired ->- case authRoute master of- Nothing ->- permissionDenied "Authentication required"- Just url' -> do- setUltDestCurrent- redirect url'- Unauthorized s' -> permissionDenied s'- handler- let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session- let ra = resolveApproot master req- let log' = messageLoggerSource master logger- yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute- (yesodRender master ra) errorHandler rr murl sessionMap h- extraHeaders <- case yar of- (YARPlain _ _ ct _ newSess) -> do- let nsToken = Map.toList $ maybe- newSess- (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess)- (reqToken rr)- sessionHeaders <- liftIO (saveSession nsToken now)- return $ ("Content-Type", ct) : map headerToPair sessionHeaders- _ -> return []- return $ yarToResponse yar extraHeaders- where- maxLen = maximumContentLength master $ fmap toMasterRoute murl- len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay- readMay s =- case reads $ S8.unpack s of- [] -> Nothing- (x, _):_ -> Just x- handler = yesodMiddleware handler'--data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text- deriving (Eq, Show, Read)---- | A type-safe, concise method of creating breadcrumbs for pages. For each--- resource, you declare the title of the page and the parent resource (if--- present).-class YesodBreadcrumbs y where- -- | Returns the title and the parent resource, if available. If you return- -- a 'Nothing', then this is considered a top-level page.- breadcrumb :: Route y -> GHandler sub y (Text , Maybe (Route y))---- | Gets the title of the current page and the hierarchy of parent pages,--- along with their respective titles.-breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)])-breadcrumbs = do- x' <- getCurrentRoute- tm <- getRouteToMaster- let x = fmap tm x'- case x of- Nothing -> return ("Not found", [])- Just y -> do- (title, next) <- breadcrumb y- z <- go [] next- return (title, z)- where- go back Nothing = return back- go back (Just this) = do- (title, next) <- breadcrumb this- go ((this, title) : back) next--applyLayout' :: Yesod master- => Html -- ^ title- -> HtmlUrl (Route master) -- ^ body- -> GHandler sub master ChooseRep-applyLayout' title body = fmap chooseRep $ defaultLayout $ do- setTitle title- toWidget body---- | The default error handler for 'errorHandler'.-defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep-defaultErrorHandler NotFound = do- r <- waiRequest- let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r- applyLayout' "Not Found"- [hamlet|-$newline never-<h1>Not Found-<p>#{path'}-|]-defaultErrorHandler (PermissionDenied msg) =- applyLayout' "Permission Denied"- [hamlet|-$newline never-<h1>Permission denied-<p>#{msg}-|]-defaultErrorHandler (InvalidArgs ia) =- applyLayout' "Invalid Arguments"- [hamlet|-$newline never-<h1>Invalid Arguments-<ul>- $forall msg <- ia- <li>#{msg}-|]-defaultErrorHandler (InternalError e) = do- $logErrorS "yesod-core" e- applyLayout' "Internal Server Error"- [hamlet|-$newline never-<h1>Internal Server Error-<pre>#{e}-|]-defaultErrorHandler (BadMethod m) =- applyLayout' "Bad Method"- [hamlet|-$newline never-<h1>Method Not Supported-<p>Method <code>#{S8.unpack m}</code> not supported-|]---- | Return the same URL if the user is authorized to see it.------ Built on top of 'isAuthorized'. This is useful for building page that only--- contain links to pages the user is allowed to see.-maybeAuthorized :: Yesod a- => Route a- -> Bool -- ^ is this a write request?- -> GHandler s a (Maybe (Route a))-maybeAuthorized r isWrite = do- x <- isAuthorized r isWrite- return $ if x == Authorized then Just r else Nothing--jsToHtml :: Javascript -> Html-jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b--jelper :: JavascriptUrl url -> HtmlUrl url-jelper = fmap jsToHtml---- | Convert a widget to a 'PageContent'.-widgetToPageContent :: (Eq (Route master), Yesod master)- => GWidget sub master ()- -> GHandler sub master (PageContent (Route master))-widgetToPageContent w = do- master <- getYesod- ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w- let title = maybe mempty unTitle mTitle- scripts = runUniqueList scripts'- stylesheets = runUniqueList stylesheets'-- render <- getUrlRenderParams- let renderLoc x =- case x of- Nothing -> Nothing- Just (Left s) -> Just s- Just (Right (u, p)) -> Just $ render u p- css <- forM (Map.toList style) $ \(mmedia, content) -> do- let rendered = toLazyText $ content render- x <- addStaticContent "css" "text/css; charset=utf-8"- $ encodeUtf8 rendered- return (mmedia,- case x of- Nothing -> Left $ preEscapedToMarkup rendered- Just y -> Right $ either id (uncurry render) y)- jsLoc <-- case jscript of- Nothing -> return Nothing- Just s -> do- x <- addStaticContent "js" "text/javascript; charset=utf-8"- $ encodeUtf8 $ renderJavascriptUrl render s- return $ renderLoc x-- -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing- -- the asynchronous loader means your page doesn't have to wait for all the js to load- let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc- regularScriptLoad = [hamlet|-$newline never-$forall s <- scripts- ^{mkScriptTag s}-$maybe j <- jscript- $maybe s <- jsLoc- <script src="#{s}">- $nothing- <script>^{jelper j}-|]-- headAll = [hamlet|-$newline never-\^{head'}-$forall s <- stylesheets- ^{mkLinkTag s}-$forall s <- css- $maybe t <- right $ snd s- $maybe media <- fst s- <link rel=stylesheet media=#{media} href=#{t}>- $nothing- <link rel=stylesheet href=#{t}>- $maybe content <- left $ snd s- $maybe media <- fst s- <style media=#{media}>#{content}- $nothing- <style>#{content}-$case jsLoader master- $of BottomOfBody- $of BottomOfHeadAsync asyncJsLoader- ^{asyncJsLoader asyncScripts mcomplete}- $of BottomOfHeadBlocking- ^{regularScriptLoad}-|]- let bodyScript = [hamlet|-$newline never-^{body}-^{regularScriptLoad}-|]-- return $ PageContent title headAll (case jsLoader master of- BottomOfBody -> bodyScript- _ -> body)- where- renderLoc' render' (Local url) = render' url []- renderLoc' _ (Remote s) = s-- addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z)- mkScriptTag (Script loc attrs) render' =- foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return ()- mkLinkTag (Stylesheet loc attrs) render' =- foldl' addAttr TBH.link- ( ("rel", "stylesheet")- : ("href", renderLoc' render' loc)- : attrs- )--data ScriptLoadPosition master- = BottomOfBody- | BottomOfHeadBlocking- | BottomOfHeadAsync (BottomOfHeadAsync master)--type BottomOfHeadAsync master- = [Text] -- ^ urls to load asynchronously- -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion- -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of <head>--left :: Either a b -> Maybe a-left (Left x) = Just x-left _ = Nothing--right :: Either a b -> Maybe b-right (Right x) = Just x-right _ = Nothing--jsonArray :: [Text] -> Html-jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String---- | For use with setting 'jsLoader' to 'BottomOfHeadAsync'-loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master))-loadJsYepnope eyn scripts mcomplete =- [hamlet|-$newline never- $maybe yn <- left eyn- <script src=#{yn}>- $maybe yn <- right eyn- <script src=@{yn}>- $maybe complete <- mcomplete- <script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}});- $nothing- <script>yepnope({load:#{jsonArray scripts}});-|]--asyncHelper :: (url -> [x] -> Text)- -> [Script (url)]- -> Maybe (JavascriptUrl (url))- -> Maybe Text- -> (Maybe (HtmlUrl url), [Text])-asyncHelper render scripts jscript jsLoc =- (mcomplete, scripts'')- where- scripts' = map goScript scripts- scripts'' =- case jsLoc of- Just s -> scripts' ++ [s]- Nothing -> scripts'- goScript (Script (Local url) _) = render url []- goScript (Script (Remote s) _) = s- mcomplete =- case jsLoc of- Just{} -> Nothing- Nothing ->- case jscript of- Nothing -> Nothing- Just j -> Just $ jelper j--yesodRender :: Yesod y- => y- -> ResolvedApproot- -> Route y- -> [(Text, Text)] -- ^ url query string- -> Text-yesodRender y ar url params =- TE.decodeUtf8 $ toByteString $- fromMaybe- (joinPath y ar ps- $ params ++ params')- (urlRenderOverride y url)- where- (ps, params') = renderRoute url--resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot-resolveApproot master req =- case approot of- ApprootRelative -> ""- ApprootStatic t -> t- ApprootMaster f -> f master- ApprootRequest f -> f master req--defaultClientSessionBackend :: Yesod master => IO (SessionBackend master)-defaultClientSessionBackend = do- key <- CS.getKey CS.defaultKeyFile- let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes- (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout- return $ clientSessionBackend2 key getCachedDate---clientSessionBackend :: Yesod master- => CS.Key -- ^ The encryption key- -> Int -- ^ Inactive session valitity in minutes- -> SessionBackend master-clientSessionBackend key timeout = SessionBackend- { sbLoadSession = loadClientSession key timeout "_SESSION"- }-{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-}--loadClientSession :: Yesod master- => CS.Key- -> Int -- ^ timeout- -> S8.ByteString -- ^ session name- -> master- -> W.Request- -> UTCTime- -> IO (BackendSession, SaveSession)-loadClientSession key timeout sessionName master req now = return (sess, save)- where- sess = fromMaybe [] $ do- raw <- lookup "Cookie" $ W.requestHeaders req- val <- lookup sessionName $ parseCookies raw- let host = "" -- fixme, properly lock sessions to client address- decodeClientSessionOld key now host val- save sess' now' = do- -- We should never cache the IV! Be careful!- iv <- liftIO CS.randomIV- return [AddCookie def- { setCookieName = sessionName- , setCookieValue = sessionVal iv- , setCookiePath = Just (cookiePath master)- , setCookieExpires = Just expires- , setCookieDomain = cookieDomain master- , setCookieHttpOnly = True- }]- where- host = "" -- fixme, properly lock sessions to client address- expires = fromIntegral (timeout * 60) `addUTCTime` now'- sessionVal iv = encodeClientSessionOld key iv expires host sess'-{-# DEPRECATED loadClientSession "Please use loadClientSession2, which is more efficient." #-}--clientSessionBackend2 :: Yesod master- => CS.Key -- ^ The encryption key- -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'- -> SessionBackend master-clientSessionBackend2 key getCachedDate =- SessionBackend {- sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req- }--loadClientSession2 :: Yesod master- => CS.Key- -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'- -> S8.ByteString -- ^ session name- -> master- -> W.Request- -> IO (BackendSession, SaveSession)-loadClientSession2 key getCachedDate sessionName master req = load- where- load = do- date <- getCachedDate- return (sess date, save date)- sess date = fromMaybe [] $ do- raw <- lookup "Cookie" $ W.requestHeaders req- val <- lookup sessionName $ parseCookies raw- let host = "" -- fixme, properly lock sessions to client address- decodeClientSession key date host val- save date sess' _ = do- -- We should never cache the IV! Be careful!- iv <- liftIO CS.randomIV- return [AddCookie def- { setCookieName = sessionName- , setCookieValue = encodeClientSession key iv date host sess'- , setCookiePath = Just (cookiePath master)- , setCookieExpires = Just (csdcExpires date)- , setCookieDomain = cookieDomain master- , setCookieHttpOnly = True- }]- where- host = "" -- fixme, properly lock sessions to client address----- | Run a 'GHandler' completely outside of Yesod. This--- function comes with many caveats and you shouldn't use it--- unless you fully understand what it's doing and how it works.------ As of now, there's only one reason to use this function at--- all: in order to run unit tests of functions inside 'GHandler'--- but that aren't easily testable with a full HTTP request.--- Even so, it's better to use @wai-test@ or @yesod-test@ instead--- of using this function.------ This function will create a fake HTTP request (both @wai@'s--- 'W.Request' and @yesod@'s 'Request') and feed it to the--- @GHandler@. The only useful information the @GHandler@ may--- get from the request is the session map, which you must supply--- as argument to @runFakeHandler@. All other fields contain--- fake information, which means that they can be accessed but--- won't have any useful information. The response of the--- @GHandler@ is completely ignored, including changes to the--- session, cookies or headers. We only return you the--- @GHandler@'s return value.-runFakeHandler :: (Yesod master, MonadIO m) =>- SessionMap- -> (master -> Logger)- -> master- -> GHandler master master a- -> m (Either ErrorResponse a)-runFakeHandler fakeSessionMap logger master handler = liftIO $ do- ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")- let handler' = do liftIO . I.writeIORef ret . Right =<< handler- return ()- let YesodApp yapp =- runHandler- handler'- (yesodRender master $ resolveApproot master fakeWaiRequest)- Nothing- id- master- master- (fileUpload master)- (messageLoggerSource master $ logger master)- errHandler err =- YesodApp $ \_ _ _ session -> do- liftIO $ I.writeIORef ret (Left err)- return $ YARPlain- H.status500- []- typePlain- (toContent ("runFakeHandler: errHandler" :: S8.ByteString))- session- fakeWaiRequest =- W.Request- { W.requestMethod = "POST"- , W.httpVersion = H.http11- , W.rawPathInfo = "/runFakeHandler/pathInfo"- , W.rawQueryString = ""- , W.serverName = "runFakeHandler-serverName"- , W.serverPort = 80- , W.requestHeaders = []- , W.isSecure = False- , W.remoteHost = error "runFakeHandler-remoteHost"- , W.pathInfo = ["runFakeHandler", "pathInfo"]- , W.queryString = []- , W.requestBody = mempty- , W.vault = mempty-#if MIN_VERSION_wai(1, 4, 0)- , W.requestBodyLength = W.KnownLength 0-#endif- }- fakeRequest =- Request- { reqGetParams = []- , reqCookies = []- , reqWaiRequest = fakeWaiRequest- , reqLangs = []- , reqToken = Just "NaN" -- not a nonce =)- , reqBodySize = 0- }- fakeContentType = []- _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap- I.readIORef ret-{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
− Yesod/Internal/Request.hs
@@ -1,183 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Yesod.Internal.Request- ( parseWaiRequest- , Request (..)- , RequestBodyContents- , FileInfo- , fileName- , fileContentType- , fileSource- , fileMove- , mkFileInfoLBS- , mkFileInfoFile- , mkFileInfoSource- , FileUpload (..)- , tooLargeResponse- -- The below are exported for testing.- , randomString- , parseWaiRequest'- ) where--import Control.Applicative ((<$>))-import Control.Arrow (second)-import qualified Network.Wai.Parse as NWP-import Yesod.Internal-import qualified Network.Wai as W-import System.Random (RandomGen, newStdGen, randomRs)-import Web.Cookie (parseCookiesText)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8-import Data.Text (Text, pack)-import Network.HTTP.Types (queryToQueryText, Status (Status))-import Control.Monad (join)-import Data.Maybe (fromMaybe, catMaybes)-import qualified Data.ByteString.Lazy as L-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Conduit-import Data.Conduit.List (sourceList)-import Data.Conduit.Binary (sourceFile, sinkFile)-import Data.Word (Word64)-import Control.Monad.IO.Class (liftIO)-import Control.Exception (throwIO)---- | 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 token used to prevent CSRF attacks.- , reqToken :: Maybe Text- -- | Size of the request body.- --- -- Note: in the presence of chunked request bodies, this value will be 0,- -- even though data is available.- , reqBodySize :: Word64 -- FIXME Consider in the future using a Maybe to represent chunked bodies- }--parseWaiRequest :: W.Request- -> [(Text, ByteString)] -- ^ session- -> Bool- -> Word64 -- ^ actual length... might be meaningless, see 'reqBodySize'- -> Word64 -- ^ maximum allowed body size- -> IO Request-parseWaiRequest env session' useToken bodySize maxBodySize =- parseWaiRequest' env session' useToken bodySize maxBodySize <$> newStdGen---- | Impose a limit on the size of the request body.-limitRequestBody :: Word64 -> W.Request -> W.Request-limitRequestBody maxLen req =- req { W.requestBody = W.requestBody req $= limit maxLen }- where- tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse-- limit 0 = tooLarge- limit remaining =- await >>= maybe (return ()) go- where- go bs = do- let len = fromIntegral $ S8.length bs- if len > remaining- then tooLarge- else do- yield bs- limit $ remaining - len--tooLargeResponse :: W.Response-tooLargeResponse = W.responseLBS- (Status 413 "Too Large")- [("Content-Type", "text/plain")]- "Request body too large to be processed."--parseWaiRequest' :: RandomGen g- => W.Request- -> [(Text, ByteString)] -- ^ session- -> Bool- -> Word64- -> Word64 -- ^ max body size- -> g- -> Request-parseWaiRequest' env session' useToken bodySize maxBodySize gen =- Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token bodySize- where- gets' = queryToQueryText $ W.queryString env- gets'' = map (second $ fromMaybe "") gets'- reqCookie = lookup "Cookie" $ W.requestHeaders env- cookies' = maybe [] parseCookiesText reqCookie- acceptLang = lookup "Accept-Language" $ W.requestHeaders env- langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang-- lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k-- -- The language preferences are prioritized as follows:- langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG- , lookup langKey cookies' -- Cookie _LANG- , lookupText langKey session' -- Session _LANG- ] ++ langs -- Accept-Language(s)-- -- Github issue #195. We want to add an extra two-letter version of any- -- language in the list.- langs'' = addTwoLetters (id, Set.empty) langs'-- -- If sessions are disabled tokens should not be used (any- -- tokenKey present in the session is ignored). If sessions- -- are enabled and a session has no tokenKey a new one is- -- generated.- token = if not useToken- then Nothing- else Just $ maybe- (pack $ randomString 10 gen)- (decodeUtf8With lenientDecode)- (lookup tokenKey session')--addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text]-addTwoLetters (toAdd, exist) [] =- filter (flip Set.notMember exist) $ toAdd []-addTwoLetters (toAdd, exist) (l:ls) =- l : addTwoLetters (toAdd', exist') ls- where- (toAdd', exist')- | T.length l > 2 = (toAdd . (T.take 2 l:), exist)- | otherwise = (toAdd, Set.insert l exist)---- | Generate a random String of alphanumerical characters--- (a-z, A-Z, and 0-9) of the given length using the given--- random number generator.-randomString :: RandomGen g => Int -> g -> String-randomString len = take len . map toChar . randomRs (0, 61)- where- toChar i- | i < 26 = toEnum $ i + fromEnum 'A'- | i < 52 = toEnum $ i + fromEnum 'a' - 26- | otherwise = toEnum $ i + fromEnum '0' - 52---- | A tuple containing both the POST parameters and submitted files.-type RequestBodyContents =- ( [(Text, Text)]- , [(Text, FileInfo)]- )--data FileInfo = FileInfo- { fileName :: Text- , fileContentType :: Text- , fileSource :: Source (ResourceT IO) ByteString- , fileMove :: FilePath -> IO ()- }--mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo-mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs)--mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo-mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)--mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo-mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)--data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString)- | FileUploadDisk (NWP.BackEnd FilePath)- | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString))
− Yesod/Internal/Session.hs
@@ -1,161 +0,0 @@-module Yesod.Internal.Session- ( encodeClientSession- , encodeClientSessionOld- , decodeClientSession- , decodeClientSessionOld- , clientSessionDateCacher- , ClientSessionDateCache(..)- , BackendSession- , SaveSession- , SaveSessionOld- , SessionBackend(..)- ) where--import Yesod.Internal (Header(..))-import qualified Web.ClientSession as CS-import Data.Int (Int64)-import Data.Serialize-import Data.Time-import Data.ByteString (ByteString)-import Control.Concurrent (forkIO, killThread, threadDelay)-import Control.Monad (forever, guard)-import Data.Text (Text, pack, unpack)-import Control.Arrow (first)-import Control.Applicative ((<$>))--import qualified Data.ByteString.Char8 as S8-import qualified Data.IORef as I-import qualified Network.Wai as W--type BackendSession = [(Text, S8.ByteString)]--type SaveSession = BackendSession -- ^ The session contents after running the handler- -> UTCTime -- FIXME remove this in the next major version bump- -> IO [Header]--type SaveSessionOld = BackendSession -- ^ The session contents after running the handler- -> UTCTime- -> IO [Header]--newtype SessionBackend master = SessionBackend- { sbLoadSession :: master- -> W.Request- -> UTCTime -- FIXME remove this in the next major version bump- -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session- }--encodeClientSession :: CS.Key- -> CS.IV- -> ClientSessionDateCache -- ^ expire time- -> ByteString -- ^ remote host- -> [(Text, ByteString)] -- ^ session- -> ByteString -- ^ cookie value-encodeClientSession key iv date rhost session' =- CS.encrypt key iv $ encode $ SessionCookie expires rhost session'- where expires = Right (csdcExpiresSerialized date)--decodeClientSession :: CS.Key- -> ClientSessionDateCache -- ^ current time- -> ByteString -- ^ remote host field- -> ByteString -- ^ cookie value- -> Maybe [(Text, ByteString)]-decodeClientSession key date rhost encrypted = do- decrypted <- CS.decrypt key encrypted- SessionCookie (Left expire) rhost' session' <-- either (const Nothing) Just $ decode decrypted- guard $ expire > csdcNow date- guard $ rhost' == rhost- return session'--data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)]- deriving (Show, Read)-instance Serialize SessionCookie where- put (SessionCookie a b c) = do- either putTime putByteString a- put b- put (map (first unpack) c)- get = do- a <- getTime- b <- get- c <- map (first pack) <$> get- return $ SessionCookie (Left a) b c------------------------------------------------------------------------------ Mostly copied from Kazu's date-cache, but with modifications--- that better suit our needs.------ The cached date is updated every 10s, we don't need second--- resolution for session expiration times.--data ClientSessionDateCache =- ClientSessionDateCache {- csdcNow :: !UTCTime- , csdcExpires :: !UTCTime- , csdcExpiresSerialized :: !ByteString- } deriving (Eq, Show)--clientSessionDateCacher ::- NominalDiffTime -- ^ Inactive session valitity.- -> IO (IO ClientSessionDateCache, IO ())-clientSessionDateCacher validity = do- ref <- getUpdated >>= I.newIORef- tid <- forkIO $ forever (doUpdate ref)- return $! (I.readIORef ref, killThread tid)- where- getUpdated = do- now <- getCurrentTime- let expires = validity `addUTCTime` now- expiresS = runPut (putTime expires)- return $! ClientSessionDateCache now expires expiresS- doUpdate ref = do- threadDelay 10000000 -- 10s- I.writeIORef ref =<< getUpdated----------------------------------------------------------------------------putTime :: Putter UTCTime-putTime (UTCTime d t) =- let d' = fromInteger $ toModifiedJulianDay d- t' = fromIntegral $ fromEnum (t / diffTimeScale)- in put (d' * posixDayLength_int64 + min posixDayLength_int64 t')--getTime :: Get UTCTime-getTime = do- val <- get- let (d, t) = val `divMod` posixDayLength_int64- d' = ModifiedJulianDay $! fromIntegral d- t' = fromIntegral t- d' `seq` t' `seq` return (UTCTime d' t')--posixDayLength_int64 :: Int64-posixDayLength_int64 = 86400--diffTimeScale :: DiffTime-diffTimeScale = 1e12--encodeClientSessionOld :: CS.Key- -> CS.IV- -> UTCTime -- ^ expire time- -> ByteString -- ^ remote host- -> [(Text, ByteString)] -- ^ session- -> ByteString -- ^ cookie value-encodeClientSessionOld key iv expire rhost session' =- CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session'--decodeClientSessionOld :: CS.Key- -> UTCTime -- ^ current time- -> ByteString -- ^ remote host field- -> ByteString -- ^ cookie value- -> Maybe [(Text, ByteString)]-decodeClientSessionOld key now rhost encrypted = do- decrypted <- CS.decrypt key encrypted- SessionCookie (Left expire) rhost' session' <-- either (const Nothing) Just $ decode decrypted- guard $ expire > now- guard $ rhost' == rhost- return session'
− Yesod/Internal/TestApi.hs
@@ -1,11 +0,0 @@------ | WARNING: This module exposes internal interfaces solely for the--- purpose of facilitating cabal-driven testing of said interfaces.--- This module is NOT part of the public Yesod API and should NOT be--- imported by library users.----module Yesod.Internal.TestApi- ( randomString, parseWaiRequest'- ) where--import Yesod.Internal.Request (randomString, parseWaiRequest')
− Yesod/Message.hs
@@ -1,6 +0,0 @@--- | This module has moved to "Text.Shakespeare.I18N"-module Yesod.Message- ( module Text.Shakespeare.I18N- ) where--import Text.Shakespeare.I18N
− Yesod/Request.hs
@@ -1,108 +0,0 @@---------------------------------------------------------------- Module : Yesod.Request--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Stable--- Portability : portable------ | Provides a parsed version of the raw 'W.Request' data.--------------------------------------------------------------module Yesod.Request- (- -- * Request datatype- RequestBodyContents- , Request (..)- , FileInfo- , fileName- , fileContentType- , fileSource- , fileMove- -- * Convenience functions- , languages- -- * Lookup parameters- , lookupGetParam- , lookupPostParam- , lookupCookie- , lookupFile- -- ** Multi-lookup- , lookupGetParams- , lookupPostParams- , lookupCookies- , lookupFiles- ) where--import Yesod.Internal.Request-import Yesod.Handler-import Control.Monad (liftM)-import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r-import Data.Maybe (listToMaybe)-import Data.Text (Text)---- | Get the list of supported languages supplied by the user.------ Languages are determined based on the following three (in descending order--- of preference):------ * The _LANG get parameter.------ * The _LANG cookie.------ * The _LANG user session variable.------ * Accept-Language HTTP header.------ Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.--- If a matching language is not found the default language will be used.------ This is handled by parseWaiRequest (not exposed).-languages :: GHandler s m [Text]-languages = reqLangs `liftM` getRequest--lookup' :: Eq a => a -> [(a, b)] -> [b]-lookup' a = map snd . filter (\x -> a == fst x)---- | Lookup for GET parameters.-lookupGetParams :: Text -> GHandler s m [Text]-lookupGetParams pn = do- rr <- getRequest- return $ lookup' pn $ reqGetParams rr---- | Lookup for GET parameters.-lookupGetParam :: Text -> GHandler s m (Maybe Text)-lookupGetParam = liftM listToMaybe . lookupGetParams---- | Lookup for POST parameters.-lookupPostParams :: Text -> GHandler s m [Text]-lookupPostParams pn = do- (pp, _) <- runRequestBody- return $ lookup' pn pp--lookupPostParam :: Text- -> GHandler s m (Maybe Text)-lookupPostParam = liftM listToMaybe . lookupPostParams---- | Lookup for POSTed files.-lookupFile :: Text- -> GHandler s m (Maybe FileInfo)-lookupFile = liftM listToMaybe . lookupFiles---- | Lookup for POSTed files.-lookupFiles :: Text- -> GHandler s m [FileInfo]-lookupFiles pn = do- (_, files) <- runRequestBody- return $ lookup' pn files---- | Lookup for cookie data.-lookupCookie :: Text -> GHandler s m (Maybe Text)-lookupCookie = liftM listToMaybe . lookupCookies---- | Lookup for cookie data.-lookupCookies :: Text -> GHandler s m [Text]-lookupCookies pn = do- rr <- getRequest- return $ lookup' pn $ reqCookies rr
− Yesod/Widget.hs
@@ -1,369 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-}--- FIXME Should we remove the older names here (addJulius, etc)?---- | Widgets combine HTML with JS and CSS dependencies with a unique identifier--- generator, allowing you to create truly modular HTML components.-module Yesod.Widget- ( -- * Datatype- GWidget- , PageContent (..)- -- * Special Hamlet quasiquoter/TH for Widgets- , whamlet- , whamletFile- , ihamletToRepHtml- -- * Convert to Widget- , ToWidget (..)- , ToWidgetHead (..)- , ToWidgetBody (..)- -- * Creating- -- ** Head of page- , setTitle- , setTitleI- , addHamletHead- , addHtmlHead- -- ** Body- , addHamlet- , addHtml- , addWidget- , addSubWidget- -- ** CSS- , addCassius- , addCassiusMedia- , addLucius- , addLuciusMedia- , addStylesheet- , addStylesheetAttrs- , addStylesheetRemote- , addStylesheetRemoteAttrs- , addStylesheetEither- , CssBuilder (..)- -- ** Javascript- , addJulius- , addJuliusBody- , addScript- , addScriptAttrs- , addScriptRemote- , addScriptRemoteAttrs- , addScriptEither- -- * Internal- , unGWidget- , whamletFileWithSettings- ) where--import Data.Monoid-import qualified Text.Blaze.Html5 as H-import Text.Hamlet-import Text.Cassius-import Text.Julius-import Yesod.Routes.Class-import Yesod.Handler- ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod- , getMessageRender, getUrlRenderParams, MonadLift (..)- )-import Yesod.Message (RenderMessage)-import Yesod.Content (RepHtml (..), toContent)-import Control.Applicative (Applicative (..), (<$>))-import Control.Monad.IO.Class (MonadIO (liftIO))-import Yesod.Internal-import Control.Monad (liftM)-import Data.Text (Text)-import qualified Data.Map as Map-import Language.Haskell.TH.Quote (QuasiQuoter)-import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName)--import Control.Monad.Trans.Control (MonadBaseControl (..))-import Control.Exception (throwIO)-import qualified Text.Hamlet as NP-import Data.Text.Lazy.Builder (fromLazyText, Builder)-import Text.Blaze.Html (toHtml, preEscapedToMarkup)-import qualified Data.Text.Lazy as TL-import Control.Monad.Base (MonadBase (liftBase))-import Control.Arrow (first)-import Control.Monad.Trans.Resource--import Control.Monad.Logger--preEscapedLazyText :: TL.Text -> Html-preEscapedLazyText = preEscapedToMarkup---- | A generic widget, allowing specification of both the subsite and master--- site datatypes. While this is simply a @WriterT@, we define a newtype for--- better error messages.-newtype GWidget sub master a = GWidget- { unGWidget :: GHandler sub master (a, GWData (Route master))- }--instance (a ~ ()) => Monoid (GWidget sub master a) where- mempty = return ()- mappend x y = x >> y--addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a-addSubWidget sub (GWidget w) = do- master <- lift getYesod- let sr = fromSubRoute sub master- (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w- tell w'- return a--class ToWidget sub master a where- toWidget :: a -> GWidget sub master ()--type RY master = Route master -> [(Text, Text)] -> Text---- | Newtype wrapper allowing injection of arbitrary content into CSS.------ Usage:------ > toWidget $ CssBuilder "p { color: red }"------ Since: 1.1.3-newtype CssBuilder = CssBuilder { unCssBuilder :: Builder }--instance render ~ RY master => ToWidget sub master (render -> Html) where- toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty-instance render ~ RY master => ToWidget sub master (render -> Css) where- toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x-instance render ~ RY master => ToWidget sub master (render -> CssBuilder) where- toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty-instance render ~ RY master => ToWidget sub master (render -> Javascript) where- toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty-instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where- toWidget = id-instance ToWidget sub master Html where- toWidget = toWidget . const--class ToWidgetBody sub master a where- toWidgetBody :: a -> GWidget sub master ()--instance render ~ RY master => ToWidgetBody sub master (render -> Html) where- toWidgetBody = toWidget-instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where- toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j-instance ToWidgetBody sub master Html where- toWidgetBody = toWidget--class ToWidgetHead sub master a where- toWidgetHead :: a -> GWidget sub master ()--instance render ~ RY master => ToWidgetHead sub master (render -> Html) where- toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head-instance render ~ RY master => ToWidgetHead sub master (render -> Css) where- toWidgetHead = toWidget-instance render ~ RY master => ToWidgetHead sub master (render -> CssBuilder) where- toWidgetHead = toWidget-instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where- toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j-instance ToWidgetHead sub master Html where- toWidgetHead = toWidgetHead . const---- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.-setTitle :: Html -> GWidget sub master ()-setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty---- | Set the page title. Calling 'setTitle' multiple times overrides previously--- set values.-setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()-setTitleI msg = do- mr <- lift getMessageRender- setTitle $ toHtml $ mr msg--{-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-}-{-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-}-{-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-}-{-# DEPRECATED addWidget "addWidget can be omitted" #-}---- | Add a 'Hamlet' to the head tag.-addHamletHead :: HtmlUrl (Route master) -> GWidget sub master ()-addHamletHead = toWidgetHead---- | Add a 'Html' to the head tag.-addHtmlHead :: Html -> GWidget sub master ()-addHtmlHead = toWidgetHead . const---- | Add a 'Hamlet' to the body tag.-addHamlet :: HtmlUrl (Route master) -> GWidget sub master ()-addHamlet = toWidget---- | Add a 'Html' to the body tag.-addHtml :: Html -> GWidget sub master ()-addHtml = toWidget---- | Add another widget. This is defined as 'id', by can help with types, and--- makes widget blocks look more consistent.-addWidget :: GWidget sub master () -> GWidget sub master ()-addWidget = id---- | Add some raw CSS to the style tag. Applies to all media types.-addCassius :: CssUrl (Route master) -> GWidget sub master ()-addCassius = toWidget---- | Identical to 'addCassius'.-addLucius :: CssUrl (Route master) -> GWidget sub master ()-addLucius = toWidget---- | Add some raw CSS to the style tag, for a specific media type.-addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()-addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty---- | Identical to 'addCassiusMedia'.-addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master ()-addLuciusMedia = addCassiusMedia---- | Link to the specified local stylesheet.-addStylesheet :: Route master -> GWidget sub master ()-addStylesheet = flip addStylesheetAttrs []---- | Link to the specified local stylesheet.-addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()-addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty---- | Link to the specified remote stylesheet.-addStylesheetRemote :: Text -> GWidget sub master ()-addStylesheetRemote = flip addStylesheetRemoteAttrs []---- | Link to the specified remote stylesheet.-addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()-addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty--addStylesheetEither :: Either (Route master) Text -> GWidget sub master ()-addStylesheetEither = either addStylesheet addStylesheetRemote--addScriptEither :: Either (Route master) Text -> GWidget sub master ()-addScriptEither = either addScript addScriptRemote---- | Link to the specified local script.-addScript :: Route master -> GWidget sub master ()-addScript = flip addScriptAttrs []---- | Link to the specified local script.-addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()-addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty---- | Link to the specified remote script.-addScriptRemote :: Text -> GWidget sub master ()-addScriptRemote = flip addScriptRemoteAttrs []---- | Link to the specified remote script.-addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()-addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty---- | Include raw Javascript in the page's script tag.-addJulius :: JavascriptUrl (Route master) -> GWidget sub master ()-addJulius = toWidget---- | Add a new script tag to the body with the contents of this 'Julius'--- template.-addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master ()-addJuliusBody = toWidgetBody---- | Content for a web page. By providing this datatype, we can easily create--- generic site templates, which would have the type signature:------ > PageContent url -> HtmlUrl url-data PageContent url = PageContent- { pageTitle :: Html- , pageHead :: HtmlUrl url- , pageBody :: HtmlUrl url- }--whamlet :: QuasiQuoter-whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings--whamletFile :: FilePath -> Q Exp-whamletFile = NP.hamletFileWithSettings rules NP.defaultHamletSettings--whamletFileWithSettings :: NP.HamletSettings -> FilePath -> Q Exp-whamletFileWithSettings = NP.hamletFileWithSettings rules--rules :: Q NP.HamletRules-rules = do- ah <- [|toWidget|]- let helper qg f = do- x <- newName "urender"- e <- f $ VarE x- let e' = LamE [VarP x] e- g <- qg- bind <- [|(>>=)|]- return $ InfixE (Just g) bind (Just e')- let ur f = do- let env = NP.Env- (Just $ helper [|liftW getUrlRenderParams|])- (Just $ helper [|liftM (toHtml .) $ liftW getMessageRender|])- f env- return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b---- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.-ihamletToRepHtml :: RenderMessage master message- => HtmlUrlI18n message (Route master)- -> GHandler sub master RepHtml-ihamletToRepHtml ih = do- urender <- getUrlRenderParams- mrender <- getMessageRender- return $ RepHtml $ toContent $ ih (toHtml . mrender) urender--tell :: GWData (Route master) -> GWidget sub master ()-tell w = GWidget $ return ((), w)--instance MonadLift (GHandler sub master) (GWidget sub master) where- lift = GWidget . fmap (\x -> (x, mempty))---- | Type-restricted version of @lift@-liftW :: GHandler sub master a -> GWidget sub master a-liftW = lift---- Instances for GWidget-instance Functor (GWidget sub master) where- fmap f (GWidget x) = GWidget (fmap (first f) x)-instance Applicative (GWidget sub master) where- pure a = GWidget $ pure (a, mempty)- GWidget f <*> GWidget v =- GWidget $ k <$> f <*> v- where- k (a, wa) (b, wb) = (a b, wa `mappend` wb)-instance Monad (GWidget sub master) where- return = pure- GWidget x >>= f = GWidget $ do- (a, wa) <- x- (b, wb) <- unGWidget (f a)- return (b, wa `mappend` wb)-instance MonadIO (GWidget sub master) where- liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO-instance MonadBase IO (GWidget sub master) where- liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase-instance MonadBaseControl IO (GWidget sub master) where- data StM (GWidget sub master) a =- StW (StM (GHandler sub master) (a, GWData (Route master)))- liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->- liftM (\x -> (x, mempty))- (f $ liftM StW . runInBase . unGWidget)- restoreM (StW base) = GWidget $ restoreM base--instance MonadUnsafeIO (GWidget sub master) where- unsafeLiftIO = liftIO-instance MonadThrow (GWidget sub master) where- monadThrow = liftIO . throwIO-instance MonadResource (GWidget sub master) where-#if MIN_VERSION_resourcet(0,4,0)- liftResourceT = lift . liftResourceT-#else- allocate a = lift . allocate a- register = lift . register- release = lift . release- resourceMask = lift . resourceMask-#endif--instance MonadLogger (GWidget sub master) where-#if MIN_VERSION_monad_logger(0, 3, 0)- monadLoggerLog a b c = lift . monadLoggerLog a b c-#else- monadLoggerLog a b = lift . monadLoggerLog a b- monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c-#endif
test/YesodCoreTest.hs view
@@ -13,6 +13,11 @@ import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize+import qualified YesodCoreTest.Json as Json+import qualified YesodCoreTest.Streaming as Streaming+import qualified YesodCoreTest.Reps as Reps+import qualified YesodCoreTest.Auth as Auth+import qualified YesodCoreTest.LiteApp as LiteApp import Test.Hspec @@ -31,3 +36,8 @@ Redirect.specs JsLoader.specs RequestBodySize.specs+ Json.specs+ Streaming.specs+ Reps.specs+ Auth.specs+ LiteApp.specs
+ test/YesodCoreTest/Auth.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}+module YesodCoreTest.Auth (specs, Widget) where++import Yesod.Core+import Test.Hspec+import Network.Wai.Test+import Network.Wai+import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T+import Data.List (isSuffixOf)++data App = App++mkYesod "App" [parseRoutes|+/no-auth NoAuthR+/needs-login-json NeedsLoginJsonR+/needs-login-html NeedsLoginHtmlR+/read-only ReadOnlyR+/forbidden ForbiddenR+|]++instance Yesod App where+ isAuthorized NoAuthR _ = return Authorized+ isAuthorized NeedsLoginJsonR _ = return AuthenticationRequired+ isAuthorized NeedsLoginHtmlR _ = return AuthenticationRequired+ isAuthorized ReadOnlyR False = return Authorized+ isAuthorized ReadOnlyR True = return $ Unauthorized "Read only"+ isAuthorized ForbiddenR _ = return $ Unauthorized "Forbidden"+ authRoute _ = Just NoAuthR++handleNoAuthR, handleReadOnlyR, handleForbiddenR :: Handler ()+handleNoAuthR = return ()+handleReadOnlyR = return ()+handleForbiddenR = return ()++handleNeedsLoginJsonR :: Handler RepJson+handleNeedsLoginJsonR = return $ repJson $ object []+handleNeedsLoginHtmlR :: Handler RepHtml+handleNeedsLoginHtmlR = return ""++test :: String -- ^ method+ -> String -- ^ path+ -> (SResponse -> Session ())+ -> Spec+test method path f = it (method ++ " " ++ path) $ do+ app <- toWaiApp App+ flip runSession app $ do+ sres <- request defaultRequest+ { requestMethod = S8.pack method+ , pathInfo = [T.pack path]+ , requestHeaders =+ if not $ isSuffixOf "json" path then [] else+ [("Accept", S8.pack "application/json")]+ }+ f sres++specs :: Spec+specs = describe "Auth" $ do+ test "GET" "no-auth" $ \sres -> assertStatus 200 sres+ test "POST" "no-auth" $ \sres -> assertStatus 200 sres+ test "GET" "needs-login-html" $ \sres -> assertStatus 303 sres+ test "POST" "needs-login-html" $ \sres -> assertStatus 303 sres+ test "GET" "needs-login-json" $ \sres -> assertStatus 401 sres+ test "POST" "needs-login-json" $ \sres -> assertStatus 401 sres+ test "GET" "read-only" $ \sres -> assertStatus 200 sres+ test "POST" "read-only" $ \sres -> assertStatus 403 sres+ test "GET" "forbidden" $ \sres -> assertStatus 403 sres+ test "POST" "forbidden" $ \sres -> assertStatus 403 sres
test/YesodCoreTest/Cache.hs view
@@ -1,39 +1,41 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} module YesodCoreTest.Cache (cacheTest, Widget) where import Test.Hspec -import Network.Wai import Network.Wai.Test import Yesod.Core+import Data.IORef.Lifted+import Data.Typeable (Typeable)+import qualified Data.ByteString.Lazy.Char8 as L8 data C = C -key :: CacheKey Int-key = $(mkCacheKey)+newtype V1 = V1 Int+ deriving Typeable -key2 :: CacheKey Int-key2 = $(mkCacheKey)+newtype V2 = V2 Int+ deriving Typeable mkYesod "C" [parseRoutes|/ RootR GET|] instance Yesod C -getRootR :: Handler ()+getRootR :: Handler RepPlain getRootR = do- Nothing <- cacheLookup key- cacheInsert key 5- Just 5 <- cacheLookup key- cacheInsert key 7- Just 7 <- cacheLookup key- Nothing <- cacheLookup key2- cacheDelete key- Nothing <- cacheLookup key- return ()+ ref <- newIORef 0+ V1 v1a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1)+ V1 v1b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) + V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)+ V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1)++ return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b]+ cacheTest :: Spec cacheTest = describe "Test.Cache" $ do@@ -44,5 +46,6 @@ works :: IO () works = runner $ do- res <- request defaultRequest { pathInfo = [] }+ res <- request defaultRequest assertStatus 200 res+ assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res
test/YesodCoreTest/CleanPath.hs view
@@ -5,7 +5,7 @@ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai import Network.Wai.Test@@ -28,12 +28,14 @@ data Route Subsite = SubsiteRoute [TS.Text] deriving (Eq, Show, Read) renderRoute (SubsiteRoute x) = (x, [])+instance ParseRoute Subsite where+ parseRoute (x, _) = Just $ SubsiteRoute x -instance YesodDispatch Subsite master where- yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS+instance YesodSubDispatch Subsite master where+ yesodSubDispatch _ req = return $ responseLBS status200 [ ("Content-Type", "SUBSITE")- ] $ L8.pack $ show pieces+ ] $ L8.pack $ show (pathInfo req) data Y = Y mkYesod "Y" [parseRoutes|@@ -84,6 +86,11 @@ it "/foo/something" fooSomething it "subsite dispatch" subsiteDispatch it "redirect with query string" redQueryString+ it "parsing" $ do+ parseRoute (["foo"], []) `shouldBe` Just FooR+ parseRoute (["foo", "bar"], []) `shouldBe` Just (FooStringR "bar")+ parseRoute (["subsite", "some", "path"], []) `shouldBe` Just (SubsiteR $ SubsiteRoute ["some", "path"])+ parseRoute (["ignore", "me"], []) `shouldBe` (Nothing :: Maybe (Route Y)) runner :: Session () -> IO () runner f = toWaiApp Y >>= runSession f
test/YesodCoreTest/Exceptions.hs view
@@ -5,7 +5,7 @@ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status301)@@ -18,7 +18,7 @@ instance Yesod Y where approot = ApprootStatic "http://test"- errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e+ errorHandler (InternalError e) = return $ toTypedContent e errorHandler x = defaultErrorHandler x getRootR :: Handler ()@@ -26,7 +26,7 @@ getRedirR :: Handler () getRedirR = do- setHeader "foo" "bar"+ addHeader "foo" "bar" redirectWith status301 RootR exceptionsTest :: Spec
test/YesodCoreTest/InternalRequest.hs view
@@ -6,9 +6,12 @@ import Network.Wai as W import Network.Wai.Test-import Yesod.Internal.TestApi (randomString, parseWaiRequest')-import Yesod.Request (Request (..))+import Yesod.Core.Internal (randomString, parseWaiRequest) import Test.Hspec+import Data.Monoid (mempty)+import Data.Map (singleton)+import Yesod.Core+import Data.Word (Word64) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do@@ -28,6 +31,15 @@ g :: StdGen g = error "test/YesodCoreTest/InternalRequest.g" +parseWaiRequest' :: Request+ -> SessionMap+ -> Bool+ -> Word64+ -> YesodRequest+parseWaiRequest' a b c d =+ case parseWaiRequest a b c (Just d) of+ Left yreq -> yreq+ Right needGen -> needGen g tokenSpecs :: Spec tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do@@ -38,19 +50,19 @@ noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where- r = parseWaiRequest' defaultRequest [] False 0 1000 g+ r = parseWaiRequest' defaultRequest mempty False 1000 ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 1000 g+ r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000 useOldToken :: Bool useOldToken = reqToken r == Just "old" where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g+ r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 generateToken :: Bool generateToken = reqToken r /= Nothing where- r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g+ r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 langSpecs :: Spec@@ -64,21 +76,21 @@ respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest- { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 1000 g+ { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where- r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 1000 g+ r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000 respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")]- } [] False 0 1000 g+ } mempty False 1000 respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where- r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 1000 g+ r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where@@ -87,8 +99,7 @@ , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")]- } [("_LANG", "en-SESSION")] False 0 10000 g-+ } (singleton "_LANG" "en-SESSION") False 10000 internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do
test/YesodCoreTest/JsLoader.hs view
@@ -3,12 +3,11 @@ {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoader (specs, Widget) where -import YesodCoreTest.JsLoaderSites.HeadAsync (HA(..)) import YesodCoreTest.JsLoaderSites.Bottom (B(..)) import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai.Test data H = H@@ -27,13 +26,9 @@ res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"load.js\"></script></head><body></body></html>" res - it "link from head async" $ runner HA $ do- res <- request defaultRequest- assertBody "<!DOCTYPE html>\n<html><head><title></title><script src=\"yepnope.js\"></script><script>yepnope({load:[\"load.js\"]});</script></head><body></body></html>" res- it "link from bottom" $ runner B $ do res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script src=\"load.js\"></script></body></html>" res -runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO ()+runner :: YesodDispatch master => master -> Session () -> IO () runner app f = toWaiApp app >>= runSession f
− test/YesodCoreTest/JsLoaderSites/HeadAsync.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-module YesodCoreTest.JsLoaderSites.HeadAsync (HA(..), Widget) where--import Yesod.Core--data HA = HA-mkYesod "HA" [parseRoutes|-/ HeadAsyncR GET-|]-instance Yesod HA where- jsLoader _ = BottomOfHeadAsync $ loadJsYepnope $ Left "yepnope.js"--getHeadAsyncR :: Handler RepHtml-getHeadAsyncR = defaultLayout $ addScriptRemote "load.js"
+ test/YesodCoreTest/Json.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}+module YesodCoreTest.Json (specs, Widget) where++import Yesod.Core+import Test.Hspec+import qualified Data.Map as Map+import Network.Wai.Test+import Data.Text (Text)+import Data.ByteString.Lazy (ByteString)++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+/has-multiple-pieces/#Int/#Int MultiplePiecesR GET+|]++instance Yesod App++getHomeR :: Handler RepPlain+getHomeR = do+ val <- parseJsonBody_+ case Map.lookup ("foo" :: Text) val of+ Nothing -> invalidArgs ["foo not found"]+ Just foo -> return $ RepPlain $ toContent (foo :: Text)++getMultiplePiecesR :: Int -> Int -> Handler ()+getMultiplePiecesR _ _ = return ()++test :: String+ -> ByteString+ -> (SResponse -> Session ())+ -> Spec+test name rbody f = it name $ do+ app <- toWaiApp App+ flip runSession app $ do+ sres <- srequest SRequest+ { simpleRequest = defaultRequest+ , simpleRequestBody = rbody+ }+ f sres++specs :: Spec+specs = describe "Yesod.Json" $ do+ test "parses valid content" "{\"foo\":\"bar\"}" $ \sres -> do+ assertStatus 200 sres+ assertBody "bar" sres+ test "400 for bad JSON" "{\"foo\":\"bar\"" $ \sres -> do+ assertStatus 400 sres+ test "400 for bad structure" "{\"foo2\":\"bar\"}" $ \sres -> do+ assertStatus 400 sres+ assertBodyContains "foo not found" sres
test/YesodCoreTest/Links.hs view
@@ -5,12 +5,11 @@ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core import Text.Hamlet import Network.Wai import Network.Wai.Test import Data.Text (Text)-import Control.Monad.IO.Class (liftIO) import Blaze.ByteString.Builder (toByteString) data Y = Y@@ -18,8 +17,23 @@ / RootR GET /single/#Text TextR GET /multi/*Texts TextsR GET++/route-test-1/+[Text] RT1 GET+/route-test-2/*Vector-String RT2 GET+/route-test-3/*Vector-(Maybe-Int) RT3 GET+/route-test-4/#(Foo-Int-Int) RT4 GET |] +data Vector a = Vector+ deriving (Show, Read, Eq)++instance PathMultiPiece (Vector a)++data Foo x y = Foo+ deriving (Show, Read, Eq)++instance PathPiece (Foo x y)+ instance Yesod Y getRootR :: Handler RepHtml@@ -30,6 +44,18 @@ getTextsR :: [Text] -> Handler RepHtml getTextsR foos = defaultLayout $ toWidget [hamlet|%#{show foos}%|]++getRT1 :: [Text] -> Handler ()+getRT1 _ = return ()++getRT2 :: Vector String -> Handler ()+getRT2 _ = return ()++getRT3 :: Vector (Maybe Int) -> Handler ()+getRT3 _ = return ()++getRT4 :: Foo Int Int -> Handler ()+getRT4 _ = return () linksTest :: Spec linksTest = describe "Test.Links" $ do
+ test/YesodCoreTest/LiteApp.hs view
@@ -0,0 +1,42 @@+module YesodCoreTest.LiteApp (specs) where++import Yesod.Core+import Test.Hspec+import Network.Wai.Test+import Network.Wai+import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T+import qualified Data.ByteString.Lazy.Char8 as L8++iapp :: IO Application+iapp = toWaiApp $ liteApp $ do+ onMethod (S8.pack "GET") (dispatchTo $ return "GetHomepage")+ onMethod (S8.pack "POST") (dispatchTo $ return "PostHomepage")+ onStatic (T.pack "string") (withDynamic (\t -> dispatchTo $ return (t :: T.Text)))+ onStatic (T.pack "multi") (withDynamicMulti (\[_, y] -> dispatchTo $ return (y :: T.Text)))++test :: String -- ^ method+ -> [String] -- ^ path+ -> (Either Int String) -- ^ status code or body+ -> Spec+test method path expected = it (method ++ " " ++ show path) $ do+ app <- iapp+ flip runSession app $ do+ sres <- request defaultRequest+ { requestMethod = S8.pack method+ , pathInfo = map T.pack path+ }+ case expected of+ Left i -> assertStatus i sres+ Right b -> assertBody (L8.pack b) sres++specs :: Spec+specs = describe "LiteApp" $ do+ test "GET" [] $ Right "GetHomepage"+ test "POST" [] $ Right "PostHomepage"+ -- test "PUT" [] $ Left 405+ test "GET" ["string", "foo"] $ Right "foo"+ test "DELETE" ["string", "bar"] $ Right "bar"+ test "GET" ["string!", "foo"] $ Left 404+ test "GET" ["multi", "foo", "bar"] $ Right "bar"+ test "GET" ["multi", "foo", "bar", "baz"] $ Left 500
test/YesodCoreTest/Media.hs view
@@ -5,7 +5,7 @@ module YesodCoreTest.Media (mediaTest, Widget) where import Test.Hspec-import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai import Network.Wai.Test import Text.Lucius@@ -15,9 +15,8 @@ instance Yesod Y where addStaticContent _ _ content = do- tm <- getRouteToMaster route <- getCurrentRoute- case fmap tm route of+ case route of Just StaticR -> return $ Just $ Left $ if content == "foo2{bar:baz}" then "screen.css"@@ -27,7 +26,7 @@ getRootR :: Handler RepHtml getRootR = defaultLayout $ do toWidget [lucius|foo1{bar:baz}|]- addCassiusMedia "screen" [lucius|foo2{bar:baz}|]+ toWidgetMedia "screen" [lucius|foo2{bar:baz}|] toWidget [lucius|foo3{bar:baz}|] getStaticR :: Handler RepHtml
test/YesodCoreTest/MediaData.hs view
@@ -8,5 +8,5 @@ data Y = Y mkYesodData "Y" [parseRoutes| / RootR GET-/static StaticR GET+/static StaticR !IGNORED GET !alsoIgnored |]
test/YesodCoreTest/NoOverloadedStrings.hs view
@@ -3,23 +3,41 @@ module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where import Test.Hspec+import YesodCoreTest.NoOverloadedStringsSub -import Yesod.Core hiding (Request)+import Yesod.Core+import Network.Wai import Network.Wai.Test import Data.Monoid (mempty)--data Subsite = Subsite+import qualified Data.Text as T+import qualified Data.ByteString.Lazy.Char8 as L8 getSubsite :: a -> Subsite-getSubsite = const Subsite+getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) -mkYesodSub "Subsite" [] [parseRoutes|-/bar BarR GET-|]+getBarR :: Monad m => m T.Text+getBarR = return $ T.pack "BarR" -getBarR :: GHandler Subsite m ()-getBarR = return ()+getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml+getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] +getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml+getBinR = do+ widget <- widgetToParentWidget [whamlet|+ <p>Used defaultLayoutT+ <a href=@{BazR}>Baz+ |]+ lift $ defaultLayout widget++getOnePiecesR :: Monad m => Int -> m ()+getOnePiecesR _ = return ()++getTwoPiecesR :: Monad m => Int -> Int -> m ()+getTwoPiecesR _ _ = return ()++getThreePiecesR :: Monad m => Int -> Int -> Int -> m ()+getThreePiecesR _ _ _ = return ()+ data Y = Y mkYesod "Y" [parseRoutes| / RootR GET@@ -43,6 +61,33 @@ res <- request defaultRequest assertBody mempty res +case_subsite :: IO ()+case_subsite = runner $ do+ res <- request defaultRequest+ { pathInfo = map T.pack ["subsite", "bar"]+ }+ assertBody (L8.pack "BarR") res+ assertStatus 200 res++case_deflayout :: IO ()+case_deflayout = runner $ do+ res <- request defaultRequest+ { pathInfo = map T.pack ["subsite", "baz"]+ }+ assertBodyContains (L8.pack "Used Default Layout") res+ assertStatus 200 res++case_deflayoutT :: IO ()+case_deflayoutT = runner $ do+ res <- request defaultRequest+ { pathInfo = map T.pack ["subsite", "bin"]+ }+ assertBodyContains (L8.pack "Used defaultLayoutT") res+ assertStatus 200 res+ noOverloadedTest :: Spec noOverloadedTest = describe "Test.NoOverloadedStrings" $ do it "sanity" case_sanity+ it "subsite" case_subsite+ it "deflayout" case_deflayout+ it "deflayoutT" case_deflayoutT
test/YesodCoreTest/Redirect.hs view
@@ -2,7 +2,7 @@ module YesodCoreTest.Redirect (specs, Widget) where import YesodCoreTest.YesodTest-import Yesod.Handler (redirectWith)+import Yesod.Core.Handler (redirectWith) import qualified Network.HTTP.Types as H data Y = Y
test/YesodCoreTest/RequestBodySize.hs view
@@ -5,7 +5,7 @@ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai import Network.Wai.Test@@ -29,7 +29,7 @@ |] instance Yesod Y where- maximumContentLength _ _ = 10+ maximumContentLength _ _ = Just 10 postPostR, postConsumeR, postPartialConsumeR, postUnusedR :: Handler RepPlain @@ -38,13 +38,11 @@ return $ RepPlain $ toContent $ T.concat val postConsumeR = do- req <- waiRequest- body <- lift $ requestBody req $$ consume+ body <- rawRequestBody $$ consume return $ RepPlain $ toContent $ S.concat body postPartialConsumeR = do- req <- waiRequest- body <- lift $ requestBody req $$ isolate 5 =$ consume+ body <- rawRequestBody $$ isolate 5 =$ consume return $ RepPlain $ toContent $ S.concat body postUnusedR = return $ RepPlain ""@@ -75,6 +73,10 @@ then [("content-length", S8.pack $ show $ S.length body)] else [] , requestMethod = "POST"+ , requestBodyLength =+ if includeLength+ then KnownLength $ fromIntegral $ S.length body+ else ChunkedBody } $ L.fromChunks $ map S.singleton $ S.unpack body specs :: Spec
test/YesodCoreTest/Widget.hs view
@@ -5,7 +5,7 @@ import Test.Hspec -import Yesod.Core hiding (Request)+import Yesod.Core import Text.Julius import Text.Lucius import Text.Hamlet@@ -61,18 +61,18 @@ getWhamletR :: Handler RepHtml getWhamletR = defaultLayout [whamlet|-$newline never-<h1>Test-<h2>@{WhamletR}-<h3>_{Goodbye}-<h3>_{MsgAnother}-^{embed}-|]+ $newline never+ <h1>Test+ <h2>@{WhamletR}+ <h3>_{Goodbye}+ <h3>_{MsgAnother}+ ^{embed}+ |] where embed = [whamlet|-$newline never-<h4>Embed-|]+ $newline never+ <h4>Embed+ |] getAutoR :: Handler RepHtml getAutoR = defaultLayout [whamlet|
test/YesodCoreTest/YesodTest.hs view
@@ -9,10 +9,10 @@ , module Test.Hspec ) where -import Yesod.Core hiding (Request)+import Yesod.Core import Network.Wai.Test import Network.Wai import Test.Hspec -yesod :: (YesodDispatch y y, Yesod y) => y -> Session a -> IO a+yesod :: YesodDispatch y => y -> Session a -> IO a yesod app f = toWaiApp app >>= runSession f
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.1.8.3+version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -22,9 +22,9 @@ test/YesodCoreTest/ErrorHandling.hs test/YesodCoreTest/Exceptions.hs test/YesodCoreTest/InternalRequest.hs+ test/YesodCoreTest/Json.hs test/YesodCoreTest/JsLoader.hs test/YesodCoreTest/JsLoaderSites/Bottom.hs- test/YesodCoreTest/JsLoaderSites/HeadAsync.hs test/YesodCoreTest/Links.hs test/YesodCoreTest/Media.hs test/YesodCoreTest/MediaData.hs@@ -34,23 +34,16 @@ test/YesodCoreTest/WaiSubsite.hs test/YesodCoreTest/Widget.hs test/YesodCoreTest/YesodTest.hs+ test/YesodCoreTest/Auth.hs+ test/YesodCoreTest/LiteApp.hs test/en.msg test/test.hs -flag test- description: Build the executable to run unit tests- default: False- library- -- Work around a bug in cabal. Without this, wai-test doesn't get built and- -- we have a missing dependency during --enable-tests builds.- if flag(test)- build-depends: wai-test- build-depends: base >= 4.3 && < 5 , time >= 1.1.4- , yesod-routes >= 1.1 && < 1.2- , wai >= 1.3 && < 1.5+ , yesod-routes >= 1.2 && < 1.3+ , wai >= 1.4 && < 1.5 , wai-extra >= 1.3 && < 1.4 , bytestring >= 0.9.1.4 , text >= 0.7 && < 0.12@@ -63,7 +56,7 @@ , shakespeare-i18n >= 1.0 && < 1.1 , blaze-builder >= 0.2.1.4 && < 0.4 , transformers >= 0.2.2 && < 0.4- , clientsession >= 0.8+ , clientsession >= 0.9 && < 0.10 , random >= 1.0.0.2 && < 1.1 , cereal >= 0.3 && < 0.4 , old-locale >= 1.0.0.2 && < 1.1@@ -79,26 +72,36 @@ , vector >= 0.9 && < 0.11 , aeson >= 0.5 , fast-logger >= 0.2- , monad-logger >= 0.2.1 && < 0.4+ , monad-logger >= 0.3.1 && < 0.4 , conduit >= 0.5- , resourcet >= 0.3 && < 0.5+ , resourcet >= 0.4.6 && < 0.5 , lifted-base >= 0.1+ , attoparsec-conduit , blaze-html >= 0.5 , blaze-markup >= 0.5.1+ , data-default+ , safe+ , warp >= 1.3.8 - exposed-modules: Yesod.Content- Yesod.Core- Yesod.Dispatch- Yesod.Handler- Yesod.Request- Yesod.Widget- Yesod.Message- Yesod.Internal.TestApi- other-modules: Yesod.Internal- Yesod.Internal.Cache- Yesod.Internal.Core- Yesod.Internal.Session- Yesod.Internal.Request+ exposed-modules: Yesod.Core+ Yesod.Core.Content+ Yesod.Core.Dispatch+ Yesod.Core.Handler+ Yesod.Core.Json+ Yesod.Core.Widget+ Yesod.Core.Internal+ Yesod.Core.Types+ other-modules: Yesod.Core.Internal.Session+ Yesod.Core.Internal.Request+ Yesod.Core.Class.Handler+ Yesod.Core.Internal.Util+ Yesod.Core.Internal.Response+ Yesod.Core.Internal.Run+ Yesod.Core.Internal.TH+ Yesod.Core.Internal.LiteApp+ Yesod.Core.Class.Yesod+ Yesod.Core.Class.Dispatch+ Yesod.Core.Class.Breadcrumbs Paths_yesod_core ghc-options: -Wall @@ -110,7 +113,7 @@ cpp-options: -DTEST build-depends: base ,hspec >= 1.3- ,wai-test+ ,wai-test >= 1.3.0.5 ,wai ,yesod-core ,bytestring@@ -125,6 +128,9 @@ ,QuickCheck >= 2 && < 3 ,transformers , conduit+ , containers+ , lifted-base+ , resourcet ghc-options: -Wall source-repository head