{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
module Yesod.Core.Class.Yesod where

import           Yesod.Core.Content
import           Yesod.Core.Handler

import           Yesod.Routes.Class

import           Data.ByteString.Builder            (Builder)
import           Data.Text.Encoding                 (encodeUtf8Builder)
import           Control.Arrow                      ((***), second)
import           Control.Exception                  (bracket)
import           Control.Monad                      (forM, when, void)
import           Control.Monad.IO.Class             (MonadIO (liftIO))
import           Control.Monad.Logger               (LogLevel (LevelInfo, LevelOther),
                                                     LogSource, logErrorS)
import           Control.Monad.Trans.Resource       (InternalState, createInternalState, closeInternalState)
import qualified Data.ByteString.Char8              as S8
import qualified Data.ByteString.Lazy               as L
import Data.Aeson (object, (.=))
import           Data.List                          (foldl', nub)
import qualified Data.Map                           as Map
import           Data.Maybe                         (catMaybes)
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           Network.Wai.Parse                  (lbsBackEnd,
                                                     tempFileBackEnd)
import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)
import           System.Log.FastLogger
import           Text.Blaze                         (customAttribute, textTag,
                                                     toValue, (!),
                                                     preEscapedToMarkup)
import qualified Text.Blaze.Html5                   as TBH
import           Text.Hamlet
import           Text.Julius
import qualified Web.ClientSession                  as CS
import           Web.Cookie                         (SetCookie (..), parseCookies, sameSiteLax,
                                                     sameSiteStrict, SameSiteOption, defaultSetCookie)
import           Yesod.Core.Types
import           Yesod.Core.Internal.Session
import           Yesod.Core.Widget
import Data.CaseInsensitive (CI)
import qualified Network.Wai.Request
import Data.IORef

-- | 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: 'guessApproot'. If you know your application root
    -- statically, it will be more efficient and more reliable to instead use
    -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute
    -- URLs, you can use 'ApprootRelative' instead.
    --
    -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.
    approot :: Approot site
    approot = Approot site
forall site. Approot site
guessApproot

    -- | Output error response pages.
    --
    -- Default value: 'defaultErrorHandler'.
    errorHandler :: ErrorResponse -> HandlerFor site TypedContent
    errorHandler = ErrorResponse -> HandlerFor site TypedContent
forall site.
Yesod site =>
ErrorResponse -> HandlerFor site TypedContent
defaultErrorHandler

    -- | Applies some form of layout to the contents of a page.
    defaultLayout :: WidgetFor site () -> HandlerFor site Html
    defaultLayout WidgetFor site ()
w = do
        PageContent (Route site)
p <- WidgetFor site () -> HandlerFor site (PageContent (Route site))
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent WidgetFor site ()
w
        [(Text, Html)]
msgs <- HandlerFor site [(Text, Html)]
forall (m :: * -> *). MonadHandler m => m [(Text, Html)]
getMessages
        ((Route (HandlerSite (HandlerFor site)) -> [(Text, Text)] -> Text)
 -> Html)
-> HandlerFor site Html
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer [hamlet|
            $newline never
            $doctype 5
            <html>
                <head>
                    <title>#{pageTitle p}
                    ^{pageHead p}
                <body>
                    $forall (status, msg) <- msgs
                        <p class="message #{status}">#{msg}
                    ^{pageBody p}
            |]

    -- | Override the rendering function for a particular URL and query string
    -- parameters. One use case for this is to offload static hosting to a
    -- different domain name to avoid sending cookies.
    --
    -- For backward compatibility default implementation is in terms of
    -- 'urlRenderOverride', probably ineffective
    --
    -- Since 1.4.23
    urlParamRenderOverride :: site
                           -> Route site
                           -> [(T.Text, T.Text)] -- ^ query string
                           -> Maybe Builder
    urlParamRenderOverride site
_ Route site
_ [(Text, Text)]
_ = Maybe Builder
forall a. Maybe a
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?
                 -> HandlerFor site AuthResult
    isAuthorized Route site
_ Bool
_ = AuthResult -> HandlerFor site AuthResult
forall (m :: * -> *) a. Monad m => a -> m a
return AuthResult
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 -> HandlerFor site Bool
    isWriteRequest Route site
_ = do
        Request
wai <- HandlerFor site Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
        Bool -> HandlerFor site Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> HandlerFor site Bool) -> Bool -> HandlerFor site Bool
forall a b. (a -> b) -> a -> b
$ Request -> Method
W.requestMethod Request
wai Method -> [Method] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
            [Method
"GET", Method
"HEAD", Method
"OPTIONS", Method
"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 site
_ = Maybe (Route site)
forall a. Maybe a
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 site
_ [Text]
s =
        if [Text]
corrected [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
s
            then [Text] -> Either [Text] [Text]
forall a b. b -> Either a b
Right ([Text] -> Either [Text] [Text]) -> [Text] -> Either [Text] [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
dropDash [Text]
s
            else [Text] -> Either [Text] [Text]
forall a b. a -> Either a b
Left [Text]
corrected
      where
        corrected :: [Text]
corrected = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) [Text]
s
        dropDash :: Text -> Text
dropDash Text
t
            | (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
t = Int -> Text -> Text
T.drop Int
1 Text
t
            | Bool
otherwise = Text
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 site
_ Text
ar [Text]
pieces' [(Text, Text)]
qs' =
        Text -> Builder
encodeUtf8Builder Text
ar Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
`mappend` [Text] -> Query -> Builder
encodePath [Text]
pieces Query
qs
      where
        pieces :: [Text]
pieces = if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
pieces' then [Text
""] else (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
addDash [Text]
pieces'
        qs :: Query
qs = ((Text, Text) -> (Method, Maybe Method)) -> [(Text, Text)] -> Query
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Method
TE.encodeUtf8 (Text -> Method)
-> (Text -> Maybe Method) -> (Text, Text) -> (Method, Maybe Method)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> Maybe Method
go) [(Text, Text)]
qs'
        go :: Text -> Maybe Method
go Text
"" = Maybe Method
forall a. Maybe a
Nothing
        go Text
x = Method -> Maybe Method
forall a. a -> Maybe a
Just (Method -> Maybe Method) -> Method -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Text -> Method
TE.encodeUtf8 Text
x
        addDash :: Text -> Text
addDash Text
t
            | (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') Text
t = Char -> Text -> Text
T.cons Char
'-' Text
t
            | Bool
otherwise = Text
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
                     -> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)])))
    addStaticContent Text
_ Text
_ ByteString
_ = Maybe (Either Text (Route site, [(Text, Text)]))
-> HandlerFor
     site (Maybe (Either Text (Route site, [(Text, Text)])))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either Text (Route site, [(Text, Text)]))
forall a. Maybe a
Nothing

    -- | Maximum allowed length of the request body, in bytes.
    -- This method may be ignored if 'maximumContentLengthIO' is overridden.
    --
    -- If @Nothing@, no maximum is applied.
    --
    -- Default: 2 megabytes.
    maximumContentLength :: site -> Maybe (Route site) -> Maybe Word64
    maximumContentLength site
_ Maybe (Route site)
_ = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1024 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1024 -- 2 megabytes

    -- | Maximum allowed length of the request body, in bytes. This is similar
    -- to 'maximumContentLength', but the result lives in @IO@. This allows
    -- you to dynamically change the maximum file size based on some external
    -- source like a database or an @IORef@.
    --
    -- The default implementation uses 'maximumContentLength'. Future version of yesod will
    -- remove 'maximumContentLength' and use this method exclusively.
    --
    -- @since 1.6.13
    maximumContentLengthIO :: site -> Maybe (Route site) -> IO (Maybe Word64)
    maximumContentLengthIO site
a Maybe (Route site)
b = Maybe Word64 -> IO (Maybe Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Word64 -> IO (Maybe Word64))
-> Maybe Word64 -> IO (Maybe Word64)
forall a b. (a -> b) -> a -> b
$ site -> Maybe (Route site) -> Maybe Word64
forall site.
Yesod site =>
site -> Maybe (Route site) -> Maybe Word64
maximumContentLength site
a Maybe (Route site)
b

    -- | 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: the 'defaultMakeLogger' function.
    makeLogger :: site -> IO Logger
    makeLogger site
_ = IO Logger
defaultMakeLogger

    -- | Send a message to the @Logger@ provided by @getLogger@.
    --
    -- Default: the 'defaultMessageLoggerSource' function, using
    -- 'shouldLogIO' to check whether we should log.
    messageLoggerSource :: site
                        -> Logger
                        -> Loc -- ^ position in source code
                        -> LogSource
                        -> LogLevel
                        -> LogStr -- ^ message
                        -> IO ()
    messageLoggerSource site
site = (Text -> LogLevel -> IO Bool)
-> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
defaultMessageLoggerSource ((Text -> LogLevel -> IO Bool)
 -> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (Text -> LogLevel -> IO Bool)
-> Logger
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
forall a b. (a -> b) -> a -> b
$ site -> Text -> LogLevel -> IO Bool
forall site. Yesod site => site -> Text -> LogLevel -> IO Bool
shouldLogIO site
site

    -- | Where to Load sripts from. We recommend the default value,
    -- 'BottomOfBody'.
    jsLoader :: site -> ScriptLoadPosition site
    jsLoader site
_ = ScriptLoadPosition site
forall master. ScriptLoadPosition master
BottomOfBody

    -- | Default attributes to put on the JavaScript <script> tag
    -- generated for julius files
    jsAttributes :: site -> [(Text, Text)]
    jsAttributes site
_ = []

    -- | Same as @jsAttributes@ but allows you to run arbitrary Handler code
    --
    -- This is useful if you need to add a randomised nonce value to the script
    -- tag generated by @widgetFile@. If this function is overridden then
    -- @jsAttributes@ is ignored.
    --
    -- @since 1.6.16
    jsAttributesHandler :: HandlerFor site [(Text, Text)]
    jsAttributesHandler = site -> [(Text, Text)]
forall site. Yesod site => site -> [(Text, Text)]
jsAttributes (site -> [(Text, Text)])
-> HandlerFor site site -> HandlerFor site [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor site site
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod

    -- | Create a session backend. Returning 'Nothing' disables
    -- sessions. If you'd like to change the way that the session
    -- cookies are created, take a look at
    -- 'customizeSessionCookies'.
    --
    -- Default: Uses clientsession with a 2 hour timeout.
    makeSessionBackend :: site -> IO (Maybe SessionBackend)
    makeSessionBackend site
_ = SessionBackend -> Maybe SessionBackend
forall a. a -> Maybe a
Just (SessionBackend -> Maybe SessionBackend)
-> IO SessionBackend -> IO (Maybe SessionBackend)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> FilePath -> IO SessionBackend
defaultClientSessionBackend Int
120 FilePath
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 site
_ (W.KnownLength Word64
size)
        | Word64
size Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
50000 = BackEnd ByteString -> FileUpload
FileUploadMemory BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m Method -> m ByteString
lbsBackEnd
    fileUpload site
_ RequestBodyLength
_ = (InternalState -> BackEnd FilePath) -> FileUpload
FileUploadDisk InternalState -> BackEnd FilePath
forall ignored1 ignored2.
InternalState -> ignored1 -> ignored2 -> IO Method -> IO FilePath
tempFileBackEnd

    -- | Should we log the given log source/level combination.
    --
    -- Default: the 'defaultShouldLogIO' function.
    --
    -- Since 1.2.4
    shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
    shouldLogIO site
_ = Text -> LogLevel -> IO Bool
defaultShouldLogIO

    -- | 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 :: ToTypedContent res => HandlerFor site res -> HandlerFor site res
    yesodMiddleware = HandlerFor site res -> HandlerFor site res
forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware

    -- | How to allocate an @InternalState@ for each request.
    --
    -- The default implementation is almost always what you want. However, if
    -- you know that you are never taking advantage of the @MonadResource@
    -- instance in your handler functions, setting this to a dummy
    -- implementation can provide a small optimization. Only do this if you
    -- really know what you're doing, otherwise you can turn safe code into a
    -- runtime error!
    --
    -- Since 1.4.2
    yesodWithInternalState :: site -> Maybe (Route site) -> (InternalState -> IO a) -> IO a
    yesodWithInternalState site
_ Maybe (Route site)
_ = IO InternalState
-> (InternalState -> IO ()) -> (InternalState -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO InternalState
forall (m :: * -> *). MonadIO m => m InternalState
createInternalState InternalState -> IO ()
forall (m :: * -> *). MonadIO m => InternalState -> m ()
closeInternalState
    {-# INLINE yesodWithInternalState #-}

    -- | Convert a title and HTML snippet into a 'Widget'. Used
    -- primarily for wrapping up error messages for better display.
    --
    -- @since 1.4.30
    defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()
    defaultMessageWidget Html
title HtmlUrl (Route site)
body = do
        Html -> WidgetFor site ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
title
        HtmlUrl (Route site) -> WidgetFor site ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget
            [hamlet|
                <h1>#{title}
                ^{body}
            |]

-- | Default implementation of 'makeLogger'. Sends to stdout and
-- automatically flushes on each write.
--
-- Since 1.4.10
defaultMakeLogger :: IO Logger
defaultMakeLogger :: IO Logger
defaultMakeLogger = do
    LoggerSet
loggerSet' <- Int -> IO LoggerSet
newStdoutLoggerSet Int
defaultBufSize
    (IO Method
getter, IO ()
_) <- IO (IO Method, IO ())
clockDateCacher
    Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$! LoggerSet -> IO Method -> Logger
Logger LoggerSet
loggerSet' IO Method
getter

-- | Default implementation of 'messageLoggerSource'. Checks if the
-- message should be logged using the provided function, and if so,
-- formats using 'formatLogMessage'. You can use 'defaultShouldLogIO'
-- as the provided function.
--
-- Since 1.4.10
defaultMessageLoggerSource ::
       (LogSource -> LogLevel -> IO Bool) -- ^ Check whether we should
                                          -- log this
    -> Logger
    -> Loc -- ^ position in source code
    -> LogSource
    -> LogLevel
    -> LogStr -- ^ message
    -> IO ()
defaultMessageLoggerSource :: (Text -> LogLevel -> IO Bool)
-> Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
defaultMessageLoggerSource Text -> LogLevel -> IO Bool
ckLoggable Logger
logger Loc
loc Text
source LogLevel
level LogStr
msg = do
    Bool
loggable <- Text -> LogLevel -> IO Bool
ckLoggable Text
source LogLevel
level
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
loggable (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO Method -> Loc -> Text -> LogLevel -> LogStr -> IO LogStr
formatLogMessage (Logger -> IO Method
loggerDate Logger
logger) Loc
loc Text
source LogLevel
level LogStr
msg IO LogStr -> (LogStr -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        Logger -> LogStr -> IO ()
loggerPutStr Logger
logger

-- | Default implementation of 'shouldLog'. Logs everything at or
-- above 'LevelInfo'.
--
-- Since 1.4.10
defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
defaultShouldLogIO :: Text -> LogLevel -> IO Bool
defaultShouldLogIO Text
_ LogLevel
level = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
LevelInfo

-- | Default implementation of 'yesodMiddleware'. Adds the response header
-- \"Vary: Accept, Accept-Language\", \"X-XSS-Protection: 1; mode=block\", and
-- performs authorization checks.
--
-- Since 1.2.0
defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware :: HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware HandlerFor site res
handler = do
    Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Vary" Text
"Accept, Accept-Language"
    Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"X-XSS-Protection" Text
"1; mode=block"
    HandlerFor site ()
forall site. Yesod site => HandlerFor site ()
authorizationCheck
    HandlerFor site res
handler

-- | Defends against session hijacking by setting the secure bit on session
-- cookies so that browsers will not transmit them over http. With this
-- setting on, it follows that the server will regard requests made over
-- http as sessionless, because the session cookie will not be included in
-- the request. Use this as part of a total security measure which also
-- includes disabling HTTP traffic to the site or issuing redirects from
-- HTTP urls, and composing 'sslOnlyMiddleware' with the site's
-- 'yesodMiddleware'.
--
-- Since 1.4.7
sslOnlySessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
sslOnlySessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
sslOnlySessions = ((Maybe SessionBackend -> Maybe SessionBackend)
-> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe SessionBackend -> Maybe SessionBackend)
 -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend))
-> ((SessionBackend -> SessionBackend)
    -> Maybe SessionBackend -> Maybe SessionBackend)
-> (SessionBackend -> SessionBackend)
-> IO (Maybe SessionBackend)
-> IO (Maybe SessionBackend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionBackend -> SessionBackend)
-> Maybe SessionBackend -> Maybe SessionBackend
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) SessionBackend -> SessionBackend
secureSessionCookies
  where
    setSecureBit :: SetCookie -> SetCookie
setSecureBit SetCookie
cookie = SetCookie
cookie { setCookieSecure :: Bool
setCookieSecure = Bool
True }
    secureSessionCookies :: SessionBackend -> SessionBackend
secureSessionCookies = (SetCookie -> SetCookie) -> SessionBackend -> SessionBackend
customizeSessionCookies SetCookie -> SetCookie
setSecureBit

-- | Helps defend against CSRF attacks by setting the SameSite attribute on
-- session cookies to Lax. With the Lax setting, the cookie will be sent with same-site
-- requests, and with cross-site top-level navigations.
--
-- This option is liable to change in future versions of Yesod as the spec evolves.
-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.
--
-- @since 1.4.23
laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
laxSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
laxSameSiteSessions = SameSiteOption
-> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
sameSiteSession SameSiteOption
sameSiteLax

-- | Helps defend against CSRF attacks by setting the SameSite attribute on
-- session cookies to Strict. With the Strict setting, the cookie will only be
-- sent with same-site requests.
--
-- This option is liable to change in future versions of Yesod as the spec evolves.
-- View more information <https://datatracker.ietf.org/doc/draft-west-first-party-cookies/ here>.
--
-- @since 1.4.23
strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
strictSameSiteSessions :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
strictSameSiteSessions = SameSiteOption
-> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
sameSiteSession SameSiteOption
sameSiteStrict

sameSiteSession :: SameSiteOption -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
sameSiteSession :: SameSiteOption
-> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
sameSiteSession SameSiteOption
s = ((Maybe SessionBackend -> Maybe SessionBackend)
-> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe SessionBackend -> Maybe SessionBackend)
 -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend))
-> ((SessionBackend -> SessionBackend)
    -> Maybe SessionBackend -> Maybe SessionBackend)
-> (SessionBackend -> SessionBackend)
-> IO (Maybe SessionBackend)
-> IO (Maybe SessionBackend)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionBackend -> SessionBackend)
-> Maybe SessionBackend -> Maybe SessionBackend
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) SessionBackend -> SessionBackend
secureSessionCookies
  where
    sameSite :: SetCookie -> SetCookie
sameSite SetCookie
cookie = SetCookie
cookie { setCookieSameSite :: Maybe SameSiteOption
setCookieSameSite = SameSiteOption -> Maybe SameSiteOption
forall a. a -> Maybe a
Just SameSiteOption
s }
    secureSessionCookies :: SessionBackend -> SessionBackend
secureSessionCookies = (SetCookie -> SetCookie) -> SessionBackend -> SessionBackend
customizeSessionCookies SetCookie -> SetCookie
sameSite

-- | Apply a Strict-Transport-Security header with the specified timeout to
-- all responses so that browsers will rewrite all http links to https
-- until the timeout expires. For security, the max-age of the STS header
-- should always equal or exceed the client sessions timeout. This defends
-- against SSL-stripping man-in-the-middle attacks. It is only effective if
-- a secure connection has already been made; Strict-Transport-Security
-- headers are ignored over HTTP.
--
-- Since 1.4.7
sslOnlyMiddleware :: Int -- ^ minutes
                  -> HandlerFor site res
                  -> HandlerFor site res
sslOnlyMiddleware :: Int -> HandlerFor site res -> HandlerFor site res
sslOnlyMiddleware Int
timeout HandlerFor site res
handler = do
    Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Strict-Transport-Security"
              (Text -> HandlerFor site ()) -> Text -> HandlerFor site ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ FilePath
"max-age="
                                , Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> Int -> FilePath
forall a b. (a -> b) -> a -> b
$ Int
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60
                                , FilePath
"; includeSubDomains"
                                ]
    HandlerFor site res
handler

-- | Check if a given request is authorized via 'isAuthorized' and
-- 'isWriteRequest'.
--
-- Since 1.2.0
authorizationCheck :: Yesod site => HandlerFor site ()
authorizationCheck :: HandlerFor site ()
authorizationCheck = HandlerFor site (Maybe (Route site))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute HandlerFor site (Maybe (Route site))
-> (Maybe (Route site) -> HandlerFor site ()) -> HandlerFor site ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HandlerFor site ()
-> (Route site -> HandlerFor site ())
-> Maybe (Route site)
-> HandlerFor site ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> HandlerFor site ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Route site -> HandlerFor site ()
forall site. Yesod site => Route site -> HandlerFor site ()
checkUrl
  where
    checkUrl :: Route site -> HandlerFor site ()
checkUrl Route site
url = do
        Bool
isWrite <- Route site -> HandlerFor site Bool
forall site. Yesod site => Route site -> HandlerFor site Bool
isWriteRequest Route site
url
        AuthResult
ar <- Route site -> Bool -> HandlerFor site AuthResult
forall site.
Yesod site =>
Route site -> Bool -> HandlerFor site AuthResult
isAuthorized Route site
url Bool
isWrite
        case AuthResult
ar of
            AuthResult
Authorized -> () -> HandlerFor site ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            AuthResult
AuthenticationRequired -> do
                site
master <- HandlerFor site site
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
                case site -> Maybe (Route site)
forall site. Yesod site => site -> Maybe (Route site)
authRoute site
master of
                    Maybe (Route site)
Nothing -> HandlerFor site Any -> HandlerFor site ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void HandlerFor site Any
forall (m :: * -> *) a. MonadHandler m => m a
notAuthenticated
                    Just Route site
url' ->
                      HandlerFor site TypedContent -> HandlerFor site ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (HandlerFor site TypedContent -> HandlerFor site ())
-> HandlerFor site TypedContent -> HandlerFor site ()
forall a b. (a -> b) -> a -> b
$ Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
                          Method
-> HandlerFor site ()
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, ToContent a) =>
Method -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType Method
typeHtml (HandlerFor site ()
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site ()
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ do
                              HandlerFor site ()
forall (m :: * -> *). MonadHandler m => m ()
setUltDestCurrent
                              HandlerFor site Any -> HandlerFor site ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (HandlerFor site Any -> HandlerFor site ())
-> HandlerFor site Any -> HandlerFor site ()
forall a b. (a -> b) -> a -> b
$ Route site -> HandlerFor site Any
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route site
url'
                          Method
-> HandlerFor site ()
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, ToContent a) =>
Method -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType Method
typeJson (HandlerFor site ()
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site ()
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$
                              HandlerFor site Any -> HandlerFor site ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void HandlerFor site Any
forall (m :: * -> *) a. MonadHandler m => m a
notAuthenticated
            Unauthorized Text
s' -> Text -> HandlerFor site ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
s'

-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
--
-- Since 1.4.14
defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultCsrfCheckMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfCheckMiddleware HandlerFor site res
handler =
    HandlerFor site res
-> HandlerFor site Bool -> CI Method -> Text -> HandlerFor site res
forall site res.
HandlerFor site res
-> HandlerFor site Bool -> CI Method -> Text -> HandlerFor site res
csrfCheckMiddleware
        HandlerFor site res
handler
        (HandlerFor site (Maybe (Route site))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute HandlerFor site (Maybe (Route site))
-> (Maybe (Route site) -> HandlerFor site Bool)
-> HandlerFor site Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HandlerFor site Bool
-> (Route site -> HandlerFor site Bool)
-> Maybe (Route site)
-> HandlerFor site Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> HandlerFor site Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Route site -> HandlerFor site Bool
forall site. Yesod site => Route site -> HandlerFor site Bool
isWriteRequest)
        CI Method
defaultCsrfHeaderName
        Text
defaultCsrfParamName

-- | Looks up the CSRF token from the request headers or POST parameters. If the value doesn't match the token stored in the session,
-- this function throws a 'PermissionDenied' error.
--
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
--
-- Since 1.4.14
csrfCheckMiddleware :: HandlerFor site res
                    -> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.
                    -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from.
                    -> Text -- ^ The POST parameter name to lookup the CSRF token from.
                    -> HandlerFor site res
csrfCheckMiddleware :: HandlerFor site res
-> HandlerFor site Bool -> CI Method -> Text -> HandlerFor site res
csrfCheckMiddleware HandlerFor site res
handler HandlerFor site Bool
shouldCheckFn CI Method
headerName Text
paramName = do
    Bool
shouldCheck <- HandlerFor site Bool
shouldCheckFn
    Bool -> HandlerFor site () -> HandlerFor site ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCheck (CI Method -> Text -> HandlerFor site ()
forall (m :: * -> *).
(MonadHandler m, MonadLogger m) =>
CI Method -> Text -> m ()
checkCsrfHeaderOrParam CI Method
headerName Text
paramName)
    HandlerFor site res
handler

-- | Calls 'csrfSetCookieMiddleware' with the 'defaultCsrfCookieName'.
--
-- The cookie's path is set to @/@, making it valid for your whole website.
--
-- Since 1.4.14
defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware HandlerFor site res
handler = HandlerFor site ()
forall (m :: * -> *). MonadHandler m => m ()
setCsrfCookie HandlerFor site () -> HandlerFor site res -> HandlerFor site res
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HandlerFor site res
handler

-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'.
--
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
--
-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.
--
-- Since 1.4.14
csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res
csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res
csrfSetCookieMiddleware HandlerFor site res
handler SetCookie
cookie = SetCookie -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => SetCookie -> m ()
setCsrfCookieWithCookie SetCookie
cookie HandlerFor site () -> HandlerFor site res -> HandlerFor site res
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HandlerFor site res
handler

-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.
--
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
--
-- You can chain this middleware together with other middleware like so:
--
-- @
-- 'yesodMiddleware' = 'defaultYesodMiddleware' . 'defaultCsrfMiddleware'
-- @
--
-- or:
--
-- @
-- 'yesodMiddleware' app = 'defaultYesodMiddleware' $ 'defaultCsrfMiddleware' $ app
-- @
--
-- Since 1.4.14
defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultCsrfMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfMiddleware = HandlerFor site res -> HandlerFor site res
forall site res. HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware (HandlerFor site res -> HandlerFor site res)
-> (HandlerFor site res -> HandlerFor site res)
-> HandlerFor site res
-> HandlerFor site res
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerFor site res -> HandlerFor site res
forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultCsrfCheckMiddleware

-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: Yesod site
                    => WidgetFor site ()
                    -> HandlerFor site (PageContent (Route site))
widgetToPageContent :: WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent WidgetFor site ()
w = do
 [(Text, Text)]
jsAttrs <- HandlerFor site [(Text, Text)]
forall site. Yesod site => HandlerFor site [(Text, Text)]
jsAttributesHandler
 (HandlerData site site -> IO (PageContent (Route site)))
-> HandlerFor site (PageContent (Route site))
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData site site -> IO (PageContent (Route site)))
 -> HandlerFor site (PageContent (Route site)))
-> (HandlerData site site -> IO (PageContent (Route site)))
-> HandlerFor site (PageContent (Route site))
forall a b. (a -> b) -> a -> b
$ \HandlerData site site
hd -> do
  site
master <- HandlerFor site site -> HandlerData site site -> IO site
forall site a. HandlerFor site a -> HandlerData site site -> IO a
unHandlerFor HandlerFor site site
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod HandlerData site site
hd
  IORef (GWData (Route site))
ref <- GWData (Route site) -> IO (IORef (GWData (Route site)))
forall a. a -> IO (IORef a)
newIORef GWData (Route site)
forall a. Monoid a => a
mempty
  WidgetFor site () -> WidgetData site -> IO ()
forall site a. WidgetFor site a -> WidgetData site -> IO a
unWidgetFor WidgetFor site ()
w WidgetData :: forall site.
IORef (GWData (Route site))
-> HandlerData site site -> WidgetData site
WidgetData
    { wdRef :: IORef (GWData (Route site))
wdRef = IORef (GWData (Route site))
ref
    , wdHandler :: HandlerData site site
wdHandler = HandlerData site site
hd
    }
  GWData (Body HtmlUrl (Route site)
body) (Last Maybe Title
mTitle) UniqueList (Script (Route site))
scripts' UniqueList (Stylesheet (Route site))
stylesheets' Map (Maybe Text) (CssBuilderUrl (Route site))
style Maybe (JavascriptUrl (Route site))
jscript (Head HtmlUrl (Route site)
head') <- IORef (GWData (Route site)) -> IO (GWData (Route site))
forall a. IORef a -> IO a
readIORef IORef (GWData (Route site))
ref
  let title :: Html
title = Html -> (Title -> Html) -> Maybe Title -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Html
forall a. Monoid a => a
mempty Title -> Html
unTitle Maybe Title
mTitle
      scripts :: [Script (Route site)]
scripts = UniqueList (Script (Route site)) -> [Script (Route site)]
forall x. Eq x => UniqueList x -> [x]
runUniqueList UniqueList (Script (Route site))
scripts'
      stylesheets :: [Stylesheet (Route site)]
stylesheets = UniqueList (Stylesheet (Route site)) -> [Stylesheet (Route site)]
forall x. Eq x => UniqueList x -> [x]
runUniqueList UniqueList (Stylesheet (Route site))
stylesheets'

  (HandlerFor site (PageContent (Route site))
 -> HandlerData site site -> IO (PageContent (Route site)))
-> HandlerData site site
-> HandlerFor site (PageContent (Route site))
-> IO (PageContent (Route site))
forall a b c. (a -> b -> c) -> b -> a -> c
flip HandlerFor site (PageContent (Route site))
-> HandlerData site site -> IO (PageContent (Route site))
forall site a. HandlerFor site a -> HandlerData site site -> IO a
unHandlerFor HandlerData site site
hd (HandlerFor site (PageContent (Route site))
 -> IO (PageContent (Route site)))
-> HandlerFor site (PageContent (Route site))
-> IO (PageContent (Route site))
forall a b. (a -> b) -> a -> b
$ do
    Route site -> [(Text, Text)] -> Text
render <- HandlerFor site (Route site -> [(Text, Text)] -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams
    let renderLoc :: Maybe (Either Text (Route site, [(Text, Text)])) -> Maybe Text
renderLoc Maybe (Either Text (Route site, [(Text, Text)]))
x =
            case Maybe (Either Text (Route site, [(Text, Text)]))
x of
                Maybe (Either Text (Route site, [(Text, Text)]))
Nothing -> Maybe Text
forall a. Maybe a
Nothing
                Just (Left Text
s) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
                Just (Right (Route site
u, [(Text, Text)]
p)) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Route site -> [(Text, Text)] -> Text
render Route site
u [(Text, Text)]
p
    [(Maybe Text, Either Html Text)]
css <- [(Maybe Text, CssBuilderUrl (Route site))]
-> ((Maybe Text, CssBuilderUrl (Route site))
    -> HandlerFor site (Maybe Text, Either Html Text))
-> HandlerFor site [(Maybe Text, Either Html Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map (Maybe Text) (CssBuilderUrl (Route site))
-> [(Maybe Text, CssBuilderUrl (Route site))]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Maybe Text) (CssBuilderUrl (Route site))
style) (((Maybe Text, CssBuilderUrl (Route site))
  -> HandlerFor site (Maybe Text, Either Html Text))
 -> HandlerFor site [(Maybe Text, Either Html Text)])
-> ((Maybe Text, CssBuilderUrl (Route site))
    -> HandlerFor site (Maybe Text, Either Html Text))
-> HandlerFor site [(Maybe Text, Either Html Text)]
forall a b. (a -> b) -> a -> b
$ \(Maybe Text
mmedia, CssBuilderUrl (Route site)
content) -> do
        let rendered :: Text
rendered = Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ CssBuilderUrl (Route site)
content Route site -> [(Text, Text)] -> Text
render
        Maybe (Either Text (Route site, [(Text, Text)]))
x <- Text
-> Text
-> ByteString
-> HandlerFor
     site (Maybe (Either Text (Route site, [(Text, Text)])))
forall site.
Yesod site =>
Text
-> Text
-> ByteString
-> HandlerFor
     site (Maybe (Either Text (Route site, [(Text, Text)])))
addStaticContent Text
"css" Text
"text/css; charset=utf-8"
           (ByteString
 -> HandlerFor
      site (Maybe (Either Text (Route site, [(Text, Text)]))))
-> ByteString
-> HandlerFor
     site (Maybe (Either Text (Route site, [(Text, Text)])))
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
rendered
        (Maybe Text, Either Html Text)
-> HandlerFor site (Maybe Text, Either Html Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
mmedia,
            case Maybe (Either Text (Route site, [(Text, Text)]))
x of
                Maybe (Either Text (Route site, [(Text, Text)]))
Nothing -> Html -> Either Html Text
forall a b. a -> Either a b
Left (Html -> Either Html Text) -> Html -> Either Html Text
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup Text
rendered
                Just Either Text (Route site, [(Text, Text)])
y -> Text -> Either Html Text
forall a b. b -> Either a b
Right (Text -> Either Html Text) -> Text -> Either Html Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text)
-> ((Route site, [(Text, Text)]) -> Text)
-> Either Text (Route site, [(Text, Text)])
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id ((Route site -> [(Text, Text)] -> Text)
-> (Route site, [(Text, Text)]) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Route site -> [(Text, Text)] -> Text
render) Either Text (Route site, [(Text, Text)])
y)
    Maybe Text
jsLoc <-
        case Maybe (JavascriptUrl (Route site))
jscript of
            Maybe (JavascriptUrl (Route site))
Nothing -> Maybe Text -> HandlerFor site (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
            Just JavascriptUrl (Route site)
s -> do
                Maybe (Either Text (Route site, [(Text, Text)]))
x <- Text
-> Text
-> ByteString
-> HandlerFor
     site (Maybe (Either Text (Route site, [(Text, Text)])))
forall site.
Yesod site =>
Text
-> Text
-> ByteString
-> HandlerFor
     site (Maybe (Either Text (Route site, [(Text, Text)])))
addStaticContent Text
"js" Text
"text/javascript; charset=utf-8"
                   (ByteString
 -> HandlerFor
      site (Maybe (Either Text (Route site, [(Text, Text)]))))
-> ByteString
-> HandlerFor
     site (Maybe (Either Text (Route site, [(Text, Text)])))
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ (Route site -> [(Text, Text)] -> Text)
-> JavascriptUrl (Route site) -> Text
forall url.
(url -> [(Text, Text)] -> Text) -> JavascriptUrl url -> Text
renderJavascriptUrl Route site -> [(Text, Text)] -> Text
render JavascriptUrl (Route site)
s
                Maybe Text -> HandlerFor site (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> HandlerFor site (Maybe Text))
-> Maybe Text -> HandlerFor site (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Maybe (Either Text (Route site, [(Text, Text)])) -> Maybe Text
renderLoc Maybe (Either Text (Route site, [(Text, Text)]))
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 (Maybe (HtmlUrl (Route site))
mcomplete, [Text]
asyncScripts) = (Route site -> [(Text, Text)] -> Text)
-> [Script (Route site)]
-> Maybe (JavascriptUrl (Route site))
-> Maybe Text
-> (Maybe (HtmlUrl (Route site)), [Text])
forall url x.
(url -> [x] -> Text)
-> [Script url]
-> Maybe (JavascriptUrl url)
-> Maybe Text
-> (Maybe (HtmlUrl url), [Text])
asyncHelper Route site -> [(Text, Text)] -> Text
render [Script (Route site)]
scripts Maybe (JavascriptUrl (Route site))
jscript Maybe Text
jsLoc
        regularScriptLoad :: HtmlUrl (Route site)
regularScriptLoad = [hamlet|
            $newline never
            $forall s <- scripts
                ^{mkScriptTag s}
            $maybe j <- jscript
                $maybe s <- jsLoc
                    <script src="#{s}" *{jsAttrs}>
                $nothing
                    <script>^{jelper j}
        |]

        headAll :: HtmlUrl (Route site)
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 :: HtmlUrl (Route site)
bodyScript = [hamlet|
            $newline never
            ^{body}
            ^{regularScriptLoad}
        |]

    PageContent (Route site)
-> HandlerFor site (PageContent (Route site))
forall (m :: * -> *) a. Monad m => a -> m a
return (PageContent (Route site)
 -> HandlerFor site (PageContent (Route site)))
-> PageContent (Route site)
-> HandlerFor site (PageContent (Route site))
forall a b. (a -> b) -> a -> b
$ Html
-> HtmlUrl (Route site)
-> HtmlUrl (Route site)
-> PageContent (Route site)
forall url. Html -> HtmlUrl url -> HtmlUrl url -> PageContent url
PageContent Html
title HtmlUrl (Route site)
headAll (HtmlUrl (Route site) -> PageContent (Route site))
-> HtmlUrl (Route site) -> PageContent (Route site)
forall a b. (a -> b) -> a -> b
$
        case site -> ScriptLoadPosition site
forall site. Yesod site => site -> ScriptLoadPosition site
jsLoader site
master of
            ScriptLoadPosition site
BottomOfBody -> HtmlUrl (Route site)
bodyScript
            ScriptLoadPosition site
_ -> HtmlUrl (Route site)
body
  where
    renderLoc' :: (t -> [a] -> Text) -> Location t -> Text
renderLoc' t -> [a] -> Text
render' (Local t
url) = t -> [a] -> Text
render' t
url []
    renderLoc' t -> [a] -> Text
_ (Remote Text
s) = Text
s

    addAttr :: h -> (Text, a) -> h
addAttr h
x (Text
y, a
z) = h
x h -> Attribute -> h
forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
customAttribute (Text -> Tag
textTag Text
y) (a -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue a
z)
    mkScriptTag :: Script t -> (t -> [a] -> Text) -> Html
mkScriptTag (Script Location t
loc [(Text, Text)]
attrs) t -> [a] -> Text
render' =
        ((Html -> Html) -> (Text, Text) -> Html -> Html)
-> (Html -> Html) -> [(Text, Text)] -> Html -> Html
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Html -> Html) -> (Text, Text) -> Html -> Html
forall h a. (Attributable h, ToValue a) => h -> (Text, a) -> h
addAttr Html -> Html
TBH.script ((Text
"src", (t -> [a] -> Text) -> Location t -> Text
forall t a. (t -> [a] -> Text) -> Location t -> Text
renderLoc' t -> [a] -> Text
render' Location t
loc) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ () -> Html
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    mkLinkTag :: Stylesheet t -> (t -> [a] -> Text) -> Html
mkLinkTag (Stylesheet Location t
loc [(Text, Text)]
attrs) t -> [a] -> Text
render' =
        (Html -> (Text, Text) -> Html) -> Html -> [(Text, Text)] -> Html
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Html -> (Text, Text) -> Html
forall h a. (Attributable h, ToValue a) => h -> (Text, a) -> h
addAttr Html
TBH.link
            ( (Text
"rel", Text
"stylesheet")
            (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: (Text
"href", (t -> [a] -> Text) -> Location t -> Text
forall t a. (t -> [a] -> Text) -> Location t -> Text
renderLoc' t -> [a] -> Text
render' Location t
loc)
            (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs
            )

    runUniqueList :: Eq x => UniqueList x -> [x]
    runUniqueList :: UniqueList x -> [x]
runUniqueList (UniqueList [x] -> [x]
x) = [x] -> [x]
forall a. Eq a => [a] -> [a]
nub ([x] -> [x]) -> [x] -> [x]
forall a b. (a -> b) -> a -> b
$ [x] -> [x]
x []

-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent
defaultErrorHandler :: ErrorResponse -> HandlerFor site TypedContent
defaultErrorHandler ErrorResponse
NotFound = Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
    HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Html
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor site () -> HandlerFor site Html)
-> WidgetFor site () -> HandlerFor site Html
forall a b. (a -> b) -> a -> b
$ do
        Request
r <- WidgetFor site Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
        let path' :: Text
path' = OnDecodeError -> Method -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ Request -> Method
W.rawPathInfo Request
r
        Html -> HtmlUrl (Route site) -> WidgetFor site ()
forall site.
Yesod site =>
Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget Html
"Not Found" [hamlet|<p>#{path'}|]
    HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Value
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Value -> HandlerFor site Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> HandlerFor site Value) -> Value -> HandlerFor site Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Not Found" :: Text)]
    HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Text
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Text -> HandlerFor site Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"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 ErrorResponse
NotAuthenticated = Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
    HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Html
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor site () -> HandlerFor site Html)
-> WidgetFor site () -> HandlerFor site Html
forall a b. (a -> b) -> a -> b
$ Html -> HtmlUrl (Route site) -> WidgetFor site ()
forall site.
Yesod site =>
Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget
        Html
"Not logged in"
        [hamlet|<p style="display:none;">Set the authRoute and the user will be redirected there.|]

    HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Value
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ 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
        Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"WWW-Authenticate" Text
"RedirectJSON realm=\"application\", param=\"authentication_url\""

        -- The client will just use the authentication_url in the JSON
        site
site <- HandlerFor site site
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        Route site -> Text
rend <- HandlerFor site (Route site -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        let apair :: Route site -> [a]
apair Route site
u = [Text
"authentication_url" Text -> Text -> a
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Route site -> Text
rend Route site
u]
            content :: [Pair]
content = [Pair] -> (Route site -> [Pair]) -> Maybe (Route site) -> [Pair]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Route site -> [Pair]
forall a. KeyValue a => Route site -> [a]
apair (site -> Maybe (Route site)
forall site. Yesod site => site -> Maybe (Route site)
authRoute site
site)
        Value -> HandlerFor site Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> HandlerFor site Value) -> Value -> HandlerFor site Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Not logged in"::Text))Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
:[Pair]
content
    HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Text
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Text -> HandlerFor site Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"Not logged in" :: Text)

defaultErrorHandler (PermissionDenied Text
msg) = Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
    HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Html
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor site () -> HandlerFor site Html)
-> WidgetFor site () -> HandlerFor site Html
forall a b. (a -> b) -> a -> b
$ Html -> HtmlUrl (Route site) -> WidgetFor site ()
forall site.
Yesod site =>
Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget
        Html
"Permission Denied"
        [hamlet|<p>#{msg}|]
    HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Value
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$
        Value -> HandlerFor site Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> HandlerFor site Value) -> Value -> HandlerFor site Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Permission Denied. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg)]
    HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Text
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Text -> HandlerFor site Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> HandlerFor site Text) -> Text -> HandlerFor site Text
forall a b. (a -> b) -> a -> b
$ Text
"Permission Denied. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

defaultErrorHandler (InvalidArgs [Text]
ia) = Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
    HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Html
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor site () -> HandlerFor site Html)
-> WidgetFor site () -> HandlerFor site Html
forall a b. (a -> b) -> a -> b
$ Html -> HtmlUrl (Route site) -> WidgetFor site ()
forall site.
Yesod site =>
Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget
        Html
"Invalid Arguments"
        [hamlet|
            <ul>
                $forall msg <- ia
                    <li>#{msg}
        |]
    HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Value
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Value -> HandlerFor site Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> HandlerFor site Value) -> Value -> HandlerFor site Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Invalid Arguments" :: Text), Text
"errors" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Text]
ia]
    HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Text
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Text -> HandlerFor site Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"Invalid Arguments: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " [Text]
ia)

defaultErrorHandler (InternalError Text
e) = do
    Text -> Text -> HandlerFor site ()
$logErrorS Text
"yesod-core" Text
e
    Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
        HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Html
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor site () -> HandlerFor site Html)
-> WidgetFor site () -> HandlerFor site Html
forall a b. (a -> b) -> a -> b
$ Html -> HtmlUrl (Route site) -> WidgetFor site ()
forall site.
Yesod site =>
Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget
            Html
"Internal Server Error"
            [hamlet|<pre>#{e}|]
        HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Value
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Value -> HandlerFor site Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> HandlerFor site Value) -> Value -> HandlerFor site Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Internal Server Error" :: Text), Text
"error" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
e]
        HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Text
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Text -> HandlerFor site Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> HandlerFor site Text) -> Text -> HandlerFor site Text
forall a b. (a -> b) -> a -> b
$ Text
"Internal Server Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

defaultErrorHandler (BadMethod Method
m) = Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep (HandlerFor site)]) ()
 -> HandlerFor site TypedContent)
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ do
    HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Html
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Html
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor site () -> HandlerFor site Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout (WidgetFor site () -> HandlerFor site Html)
-> WidgetFor site () -> HandlerFor site Html
forall a b. (a -> b) -> a -> b
$ Html -> HtmlUrl (Route site) -> WidgetFor site ()
forall site.
Yesod site =>
Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget
        Html
"Method Not Supported"
        [hamlet|<p>Method <code>#{S8.unpack m}</code> not supported|]
    HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Value
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Value
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Value -> HandlerFor site Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> HandlerFor site Value) -> Value -> HandlerFor site Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Bad method" :: Text), Text
"method" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= OnDecodeError -> Method -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode Method
m]
    HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (HandlerFor site Text
 -> Writer (Endo [ProvidedRep (HandlerFor site)]) ())
-> HandlerFor site Text
-> Writer (Endo [ProvidedRep (HandlerFor site)]) ()
forall a b. (a -> b) -> a -> b
$ Text -> HandlerFor site Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> HandlerFor site Text) -> Text -> HandlerFor site Text
forall a b. (a -> b) -> a -> b
$ Text
"Bad Method " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> OnDecodeError -> Method -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode Method
m

asyncHelper :: (url -> [x] -> Text)
         -> [Script url]
         -> Maybe (JavascriptUrl url)
         -> Maybe Text
         -> (Maybe (HtmlUrl url), [Text])
asyncHelper :: (url -> [x] -> Text)
-> [Script url]
-> Maybe (JavascriptUrl url)
-> Maybe Text
-> (Maybe (HtmlUrl url), [Text])
asyncHelper url -> [x] -> Text
render [Script url]
scripts Maybe (JavascriptUrl url)
jscript Maybe Text
jsLoc =
    (Maybe (HtmlUrl url)
mcomplete, [Text]
scripts'')
  where
    scripts' :: [Text]
scripts' = (Script url -> Text) -> [Script url] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Script url -> Text
goScript [Script url]
scripts
    scripts'' :: [Text]
scripts'' =
        case Maybe Text
jsLoc of
            Just Text
s -> [Text]
scripts' [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
s]
            Maybe Text
Nothing -> [Text]
scripts'
    goScript :: Script url -> Text
goScript (Script (Local url
url) [(Text, Text)]
_) = url -> [x] -> Text
render url
url []
    goScript (Script (Remote Text
s) [(Text, Text)]
_) = Text
s
    mcomplete :: Maybe (HtmlUrl url)
mcomplete =
        case Maybe Text
jsLoc of
            Just{} -> Maybe (HtmlUrl url)
forall a. Maybe a
Nothing
            Maybe Text
Nothing ->
                case Maybe (JavascriptUrl url)
jscript of
                    Maybe (JavascriptUrl url)
Nothing -> Maybe (HtmlUrl url)
forall a. Maybe a
Nothing
                    Just JavascriptUrl url
j -> HtmlUrl url -> Maybe (HtmlUrl url)
forall a. a -> Maybe a
Just (HtmlUrl url -> Maybe (HtmlUrl url))
-> HtmlUrl url -> Maybe (HtmlUrl url)
forall a b. (a -> b) -> a -> b
$ JavascriptUrl url -> HtmlUrl url
forall url. JavascriptUrl url -> HtmlUrl url
jelper JavascriptUrl url
j

-- | Default formatting for log messages. When you use
-- the template haskell logging functions for to log with information
-- about the source location, that information will be appended to
-- the end of the log. When you use the non-TH logging functions,
-- like 'logDebugN', this function does not include source
-- information. This currently works by checking to see if the
-- package name is the string \"\<unknown\>\". This is a hack,
-- but it removes some of the visual clutter from non-TH logs.
--
-- Since 1.4.10
formatLogMessage :: IO ZonedDate
                 -> Loc
                 -> LogSource
                 -> LogLevel
                 -> LogStr -- ^ message
                 -> IO LogStr
formatLogMessage :: IO Method -> Loc -> Text -> LogLevel -> LogStr -> IO LogStr
formatLogMessage IO Method
getdate Loc
loc Text
src LogLevel
level LogStr
msg = do
    Method
now <- IO Method
getdate
    LogStr -> IO LogStr
forall (m :: * -> *) a. Monad m => a -> m a
return (LogStr -> IO LogStr) -> LogStr -> IO LogStr
forall a b. (a -> b) -> a -> b
$ LogStr
forall a. Monoid a => a
mempty
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` Method -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Method
now
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` LogStr
" ["
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` (case LogLevel
level of
            LevelOther Text
t -> Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
t
            LogLevel
_ -> FilePath -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (FilePath -> LogStr) -> FilePath -> LogStr
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
5 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ LogLevel -> FilePath
forall a. Show a => a -> FilePath
show LogLevel
level)
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` (if Text -> Bool
T.null Text
src
            then LogStr
forall a. Monoid a => a
mempty
            else LogStr
"#" LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
src)
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` LogStr
"] "
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` LogStr
msg
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` LogStr
sourceSuffix
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` LogStr
"\n"
    where
    sourceSuffix :: LogStr
sourceSuffix = if Loc -> FilePath
loc_package Loc
loc FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"<unknown>" then LogStr
"" else LogStr
forall a. Monoid a => a
mempty
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` LogStr
" @("
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` FilePath -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Loc -> FilePath
fileLocationToString Loc
loc)
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` LogStr
")"

-- | Customize the cookies used by the session backend.  You may
-- use this function on your definition of 'makeSessionBackend'.
--
-- For example, you could set the cookie domain so that it
-- would work across many subdomains:
--
-- @
-- makeSessionBackend site =
--     (fmap . fmap) (customizeSessionCookies addDomain) ...
--   where
--     addDomain cookie = cookie { 'setCookieDomain' = Just \".example.com\" }
-- @
--
-- Default: Do not customize anything ('id').
customizeSessionCookies :: (SetCookie -> SetCookie) -> (SessionBackend -> SessionBackend)
customizeSessionCookies :: (SetCookie -> SetCookie) -> SessionBackend -> SessionBackend
customizeSessionCookies SetCookie -> SetCookie
customizeCookie SessionBackend
backend = SessionBackend
backend'
  where
    customizeHeader :: Header -> Header
customizeHeader (AddCookie SetCookie
cookie) = SetCookie -> Header
AddCookie (SetCookie -> SetCookie
customizeCookie SetCookie
cookie)
    customizeHeader Header
other              = Header
other
    customizeSaveSession :: (SessionMap -> IO [Header]) -> SessionMap -> IO [Header]
customizeSaveSession = ((IO [Header] -> IO [Header])
-> (SessionMap -> IO [Header]) -> SessionMap -> IO [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IO [Header] -> IO [Header])
 -> (SessionMap -> IO [Header]) -> SessionMap -> IO [Header])
-> ((Header -> Header) -> IO [Header] -> IO [Header])
-> (Header -> Header)
-> (SessionMap -> IO [Header])
-> SessionMap
-> IO [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Header] -> [Header]) -> IO [Header] -> IO [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Header] -> [Header]) -> IO [Header] -> IO [Header])
-> ((Header -> Header) -> [Header] -> [Header])
-> (Header -> Header)
-> IO [Header]
-> IO [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Header) -> [Header] -> [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Header -> Header
customizeHeader
    backend' :: SessionBackend
backend' =
      SessionBackend
backend {
        sbLoadSession :: Request -> IO (SessionMap, SessionMap -> IO [Header])
sbLoadSession = \Request
req ->
          ((SessionMap -> IO [Header]) -> SessionMap -> IO [Header])
-> (SessionMap, SessionMap -> IO [Header])
-> (SessionMap, SessionMap -> IO [Header])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SessionMap -> IO [Header]) -> SessionMap -> IO [Header]
customizeSaveSession ((SessionMap, SessionMap -> IO [Header])
 -> (SessionMap, SessionMap -> IO [Header]))
-> IO (SessionMap, SessionMap -> IO [Header])
-> IO (SessionMap, SessionMap -> IO [Header])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SessionBackend
-> Request -> IO (SessionMap, SessionMap -> IO [Header])
sbLoadSession SessionBackend
backend Request
req
      }


defaultClientSessionBackend :: Int -- ^ minutes
                            -> FilePath -- ^ key file
                            -> IO SessionBackend
defaultClientSessionBackend :: Int -> FilePath -> IO SessionBackend
defaultClientSessionBackend Int
minutes FilePath
fp = do
  Key
key <- FilePath -> IO Key
CS.getKey FilePath
fp
  (IO ClientSessionDateCache
getCachedDate, IO ()
_closeDateCacher) <- NominalDiffTime -> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
minToSec Int
minutes)
  SessionBackend -> IO SessionBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionBackend -> IO SessionBackend)
-> SessionBackend -> IO SessionBackend
forall a b. (a -> b) -> a -> b
$ Key -> IO ClientSessionDateCache -> SessionBackend
clientSessionBackend Key
key IO ClientSessionDateCache
getCachedDate

-- | Create a @SessionBackend@ which reads the session key from the named
-- environment variable.
--
-- This can be useful if:
--
-- 1. You can't rely on a persistent file system (e.g. Heroku)
-- 2. Your application is open source (e.g. you can't commit the key)
--
-- By keeping a consistent value in the environment variable, your users will
-- have consistent sessions without relying on the file system.
--
-- Note: A suitable value should only be obtained in one of two ways:
--
-- 1. Run this code without the variable set, a value will be generated and
--    printed on @/dev/stdout/@
-- 2. Use @clientsession-generate@
--
-- Since 1.4.5
envClientSessionBackend :: Int -- ^ minutes
                        -> String -- ^ environment variable name
                        -> IO SessionBackend
envClientSessionBackend :: Int -> FilePath -> IO SessionBackend
envClientSessionBackend Int
minutes FilePath
name = do
    Key
key <- FilePath -> IO Key
CS.getKeyEnv FilePath
name
    (IO ClientSessionDateCache
getCachedDate, IO ()
_closeDateCacher) <- NominalDiffTime -> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher (NominalDiffTime -> IO (IO ClientSessionDateCache, IO ()))
-> NominalDiffTime -> IO (IO ClientSessionDateCache, IO ())
forall a b. (a -> b) -> a -> b
$ Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
minToSec Int
minutes
    SessionBackend -> IO SessionBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionBackend -> IO SessionBackend)
-> SessionBackend -> IO SessionBackend
forall a b. (a -> b) -> a -> b
$ Key -> IO ClientSessionDateCache -> SessionBackend
clientSessionBackend Key
key IO ClientSessionDateCache
getCachedDate

minToSec :: (Integral a, Num b) => a -> b
minToSec :: a -> b
minToSec a
minutes = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
minutes a -> a -> a
forall a. Num a => a -> a -> a
* a
60)

jsToHtml :: Javascript -> Html
jsToHtml :: Javascript -> Html
jsToHtml (Javascript Builder
b) = Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText Builder
b

jelper :: JavascriptUrl url -> HtmlUrl url
jelper :: JavascriptUrl url -> HtmlUrl url
jelper = (Javascript -> Html) -> JavascriptUrl url -> HtmlUrl url
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Javascript -> Html
jsToHtml

left :: Either a b -> Maybe a
left :: Either a b -> Maybe a
left (Left a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
left Either a b
_ = Maybe a
forall a. Maybe a
Nothing

right :: Either a b -> Maybe b
right :: Either a b -> Maybe b
right (Right b
x) = b -> Maybe b
forall a. a -> Maybe a
Just b
x
right Either a b
_ = Maybe b
forall a. Maybe a
Nothing

clientSessionBackend :: CS.Key  -- ^ The encryption key
                     -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
                     -> SessionBackend
clientSessionBackend :: Key -> IO ClientSessionDateCache -> SessionBackend
clientSessionBackend Key
key IO ClientSessionDateCache
getCachedDate =
  SessionBackend :: (Request -> IO (SessionMap, SessionMap -> IO [Header]))
-> SessionBackend
SessionBackend {
    sbLoadSession :: Request -> IO (SessionMap, SessionMap -> IO [Header])
sbLoadSession = Key
-> IO ClientSessionDateCache
-> Method
-> Request
-> IO (SessionMap, SessionMap -> IO [Header])
loadClientSession Key
key IO ClientSessionDateCache
getCachedDate Method
"_SESSION"
  }

justSingleton :: a -> [Maybe a] -> a
justSingleton :: a -> [Maybe a] -> a
justSingleton a
d = [a] -> a
just ([a] -> a) -> ([Maybe a] -> [a]) -> [Maybe a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes
  where
    just :: [a] -> a
just [a
s] = a
s
    just [a]
_   = a
d

loadClientSession :: CS.Key
                  -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher'
                  -> S8.ByteString -- ^ session name
                  -> W.Request
                  -> IO (SessionMap, SaveSession)
loadClientSession :: Key
-> IO ClientSessionDateCache
-> Method
-> Request
-> IO (SessionMap, SessionMap -> IO [Header])
loadClientSession Key
key IO ClientSessionDateCache
getCachedDate Method
sessionName Request
req = IO (SessionMap, SessionMap -> IO [Header])
load
  where
    load :: IO (SessionMap, SessionMap -> IO [Header])
load = do
      ClientSessionDateCache
date <- IO ClientSessionDateCache
getCachedDate
      (SessionMap, SessionMap -> IO [Header])
-> IO (SessionMap, SessionMap -> IO [Header])
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientSessionDateCache -> SessionMap
sess ClientSessionDateCache
date, ClientSessionDateCache -> SessionMap -> IO [Header]
forall (m :: * -> *).
MonadIO m =>
ClientSessionDateCache -> SessionMap -> m [Header]
save ClientSessionDateCache
date)
    sess :: ClientSessionDateCache -> SessionMap
sess ClientSessionDateCache
date = SessionMap -> [Maybe SessionMap] -> SessionMap
forall a. a -> [Maybe a] -> a
justSingleton SessionMap
forall k a. Map k a
Map.empty ([Maybe SessionMap] -> SessionMap)
-> [Maybe SessionMap] -> SessionMap
forall a b. (a -> b) -> a -> b
$ do
      Method
raw <- [Method
v | (CI Method
k, Method
v) <- Request -> RequestHeaders
W.requestHeaders Request
req, CI Method
k CI Method -> CI Method -> Bool
forall a. Eq a => a -> a -> Bool
== CI Method
"Cookie"]
      Method
val <- [Method
v | (Method
k, Method
v) <- Method -> Cookies
parseCookies Method
raw, Method
k Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
sessionName]
      let host :: Method
host = Method
"" -- fixme, properly lock sessions to client address
      Maybe SessionMap -> [Maybe SessionMap]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SessionMap -> [Maybe SessionMap])
-> Maybe SessionMap -> [Maybe SessionMap]
forall a b. (a -> b) -> a -> b
$ Key
-> ClientSessionDateCache -> Method -> Method -> Maybe SessionMap
decodeClientSession Key
key ClientSessionDateCache
date Method
host Method
val
    save :: ClientSessionDateCache -> SessionMap -> m [Header]
save ClientSessionDateCache
date SessionMap
sess' = do
      -- We should never cache the IV!  Be careful!
      IV
iv <- IO IV -> m IV
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO IV
CS.randomIV
      [Header] -> m [Header]
forall (m :: * -> *) a. Monad m => a -> m a
return [SetCookie -> Header
AddCookie SetCookie
defaultSetCookie
          { setCookieName :: Method
setCookieName = Method
sessionName
          , setCookieValue :: Method
setCookieValue = Key
-> IV -> ClientSessionDateCache -> Method -> SessionMap -> Method
encodeClientSession Key
key IV
iv ClientSessionDateCache
date Method
host SessionMap
sess'
          , setCookiePath :: Maybe Method
setCookiePath = Method -> Maybe Method
forall a. a -> Maybe a
Just Method
"/"
          , setCookieExpires :: Maybe UTCTime
setCookieExpires = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (ClientSessionDateCache -> UTCTime
csdcExpires ClientSessionDateCache
date)
          , setCookieDomain :: Maybe Method
setCookieDomain = Maybe Method
forall a. Maybe a
Nothing
          , setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True
          }]
        where
          host :: Method
host = Method
"" -- 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 -> FilePath
fileLocationToString Loc
loc =
    [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ Loc -> FilePath
loc_package Loc
loc
      , Char
':' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Loc -> FilePath
loc_module Loc
loc
      , Char
' ' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Loc -> FilePath
loc_filename Loc
loc
      , Char
':' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Loc -> FilePath
line Loc
loc
      , Char
':' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: Loc -> FilePath
char Loc
loc
      ]
  where
    line :: Loc -> FilePath
line = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (Loc -> Int) -> Loc -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start
    char :: Loc -> FilePath
char = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (Loc -> Int) -> Loc -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start

-- | Guess the approot based on request headers. For more information, see
-- "Network.Wai.Middleware.Approot"
--
-- In the case of headers being unavailable, it falls back to 'ApprootRelative'
--
-- Since 1.4.16
guessApproot :: Approot site
guessApproot :: Approot site
guessApproot = Approot site -> Approot site
forall site. Approot site -> Approot site
guessApprootOr Approot site
forall site. Approot site
ApprootRelative

-- | Guess the approot based on request headers, with fall back to the
-- specified 'AppRoot'.
--
-- Since 1.4.16
guessApprootOr :: Approot site -> Approot site
guessApprootOr :: Approot site -> Approot site
guessApprootOr Approot site
fallback = (site -> Request -> Text) -> Approot site
forall master. (master -> Request -> Text) -> Approot master
ApprootRequest ((site -> Request -> Text) -> Approot site)
-> (site -> Request -> Text) -> Approot site
forall a b. (a -> b) -> a -> b
$ \site
master Request
req ->
    case Request -> Maybe Method
W.requestHeaderHost Request
req of
        Maybe Method
Nothing -> Approot site -> site -> Request -> Text
forall site. Approot site -> site -> Request -> Text
getApprootText Approot site
fallback site
master Request
req
        Just Method
host ->
            (if Request -> Bool
Network.Wai.Request.appearsSecure Request
req
                then Text
"https://"
                else Text
"http://")
            Text -> Text -> Text
`T.append` OnDecodeError -> Method -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode Method
host

-- | Get the textual application root from an 'Approot' value.
--
-- Since 1.4.17
getApprootText :: Approot site -> site -> W.Request -> Text
getApprootText :: Approot site -> site -> Request -> Text
getApprootText Approot site
ar site
site Request
req =
    case Approot site
ar of
        Approot site
ApprootRelative -> Text
""
        ApprootStatic Text
t -> Text
t
        ApprootMaster site -> Text
f -> site -> Text
f site
site
        ApprootRequest site -> Request -> Text
f -> site -> Request -> Text
f site
site Request
req