{-# 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
class RenderRoute site => Yesod site where
approot :: Approot site
approot = Approot site
forall site. Approot site
guessApproot
errorHandler :: ErrorResponse -> HandlerFor site TypedContent
errorHandler = ErrorResponse -> HandlerFor site TypedContent
forall site.
Yesod site =>
ErrorResponse -> HandlerFor site TypedContent
defaultErrorHandler
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}
|]
urlParamRenderOverride :: site
-> Route site
-> [(T.Text, T.Text)]
-> Maybe Builder
urlParamRenderOverride _ _ _ = Maybe Builder
forall a. Maybe a
Nothing
isAuthorized :: Route site
-> Bool
-> HandlerFor site AuthResult
isAuthorized _ _ = AuthResult -> HandlerFor site AuthResult
forall (m :: * -> *) a. Monad m => a -> m a
return AuthResult
Authorized
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"]
authRoute :: site -> Maybe (Route site)
authRoute _ = Maybe (Route site)
forall a. Maybe a
Nothing
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
joinPath :: site
-> T.Text
-> [T.Text]
-> [(T.Text, T.Text)]
-> 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
addStaticContent :: Text
-> Text
-> L.ByteString
-> 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
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
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
makeLogger :: site -> IO Logger
makeLogger _ = IO Logger
defaultMakeLogger
messageLoggerSource :: site
-> Logger
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> 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
jsLoader :: site -> ScriptLoadPosition site
jsLoader _ = ScriptLoadPosition site
forall master. ScriptLoadPosition master
BottomOfBody
jsAttributes :: site -> [(Text, Text)]
jsAttributes _ = []
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
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
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
shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
shouldLogIO _ = Text -> LogLevel -> IO Bool
defaultShouldLogIO
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
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 #-}
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}
|]
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
defaultMessageLoggerSource ::
(LogSource -> LogLevel -> IO Bool)
-> Logger
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> 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
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
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
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
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
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
sslOnlyMiddleware :: Int
-> 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
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'
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
csrfCheckMiddleware :: HandlerFor site res
-> HandlerFor site Bool
-> CI S8.ByteString
-> Text
-> 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
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
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
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
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
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 []
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)
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
Text -> Text -> HandlerFor site ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader "WWW-Authenticate" "RedirectJSON realm=\"application\", param=\"authentication_url\""
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
formatLogMessage :: IO ZonedDate
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> 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` ")"
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
-> FilePath
-> 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
envClientSessionBackend :: Int
-> String
-> 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
-> IO ClientSessionDateCache
-> 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
-> S8.ByteString
-> 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 = ""
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
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 = ""
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
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
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
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