{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE ScopedTypeVariables #-}

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.Handler.Warp as Warp
import qualified Network.Wai.Request
import Data.IORef
import UnliftIO (SomeException, catch, MonadUnliftIO)

-- | 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 = forall site. Approot site
guessApproot

    -- | @since 1.6.24.0
    --  allows the user to specify how exceptions are cought.
    --  by default all async exceptions are thrown and synchronous
    --  exceptions render a 500 page.
    -- To catch all exceptions (even async) to render a 500 page, 
    -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware
    -- this may have negative effects with functions like 'timeout'.
    catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a
    catchHandlerExceptions site
_ = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch

    -- | Output error response pages.
    --
    -- Default value: 'defaultErrorHandler'.
    errorHandler :: ErrorResponse -> HandlerFor site TypedContent
    errorHandler = 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 <- forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent WidgetFor site ()
w
        [(Text, Html)]
msgs <- forall (m :: * -> *). MonadHandler m => m [(Text, Html)]
getMessages
        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}
                    $maybe description <- pageDescription p
                      <meta name="description" content="#{description}">
                    ^{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)]
_ = 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
_ = 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 <- forall (m :: * -> *). MonadHandler m => m Request
waiRequest
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request -> ByteString
W.requestMethod Request
wai forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
            [ByteString
"GET", ByteString
"HEAD", ByteString
"OPTIONS", ByteString
"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
_ = 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 forall a. Eq a => a -> a -> Bool
== [Text]
s
            then forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
dropDash [Text]
s
            else forall a b. a -> Either a b
Left [Text]
corrected
      where
        corrected :: [Text]
corrected = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not 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 (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 forall a. Monoid a => a -> a -> a
`mappend` [Text] -> Query -> Builder
encodePath [Text]
pieces Query
qs
      where
        pieces :: [Text]
pieces = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
pieces' then [Text
""] else forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
addDash [Text]
pieces'
        qs :: Query
qs = forall a b. (a -> b) -> [a] -> [b]
map (Text -> ByteString
TE.encodeUtf8 forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Text -> Maybe ByteString
go) [(Text, Text)]
qs'
        go :: Text -> Maybe ByteString
go Text
"" = forall a. Maybe a
Nothing
        go Text
x = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
x
        addDash :: Text -> Text
addDash Text
t
            | (Char -> Bool) -> Text -> Bool
T.all (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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return 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)
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word64
2 forall a. Num a => a -> a -> a
* Word64
1024 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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
_ = 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 = forall site. Yesod site => site -> [(Text, Text)]
jsAttributes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
_ = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Char] -> IO SessionBackend
defaultClientSessionBackend Int
120 [Char]
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 forall a. Ord a => a -> a -> Bool
<= Word64
50000 = BackEnd ByteString -> FileUpload
FileUploadMemory forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd
    fileUpload site
_ RequestBodyLength
_ = (InternalState -> BackEnd [Char]) -> FileUpload
FileUploadDisk forall ignored1 ignored2.
InternalState -> ignored1 -> ignored2 -> IO ByteString -> IO [Char]
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 = 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)
_ = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket forall (m :: * -> *). MonadIO m => m InternalState
createInternalState 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
        forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
title
        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 ByteString
getter, IO ()
_) <- IO (IO ByteString, IO ())
clockDateCacher
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! LoggerSet -> IO ByteString -> Logger
Logger LoggerSet
loggerSet' IO ByteString
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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
loggable forall a b. (a -> b) -> a -> b
$
        IO ByteString -> Loc -> Text -> LogLevel -> LogStr -> IO LogStr
formatLogMessage (Logger -> IO ByteString
loggerDate Logger
logger) Loc
loc Text
source LogLevel
level LogStr
msg 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ LogLevel
level 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 :: forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware HandlerFor site res
handler = do
    forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Vary" Text
"Accept, Accept-Language"
    forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"X-XSS-Protection" Text
"1; mode=block"
    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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 :: forall site res. Int -> HandlerFor site res -> HandlerFor site res
sslOnlyMiddleware Int
timeout HandlerFor site res
handler = do
    forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Strict-Transport-Security"
              forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
"max-age="
                                , forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ Int
timeout forall a. Num a => a -> a -> a
* Int
60
                                , [Char]
"; 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 :: forall site. Yesod site => HandlerFor site ()
authorizationCheck = forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall {site}. Yesod site => Route site -> HandlerFor site ()
checkUrl
  where
    checkUrl :: Route site -> HandlerFor site ()
checkUrl Route site
url = do
        Bool
isWrite <- forall site. Yesod site => Route site -> HandlerFor site Bool
isWriteRequest Route site
url
        AuthResult
ar <- forall site.
Yesod site =>
Route site -> Bool -> HandlerFor site AuthResult
isAuthorized Route site
url Bool
isWrite
        case AuthResult
ar of
            AuthResult
Authorized -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            AuthResult
AuthenticationRequired -> do
                site
master <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
                case forall site. Yesod site => site -> Maybe (Route site)
authRoute site
master of
                    Maybe (Route site)
Nothing -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (m :: * -> *) a. MonadHandler m => m a
notAuthenticated
                    Just Route site
url' ->
                      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
                          forall (m :: * -> *) a.
(Monad m, ToContent a) =>
ByteString -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType ByteString
typeHtml forall a b. (a -> b) -> a -> b
$ do
                              forall (m :: * -> *). MonadHandler m => m ()
setUltDestCurrent
                              forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route site
url'
                          forall (m :: * -> *) a.
(Monad m, ToContent a) =>
ByteString -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType ByteString
typeJson forall a b. (a -> b) -> a -> b
$
                              forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (m :: * -> *) a. MonadHandler m => m a
notAuthenticated
            Unauthorized Text
s' -> 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 :: forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultCsrfCheckMiddleware HandlerFor site res
handler =
    forall site res.
HandlerFor site res
-> HandlerFor site Bool
-> CI ByteString
-> Text
-> HandlerFor site res
csrfCheckMiddleware
        HandlerFor site res
handler
        (forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) forall site. Yesod site => Route site -> HandlerFor site Bool
isWriteRequest)
        CI ByteString
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 :: forall site res.
HandlerFor site res
-> HandlerFor site Bool
-> CI ByteString
-> Text
-> HandlerFor site res
csrfCheckMiddleware HandlerFor site res
handler HandlerFor site Bool
shouldCheckFn CI ByteString
headerName Text
paramName = do
    Bool
shouldCheck <- HandlerFor site Bool
shouldCheckFn
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldCheck (forall (m :: * -> *).
(MonadHandler m, MonadLogger m) =>
CI ByteString -> Text -> m ()
checkCsrfHeaderOrParam CI ByteString
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 :: forall site res. HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware HandlerFor site res
handler = forall (m :: * -> *). MonadHandler m => m ()
setCsrfCookie 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 :: forall site res.
HandlerFor site res -> SetCookie -> HandlerFor site res
csrfSetCookieMiddleware HandlerFor site res
handler SetCookie
cookie = forall (m :: * -> *). MonadHandler m => SetCookie -> m ()
setCsrfCookieWithCookie SetCookie
cookie 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 :: forall site res.
Yesod site =>
HandlerFor site res -> HandlerFor site res
defaultCsrfMiddleware = forall site res. HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site (PageContent (Route site))
widgetToPageContent WidgetFor site ()
w = do
 [(Text, Text)]
jsAttrs <- forall site. Yesod site => HandlerFor site [(Text, Text)]
jsAttributesHandler
 forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor forall a b. (a -> b) -> a -> b
$ \HandlerData site site
hd -> do
  site
master <- forall site a. HandlerFor site a -> HandlerData site site -> IO a
unHandlerFor forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod HandlerData site site
hd
  IORef (GWData (Route site))
ref <- forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
  forall site a. WidgetFor site a -> WidgetData site -> IO a
unWidgetFor WidgetFor site ()
w 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) (Last Maybe Description
mDescription) 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') <- forall a. IORef a -> IO a
readIORef IORef (GWData (Route site))
ref
  let title :: Html
title = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Title -> Html
unTitle Maybe Title
mTitle
      description :: Maybe Text
description = Description -> Text
unDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Description
mDescription
      scripts :: [Script (Route site)]
scripts = forall x. Eq x => UniqueList x -> [x]
runUniqueList UniqueList (Script (Route site))
scripts'
      stylesheets :: [Stylesheet (Route site)]
stylesheets = forall x. Eq x => UniqueList x -> [x]
runUniqueList UniqueList (Stylesheet (Route site))
stylesheets'

  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall site a. HandlerFor site a -> HandlerData site site -> IO a
unHandlerFor HandlerData site site
hd forall a b. (a -> b) -> a -> b
$ do
    Route site -> [(Text, Text)] -> Text
render <- 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 -> forall a. Maybe a
Nothing
                Just (Left Text
s) -> forall a. a -> Maybe a
Just Text
s
                Just (Right (Route site
u, [(Text, Text)]
p)) -> forall a. a -> Maybe a
Just 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map (Maybe Text) (CssBuilderUrl (Route site))
style) forall a b. (a -> b) -> a -> b
$ \(Maybe Text
mmedia, CssBuilderUrl (Route site)
content) -> do
        let rendered :: Text
rendered = Builder -> Text
toLazyText 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 <- 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"
           forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
rendered
        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 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. ToMarkup a => a -> Html
preEscapedToMarkup Text
rendered
                Just Either Text (Route site, [(Text, Text)])
y -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just JavascriptUrl (Route site)
s -> do
                Maybe (Either Text (Route site, [(Text, Text)]))
x <- 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"
                   forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall url.
(url -> [(Text, Text)] -> Text) -> JavascriptUrl url -> Text
renderJavascriptUrl Route site -> [(Text, Text)] -> Text
render JavascriptUrl (Route site)
s
                forall (m :: * -> *) a. Monad m => a -> m a
return 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) = 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}
        |]

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall url.
Html -> Maybe Text -> HtmlUrl url -> HtmlUrl url -> PageContent url
PageContent Html
title Maybe Text
description HtmlUrl (Route site)
headAll forall a b. (a -> b) -> a -> b
$
        case 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 forall h. Attributable h => h -> Attribute -> h
! Tag -> AttributeValue -> Attribute
customAttribute (Text -> Tag
textTag Text
y) (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' =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {h} {a}. (Attributable h, ToValue a) => h -> (Text, a) -> h
addAttr Html -> Html
TBH.script ((Text
"src", forall {t} {a}. (t -> [a] -> Text) -> Location t -> Text
renderLoc' t -> [a] -> Text
render' Location t
loc) forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs) forall a b. (a -> b) -> a -> b
$ 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' =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {h} {a}. (Attributable h, ToValue a) => h -> (Text, a) -> h
addAttr Html
TBH.link
            ( (Text
"rel", Text
"stylesheet")
            forall a. a -> [a] -> [a]
: (Text
"href", forall {t} {a}. (t -> [a] -> Text) -> Location t -> Text
renderLoc' t -> [a] -> Text
render' Location t
loc)
            forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs
            )

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

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

    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep 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
        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 <- forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        Route site -> Text
rend <- forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        let apair :: Route site -> [a]
apair Route site
u = [Key
"authentication_url" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Route site -> Text
rend Route site
u]
            content :: [Pair]
content = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall {a}. KeyValue a => Route site -> [a]
apair (forall site. Yesod site => site -> Maybe (Route site)
authRoute site
site)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ (Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"Not logged in"::Text))forall a. a -> [a] -> [a]
:[Pair]
content
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"Not logged in" :: Text)

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

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

defaultErrorHandler (BadMethod ByteString
m) = forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout forall a b. (a -> b) -> a -> b
$ 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|]
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"Bad method" :: Text), Key
"method" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
m]
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
"Bad Method " forall a. Semigroup a => a -> a -> a
<> OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
m

asyncHelper :: (url -> [x] -> Text)
         -> [Script url]
         -> Maybe (JavascriptUrl url)
         -> Maybe Text
         -> (Maybe (HtmlUrl url), [Text])
asyncHelper :: forall url x.
(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' = 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' 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{} -> forall a. Maybe a
Nothing
            Maybe Text
Nothing ->
                case Maybe (JavascriptUrl url)
jscript of
                    Maybe (JavascriptUrl url)
Nothing -> forall a. Maybe a
Nothing
                    Just JavascriptUrl url
j -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 ByteString -> Loc -> Text -> LogLevel -> LogStr -> IO LogStr
formatLogMessage IO ByteString
getdate Loc
loc Text
src LogLevel
level LogStr
msg = do
    ByteString
now <- IO ByteString
getdate
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a
mempty
        forall a. Monoid a => a -> a -> a
`mappend` forall msg. ToLogStr msg => msg -> LogStr
toLogStr ByteString
now
        forall a. Monoid a => a -> a -> a
`mappend` LogStr
" ["
        forall a. Monoid a => a -> a -> a
`mappend` (case LogLevel
level of
            LevelOther Text
t -> forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
t
            LogLevel
_ -> forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
5 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show LogLevel
level)
        forall a. Monoid a => a -> a -> a
`mappend` (if Text -> Bool
T.null Text
src
            then forall a. Monoid a => a
mempty
            else LogStr
"#" forall a. Monoid a => a -> a -> a
`mappend` forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
src)
        forall a. Monoid a => a -> a -> a
`mappend` LogStr
"] "
        forall a. Monoid a => a -> a -> a
`mappend` LogStr
msg
        forall a. Monoid a => a -> a -> a
`mappend` LogStr
sourceSuffix
        forall a. Monoid a => a -> a -> a
`mappend` LogStr
"\n"
    where
    sourceSuffix :: LogStr
sourceSuffix = if Loc -> [Char]
loc_package Loc
loc forall a. Eq a => a -> a -> Bool
== [Char]
"<unknown>" then LogStr
"" else forall a. Monoid a => a
mempty
        forall a. Monoid a => a -> a -> a
`mappend` LogStr
" @("
        forall a. Monoid a => a -> a -> a
`mappend` forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Loc -> [Char]
fileLocationToString Loc
loc)
        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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 ->
          forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SessionMap -> IO [Header]) -> SessionMap -> IO [Header]
customizeSaveSession 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 -> [Char] -> IO SessionBackend
defaultClientSessionBackend Int
minutes [Char]
fp = do
  Key
key <- [Char] -> IO Key
CS.getKey [Char]
fp
  (IO ClientSessionDateCache
getCachedDate, IO ()
_closeDateCacher) <- NominalDiffTime -> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher (forall a b. (Integral a, Num b) => a -> b
minToSec Int
minutes)
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> [Char] -> IO SessionBackend
envClientSessionBackend Int
minutes [Char]
name = do
    Key
key <- [Char] -> IO Key
CS.getKeyEnv [Char]
name
    (IO ClientSessionDateCache
getCachedDate, IO ()
_closeDateCacher) <- NominalDiffTime -> IO (IO ClientSessionDateCache, IO ())
clientSessionDateCacher forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
minToSec Int
minutes
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall a b. (Integral a, Num b) => a -> b
minToSec a
minutes = forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
minutes forall a. Num a => a -> a -> a
* a
60)

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

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

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

right :: Either a b -> Maybe b
right :: forall a b. Either a b -> Maybe b
right (Right b
x) = forall a. a -> Maybe a
Just b
x
right Either a 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 {
    sbLoadSession :: Request -> IO (SessionMap, SessionMap -> IO [Header])
sbLoadSession = Key
-> IO ClientSessionDateCache
-> ByteString
-> Request
-> IO (SessionMap, SessionMap -> IO [Header])
loadClientSession Key
key IO ClientSessionDateCache
getCachedDate ByteString
"_SESSION"
  }

justSingleton :: a -> [Maybe a] -> a
justSingleton :: forall a. a -> [Maybe a] -> a
justSingleton a
d = [a] -> a
just forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
-> ByteString
-> Request
-> IO (SessionMap, SessionMap -> IO [Header])
loadClientSession Key
key IO ClientSessionDateCache
getCachedDate ByteString
sessionName Request
req = IO (SessionMap, SessionMap -> IO [Header])
load
  where
    load :: IO (SessionMap, SessionMap -> IO [Header])
load = do
      ClientSessionDateCache
date <- IO ClientSessionDateCache
getCachedDate
      forall (m :: * -> *) a. Monad m => a -> m a
return (ClientSessionDateCache -> SessionMap
sess ClientSessionDateCache
date, forall {m :: * -> *}.
MonadIO m =>
ClientSessionDateCache -> SessionMap -> m [Header]
save ClientSessionDateCache
date)
    sess :: ClientSessionDateCache -> SessionMap
sess ClientSessionDateCache
date = forall a. a -> [Maybe a] -> a
justSingleton forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ do
      ByteString
raw <- [ByteString
v | (CI ByteString
k, ByteString
v) <- Request -> RequestHeaders
W.requestHeaders Request
req, CI ByteString
k forall a. Eq a => a -> a -> Bool
== CI ByteString
"Cookie"]
      ByteString
val <- [ByteString
v | (ByteString
k, ByteString
v) <- ByteString -> Cookies
parseCookies ByteString
raw, ByteString
k forall a. Eq a => a -> a -> Bool
== ByteString
sessionName]
      let host :: ByteString
host = ByteString
"" -- fixme, properly lock sessions to client address
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key
-> ClientSessionDateCache
-> ByteString
-> ByteString
-> Maybe SessionMap
decodeClientSession Key
key ClientSessionDateCache
date ByteString
host ByteString
val
    save :: ClientSessionDateCache -> SessionMap -> m [Header]
save ClientSessionDateCache
date SessionMap
sess' = do
      -- We should never cache the IV!  Be careful!
      IV
iv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO IV
CS.randomIV
      forall (m :: * -> *) a. Monad m => a -> m a
return [SetCookie -> Header
AddCookie SetCookie
defaultSetCookie
          { setCookieName :: ByteString
setCookieName = ByteString
sessionName
          , setCookieValue :: ByteString
setCookieValue = Key
-> IV
-> ClientSessionDateCache
-> ByteString
-> SessionMap
-> ByteString
encodeClientSession Key
key IV
iv ClientSessionDateCache
date ByteString
host SessionMap
sess'
          , setCookiePath :: Maybe ByteString
setCookiePath = forall a. a -> Maybe a
Just ByteString
"/"
          , setCookieExpires :: Maybe UTCTime
setCookieExpires = forall a. a -> Maybe a
Just (ClientSessionDateCache -> UTCTime
csdcExpires ClientSessionDateCache
date)
          , setCookieDomain :: Maybe ByteString
setCookieDomain = forall a. Maybe a
Nothing
          , setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True
          }]
        where
          host :: ByteString
host = ByteString
"" -- 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 -> [Char]
fileLocationToString Loc
loc =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ Loc -> [Char]
loc_package Loc
loc
      , Char
':' forall a. a -> [a] -> [a]
: Loc -> [Char]
loc_module Loc
loc
      , Char
' ' forall a. a -> [a] -> [a]
: Loc -> [Char]
loc_filename Loc
loc
      , Char
':' forall a. a -> [a] -> [a]
: Loc -> [Char]
line Loc
loc
      , Char
':' forall a. a -> [a] -> [a]
: Loc -> [Char]
char Loc
loc
      ]
  where
    line :: Loc -> [Char]
line = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start
    char :: Loc -> [Char]
char = forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
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 :: forall site. Approot site
guessApproot = forall site. Approot site -> Approot site
guessApprootOr 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 :: forall site. Approot site -> Approot site
guessApprootOr Approot site
fallback = forall master. (master -> Request -> Text) -> Approot master
ApprootRequest forall a b. (a -> b) -> a -> b
$ \site
master Request
req ->
    case Request -> Maybe ByteString
W.requestHeaderHost Request
req of
        Maybe ByteString
Nothing -> forall site. Approot site -> site -> Request -> Text
getApprootText Approot site
fallback site
master Request
req
        Just ByteString
host ->
            (if Request -> Bool
Network.Wai.Request.appearsSecure Request
req
                then Text
"https://"
                else Text
"http://")
            Text -> Text -> Text
`T.append` OnDecodeError -> ByteString -> Text
TE.decodeUtf8With OnDecodeError
TEE.lenientDecode ByteString
host

-- | Get the textual application root from an 'Approot' value.
--
-- Since 1.4.17
getApprootText :: Approot site -> site -> W.Request -> Text
getApprootText :: forall site. 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