diff --git a/Yesod/Content.hs b/Yesod/Content.hs
deleted file mode 100644
--- a/Yesod/Content.hs
+++ /dev/null
@@ -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
diff --git a/Yesod/Core.hs b/Yesod/Core.hs
--- a/Yesod/Core.hs
+++ b/Yesod/Core.hs
@@ -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
diff --git a/Yesod/Core/Class/Breadcrumbs.hs b/Yesod/Core/Class/Breadcrumbs.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Class/Breadcrumbs.hs
@@ -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
diff --git a/Yesod/Core/Class/Dispatch.hs b/Yesod/Core/Class/Dispatch.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Class/Dispatch.hs
@@ -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
diff --git a/Yesod/Core/Class/Handler.hs b/Yesod/Core/Class/Handler.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Class/Handler.hs
@@ -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
diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Class/Yesod.hs
@@ -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
+
+
+ #{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
diff --git a/Yesod/Core/Content.hs b/Yesod/Core/Content.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Content.hs
@@ -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)
diff --git a/Yesod/Core/Dispatch.hs b/Yesod/Core/Dispatch.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Dispatch.hs
@@ -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
diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Handler.hs
@@ -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
diff --git a/Yesod/Core/Internal.hs b/Yesod/Core/Internal.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal.hs
@@ -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)
diff --git a/Yesod/Core/Internal/LiteApp.hs b/Yesod/Core/Internal/LiteApp.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal/LiteApp.hs
@@ -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 []
diff --git a/Yesod/Core/Internal/Request.hs b/Yesod/Core/Internal/Request.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal/Request.hs
@@ -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"
diff --git a/Yesod/Core/Internal/Response.hs b/Yesod/Core/Internal/Response.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal/Response.hs
@@ -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
diff --git a/Yesod/Core/Internal/Run.hs b/Yesod/Core/Internal/Run.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal/Run.hs
@@ -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
+ }
diff --git a/Yesod/Core/Internal/Session.hs b/Yesod/Core/Internal/Session.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal/Session.hs
@@ -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
diff --git a/Yesod/Core/Internal/TH.hs b/Yesod/Core/Internal/TH.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal/TH.hs
@@ -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)
diff --git a/Yesod/Core/Internal/Util.hs b/Yesod/Core/Internal/Util.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Internal/Util.hs
@@ -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"
diff --git a/Yesod/Core/Json.hs b/Yesod/Core/Json.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Json.hs
@@ -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
diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Types.hs
@@ -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
diff --git a/Yesod/Core/Widget.hs b/Yesod/Core/Widget.hs
new file mode 100644
--- /dev/null
+++ b/Yesod/Core/Widget.hs
@@ -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
diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs
deleted file mode 100644
--- a/Yesod/Dispatch.hs
+++ /dev/null
@@ -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
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
deleted file mode 100644
--- a/Yesod/Handler.hs
+++ /dev/null
@@ -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
diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs
deleted file mode 100644
--- a/Yesod/Internal.hs
+++ /dev/null
@@ -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
diff --git a/Yesod/Internal/Cache.hs b/Yesod/Internal/Cache.hs
deleted file mode 100644
--- a/Yesod/Internal/Cache.hs
+++ /dev/null
@@ -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)
diff --git a/Yesod/Internal/Core.hs b/Yesod/Internal/Core.hs
deleted file mode 100644
--- a/Yesod/Internal/Core.hs
+++ /dev/null
@@ -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." #-}
diff --git a/Yesod/Internal/Request.hs b/Yesod/Internal/Request.hs
deleted file mode 100644
--- a/Yesod/Internal/Request.hs
+++ /dev/null
@@ -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))
diff --git a/Yesod/Internal/Session.hs b/Yesod/Internal/Session.hs
deleted file mode 100644
--- a/Yesod/Internal/Session.hs
+++ /dev/null
@@ -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'
diff --git a/Yesod/Internal/TestApi.hs b/Yesod/Internal/TestApi.hs
deleted file mode 100644
--- a/Yesod/Internal/TestApi.hs
+++ /dev/null
@@ -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')
diff --git a/Yesod/Message.hs b/Yesod/Message.hs
deleted file mode 100644
--- a/Yesod/Message.hs
+++ /dev/null
@@ -1,6 +0,0 @@
--- | This module has moved to "Text.Shakespeare.I18N"
-module Yesod.Message
- ( module Text.Shakespeare.I18N
- ) where
-
-import Text.Shakespeare.I18N
diff --git a/Yesod/Request.hs b/Yesod/Request.hs
deleted file mode 100644
--- a/Yesod/Request.hs
+++ /dev/null
@@ -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
diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs
deleted file mode 100644
--- a/Yesod/Widget.hs
+++ /dev/null
@@ -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
diff --git a/test/YesodCoreTest.hs b/test/YesodCoreTest.hs
--- a/test/YesodCoreTest.hs
+++ b/test/YesodCoreTest.hs
@@ -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
diff --git a/test/YesodCoreTest/Auth.hs b/test/YesodCoreTest/Auth.hs
new file mode 100644
--- /dev/null
+++ b/test/YesodCoreTest/Auth.hs
@@ -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
diff --git a/test/YesodCoreTest/Cache.hs b/test/YesodCoreTest/Cache.hs
--- a/test/YesodCoreTest/Cache.hs
+++ b/test/YesodCoreTest/Cache.hs
@@ -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
diff --git a/test/YesodCoreTest/CleanPath.hs b/test/YesodCoreTest/CleanPath.hs
--- a/test/YesodCoreTest/CleanPath.hs
+++ b/test/YesodCoreTest/CleanPath.hs
@@ -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
diff --git a/test/YesodCoreTest/Exceptions.hs b/test/YesodCoreTest/Exceptions.hs
--- a/test/YesodCoreTest/Exceptions.hs
+++ b/test/YesodCoreTest/Exceptions.hs
@@ -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
diff --git a/test/YesodCoreTest/InternalRequest.hs b/test/YesodCoreTest/InternalRequest.hs
--- a/test/YesodCoreTest/InternalRequest.hs
+++ b/test/YesodCoreTest/InternalRequest.hs
@@ -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
diff --git a/test/YesodCoreTest/JsLoader.hs b/test/YesodCoreTest/JsLoader.hs
--- a/test/YesodCoreTest/JsLoader.hs
+++ b/test/YesodCoreTest/JsLoader.hs
@@ -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>" res
- it "link from head async" $ runner HA $ do
- res <- request defaultRequest
- assertBody "\n" res
-
it "link from bottom" $ runner B $ do
res <- request defaultRequest
assertBody "\n" res
-runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO ()
+runner :: YesodDispatch master => master -> Session () -> IO ()
runner app f = toWaiApp app >>= runSession f
diff --git a/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs b/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs
deleted file mode 100644
--- a/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs
+++ /dev/null
@@ -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"
diff --git a/test/YesodCoreTest/Json.hs b/test/YesodCoreTest/Json.hs
new file mode 100644
--- /dev/null
+++ b/test/YesodCoreTest/Json.hs
@@ -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
diff --git a/test/YesodCoreTest/Links.hs b/test/YesodCoreTest/Links.hs
--- a/test/YesodCoreTest/Links.hs
+++ b/test/YesodCoreTest/Links.hs
@@ -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
diff --git a/test/YesodCoreTest/LiteApp.hs b/test/YesodCoreTest/LiteApp.hs
new file mode 100644
--- /dev/null
+++ b/test/YesodCoreTest/LiteApp.hs
@@ -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
diff --git a/test/YesodCoreTest/Media.hs b/test/YesodCoreTest/Media.hs
--- a/test/YesodCoreTest/Media.hs
+++ b/test/YesodCoreTest/Media.hs
@@ -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
diff --git a/test/YesodCoreTest/MediaData.hs b/test/YesodCoreTest/MediaData.hs
--- a/test/YesodCoreTest/MediaData.hs
+++ b/test/YesodCoreTest/MediaData.hs
@@ -8,5 +8,5 @@
data Y = Y
mkYesodData "Y" [parseRoutes|
/ RootR GET
-/static StaticR GET
+/static StaticR !IGNORED GET !alsoIgnored
|]
diff --git a/test/YesodCoreTest/NoOverloadedStrings.hs b/test/YesodCoreTest/NoOverloadedStrings.hs
--- a/test/YesodCoreTest/NoOverloadedStrings.hs
+++ b/test/YesodCoreTest/NoOverloadedStrings.hs
@@ -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|
+ Used defaultLayoutT
+ 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
diff --git a/test/YesodCoreTest/Redirect.hs b/test/YesodCoreTest/Redirect.hs
--- a/test/YesodCoreTest/Redirect.hs
+++ b/test/YesodCoreTest/Redirect.hs
@@ -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
diff --git a/test/YesodCoreTest/RequestBodySize.hs b/test/YesodCoreTest/RequestBodySize.hs
--- a/test/YesodCoreTest/RequestBodySize.hs
+++ b/test/YesodCoreTest/RequestBodySize.hs
@@ -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
diff --git a/test/YesodCoreTest/Widget.hs b/test/YesodCoreTest/Widget.hs
--- a/test/YesodCoreTest/Widget.hs
+++ b/test/YesodCoreTest/Widget.hs
@@ -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
-Test
-@{WhamletR}
-_{Goodbye}
-_{MsgAnother}
-^{embed}
-|]
+ $newline never
+ Test
+ @{WhamletR}
+ _{Goodbye}
+ _{MsgAnother}
+ ^{embed}
+ |]
where
embed = [whamlet|
-$newline never
-Embed
-|]
+ $newline never
+ Embed
+ |]
getAutoR :: Handler RepHtml
getAutoR = defaultLayout [whamlet|
diff --git a/test/YesodCoreTest/YesodTest.hs b/test/YesodCoreTest/YesodTest.hs
--- a/test/YesodCoreTest/YesodTest.hs
+++ b/test/YesodCoreTest/YesodTest.hs
@@ -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
diff --git a/yesod-core.cabal b/yesod-core.cabal
--- a/yesod-core.cabal
+++ b/yesod-core.cabal
@@ -1,5 +1,5 @@
name: yesod-core
-version: 1.1.8.3
+version: 1.2.0
license: MIT
license-file: LICENSE
author: Michael Snoyman
@@ -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