{-# 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 w :: 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 _ _ _ = 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 _ _ = 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 _ = 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`
            ["GET", "HEAD", "OPTIONS", "TRACE"]

    -- | The default route for authentication.
    --
    -- Used in particular by 'isAuthorized', but library users can do whatever
    -- they want with it.
    authRoute :: site -> Maybe (Route site)
    authRoute _ = 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 _ s :: [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 t :: Text
t
            | (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-') Text
t = Int -> Text -> Text
T.drop 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 _ ar :: Text
ar pieces' :: [Text]
pieces' qs' :: [(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 [""] 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 "" = Maybe Method
forall a. Maybe a
Nothing
        go x :: 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 t :: Text
t
            | (Char -> Bool) -> Text -> Bool
T.all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-') Text
t = Char -> Text -> Text
T.cons '-' 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 _ _ _ = 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 _ _ = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$ 2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 1024 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* 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 a :: site
a b :: 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 _ = 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
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 _ = 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 _ = []

    -- | 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 _ = 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 -> String -> IO SessionBackend
defaultClientSessionBackend 120 String
CS.defaultKeyFile

    -- | How to store uploaded files.
    --
    -- Default: When the request body is greater than 50kb, store in a temp
    -- file. For chunked request bodies, store in a temp file. Otherwise, store
    -- in memory.
    fileUpload :: site -> W.RequestBodyLength -> FileUpload
    fileUpload _ (W.KnownLength size :: Word64
size)
        | Word64
size Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= 50000 = BackEnd ByteString -> FileUpload
FileUploadMemory BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m Method -> m ByteString
lbsBackEnd
    fileUpload _ _ = (InternalState -> BackEnd String) -> FileUpload
FileUploadDisk InternalState -> BackEnd String
forall ignored1 ignored2.
InternalState -> ignored1 -> ignored2 -> IO Method -> IO String
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 _ = 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 _ _ = 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 title :: Html
title body :: 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
    (getter :: IO Method
getter, _) <- 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 ckLoggable :: Text -> LogLevel -> IO Bool
ckLoggable logger :: Logger
logger loc :: Loc
loc source :: Text
source level :: LogLevel
level msg :: 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 _ level :: 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 handler :: HandlerFor site res
handler = do
    Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader "Vary" "Accept, Accept-Language"
    Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader "X-XSS-Protection" "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 cookie :: 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 s :: 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 cookie :: 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 timeout :: Int
timeout handler :: HandlerFor site res
handler = do
    Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader "Strict-Transport-Security"
              (Text -> HandlerFor site ()) -> Text -> HandlerFor site ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ "max-age="
                                , Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* 60
                                , "; 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 url :: 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
            Authorized -> () -> HandlerFor site ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            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
                    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 url' :: 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 s' :: 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 handler :: 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 handler :: HandlerFor site res
handler shouldCheckFn :: HandlerFor site Bool
shouldCheckFn headerName :: CI Method
headerName paramName :: 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 handler :: 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 handler :: HandlerFor site res
handler cookie :: 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 w :: 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
$ \hd :: 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 $WWidgetData :: 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 body :: HtmlUrl (Route site)
body) (Last mTitle :: Maybe Title
mTitle) scripts' :: UniqueList (Script (Route site))
scripts' stylesheets' :: UniqueList (Stylesheet (Route site))
stylesheets' style :: Map (Maybe Text) (CssBuilderUrl (Route site))
style jscript :: Maybe (JavascriptUrl (Route site))
jscript (Head 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 x :: Maybe (Either Text (Route site, [(Text, Text)]))
x =
            case Maybe (Either Text (Route site, [(Text, Text)]))
x of
                Nothing -> Maybe Text
forall a. Maybe a
Nothing
                Just (Left s :: Text
s) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
                Just (Right (u :: Route site
u, p :: [(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
$ \(mmedia :: Maybe Text
mmedia, content :: 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 "css" "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
                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 y :: 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
            Nothing -> Maybe Text -> HandlerFor site (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
            Just s :: 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 "js" "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 (mcomplete :: Maybe (HtmlUrl (Route site))
mcomplete, asyncScripts :: [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
            BottomOfBody -> HtmlUrl (Route site)
bodyScript
            _ -> HtmlUrl (Route site)
body
  where
    renderLoc' :: (t -> [a] -> Text) -> Location t -> Text
renderLoc' render' :: t -> [a] -> Text
render' (Local url :: t
url) = t -> [a] -> Text
render' t
url []
    renderLoc' _ (Remote s :: Text
s) = Text
s

    addAttr :: h -> (Text, a) -> h
addAttr x :: h
x (y :: Text
y, z :: 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 loc :: Location t
loc attrs :: [(Text, Text)]
attrs) render' :: 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 (("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 loc :: Location t
loc attrs :: [(Text, Text)]
attrs) render' :: 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
            ( ("rel", "stylesheet")
            (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: ("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] -> [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 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 "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 ["message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ("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 ("Not Found" :: Text)

-- For API requests.
-- For a user with a browser,
-- if you specify an authRoute the user will be redirected there and
-- this page will not be shown.
defaultErrorHandler NotAuthenticated = 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
        "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 "WWW-Authenticate" "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 u :: Route site
u = ["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
$ ("message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ("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 ("Not logged in" :: Text)

defaultErrorHandler (PermissionDenied msg :: 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
        "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 ["message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ("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
$ "Permission Denied. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

defaultErrorHandler (InvalidArgs ia :: [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
        "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 ["message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ("Invalid Arguments" :: 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 ("Invalid Arguments: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate " " [Text]
ia)

defaultErrorHandler (InternalError e :: Text
e) = do
    Text
LogLevel
String -> String -> String -> CharPos -> CharPos -> Loc
Loc -> Text -> LogLevel -> Text -> HandlerFor site ()
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
b :: Text
a :: Text
$logErrorS "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
            "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 ["message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ("Internal Server Error" :: 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
$ "Internal Server Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e

defaultErrorHandler (BadMethod m :: 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
        "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 ["message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ("Bad method" :: 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
$ "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 render :: url -> [x] -> Text
render scripts :: [Script url]
scripts jscript :: Maybe (JavascriptUrl url)
jscript jsLoc :: 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 s :: Text
s -> [Text]
scripts' [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
s]
            Nothing -> [Text]
scripts'
    goScript :: Script url -> Text
goScript (Script (Local url :: url
url) _) = url -> [x] -> Text
render url
url []
    goScript (Script (Remote s :: Text
s) _) = Text
s
    mcomplete :: Maybe (HtmlUrl url)
mcomplete =
        case Maybe Text
jsLoc of
            Just{} -> Maybe (HtmlUrl url)
forall a. Maybe a
Nothing
            Nothing ->
                case Maybe (JavascriptUrl url)
jscript of
                    Nothing -> Maybe (HtmlUrl url)
forall a. Maybe a
Nothing
                    Just j :: 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 getdate :: IO Method
getdate loc :: Loc
loc src :: Text
src level :: LogLevel
level msg :: 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
forall a. Monoid a => a -> a -> a
`mappend` (case LogLevel
level of
            LevelOther t :: Text
t -> Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
t
            _ -> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 5 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ LogLevel -> String
forall a. Show a => a -> String
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
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
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` "\n"
    where
    sourceSuffix :: LogStr
sourceSuffix = if Loc -> String
loc_package Loc
loc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "<unknown>" then "" else LogStr
forall a. Monoid a => a
mempty
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` " @("
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Loc -> String
fileLocationToString Loc
loc)
        LogStr -> LogStr -> LogStr
forall a. Monoid a => a -> a -> a
`mappend` ")"

-- | 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 customizeCookie :: SetCookie -> SetCookie
customizeCookie backend :: SessionBackend
backend = SessionBackend
backend'
  where
    customizeHeader :: Header -> Header
customizeHeader (AddCookie cookie :: SetCookie
cookie) = SetCookie -> Header
AddCookie (SetCookie -> SetCookie
customizeCookie SetCookie
cookie)
    customizeHeader other :: 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 = \req :: 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 -> String -> IO SessionBackend
defaultClientSessionBackend minutes :: Int
minutes fp :: String
fp = do
  Key
key <- String -> IO Key
CS.getKey String
fp
  (getCachedDate :: IO ClientSessionDateCache
getCachedDate, _closeDateCacher :: 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 -> String -> IO SessionBackend
envClientSessionBackend minutes :: Int
minutes name :: String
name = do
    Key
key <- String -> IO Key
CS.getKeyEnv String
name
    (getCachedDate :: IO ClientSessionDateCache
getCachedDate, _closeDateCacher :: 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 minutes :: 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
* 60)

jsToHtml :: Javascript -> Html
jsToHtml :: Javascript -> Html
jsToHtml (Javascript b :: 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 x :: a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
left _ = Maybe a
forall a. Maybe a
Nothing

right :: Either a b -> Maybe b
right :: Either a b -> Maybe b
right (Right x :: b
x) = b -> Maybe b
forall a. a -> Maybe a
Just b
x
right _ = 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
key getCachedDate :: 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 "_SESSION"
  }

justSingleton :: a -> [Maybe a] -> a
justSingleton :: a -> [Maybe a] -> a
justSingleton d :: 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 [s :: a
s] = a
s
    just _   = 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
key getCachedDate :: IO ClientSessionDateCache
getCachedDate sessionName :: Method
sessionName req :: 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 date :: 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 | (k :: CI Method
k, v :: Method
v) <- Request -> RequestHeaders
W.requestHeaders Request
req, CI Method
k CI Method -> CI Method -> Bool
forall a. Eq a => a -> a -> Bool
== "Cookie"]
      Method
val <- [Method
v | (k :: Method
k, v :: 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 = "" -- 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 date :: ClientSessionDateCache
date sess' :: 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 "/"
          , 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 = "" -- 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 -> String
fileLocationToString loc :: Loc
loc =
    [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ Loc -> String
loc_package Loc
loc
      , ':' Char -> String -> String
forall a. a -> [a] -> [a]
: Loc -> String
loc_module Loc
loc
      , ' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Loc -> String
loc_filename Loc
loc
      , ':' Char -> String -> String
forall a. a -> [a] -> [a]
: Loc -> String
line Loc
loc
      , ':' Char -> String -> String
forall a. a -> [a] -> [a]
: Loc -> String
char Loc
loc
      ]
  where
    line :: Loc -> String
line = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> a
fst (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start
    char :: Loc -> String
char = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> b
snd (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
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 :: 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 fallback :: 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
$ \master :: site
master req :: Request
req ->
    case Request -> Maybe Method
W.requestHeaderHost Request
req of
        Nothing -> Approot site -> site -> Request -> Text
forall site. Approot site -> site -> Request -> Text
getApprootText Approot site
fallback site
master Request
req
        Just host :: Method
host ->
            (if Request -> Bool
Network.Wai.Request.appearsSecure Request
req
                then "https://"
                else "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 ar :: Approot site
ar site :: site
site req :: Request
req =
    case Approot site
ar of
        ApprootRelative -> ""
        ApprootStatic t :: Text
t -> Text
t
        ApprootMaster f :: site -> Text
f -> site -> Text
f site
site
        ApprootRequest f :: site -> Request -> Text
f -> site -> Request -> Text
f site
site Request
req