{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Yesod.Core.Handler
(
HandlerT
, HandlerFor
, getYesod
, getsYesod
, getUrlRender
, getUrlRenderParams
, getPostParams
, getCurrentRoute
, getRequest
, waiRequest
, runRequestBody
, rawRequestBody
, RequestBodyContents
, YesodRequest (..)
, FileInfo
, fileName
, fileContentType
, fileSource
, fileSourceByteString
, fileMove
, languages
, lookupGetParam
, lookupPostParam
, lookupCookie
, lookupFile
, lookupHeader
, lookupBasicAuth
, lookupBearerAuth
, lookupGetParams
, lookupPostParams
, lookupCookies
, lookupFiles
, lookupHeaders
, respond
, respondSource
, sendChunk
, sendFlush
, sendChunkBS
, sendChunkLBS
, sendChunkText
, sendChunkLazyText
, sendChunkHtml
, RedirectUrl (..)
, redirect
, redirectWith
, redirectToPost
, Fragment(..)
, notFound
, badMethod
, notAuthenticated
, permissionDenied
, permissionDeniedI
, invalidArgs
, invalidArgsI
, sendFile
, sendFilePart
, sendResponse
, sendResponseStatus
, sendStatusJSON
, sendResponseCreated
, sendResponseNoContent
, sendWaiResponse
, sendWaiApplication
, sendRawResponse
, sendRawResponseNoConduit
, notModified
, selectRep
, provideRep
, provideRepType
, ProvidedRep
, setCookie
, getExpires
, deleteCookie
, addHeader
, setHeader
, replaceOrAddHeader
, setLanguage
, addContentDispositionFileName
, cacheSeconds
, neverExpires
, alreadyExpired
, expiresAt
, setEtag
, setWeakEtag
, SessionMap
, lookupSession
, lookupSessionBS
, getSession
, setSession
, setSessionBS
, deleteSession
, clearSession
, setUltDest
, setUltDestCurrent
, setUltDestReferer
, redirectUltDest
, clearUltDest
, addMessage
, addMessageI
, getMessages
, setMessage
, setMessageI
, getMessage
, SubHandlerFor
, getSubYesod
, getRouteToParent
, getSubCurrentRoute
, hamletToRepHtml
, giveUrlRenderer
, withUrlRenderer
, newIdent
, handlerToIO
, forkHandler
, getMessageRender
, cached
, cacheGet
, cacheSet
, cachedBy
, cacheByGet
, cacheBySet
, setCsrfCookie
, setCsrfCookieWithCookie
, defaultCsrfCookieName
, checkCsrfHeaderNamed
, hasValidCsrfHeaderNamed
, defaultCsrfHeaderName
, hasValidCsrfParamNamed
, checkCsrfParamNamed
, defaultCsrfParamName
, checkCsrfHeaderOrParam
) where
import Data.Time (UTCTime, addUTCTime,
getCurrentTime)
import Yesod.Core.Internal.Request (langKey, mkFileInfoFile,
mkFileInfoLBS, mkFileInfoSource)
import Control.Applicative ((<|>))
import qualified Data.CaseInsensitive as CI
import Control.Exception (evaluate, SomeException, throwIO)
import Control.Exception (handle)
import Control.Monad (void, liftM, unless)
import qualified Control.Monad.Trans.Writer as Writer
import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import Network.Wai.Middleware.HttpAuth
( extractBasicAuth, extractBearerAuth )
import Control.Monad.Trans.Class (lift)
import Data.Aeson (ToJSON(..))
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as TL
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Hamlet (Html, HtmlUrl, hamlet)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import qualified Data.HashMap.Strict as HM
import Data.ByteArray (constEq)
import Control.Arrow ((***))
import qualified Data.ByteString.Char8 as S8
import Data.Monoid (Endo (..))
import Data.Text (Text)
import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..))
import Web.Cookie (SetCookie (..), defaultSetCookie)
import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToHtml, toHtml)
import qualified Data.IORef as I
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Typeable (Typeable)
import Data.Kind (Type)
import Web.PathPieces (PathPiece(..))
import Yesod.Core.Class.Handler
import Yesod.Core.Types
import Yesod.Routes.Class (Route)
import Data.ByteString.Builder (Builder)
import Data.CaseInsensitive (CI, original)
import qualified Data.Conduit.List as CL
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
import qualified System.PosixCompat.Files as PC
import Conduit ((.|), runConduit, sinkLazy)
import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)
import qualified Yesod.Core.TypeCache as Cache
import qualified Data.Word8 as W8
import qualified Data.Foldable as Fold
import Control.Monad.Logger (MonadLogger, logWarnS)
type HandlerT site (m :: Type -> Type) = HandlerFor site
{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
get :: MonadHandler m => m GHState
get :: forall (m :: * -> *). MonadHandler m => m GHState
get = HandlerFor (HandlerSite m) GHState -> m GHState
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) GHState -> m GHState)
-> HandlerFor (HandlerSite m) GHState -> m GHState
forall a b. (a -> b) -> a -> b
$ (HandlerData (HandlerSite m) (HandlerSite m) -> IO GHState)
-> HandlerFor (HandlerSite m) GHState
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData (HandlerSite m) (HandlerSite m) -> IO GHState)
-> HandlerFor (HandlerSite m) GHState)
-> (HandlerData (HandlerSite m) (HandlerSite m) -> IO GHState)
-> HandlerFor (HandlerSite m) GHState
forall a b. (a -> b) -> a -> b
$ IORef GHState -> IO GHState
forall a. IORef a -> IO a
I.readIORef (IORef GHState -> IO GHState)
-> (HandlerData (HandlerSite m) (HandlerSite m) -> IORef GHState)
-> HandlerData (HandlerSite m) (HandlerSite m)
-> IO GHState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (HandlerSite m) (HandlerSite m) -> IORef GHState
forall child site. HandlerData child site -> IORef GHState
handlerState
put :: MonadHandler m => GHState -> m ()
put :: forall (m :: * -> *). MonadHandler m => GHState -> m ()
put GHState
x = HandlerFor (HandlerSite m) () -> m ()
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) () -> m ())
-> HandlerFor (HandlerSite m) () -> m ()
forall a b. (a -> b) -> a -> b
$ (HandlerData (HandlerSite m) (HandlerSite m) -> IO ())
-> HandlerFor (HandlerSite m) ()
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData (HandlerSite m) (HandlerSite m) -> IO ())
-> HandlerFor (HandlerSite m) ())
-> (HandlerData (HandlerSite m) (HandlerSite m) -> IO ())
-> HandlerFor (HandlerSite m) ()
forall a b. (a -> b) -> a -> b
$ (IORef GHState -> GHState -> IO ())
-> GHState -> IORef GHState -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef GHState -> GHState -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef GHState
x (IORef GHState -> IO ())
-> (HandlerData (HandlerSite m) (HandlerSite m) -> IORef GHState)
-> HandlerData (HandlerSite m) (HandlerSite m)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (HandlerSite m) (HandlerSite m) -> IORef GHState
forall child site. HandlerData child site -> IORef GHState
handlerState
modify :: MonadHandler m => (GHState -> GHState) -> m ()
modify :: forall (m :: * -> *).
MonadHandler m =>
(GHState -> GHState) -> m ()
modify GHState -> GHState
f = HandlerFor (HandlerSite m) () -> m ()
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) () -> m ())
-> HandlerFor (HandlerSite m) () -> m ()
forall a b. (a -> b) -> a -> b
$ (HandlerData (HandlerSite m) (HandlerSite m) -> IO ())
-> HandlerFor (HandlerSite m) ()
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData (HandlerSite m) (HandlerSite m) -> IO ())
-> HandlerFor (HandlerSite m) ())
-> (HandlerData (HandlerSite m) (HandlerSite m) -> IO ())
-> HandlerFor (HandlerSite m) ()
forall a b. (a -> b) -> a -> b
$ (IORef GHState -> (GHState -> GHState) -> IO ())
-> (GHState -> GHState) -> IORef GHState -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef GHState -> (GHState -> GHState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
I.modifyIORef GHState -> GHState
f (IORef GHState -> IO ())
-> (HandlerData (HandlerSite m) (HandlerSite m) -> IORef GHState)
-> HandlerData (HandlerSite m) (HandlerSite m)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (HandlerSite m) (HandlerSite m) -> IORef GHState
forall child site. HandlerData child site -> IORef GHState
handlerState
tell :: MonadHandler m => Endo [Header] -> m ()
tell :: forall (m :: * -> *). MonadHandler m => Endo [Header] -> m ()
tell Endo [Header]
hs = (GHState -> GHState) -> m ()
forall (m :: * -> *).
MonadHandler m =>
(GHState -> GHState) -> m ()
modify ((GHState -> GHState) -> m ()) -> (GHState -> GHState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHState
g -> GHState
g { ghsHeaders = ghsHeaders g `mappend` hs }
handlerError :: MonadHandler m => HandlerContents -> m a
handlerError :: forall (m :: * -> *) a. MonadHandler m => HandlerContents -> m a
handlerError = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> (HandlerContents -> IO a) -> HandlerContents -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerContents -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO
hcError :: MonadHandler m => ErrorResponse -> m a
hcError :: forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError = HandlerContents -> m a
forall (m :: * -> *) a. MonadHandler m => HandlerContents -> m a
handlerError (HandlerContents -> m a)
-> (ErrorResponse -> HandlerContents) -> ErrorResponse -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorResponse -> HandlerContents
HCError
getRequest :: MonadHandler m => m YesodRequest
getRequest :: forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest = HandlerFor (HandlerSite m) YesodRequest -> m YesodRequest
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor (HandlerSite m) YesodRequest -> m YesodRequest)
-> HandlerFor (HandlerSite m) YesodRequest -> m YesodRequest
forall a b. (a -> b) -> a -> b
$ (HandlerData (HandlerSite m) (HandlerSite m) -> IO YesodRequest)
-> HandlerFor (HandlerSite m) YesodRequest
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData (HandlerSite m) (HandlerSite m) -> IO YesodRequest)
-> HandlerFor (HandlerSite m) YesodRequest)
-> (HandlerData (HandlerSite m) (HandlerSite m) -> IO YesodRequest)
-> HandlerFor (HandlerSite m) YesodRequest
forall a b. (a -> b) -> a -> b
$ YesodRequest -> IO YesodRequest
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (YesodRequest -> IO YesodRequest)
-> (HandlerData (HandlerSite m) (HandlerSite m) -> YesodRequest)
-> HandlerData (HandlerSite m) (HandlerSite m)
-> IO YesodRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (HandlerSite m) (HandlerSite m) -> YesodRequest
forall child site. HandlerData child site -> YesodRequest
handlerRequest
runRequestBody :: MonadHandler m => m RequestBodyContents
runRequestBody :: forall (m :: * -> *). MonadHandler m => m RequestBodyContents
runRequestBody = do
HandlerData
{ handlerEnv = RunHandlerEnv {..}
, handlerRequest = req
} <- HandlerFor
(HandlerSite m) (HandlerData (HandlerSite m) (HandlerSite m))
-> m (HandlerData (HandlerSite m) (HandlerSite m))
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor
(HandlerSite m) (HandlerData (HandlerSite m) (HandlerSite m))
-> m (HandlerData (HandlerSite m) (HandlerSite m)))
-> HandlerFor
(HandlerSite m) (HandlerData (HandlerSite m) (HandlerSite m))
-> m (HandlerData (HandlerSite m) (HandlerSite m))
forall a b. (a -> b) -> a -> b
$ (HandlerData (HandlerSite m) (HandlerSite m)
-> IO (HandlerData (HandlerSite m) (HandlerSite m)))
-> HandlerFor
(HandlerSite m) (HandlerData (HandlerSite m) (HandlerSite m))
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor HandlerData (HandlerSite m) (HandlerSite m)
-> IO (HandlerData (HandlerSite m) (HandlerSite m))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
let len = Request -> RequestBodyLength
W.requestBodyLength (Request -> RequestBodyLength) -> Request -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ YesodRequest -> Request
reqWaiRequest YesodRequest
req
upload = RequestBodyLength -> FileUpload
rheUpload RequestBodyLength
len
x <- get
case ghsRBC x of
Just RequestBodyContents
rbc -> RequestBodyContents -> m RequestBodyContents
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return RequestBodyContents
rbc
Maybe RequestBodyContents
Nothing -> do
rr <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
internalState <- liftResourceT getInternalState
rbc <- liftIO $ rbHelper upload rr internalState
put x { ghsRBC = Just rbc }
return rbc
rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents
rbHelper :: FileUpload -> Request -> InternalState -> IO RequestBodyContents
rbHelper FileUpload
upload Request
req InternalState
internalState =
case FileUpload
upload of
FileUploadMemory BackEnd ByteString
s -> BackEnd ByteString
-> (Text -> Text -> ByteString -> FileInfo)
-> Request
-> IO RequestBodyContents
forall x.
BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> Request
-> IO RequestBodyContents
rbHelper' BackEnd ByteString
s Text -> Text -> ByteString -> FileInfo
mkFileInfoLBS Request
req
FileUploadDisk InternalState -> BackEnd FilePath
s -> BackEnd FilePath
-> (Text -> Text -> FilePath -> FileInfo)
-> Request
-> IO RequestBodyContents
forall x.
BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> Request
-> IO RequestBodyContents
rbHelper' (InternalState -> BackEnd FilePath
s InternalState
internalState) Text -> Text -> FilePath -> FileInfo
mkFileInfoFile Request
req
FileUploadSource BackEnd (ConduitT () ByteString (ResourceT IO) ())
s -> BackEnd (ConduitT () ByteString (ResourceT IO) ())
-> (Text
-> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo)
-> Request
-> IO RequestBodyContents
forall x.
BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> Request
-> IO RequestBodyContents
rbHelper' BackEnd (ConduitT () ByteString (ResourceT IO) ())
s Text
-> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
mkFileInfoSource Request
req
rbHelper' :: NWP.BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> W.Request
-> IO ([(Text, Text)], [(Text, FileInfo)])
rbHelper' :: forall x.
BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> Request
-> IO RequestBodyContents
rbHelper' BackEnd x
backend Text -> Text -> x -> FileInfo
mkFI Request
req =
((Param -> (Text, Text)) -> [Param] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Param -> (Text, Text)
fix1 ([Param] -> [(Text, Text)])
-> ([File x] -> [(Text, FileInfo)])
-> ([Param], [File x])
-> RequestBodyContents
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (File x -> Maybe (Text, FileInfo))
-> [File x] -> [(Text, FileInfo)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe File x -> Maybe (Text, FileInfo)
fix2) (([Param], [File x]) -> RequestBodyContents)
-> IO ([Param], [File x]) -> IO RequestBodyContents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BackEnd x -> Request -> IO ([Param], [File x])
forall y. BackEnd y -> Request -> IO ([Param], [File y])
NWP.parseRequestBody BackEnd x
backend Request
req
where
fix1 :: Param -> (Text, Text)
fix1 = ByteString -> Text
go (ByteString -> Text)
-> (ByteString -> Text) -> Param -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
go
fix2 :: File x -> Maybe (Text, FileInfo)
fix2 (ByteString
x, NWP.FileInfo ByteString
a' ByteString
b x
c)
| ByteString -> Bool
S.null ByteString
a = Maybe (Text, FileInfo)
forall a. Maybe a
Nothing
| Bool
otherwise = (Text, FileInfo) -> Maybe (Text, FileInfo)
forall a. a -> Maybe a
Just (ByteString -> Text
go ByteString
x, Text -> Text -> x -> FileInfo
mkFI (ByteString -> Text
go ByteString
a) (ByteString -> Text
go ByteString
b) x
c)
where
a :: ByteString
a
| ByteString -> Int
S.length ByteString
a' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = ByteString
a'
| ByteString -> Char
S8.head ByteString
a' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
&& ByteString -> Char
S8.last ByteString
a' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init ByteString
a'
| ByteString -> Char
S8.head ByteString
a' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
&& ByteString -> Char
S8.last ByteString
a' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init ByteString
a'
| Bool
otherwise = ByteString
a'
go :: ByteString -> Text
go = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv :: forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv = HandlerFor
(HandlerSite m) (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall a. HandlerFor (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor
(HandlerSite m) (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m)))
-> HandlerFor
(HandlerSite m) (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall a b. (a -> b) -> a -> b
$ (HandlerData (HandlerSite m) (HandlerSite m)
-> IO (RunHandlerEnv (HandlerSite m) (HandlerSite m)))
-> HandlerFor
(HandlerSite m) (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData (HandlerSite m) (HandlerSite m)
-> IO (RunHandlerEnv (HandlerSite m) (HandlerSite m)))
-> HandlerFor
(HandlerSite m) (RunHandlerEnv (HandlerSite m) (HandlerSite m)))
-> (HandlerData (HandlerSite m) (HandlerSite m)
-> IO (RunHandlerEnv (HandlerSite m) (HandlerSite m)))
-> HandlerFor
(HandlerSite m) (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall a b. (a -> b) -> a -> b
$ RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> IO (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> IO (RunHandlerEnv (HandlerSite m) (HandlerSite m)))
-> (HandlerData (HandlerSite m) (HandlerSite m)
-> RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> HandlerData (HandlerSite m) (HandlerSite m)
-> IO (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (HandlerSite m) (HandlerSite m)
-> RunHandlerEnv (HandlerSite m) (HandlerSite m)
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv
getYesod :: MonadHandler m => m (HandlerSite m)
getYesod :: forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod = RunHandlerEnv (HandlerSite m) (HandlerSite m) -> HandlerSite m
forall child site. RunHandlerEnv child site -> site
rheSite (RunHandlerEnv (HandlerSite m) (HandlerSite m) -> HandlerSite m)
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (HandlerSite m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a
getsYesod :: forall (m :: * -> *) a.
MonadHandler m =>
(HandlerSite m -> a) -> m a
getsYesod HandlerSite m -> a
f = (HandlerSite m -> a
f (HandlerSite m -> a)
-> (RunHandlerEnv (HandlerSite m) (HandlerSite m) -> HandlerSite m)
-> RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunHandlerEnv (HandlerSite m) (HandlerSite m) -> HandlerSite m
forall child site. RunHandlerEnv child site -> site
rheSite) (RunHandlerEnv (HandlerSite m) (HandlerSite m) -> a)
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m)) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)
getUrlRender :: forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender = do
x <- RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> Route (HandlerSite m) -> [(Text, Text)] -> Text
forall child site.
RunHandlerEnv child site -> Route site -> [(Text, Text)] -> Text
rheRender (RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> Route (HandlerSite m) -> [(Text, Text)] -> Text)
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
return $ flip x []
getUrlRenderParams
:: MonadHandler m
=> m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams :: forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams = RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> Route (HandlerSite m) -> [(Text, Text)] -> Text
forall child site.
RunHandlerEnv child site -> Route site -> [(Text, Text)] -> Text
rheRender (RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> Route (HandlerSite m) -> [(Text, Text)] -> Text)
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
getPostParams
:: MonadHandler m
=> m [(Text, Text)]
getPostParams :: forall (m :: * -> *). MonadHandler m => m [(Text, Text)]
getPostParams = do
reqBodyContent <- m RequestBodyContents
forall (m :: * -> *). MonadHandler m => m RequestBodyContents
runRequestBody
return $ fst reqBodyContent
getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute :: forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute = RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> Maybe (Route (HandlerSite m))
forall child site. RunHandlerEnv child site -> Maybe (Route child)
rheRoute (RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> Maybe (Route (HandlerSite m)))
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (Maybe (Route (HandlerSite m)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
handlerToIO :: forall (m :: * -> *) site a.
MonadIO m =>
HandlerFor site (HandlerFor site a -> m a)
handlerToIO =
(HandlerData site site -> IO (HandlerFor site a -> m a))
-> HandlerFor site (HandlerFor site a -> m a)
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData site site -> IO (HandlerFor site a -> m a))
-> HandlerFor site (HandlerFor site a -> m a))
-> (HandlerData site site -> IO (HandlerFor site a -> m a))
-> HandlerFor site (HandlerFor site a -> m a)
forall a b. (a -> b) -> a -> b
$ \HandlerData site site
oldHandlerData -> do
let newReq :: YesodRequest
newReq = YesodRequest
oldReq { reqWaiRequest = newWaiReq }
where
oldReq :: YesodRequest
oldReq = HandlerData site site -> YesodRequest
forall child site. HandlerData child site -> YesodRequest
handlerRequest HandlerData site site
oldHandlerData
oldWaiReq :: Request
oldWaiReq = YesodRequest -> Request
reqWaiRequest YesodRequest
oldReq
newWaiReq :: Request
newWaiReq = Request
oldWaiReq { W.requestBody = return mempty
, W.requestBodyLength = W.KnownLength 0
}
oldEnv :: RunHandlerEnv site site
oldEnv = HandlerData site site -> RunHandlerEnv site site
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv HandlerData site site
oldHandlerData
newState <- IO GHState -> IO GHState
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GHState -> IO GHState) -> IO GHState -> IO GHState
forall a b. (a -> b) -> a -> b
$ do
oldState <- IORef GHState -> IO GHState
forall a. IORef a -> IO a
I.readIORef (HandlerData site site -> IORef GHState
forall child site. HandlerData child site -> IORef GHState
handlerState HandlerData site site
oldHandlerData)
return $ oldState { ghsRBC = Nothing
, ghsIdent = 1
, ghsCache = mempty
, ghsCacheBy = mempty
, ghsHeaders = mempty }
liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
return $ \(HandlerFor HandlerData site site -> IO a
f) ->
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$
ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO a -> IO a) -> ResourceT IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (InternalState -> IO a) -> ResourceT IO a
forall (m :: * -> *) a. (InternalState -> m a) -> ResourceT m a
withInternalState ((InternalState -> IO a) -> ResourceT IO a)
-> (InternalState -> IO a) -> ResourceT IO a
forall a b. (a -> b) -> a -> b
$ \InternalState
resState -> do
newStateIORef <- IO (IORef GHState) -> IO (IORef GHState)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (GHState -> IO (IORef GHState)
forall a. a -> IO (IORef a)
I.newIORef GHState
newState)
let newHandlerData =
HandlerData
{ handlerRequest :: YesodRequest
handlerRequest = YesodRequest
newReq
, handlerEnv :: RunHandlerEnv site site
handlerEnv = RunHandlerEnv site site
oldEnv
, handlerState :: IORef GHState
handlerState = IORef GHState
newStateIORef
, handlerResource :: InternalState
handlerResource = InternalState
resState
}
liftIO (f newHandlerData)
forkHandler :: (SomeException -> HandlerFor site ())
-> HandlerFor site ()
-> HandlerFor site ()
forkHandler :: forall site.
(SomeException -> HandlerFor site ())
-> HandlerFor site () -> HandlerFor site ()
forkHandler SomeException -> HandlerFor site ()
onErr HandlerFor site ()
handler = do
yesRunner <- HandlerFor site (HandlerFor site () -> IO ())
forall (m :: * -> *) site a.
MonadIO m =>
HandlerFor site (HandlerFor site a -> m a)
handlerToIO
void $ liftResourceT $ resourceForkIO $
liftIO $ handle (yesRunner . onErr) (yesRunner handler)
redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> url -> m a
redirect :: forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect url
url = do
req <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
let status =
if Request -> HttpVersion
W.httpVersion Request
req HttpVersion -> HttpVersion -> Bool
forall a. Eq a => a -> a -> Bool
== HttpVersion
H.http11
then Status
H.status303
else Status
H.status302
redirectWith status url
redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> H.Status
-> url
-> m a
redirectWith :: forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
Status -> url -> m a
redirectWith Status
status url
url = do
urlText <- url -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ HandlerSite m) =>
url -> m Text
toTextUrl url
url
handlerError $ HCRedirect status urlText
ultDestKey :: Text
ultDestKey :: Text
ultDestKey = Text
"_ULT"
setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> url
-> m ()
setUltDest :: forall (m :: * -> *) url.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m ()
setUltDest url
url = do
urlText <- url -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ HandlerSite m) =>
url -> m Text
toTextUrl url
url
setSession ultDestKey urlText
setUltDestCurrent :: MonadHandler m => m ()
setUltDestCurrent :: forall (m :: * -> *). MonadHandler m => m ()
setUltDestCurrent = do
route <- m (Maybe (Route (HandlerSite m)))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
case route of
Maybe (Route (HandlerSite m))
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Route (HandlerSite m)
r -> do
gets' <- YesodRequest -> [(Text, Text)]
reqGetParams (YesodRequest -> [(Text, Text)])
-> m YesodRequest -> m [(Text, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
setUltDest (r, gets')
setUltDestReferer :: MonadHandler m => m ()
setUltDestReferer :: forall (m :: * -> *). MonadHandler m => m ()
setUltDestReferer = do
mdest <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
ultDestKey
maybe
(waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)
(const $ return ())
mdest
where
setUltDestBS :: ByteString -> m ()
setUltDestBS = Text -> m ()
forall (m :: * -> *) url.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m ()
setUltDest (Text -> m ()) -> (ByteString -> Text) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text)
-> (ByteString -> FilePath) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
S8.unpack
redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)
=> url
-> m a
redirectUltDest :: forall (m :: * -> *) url a.
(RedirectUrl (HandlerSite m) url, MonadHandler m) =>
url -> m a
redirectUltDest url
defaultDestination = do
mdest <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
ultDestKey
deleteSession ultDestKey
maybe (redirect defaultDestination) redirect mdest
clearUltDest :: MonadHandler m => m ()
clearUltDest :: forall (m :: * -> *). MonadHandler m => m ()
clearUltDest = Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
ultDestKey
msgKey :: Text
msgKey :: Text
msgKey = Text
"_MSG"
addMessage :: MonadHandler m
=> Text
-> Html
-> m ()
addMessage :: forall (m :: * -> *). MonadHandler m => Text -> Html -> m ()
addMessage Text
status Html
msg = do
val <- Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
msgKey
setSessionBS msgKey $ addMsg val
where
addMsg :: Maybe ByteString -> ByteString
addMsg = ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
msg' (ByteString -> ByteString -> ByteString
S.append ByteString
msg' (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> ByteString
S.cons Word8
W8._nul)
msg' :: ByteString
msg' = ByteString -> ByteString -> ByteString
S.append
(Text -> ByteString
encodeUtf8 Text
status)
(Word8
W8._nul Word8 -> ByteString -> ByteString
`S.cons` ByteString -> ByteString
L.toStrict (Html -> ByteString
renderHtml Html
msg))
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
=> Text -> msg -> m ()
addMessageI :: forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
Text -> msg -> m ()
addMessageI Text
status msg
msg = do
mr <- m (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
addMessage status $ toHtml $ mr msg
getMessages :: MonadHandler m => m [(Text, Html)]
getMessages :: forall (m :: * -> *). MonadHandler m => m [(Text, Html)]
getMessages = do
bs <- Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
msgKey
let ms = [(Text, Html)]
-> (ByteString -> [(Text, Html)])
-> Maybe ByteString
-> [(Text, Html)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [(Text, Html)]
enlist Maybe ByteString
bs
deleteSession msgKey
return ms
where
enlist :: ByteString -> [(Text, Html)]
enlist = [ByteString] -> [(Text, Html)]
pairup ([ByteString] -> [(Text, Html)])
-> (ByteString -> [ByteString]) -> ByteString -> [(Text, Html)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
W8._nul
pairup :: [ByteString] -> [(Text, Html)]
pairup [] = []
pairup [ByteString
_] = []
pairup (ByteString
s:ByteString
v:[ByteString]
xs) = (ByteString -> Text
decode ByteString
s, Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml (ByteString -> Text
decode ByteString
v)) (Text, Html) -> [(Text, Html)] -> [(Text, Html)]
forall a. a -> [a] -> [a]
: [ByteString] -> [(Text, Html)]
pairup [ByteString]
xs
decode :: ByteString -> Text
decode = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
setMessage :: MonadHandler m => Html -> m ()
setMessage :: forall (m :: * -> *). MonadHandler m => Html -> m ()
setMessage = Text -> Html -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Html -> m ()
addMessage Text
""
setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
=> msg -> m ()
setMessageI :: forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
msg -> m ()
setMessageI = Text -> msg -> m ()
forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
Text -> msg -> m ()
addMessageI Text
""
getMessage :: MonadHandler m => m (Maybe Html)
getMessage :: forall (m :: * -> *). MonadHandler m => m (Maybe Html)
getMessage = ([(Text, Html)] -> Maybe Html)
-> m [(Text, Html)] -> m (Maybe Html)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Text, Html) -> Html) -> Maybe (Text, Html) -> Maybe Html
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Html) -> Html
forall a b. (a, b) -> b
snd (Maybe (Text, Html) -> Maybe Html)
-> ([(Text, Html)] -> Maybe (Text, Html))
-> [(Text, Html)]
-> Maybe Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Html)] -> Maybe (Text, Html)
forall a. [a] -> Maybe a
listToMaybe) m [(Text, Html)]
forall (m :: * -> *). MonadHandler m => m [(Text, Html)]
getMessages
sendFile :: MonadHandler m => ContentType -> FilePath -> m a
sendFile :: forall (m :: * -> *) a.
MonadHandler m =>
ByteString -> FilePath -> m a
sendFile ByteString
ct FilePath
fp = HandlerContents -> m a
forall (m :: * -> *) a. MonadHandler m => HandlerContents -> m a
handlerError (HandlerContents -> m a) -> HandlerContents -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath -> Maybe FilePart -> HandlerContents
HCSendFile ByteString
ct FilePath
fp Maybe FilePart
forall a. Maybe a
Nothing
sendFilePart :: MonadHandler m
=> ContentType
-> FilePath
-> Integer
-> Integer
-> m a
sendFilePart :: forall (m :: * -> *) a.
MonadHandler m =>
ByteString -> FilePath -> Integer -> Integer -> m a
sendFilePart ByteString
ct FilePath
fp Integer
off Integer
count = do
fs <- IO FileStatus -> m FileStatus
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> m FileStatus) -> IO FileStatus -> m FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
PC.getFileStatus FilePath
fp
handlerError $ HCSendFile ct fp $ Just W.FilePart
{ W.filePartOffset = off
, W.filePartByteCount = count
, W.filePartFileSize = fromIntegral $ PC.fileSize fs
}
sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a
sendResponse :: forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse = HandlerContents -> m a
forall (m :: * -> *) a. MonadHandler m => HandlerContents -> m a
handlerError (HandlerContents -> m a) -> (c -> HandlerContents) -> c -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> TypedContent -> HandlerContents
HCContent Status
H.status200 (TypedContent -> HandlerContents)
-> (c -> TypedContent) -> c -> HandlerContents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> TypedContent
forall a. ToTypedContent a => a -> TypedContent
toTypedContent
sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a
sendResponseStatus :: forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
s = HandlerContents -> m a
forall (m :: * -> *) a. MonadHandler m => HandlerContents -> m a
handlerError (HandlerContents -> m a) -> (c -> HandlerContents) -> c -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> TypedContent -> HandlerContents
HCContent Status
s (TypedContent -> HandlerContents)
-> (c -> TypedContent) -> c -> HandlerContents
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> TypedContent
forall a. ToTypedContent a => a -> TypedContent
toTypedContent
sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a
sendStatusJSON :: forall (m :: * -> *) c a.
(MonadHandler m, ToJSON c) =>
Status -> c -> m a
sendStatusJSON Status
s c
v = Status -> Encoding -> m a
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
s (c -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding c
v)
sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a
sendResponseCreated :: forall (m :: * -> *) a.
MonadHandler m =>
Route (HandlerSite m) -> m a
sendResponseCreated Route (HandlerSite m)
url = do
r <- m (Route (HandlerSite m) -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
handlerError $ HCCreated $ r url
sendResponseNoContent :: MonadHandler m => m a
sendResponseNoContent :: forall (m :: * -> *) a. MonadHandler m => m a
sendResponseNoContent = Response -> m a
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse (Response -> m a) -> Response -> m a
forall a b. (a -> b) -> a -> b
$ Status -> [(CI ByteString, ByteString)] -> Builder -> Response
W.responseBuilder Status
H.status204 [] Builder
forall a. Monoid a => a
mempty
sendWaiResponse :: MonadHandler m => W.Response -> m b
sendWaiResponse :: forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse = HandlerContents -> m b
forall (m :: * -> *) a. MonadHandler m => HandlerContents -> m a
handlerError (HandlerContents -> m b)
-> (Response -> HandlerContents) -> Response -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> HandlerContents
HCWai
sendWaiApplication :: MonadHandler m => W.Application -> m b
sendWaiApplication :: forall (m :: * -> *) b. MonadHandler m => Application -> m b
sendWaiApplication = HandlerContents -> m b
forall (m :: * -> *) a. MonadHandler m => HandlerContents -> m a
handlerError (HandlerContents -> m b)
-> (Application -> HandlerContents) -> Application -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> HandlerContents
HCWaiApp
sendRawResponseNoConduit
:: (MonadHandler m, MonadUnliftIO m)
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
-> m a
sendRawResponseNoConduit :: forall (m :: * -> *) a.
(MonadHandler m, MonadUnliftIO m) =>
(IO ByteString -> (ByteString -> IO ()) -> m ()) -> m a
sendRawResponseNoConduit IO ByteString -> (ByteString -> IO ()) -> m ()
raw = ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ HandlerContents -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (HandlerContents -> IO a) -> HandlerContents -> IO a
forall a b. (a -> b) -> a -> b
$ Response -> HandlerContents
HCWai (Response -> HandlerContents) -> Response -> HandlerContents
forall a b. (a -> b) -> a -> b
$ ((IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response)
-> Response
-> (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
W.responseRaw Response
fallback
((IO ByteString -> (ByteString -> IO ()) -> IO ()) -> Response)
-> (IO ByteString -> (ByteString -> IO ()) -> IO ()) -> Response
forall a b. (a -> b) -> a -> b
$ \IO ByteString
src ByteString -> IO ()
sink -> IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ m () -> IO ()
forall a. m a -> IO a
runInIO (IO ByteString -> (ByteString -> IO ()) -> m ()
raw IO ByteString
src ByteString -> IO ()
sink)
where
fallback :: Response
fallback = Status -> [(CI ByteString, ByteString)] -> ByteString -> Response
W.responseLBS Status
H.status500 [(CI ByteString
"Content-Type", ByteString
"text/plain")]
ByteString
"sendRawResponse: backend does not support raw responses"
sendRawResponse
:: (MonadHandler m, MonadUnliftIO m)
=> (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())
-> m a
sendRawResponse :: forall (m :: * -> *) a.
(MonadHandler m, MonadUnliftIO m) =>
(ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO () -> m ())
-> m a
sendRawResponse ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO () -> m ()
raw = ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ HandlerContents -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (HandlerContents -> IO a) -> HandlerContents -> IO a
forall a b. (a -> b) -> a -> b
$ Response -> HandlerContents
HCWai (Response -> HandlerContents) -> Response -> HandlerContents
forall a b. (a -> b) -> a -> b
$ ((IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response)
-> Response
-> (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response
forall a b c. (a -> b -> c) -> b -> a -> c
flip (IO ByteString -> (ByteString -> IO ()) -> IO ())
-> Response -> Response
W.responseRaw Response
fallback
((IO ByteString -> (ByteString -> IO ()) -> IO ()) -> Response)
-> (IO ByteString -> (ByteString -> IO ()) -> IO ()) -> Response
forall a b. (a -> b) -> a -> b
$ \IO ByteString
src ByteString -> IO ()
sink -> IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> IO ()) -> m () -> IO ()
forall a b. (a -> b) -> a -> b
$ ConduitT () ByteString IO ()
-> ConduitT ByteString Void IO () -> m ()
raw (IO ByteString -> ConduitT () ByteString IO ()
forall {m :: * -> *} {i}.
MonadIO m =>
IO ByteString -> ConduitT i ByteString m ()
src' IO ByteString
src) ((ByteString -> IO ()) -> ConduitT ByteString Void IO ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
CL.mapM_ ByteString -> IO ()
sink)
where
fallback :: Response
fallback = Status -> [(CI ByteString, ByteString)] -> ByteString -> Response
W.responseLBS Status
H.status500 [(CI ByteString
"Content-Type", ByteString
"text/plain")]
ByteString
"sendRawResponse: backend does not support raw responses"
src' :: IO ByteString -> ConduitT i ByteString m ()
src' IO ByteString
src = do
bs <- IO ByteString -> ConduitT i ByteString m ByteString
forall a. IO a -> ConduitT i ByteString m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
src
unless (S.null bs) $ do
yield bs
src' src
notModified :: MonadHandler m => m a
notModified :: forall (m :: * -> *) a. MonadHandler m => m a
notModified = Response -> m a
forall (m :: * -> *) b. MonadHandler m => Response -> m b
sendWaiResponse (Response -> m a) -> Response -> m a
forall a b. (a -> b) -> a -> b
$ Status -> [(CI ByteString, ByteString)] -> Builder -> Response
W.responseBuilder Status
H.status304 [] Builder
forall a. Monoid a => a
mempty
notFound :: MonadHandler m => m a
notFound :: forall (m :: * -> *) a. MonadHandler m => m a
notFound = ErrorResponse -> m a
forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError ErrorResponse
NotFound
badMethod :: MonadHandler m => m a
badMethod :: forall (m :: * -> *) a. MonadHandler m => m a
badMethod = do
w <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
hcError $ BadMethod $ W.requestMethod w
notAuthenticated :: MonadHandler m => m a
notAuthenticated :: forall (m :: * -> *) a. MonadHandler m => m a
notAuthenticated = ErrorResponse -> m a
forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError ErrorResponse
NotAuthenticated
permissionDenied :: MonadHandler m => Text -> m a
permissionDenied :: forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied = ErrorResponse -> m a
forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError (ErrorResponse -> m a) -> (Text -> ErrorResponse) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ErrorResponse
PermissionDenied
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
=> msg
-> m a
permissionDeniedI :: forall (m :: * -> *) msg a.
(RenderMessage (HandlerSite m) msg, MonadHandler m) =>
msg -> m a
permissionDeniedI msg
msg = do
mr <- m (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
permissionDenied $ mr msg
invalidArgs :: MonadHandler m => [Text] -> m a
invalidArgs :: forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs = ErrorResponse -> m a
forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError (ErrorResponse -> m a)
-> ([Text] -> ErrorResponse) -> [Text] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> ErrorResponse
InvalidArgs
invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
invalidArgsI :: forall (m :: * -> *) msg a.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
[msg] -> m a
invalidArgsI [msg]
msg = do
mr <- m (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
invalidArgs $ map mr msg
setCookie :: MonadHandler m => SetCookie -> m ()
setCookie :: forall (m :: * -> *). MonadHandler m => SetCookie -> m ()
setCookie SetCookie
sc = do
Header -> m ()
forall (m :: * -> *). MonadHandler m => Header -> m ()
addHeaderInternal (ByteString -> ByteString -> Header
DeleteCookie ByteString
name ByteString
path)
Header -> m ()
forall (m :: * -> *). MonadHandler m => Header -> m ()
addHeaderInternal (SetCookie -> Header
AddCookie SetCookie
sc)
where name :: ByteString
name = SetCookie -> ByteString
setCookieName SetCookie
sc
path :: ByteString
path = ByteString
-> (ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"/" ByteString -> ByteString
forall a. a -> a
id (SetCookie -> Maybe ByteString
setCookiePath SetCookie
sc)
getExpires :: MonadIO m
=> Int
-> m UTCTime
getExpires :: forall (m :: * -> *). MonadIO m => Int -> m UTCTime
getExpires Int
m = do
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
return $ fromIntegral (m * 60) `addUTCTime` now
deleteCookie :: MonadHandler m
=> Text
-> Text
-> m ()
deleteCookie :: forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
deleteCookie Text
a = Header -> m ()
forall (m :: * -> *). MonadHandler m => Header -> m ()
addHeaderInternal (Header -> m ()) -> (Text -> Header) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Header
DeleteCookie (Text -> ByteString
encodeUtf8 Text
a) (ByteString -> Header) -> (Text -> ByteString) -> Text -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
setLanguage :: MonadHandler m => Text -> m ()
setLanguage :: forall (m :: * -> *). MonadHandler m => Text -> m ()
setLanguage = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
forall a. IsString a => a
langKey
addContentDispositionFileName :: MonadHandler m => T.Text -> m ()
addContentDispositionFileName :: forall (m :: * -> *). MonadHandler m => Text -> m ()
addContentDispositionFileName Text
fileName
= Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"Content-Disposition" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
rfc6266Utf8FileName Text
fileName
rfc6266Utf8FileName :: T.Text -> T.Text
rfc6266Utf8FileName :: Text -> Text
rfc6266Utf8FileName Text
fileName = Text
"attachment; filename*=UTF-8''" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Text
decodeUtf8 (Bool -> ByteString -> ByteString
H.urlEncode Bool
True (Text -> ByteString
encodeUtf8 Text
fileName))
addHeader :: MonadHandler m => Text -> Text -> m ()
Text
a = Header -> m ()
forall (m :: * -> *). MonadHandler m => Header -> m ()
addHeaderInternal (Header -> m ()) -> (Text -> Header) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString -> Header
Header (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
a) (ByteString -> Header) -> (Text -> ByteString) -> Text -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
setHeader :: MonadHandler m => Text -> Text -> m ()
= Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader
{-# DEPRECATED setHeader "Please use addHeader instead" #-}
replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
Text
a Text
b =
(GHState -> GHState) -> m ()
forall (m :: * -> *).
MonadHandler m =>
(GHState -> GHState) -> m ()
modify ((GHState -> GHState) -> m ()) -> (GHState -> GHState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHState
g -> GHState
g {ghsHeaders = replaceHeader (ghsHeaders g)}
where
repHeader :: Header
repHeader = CI ByteString -> ByteString -> Header
Header (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
a) (Text -> ByteString
encodeUtf8 Text
b)
sameHeaderName :: Header -> Header -> Bool
sameHeaderName :: Header -> Header -> Bool
sameHeaderName (Header CI ByteString
n1 ByteString
_) (Header CI ByteString
n2 ByteString
_) = CI ByteString
n1 CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
n2
sameHeaderName Header
_ Header
_ = Bool
False
replaceIndividualHeader :: [Header] -> [Header]
replaceIndividualHeader :: [Header] -> [Header]
replaceIndividualHeader [] = [Header
repHeader]
replaceIndividualHeader [Header]
xs = [Header] -> [Header] -> [Header]
aux [Header]
xs []
where
aux :: [Header] -> [Header] -> [Header]
aux [] [Header]
acc = [Header]
acc [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header
repHeader]
aux (Header
x:[Header]
xs') [Header]
acc =
if Header -> Header -> Bool
sameHeaderName Header
repHeader Header
x
then [Header]
acc [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++
[Header
repHeader] [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++
((Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Header
header -> Bool -> Bool
not (Header -> Header -> Bool
sameHeaderName Header
header Header
repHeader)) [Header]
xs')
else [Header] -> [Header] -> [Header]
aux [Header]
xs' ([Header]
acc [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header
x])
replaceHeader :: Endo [Header] -> Endo [Header]
replaceHeader :: Endo [Header] -> Endo [Header]
replaceHeader Endo [Header]
endo =
let [Header]
allHeaders :: [Header] = Endo [Header] -> [Header] -> [Header]
forall a. Endo a -> a -> a
appEndo Endo [Header]
endo []
in ([Header] -> [Header]) -> Endo [Header]
forall a. (a -> a) -> Endo a
Endo (\[Header]
rest -> [Header] -> [Header]
replaceIndividualHeader [Header]
allHeaders [Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++ [Header]
rest)
cacheSeconds :: MonadHandler m => Int -> m ()
cacheSeconds :: forall (m :: * -> *). MonadHandler m => Int -> m ()
cacheSeconds Int
i = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setHeader Text
"Cache-Control" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"max-age="
, FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i
, Text
", public"
]
neverExpires :: MonadHandler m => m ()
neverExpires :: forall (m :: * -> *). MonadHandler m => m ()
neverExpires = do
Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setHeader Text
"Expires" (Text -> m ())
-> (RunHandlerEnv (HandlerSite m) (HandlerSite m) -> Text)
-> RunHandlerEnv (HandlerSite m) (HandlerSite m)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunHandlerEnv (HandlerSite m) (HandlerSite m) -> Text
forall child site. RunHandlerEnv child site -> Text
rheMaxExpires (RunHandlerEnv (HandlerSite m) (HandlerSite m) -> m ())
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
Int -> m ()
forall (m :: * -> *). MonadHandler m => Int -> m ()
cacheSeconds Int
oneYear
where
oneYear :: Int
oneYear :: Int
oneYear = Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
365
alreadyExpired :: MonadHandler m => m ()
alreadyExpired :: forall (m :: * -> *). MonadHandler m => m ()
alreadyExpired = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setHeader Text
"Expires" Text
"Thu, 01 Jan 1970 05:05:05 GMT"
expiresAt :: MonadHandler m => UTCTime -> m ()
expiresAt :: forall (m :: * -> *). MonadHandler m => UTCTime -> m ()
expiresAt = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setHeader Text
"Expires" (Text -> m ()) -> (UTCTime -> Text) -> UTCTime -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Text
formatRFC1123
data Etag
= WeakEtag !S.ByteString
| StrongEtag !S.ByteString
| InvalidEtag !S.ByteString
deriving (Int -> Etag -> ShowS
[Etag] -> ShowS
Etag -> FilePath
(Int -> Etag -> ShowS)
-> (Etag -> FilePath) -> ([Etag] -> ShowS) -> Show Etag
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Etag -> ShowS
showsPrec :: Int -> Etag -> ShowS
$cshow :: Etag -> FilePath
show :: Etag -> FilePath
$cshowList :: [Etag] -> ShowS
showList :: [Etag] -> ShowS
Show, Etag -> Etag -> Bool
(Etag -> Etag -> Bool) -> (Etag -> Etag -> Bool) -> Eq Etag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Etag -> Etag -> Bool
== :: Etag -> Etag -> Bool
$c/= :: Etag -> Etag -> Bool
/= :: Etag -> Etag -> Bool
Eq)
setEtag :: MonadHandler m => Text -> m ()
setEtag :: forall (m :: * -> *). MonadHandler m => Text -> m ()
setEtag Text
etag = do
mmatch <- CI ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"if-none-match"
let matches = [Etag] -> (ByteString -> [Etag]) -> Maybe ByteString -> [Etag]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [Etag]
parseMatch Maybe ByteString
mmatch
baseTag = Text -> ByteString
encodeUtf8 Text
etag
strongTag = ByteString -> Etag
StrongEtag ByteString
baseTag
badTag = ByteString -> Etag
InvalidEtag ByteString
baseTag
if any (\Etag
tag -> Etag
tag Etag -> Etag -> Bool
forall a. Eq a => a -> a -> Bool
== Etag
strongTag Bool -> Bool -> Bool
|| Etag
tag Etag -> Etag -> Bool
forall a. Eq a => a -> a -> Bool
== Etag
badTag) matches
then notModified
else addHeader "etag" $ T.concat ["\"", etag, "\""]
parseMatch :: S.ByteString -> [Etag]
parseMatch :: ByteString -> [Etag]
parseMatch =
(ByteString -> Etag) -> [ByteString] -> [Etag]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Etag
clean ([ByteString] -> [Etag])
-> (ByteString -> [ByteString]) -> ByteString -> [Etag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
W8._comma
where
clean :: ByteString -> Etag
clean = ByteString -> Etag
classify (ByteString -> Etag)
-> (ByteString -> ByteString) -> ByteString -> Etag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> ByteString
forall a b. (a, b) -> a
fst (Param -> ByteString)
-> (ByteString -> Param) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> Param
S.spanEnd Word8 -> Bool
W8.isSpace (ByteString -> Param)
-> (ByteString -> ByteString) -> ByteString -> Param
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile Word8 -> Bool
W8.isSpace
classify :: ByteString -> Etag
classify ByteString
bs
| ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
S.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._quotedbl Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._quotedbl
= ByteString -> Etag
StrongEtag (ByteString -> Etag) -> ByteString -> Etag
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.tail ByteString
bs
| ByteString -> Int
S.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4 Bool -> Bool -> Bool
&&
HasCallStack => ByteString -> Word8
ByteString -> Word8
S.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._W Bool -> Bool -> Bool
&&
HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
S.index ByteString
bs Int
1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._slash Bool -> Bool -> Bool
&&
HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
S.index ByteString
bs Int
2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._quotedbl Bool -> Bool -> Bool
&&
HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._quotedbl
= ByteString -> Etag
WeakEtag (ByteString -> Etag) -> ByteString -> Etag
forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> ByteString
ByteString -> ByteString
S.init (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
S.drop Int
3 ByteString
bs
| Bool
otherwise = ByteString -> Etag
InvalidEtag ByteString
bs
setWeakEtag :: MonadHandler m => Text -> m ()
setWeakEtag :: forall (m :: * -> *). MonadHandler m => Text -> m ()
setWeakEtag Text
etag = do
mmatch <- CI ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"if-none-match"
let matches = [Etag] -> (ByteString -> [Etag]) -> Maybe ByteString -> [Etag]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [Etag]
parseMatch Maybe ByteString
mmatch
if WeakEtag (encodeUtf8 etag) `elem` matches
then notModified
else addHeader "etag" $ T.concat ["W/\"", etag, "\""]
setSession :: MonadHandler m
=> Text
-> Text
-> m ()
setSession :: forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
k = Text -> ByteString -> m ()
forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
k (ByteString -> m ()) -> (Text -> ByteString) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8
setSessionBS :: MonadHandler m
=> Text
-> S.ByteString
-> m ()
setSessionBS :: forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
k = (GHState -> GHState) -> m ()
forall (m :: * -> *).
MonadHandler m =>
(GHState -> GHState) -> m ()
modify ((GHState -> GHState) -> m ())
-> (ByteString -> GHState -> GHState) -> ByteString -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionMap -> SessionMap) -> GHState -> GHState
modSession ((SessionMap -> SessionMap) -> GHState -> GHState)
-> (ByteString -> SessionMap -> SessionMap)
-> ByteString
-> GHState
-> GHState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString -> SessionMap -> SessionMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
k
deleteSession :: MonadHandler m => Text -> m ()
deleteSession :: forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession = (GHState -> GHState) -> m ()
forall (m :: * -> *).
MonadHandler m =>
(GHState -> GHState) -> m ()
modify ((GHState -> GHState) -> m ())
-> (Text -> GHState -> GHState) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionMap -> SessionMap) -> GHState -> GHState
modSession ((SessionMap -> SessionMap) -> GHState -> GHState)
-> (Text -> SessionMap -> SessionMap) -> Text -> GHState -> GHState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SessionMap -> SessionMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete
clearSession :: MonadHandler m => m ()
clearSession :: forall (m :: * -> *). MonadHandler m => m ()
clearSession = (GHState -> GHState) -> m ()
forall (m :: * -> *).
MonadHandler m =>
(GHState -> GHState) -> m ()
modify ((GHState -> GHState) -> m ()) -> (GHState -> GHState) -> m ()
forall a b. (a -> b) -> a -> b
$ \GHState
x -> GHState
x { ghsSession = Map.empty }
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession SessionMap -> SessionMap
f GHState
x = GHState
x { ghsSession = f $ ghsSession x }
addHeaderInternal :: MonadHandler m => Header -> m ()
= Endo [Header] -> m ()
forall (m :: * -> *). MonadHandler m => Endo [Header] -> m ()
tell (Endo [Header] -> m ())
-> (Header -> Endo [Header]) -> Header -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Header] -> [Header]) -> Endo [Header]
forall a. (a -> a) -> Endo a
Endo (([Header] -> [Header]) -> Endo [Header])
-> (Header -> [Header] -> [Header]) -> Header -> Endo [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)
class RedirectUrl master a where
toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text
instance RedirectUrl master Text where
toTextUrl :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
Text -> m Text
toTextUrl = Text -> m Text
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
instance RedirectUrl master String where
toTextUrl :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
FilePath -> m Text
toTextUrl = Text -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
Text -> m Text
toTextUrl (Text -> m Text) -> (FilePath -> Text) -> FilePath -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
instance RedirectUrl master (Route master) where
toTextUrl :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
Route master -> m Text
toTextUrl Route master
url = do
r <- m (Route master -> Text)
m (Route (HandlerSite m) -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
return $ r url
instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where
toTextUrl :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
(Route master, [(key, val)]) -> m Text
toTextUrl (Route master
url, [(key, val)]
params) = do
r <- m (Route master -> [(key, val)] -> Text)
m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams
return $ r url params
instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where
toTextUrl :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
(Route master, Map key val) -> m Text
toTextUrl (Route master
url, Map key val
params) = (Route master, [(key, val)]) -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
(Route master, [(key, val)]) -> m Text
toTextUrl (Route master
url, Map key val -> [(key, val)]
forall k a. Map k a -> [(k, a)]
Map.toList Map key val
params)
data Fragment a b = a :#: b deriving Int -> Fragment a b -> ShowS
[Fragment a b] -> ShowS
Fragment a b -> FilePath
(Int -> Fragment a b -> ShowS)
-> (Fragment a b -> FilePath)
-> ([Fragment a b] -> ShowS)
-> Show (Fragment a b)
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Fragment a b -> ShowS
forall a b. (Show a, Show b) => [Fragment a b] -> ShowS
forall a b. (Show a, Show b) => Fragment a b -> FilePath
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Fragment a b -> ShowS
showsPrec :: Int -> Fragment a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => Fragment a b -> FilePath
show :: Fragment a b -> FilePath
$cshowList :: forall a b. (Show a, Show b) => [Fragment a b] -> ShowS
showList :: [Fragment a b] -> ShowS
Show
instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
toTextUrl :: forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
Fragment a b -> m Text
toTextUrl (a
a :#: b
b) = (\Text
ua -> [Text] -> Text
T.concat [Text
ua, Text
"#", b -> Text
forall s. PathPiece s => s -> Text
toPathPiece b
b]) (Text -> Text) -> m Text -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
toTextUrl a
a
lookupSession :: MonadHandler m => Text -> m (Maybe Text)
lookupSession :: forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession = ((Maybe ByteString -> Maybe Text)
-> m (Maybe ByteString) -> m (Maybe Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe ByteString -> Maybe Text)
-> m (Maybe ByteString) -> m (Maybe Text))
-> ((ByteString -> Text) -> Maybe ByteString -> Maybe Text)
-> (ByteString -> Text)
-> m (Maybe ByteString)
-> m (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode) (m (Maybe ByteString) -> m (Maybe Text))
-> (Text -> m (Maybe ByteString)) -> Text -> m (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS
lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)
lookupSessionBS :: forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
n = do
m <- (GHState -> SessionMap) -> m GHState -> m SessionMap
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GHState -> SessionMap
ghsSession m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
return $ Map.lookup n m
getSession :: MonadHandler m => m SessionMap
getSession :: forall (m :: * -> *). MonadHandler m => m SessionMap
getSession = (GHState -> SessionMap) -> m GHState -> m SessionMap
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GHState -> SessionMap
ghsSession m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
newIdent :: MonadHandler m => m Text
newIdent :: forall (m :: * -> *). MonadHandler m => m Text
newIdent = do
x <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
let i' = GHState -> Int
ghsIdent GHState
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
put x { ghsIdent = i' }
return $ T.pack $ "hident" ++ show i'
redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
=> url
-> m a
redirectToPost :: forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirectToPost url
url = do
urlText <- url -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ HandlerSite m) =>
url -> m Text
toTextUrl url
url
req <- getRequest
withUrlRenderer [hamlet|
$newline never
$doctype 5
<html>
<head>
<title>Redirecting...
<body>
<form id="form" method="post" action=#{urlText}>
$maybe token <- reqToken req
<input type=hidden name=#{defaultCsrfParamName} value=#{token}>
<noscript>
<p>Javascript has been disabled; please click on the button below to be redirected.
<input type="submit" value="Continue">
<script>
window.onload = function() { document.getElementById('form').submit(); };
|] >>= sendResponse
hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html
hamletToRepHtml :: forall (m :: * -> *).
MonadHandler m =>
HtmlUrl (Route (HandlerSite m)) -> m Html
hamletToRepHtml = ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> Html)
-> m Html
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer
{-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-}
giveUrlRenderer :: MonadHandler m
=> ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
giveUrlRenderer :: forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
giveUrlRenderer = ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer
{-# DEPRECATED giveUrlRenderer "Use withUrlRenderer instead" #-}
withUrlRenderer :: MonadHandler m
=> ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer :: forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer (Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output
f = do
render <- m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams
return $ f render
waiRequest :: MonadHandler m => m W.Request
waiRequest :: forall (m :: * -> *). MonadHandler m => m Request
waiRequest = YesodRequest -> Request
reqWaiRequest (YesodRequest -> Request) -> m YesodRequest -> m Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message)
=> m (message -> Text)
getMessageRender :: forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender = do
env <- m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
l <- languages
return $ renderMessage (rheSite env) l
cached :: (MonadHandler m, Typeable a)
=> m a
-> m a
cached :: forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m a -> m a
cached m a
action = do
cache <- GHState -> TypeMap
ghsCache (GHState -> TypeMap) -> m GHState -> m TypeMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
eres <- Cache.cached cache action
case eres of
Right a
res -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
Left (TypeMap
newCache, a
res) -> do
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
let merged = TypeMap
newCache TypeMap -> TypeMap -> TypeMap
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
`HM.union` GHState -> TypeMap
ghsCache GHState
gs
put $ gs { ghsCache = merged }
return res
cacheGet :: (MonadHandler m, Typeable a)
=> m (Maybe a)
cacheGet :: forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m (Maybe a)
cacheGet = do
cache <- GHState -> TypeMap
ghsCache (GHState -> TypeMap) -> m GHState -> m TypeMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
pure $ Cache.cacheGet cache
cacheSet :: (MonadHandler m, Typeable a)
=> a
-> m ()
cacheSet :: forall (m :: * -> *) a. (MonadHandler m, Typeable a) => a -> m ()
cacheSet a
value = do
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
let cache = GHState -> TypeMap
ghsCache GHState
gs
newCache = a -> TypeMap -> TypeMap
forall a. Typeable a => a -> TypeMap -> TypeMap
Cache.cacheSet a
value TypeMap
cache
put $ gs { ghsCache = newCache }
cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a
cachedBy :: forall (m :: * -> *) a.
(MonadHandler m, Typeable a) =>
ByteString -> m a -> m a
cachedBy ByteString
k m a
action = do
cache <- GHState -> KeyedTypeMap
ghsCacheBy (GHState -> KeyedTypeMap) -> m GHState -> m KeyedTypeMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
eres <- Cache.cachedBy cache k action
case eres of
Right a
res -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
Left (KeyedTypeMap
newCache, a
res) -> do
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
let merged = KeyedTypeMap
newCache KeyedTypeMap -> KeyedTypeMap -> KeyedTypeMap
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
`HM.union` GHState -> KeyedTypeMap
ghsCacheBy GHState
gs
put $ gs { ghsCacheBy = merged }
return res
cacheByGet :: (MonadHandler m, Typeable a)
=> S.ByteString
-> m (Maybe a)
cacheByGet :: forall (m :: * -> *) a.
(MonadHandler m, Typeable a) =>
ByteString -> m (Maybe a)
cacheByGet ByteString
key = do
cache <- GHState -> KeyedTypeMap
ghsCacheBy (GHState -> KeyedTypeMap) -> m GHState -> m KeyedTypeMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
pure $ Cache.cacheByGet key cache
cacheBySet :: (MonadHandler m, Typeable a)
=> S.ByteString
-> a
-> m ()
cacheBySet :: forall (m :: * -> *) a.
(MonadHandler m, Typeable a) =>
ByteString -> a -> m ()
cacheBySet ByteString
key a
value = do
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
let cache = GHState -> KeyedTypeMap
ghsCacheBy GHState
gs
newCache = ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
forall a.
Typeable a =>
ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
Cache.cacheBySet ByteString
key a
value KeyedTypeMap
cache
put $ gs { ghsCacheBy = newCache }
languages :: MonadHandler m => m [Text]
languages :: forall (m :: * -> *). MonadHandler m => m [Text]
languages = YesodRequest -> [Text]
reqLangs (YesodRequest -> [Text]) -> m YesodRequest -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
lookup' :: Eq a => a -> [(a, b)] -> [b]
lookup' :: forall a b. Eq a => a -> [(a, b)] -> [b]
lookup' a
a = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd ([(a, b)] -> [b]) -> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a, b)
x -> a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
x)
lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)
= ([ByteString] -> Maybe ByteString)
-> m [ByteString] -> m (Maybe ByteString)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe (m [ByteString] -> m (Maybe ByteString))
-> (CI ByteString -> m [ByteString])
-> CI ByteString
-> m (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> m [ByteString]
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m [ByteString]
lookupHeaders
lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString]
CI ByteString
key = do
req <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
return $ lookup' key $ W.requestHeaders req
lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))
lookupBasicAuth :: forall (m :: * -> *). MonadHandler m => m (Maybe (Text, Text))
lookupBasicAuth = (Maybe ByteString -> Maybe (Text, Text))
-> m (Maybe ByteString) -> m (Maybe (Text, Text))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ByteString
-> (ByteString -> Maybe (Text, Text)) -> Maybe (Text, Text)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Text, Text)
getBA) (CI ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"Authorization")
where
getBA :: ByteString -> Maybe (Text, Text)
getBA ByteString
bs = (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (ByteString -> Text) -> Param -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode)
(Param -> (Text, Text)) -> Maybe Param -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe Param
extractBasicAuth ByteString
bs
lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)
lookupBearerAuth :: forall (m :: * -> *). MonadHandler m => m (Maybe Text)
lookupBearerAuth = (Maybe ByteString -> Maybe Text)
-> m (Maybe ByteString) -> m (Maybe Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ByteString -> (ByteString -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Text
getBR)
(CI ByteString -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Maybe ByteString)
lookupHeader CI ByteString
"Authorization")
where
getBR :: ByteString -> Maybe Text
getBR ByteString
bs = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode
(ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe ByteString
extractBearerAuth ByteString
bs
lookupGetParams :: MonadHandler m => Text -> m [Text]
lookupGetParams :: forall (m :: * -> *). MonadHandler m => Text -> m [Text]
lookupGetParams Text
pn = do
rr <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
return $ lookup' pn $ reqGetParams rr
lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)
lookupGetParam :: forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam = ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe (m [Text] -> m (Maybe Text))
-> (Text -> m [Text]) -> Text -> m (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [Text]
forall (m :: * -> *). MonadHandler m => Text -> m [Text]
lookupGetParams
lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]
lookupPostParams :: forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m [Text]
lookupPostParams Text
pn = do
(pp, _) <- m RequestBodyContents
forall (m :: * -> *). MonadHandler m => m RequestBodyContents
runRequestBody
return $ lookup' pn pp
lookupPostParam :: (MonadResource m, MonadHandler m)
=> Text
-> m (Maybe Text)
lookupPostParam :: forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m (Maybe Text)
lookupPostParam = ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe (m [Text] -> m (Maybe Text))
-> (Text -> m [Text]) -> Text -> m (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [Text]
forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m [Text]
lookupPostParams
lookupFile :: MonadHandler m
=> Text
-> m (Maybe FileInfo)
lookupFile :: forall (m :: * -> *). MonadHandler m => Text -> m (Maybe FileInfo)
lookupFile = ([FileInfo] -> Maybe FileInfo)
-> m [FileInfo] -> m (Maybe FileInfo)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FileInfo] -> Maybe FileInfo
forall a. [a] -> Maybe a
listToMaybe (m [FileInfo] -> m (Maybe FileInfo))
-> (Text -> m [FileInfo]) -> Text -> m (Maybe FileInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [FileInfo]
forall (m :: * -> *). MonadHandler m => Text -> m [FileInfo]
lookupFiles
lookupFiles :: MonadHandler m
=> Text
-> m [FileInfo]
lookupFiles :: forall (m :: * -> *). MonadHandler m => Text -> m [FileInfo]
lookupFiles Text
pn = do
(_, files) <- m RequestBodyContents
forall (m :: * -> *). MonadHandler m => m RequestBodyContents
runRequestBody
return $ lookup' pn files
lookupCookie :: MonadHandler m => Text -> m (Maybe Text)
lookupCookie :: forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupCookie = ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe (m [Text] -> m (Maybe Text))
-> (Text -> m [Text]) -> Text -> m (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> m [Text]
forall (m :: * -> *). MonadHandler m => Text -> m [Text]
lookupCookies
lookupCookies :: MonadHandler m => Text -> m [Text]
lookupCookies :: forall (m :: * -> *). MonadHandler m => Text -> m [Text]
lookupCookies Text
pn = do
rr <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
return $ lookup' pn $ reqCookies rr
selectRep :: MonadHandler m
=> Writer.Writer (Endo [ProvidedRep m]) ()
-> m TypedContent
selectRep :: forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep Writer (Endo [ProvidedRep m]) ()
w = do
cts <- (YesodRequest -> [ByteString]) -> m YesodRequest -> m [ByteString]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap YesodRequest -> [ByteString]
reqAccept m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
case mapMaybe tryAccept cts of
[] ->
case [ProvidedRep m]
reps of
[] -> Status -> Text -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
H.status500 (Text
"No reps provided to selectRep" :: Text)
ProvidedRep m
rep:[ProvidedRep m]
_ -> ProvidedRep m -> m TypedContent
forall {f :: * -> *}. Functor f => ProvidedRep f -> f TypedContent
returnRep ProvidedRep m
rep
ProvidedRep m
rep:[ProvidedRep m]
_ -> ProvidedRep m -> m TypedContent
forall {f :: * -> *}. Functor f => ProvidedRep f -> f TypedContent
returnRep ProvidedRep m
rep
where
returnRep :: ProvidedRep f -> f TypedContent
returnRep (ProvidedRep ByteString
ct f Content
mcontent) = (Content -> TypedContent) -> f Content -> f TypedContent
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Content -> TypedContent
TypedContent ByteString
ct) f Content
mcontent
reps :: [ProvidedRep m]
reps = Endo [ProvidedRep m] -> [ProvidedRep m] -> [ProvidedRep m]
forall a. Endo a -> a -> a
appEndo (Writer (Endo [ProvidedRep m]) () -> Endo [ProvidedRep m]
forall w a. Writer w a -> w
Writer.execWriter Writer (Endo [ProvidedRep m]) ()
w) []
repMap :: Map ByteString (ProvidedRep m)
repMap = [Map ByteString (ProvidedRep m)] -> Map ByteString (ProvidedRep m)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([Map ByteString (ProvidedRep m)]
-> Map ByteString (ProvidedRep m))
-> [Map ByteString (ProvidedRep m)]
-> Map ByteString (ProvidedRep m)
forall a b. (a -> b) -> a -> b
$ (ProvidedRep m -> Map ByteString (ProvidedRep m))
-> [ProvidedRep m] -> [Map ByteString (ProvidedRep m)]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: ProvidedRep m
v@(ProvidedRep ByteString
k m Content
_) -> [(ByteString, ProvidedRep m)] -> Map ByteString (ProvidedRep m)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (ByteString
k, ProvidedRep m
v)
, (ByteString -> ByteString
noSpace ByteString
k, ProvidedRep m
v)
, (ByteString -> ByteString
simpleContentType ByteString
k, ProvidedRep m
v)
]) [ProvidedRep m]
reps
mainTypeMap :: Map ByteString (ProvidedRep m)
mainTypeMap = [(ByteString, ProvidedRep m)] -> Map ByteString (ProvidedRep m)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ByteString, ProvidedRep m)] -> Map ByteString (ProvidedRep m))
-> [(ByteString, ProvidedRep m)] -> Map ByteString (ProvidedRep m)
forall a b. (a -> b) -> a -> b
$ [(ByteString, ProvidedRep m)] -> [(ByteString, ProvidedRep m)]
forall a. [a] -> [a]
reverse ([(ByteString, ProvidedRep m)] -> [(ByteString, ProvidedRep m)])
-> [(ByteString, ProvidedRep m)] -> [(ByteString, ProvidedRep m)]
forall a b. (a -> b) -> a -> b
$ (ProvidedRep m -> (ByteString, ProvidedRep m))
-> [ProvidedRep m] -> [(ByteString, ProvidedRep m)]
forall a b. (a -> b) -> [a] -> [b]
map
(\v :: ProvidedRep m
v@(ProvidedRep ByteString
ct m Content
_) -> (Param -> ByteString
forall a b. (a, b) -> a
fst (Param -> ByteString) -> Param -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Param
contentTypeTypes ByteString
ct, ProvidedRep m
v)) [ProvidedRep m]
reps
tryAccept :: ByteString -> Maybe (ProvidedRep m)
tryAccept ByteString
ct =
if ByteString
subType ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"*"
then if ByteString
mainType ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"*"
then [ProvidedRep m] -> Maybe (ProvidedRep m)
forall a. [a] -> Maybe a
listToMaybe [ProvidedRep m]
reps
else ByteString
-> Map ByteString (ProvidedRep m) -> Maybe (ProvidedRep m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
mainType Map ByteString (ProvidedRep m)
mainTypeMap
else ByteString -> Maybe (ProvidedRep m)
lookupAccept ByteString
ct
where
(ByteString
mainType, ByteString
subType) = ByteString -> Param
contentTypeTypes ByteString
ct
lookupAccept :: ByteString -> Maybe (ProvidedRep m)
lookupAccept ByteString
ct = ByteString
-> Map ByteString (ProvidedRep m) -> Maybe (ProvidedRep m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
ct Map ByteString (ProvidedRep m)
repMap Maybe (ProvidedRep m)
-> Maybe (ProvidedRep m) -> Maybe (ProvidedRep m)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
ByteString
-> Map ByteString (ProvidedRep m) -> Maybe (ProvidedRep m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> ByteString
noSpace ByteString
ct) Map ByteString (ProvidedRep m)
repMap Maybe (ProvidedRep m)
-> Maybe (ProvidedRep m) -> Maybe (ProvidedRep m)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
ByteString
-> Map ByteString (ProvidedRep m) -> Maybe (ProvidedRep m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ByteString -> ByteString
simpleContentType ByteString
ct) Map ByteString (ProvidedRep m)
repMap
noSpace :: ByteString -> ByteString
noSpace = (Char -> Bool) -> ByteString -> ByteString
S8.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')
data ProvidedRep m = ProvidedRep !ContentType !(m Content)
provideRep :: (Monad m, HasContentType a)
=> m a
-> Writer.Writer (Endo [ProvidedRep m]) ()
provideRep :: forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep m a
handler = ByteString -> m a -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, ToContent a) =>
ByteString -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType (m a -> ByteString
forall a (m :: * -> *).
(HasContentType a, Monad m) =>
m a -> ByteString
forall (m :: * -> *). Monad m => m a -> ByteString
getContentType m a
handler) m a
handler
provideRepType :: (Monad m, ToContent a)
=> ContentType
-> m a
-> Writer.Writer (Endo [ProvidedRep m]) ()
provideRepType :: forall (m :: * -> *) a.
(Monad m, ToContent a) =>
ByteString -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType ByteString
ct m a
handler =
Endo [ProvidedRep m] -> WriterT (Endo [ProvidedRep m]) Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell (Endo [ProvidedRep m]
-> WriterT (Endo [ProvidedRep m]) Identity ())
-> Endo [ProvidedRep m]
-> WriterT (Endo [ProvidedRep m]) Identity ()
forall a b. (a -> b) -> a -> b
$ ([ProvidedRep m] -> [ProvidedRep m]) -> Endo [ProvidedRep m]
forall a. (a -> a) -> Endo a
Endo (ByteString -> m Content -> ProvidedRep m
forall (m :: * -> *). ByteString -> m Content -> ProvidedRep m
ProvidedRep ByteString
ct ((a -> Content) -> m a -> m Content
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Content
forall a. ToContent a => a -> Content
toContent m a
handler)ProvidedRep m -> [ProvidedRep m] -> [ProvidedRep m]
forall a. a -> [a] -> [a]
:)
rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()
rawRequestBody :: forall (m :: * -> *) i.
MonadHandler m =>
ConduitT i ByteString m ()
rawRequestBody = do
req <- m Request -> ConduitT i ByteString m Request
forall (m :: * -> *) a. Monad m => m a -> ConduitT i ByteString m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
let loop = do
bs <- IO ByteString -> ConduitT i ByteString m ByteString
forall a. IO a -> ConduitT i ByteString m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ConduitT i ByteString m ByteString)
-> IO ByteString -> ConduitT i ByteString m ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
W.requestBody Request
req
unless (S.null bs) $ do
yield bs
loop
loop
fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()
fileSource :: forall (m :: * -> *).
MonadResource m =>
FileInfo -> ConduitT () ByteString m ()
fileSource = (forall a. ResourceT IO a -> m a)
-> ConduitT () ByteString (ResourceT IO) ()
-> ConduitT () ByteString m ()
forall (m :: * -> *) (n :: * -> *) i o r.
Monad m =>
(forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
transPipe ResourceT IO a -> m a
forall a. ResourceT IO a -> m a
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (ConduitT () ByteString (ResourceT IO) ()
-> ConduitT () ByteString m ())
-> (FileInfo -> ConduitT () ByteString (ResourceT IO) ())
-> FileInfo
-> ConduitT () ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo -> ConduitT () ByteString (ResourceT IO) ()
fileSourceRaw
fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString
fileSourceByteString :: forall (m :: * -> *). MonadResource m => FileInfo -> m ByteString
fileSourceByteString FileInfo
fileInfo = ConduitT () Void m ByteString -> m ByteString
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ByteString -> ByteString
L.toStrict (ByteString -> ByteString)
-> ConduitT () Void m ByteString -> ConduitT () Void m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FileInfo -> ConduitT () ByteString m ()
forall (m :: * -> *).
MonadResource m =>
FileInfo -> ConduitT () ByteString m ()
fileSource FileInfo
fileInfo ConduitT () ByteString m ()
-> ConduitT ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void m ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy))
respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent
respond :: forall (m :: * -> *) a.
(Monad m, ToContent a) =>
ByteString -> a -> m TypedContent
respond ByteString
ct = TypedContent -> m TypedContent
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedContent -> m TypedContent)
-> (a -> TypedContent) -> a -> m TypedContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Content -> TypedContent
TypedContent ByteString
ct (Content -> TypedContent) -> (a -> Content) -> a -> TypedContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Content
forall a. ToContent a => a -> Content
toContent
respondSource :: ContentType
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondSource :: forall site.
ByteString
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerFor site TypedContent
respondSource ByteString
ctype ConduitT () (Flush Builder) (HandlerFor site) ()
src = (HandlerData site site -> IO TypedContent)
-> HandlerFor site TypedContent
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData site site -> IO TypedContent)
-> HandlerFor site TypedContent)
-> (HandlerData site site -> IO TypedContent)
-> HandlerFor site TypedContent
forall a b. (a -> b) -> a -> b
$ \HandlerData site site
hd ->
TypedContent -> IO TypedContent
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedContent -> IO TypedContent)
-> TypedContent -> IO TypedContent
forall a b. (a -> b) -> a -> b
$ ByteString -> Content -> TypedContent
TypedContent ByteString
ctype (Content -> TypedContent) -> Content -> TypedContent
forall a b. (a -> b) -> a -> b
$ ConduitT () (Flush Builder) (ResourceT IO) () -> Content
ContentSource
(ConduitT () (Flush Builder) (ResourceT IO) () -> Content)
-> ConduitT () (Flush Builder) (ResourceT IO) () -> Content
forall a b. (a -> b) -> a -> b
$ (forall a. HandlerFor site a -> ResourceT IO a)
-> ConduitT () (Flush Builder) (HandlerFor site) ()
-> ConduitT () (Flush Builder) (ResourceT IO) ()
forall (m :: * -> *) (n :: * -> *) i o r.
Monad m =>
(forall a. m a -> n a) -> ConduitT i o m r -> ConduitT i o n r
transPipe (IO a -> ResourceT IO a
forall (m :: * -> *) a. Monad m => m a -> ResourceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ResourceT IO a)
-> (HandlerFor site a -> IO a)
-> HandlerFor site a
-> ResourceT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HandlerFor site a -> HandlerData site site -> IO a)
-> HandlerData site site -> HandlerFor site a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip HandlerFor site a -> HandlerData site site -> IO a
forall site a. HandlerFor site a -> HandlerData site site -> IO a
unHandlerFor HandlerData site site
hd) ConduitT () (Flush Builder) (HandlerFor site) ()
src
sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()
sendChunk :: forall (m :: * -> *) a i.
(Monad m, ToFlushBuilder a) =>
a -> ConduitT i (Flush Builder) m ()
sendChunk = Flush Builder -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Flush Builder -> ConduitT i (Flush Builder) m ())
-> (a -> Flush Builder) -> a -> ConduitT i (Flush Builder) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Flush Builder
forall a. ToFlushBuilder a => a -> Flush Builder
toFlushBuilder
sendFlush :: Monad m => ConduitT i (Flush Builder) m ()
sendFlush :: forall (m :: * -> *) i. Monad m => ConduitT i (Flush Builder) m ()
sendFlush = Flush Builder -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Flush Builder
forall a. Flush a
Flush
sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkBS :: forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i (Flush Builder) m ()
sendChunkBS = ByteString -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) a i.
(Monad m, ToFlushBuilder a) =>
a -> ConduitT i (Flush Builder) m ()
sendChunk
sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkLBS :: forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i (Flush Builder) m ()
sendChunkLBS = ByteString -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) a i.
(Monad m, ToFlushBuilder a) =>
a -> ConduitT i (Flush Builder) m ()
sendChunk
sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()
sendChunkText :: forall (m :: * -> *) i.
Monad m =>
Text -> ConduitT i (Flush Builder) m ()
sendChunkText = Text -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) a i.
(Monad m, ToFlushBuilder a) =>
a -> ConduitT i (Flush Builder) m ()
sendChunk
sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()
sendChunkLazyText :: forall (m :: * -> *) i.
Monad m =>
Text -> ConduitT i (Flush Builder) m ()
sendChunkLazyText = Text -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) a i.
(Monad m, ToFlushBuilder a) =>
a -> ConduitT i (Flush Builder) m ()
sendChunk
sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()
sendChunkHtml :: forall (m :: * -> *) i.
Monad m =>
Html -> ConduitT i (Flush Builder) m ()
sendChunkHtml = Html -> ConduitT i (Flush Builder) m ()
forall (m :: * -> *) a i.
(Monad m, ToFlushBuilder a) =>
a -> ConduitT i (Flush Builder) m ()
sendChunk
defaultCsrfCookieName :: S8.ByteString
defaultCsrfCookieName :: ByteString
defaultCsrfCookieName = ByteString
"XSRF-TOKEN"
setCsrfCookie :: MonadHandler m => m ()
setCsrfCookie :: forall (m :: * -> *). MonadHandler m => m ()
setCsrfCookie = SetCookie -> m ()
forall (m :: * -> *). MonadHandler m => SetCookie -> m ()
setCsrfCookieWithCookie SetCookie
defaultSetCookie
{ setCookieName = defaultCsrfCookieName
, setCookiePath = Just "/"
}
setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m ()
setCsrfCookieWithCookie :: forall (m :: * -> *). MonadHandler m => SetCookie -> m ()
setCsrfCookieWithCookie SetCookie
cookie = do
mCsrfToken <- YesodRequest -> Maybe Text
reqToken (YesodRequest -> Maybe Text) -> m YesodRequest -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
Fold.forM_ mCsrfToken (\Text
token -> SetCookie -> m ()
forall (m :: * -> *). MonadHandler m => SetCookie -> m ()
setCookie (SetCookie -> m ()) -> SetCookie -> m ()
forall a b. (a -> b) -> a -> b
$ SetCookie
cookie { setCookieValue = encodeUtf8 token })
defaultCsrfHeaderName :: CI S8.ByteString
= CI ByteString
"X-XSRF-TOKEN"
checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m ()
CI ByteString
headerName = do
(valid, mHeader) <- CI ByteString -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' CI ByteString
headerName
unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader])
hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool
CI ByteString
headerName = (Bool, Maybe Text) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Maybe Text) -> Bool) -> m (Bool, Maybe Text) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' CI ByteString
headerName
hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text)
CI ByteString
headerName = do
mCsrfToken <- YesodRequest -> Maybe Text
reqToken (YesodRequest -> Maybe Text) -> m YesodRequest -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
mXsrfHeader <- lookupHeader headerName
return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader)
defaultCsrfParamName :: Text
defaultCsrfParamName :: Text
defaultCsrfParamName = Text
"_token"
checkCsrfParamNamed :: MonadHandler m => Text -> m ()
checkCsrfParamNamed :: forall (m :: * -> *). MonadHandler m => Text -> m ()
checkCsrfParamNamed Text
paramName = do
(valid, mParam) <- Text -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' Text
paramName
unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam])
hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed :: forall (m :: * -> *). MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed Text
paramName = (Bool, Maybe Text) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Maybe Text) -> Bool) -> m (Bool, Maybe Text) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' Text
paramName
hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' :: forall (m :: * -> *).
MonadHandler m =>
Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' Text
paramName = do
mCsrfToken <- YesodRequest -> Maybe Text
reqToken (YesodRequest -> Maybe Text) -> m YesodRequest -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
mCsrfParam <- lookupPostParam paramName
return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam)
checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)
=> CI S8.ByteString
-> Text
-> m ()
CI ByteString
headerName Text
paramName = do
(validHeader, mHeader) <- CI ByteString -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
CI ByteString -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' CI ByteString
headerName
(validParam, mParam) <- hasValidCsrfParamNamed' paramName
unless (validHeader || validParam) $ do
let errorMessage = [CSRFExpectation] -> Text
csrfErrorMessage ([CSRFExpectation] -> Text) -> [CSRFExpectation] -> Text
forall a b. (a -> b) -> a -> b
$ [Text -> Maybe Text -> CSRFExpectation
CSRFHeader (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString
forall s. CI s -> s
original CI ByteString
headerName) Maybe Text
mHeader, Text -> Maybe Text -> CSRFExpectation
CSRFParam Text
paramName Maybe Text
mParam]
$logWarnS "yesod-core" errorMessage
permissionDenied errorMessage
validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
validCsrf :: Maybe Text -> Maybe ByteString -> Bool
validCsrf (Just Text
token) (Just ByteString
param) = Text -> ByteString
encodeUtf8 Text
token ByteString -> ByteString -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
`constEq` ByteString
param
validCsrf Maybe Text
Nothing Maybe ByteString
_param = Bool
True
validCsrf (Just Text
_token) Maybe ByteString
Nothing = Bool
False
data CSRFExpectation = Text (Maybe Text)
| CSRFParam Text (Maybe Text)
csrfErrorMessage :: [CSRFExpectation]
-> Text
csrfErrorMessage :: [CSRFExpectation] -> Text
csrfErrorMessage [CSRFExpectation]
expectedLocations = Text -> [Text] -> Text
T.intercalate Text
"\n"
[ Text
"A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether."
, Text
"If you're a developer of this site, these tips will help you debug the issue:"
, Text
"- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection."
, Text
"- Check that your HTTP client is persisting cookies between requests, like a browser does."
, Text
"- By default, the CSRF token is sent to the client in a cookie named " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` (ByteString -> Text
decodeUtf8 ByteString
defaultCsrfCookieName) Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
"."
, Text
"- The server is looking for the token in the following locations:\n" Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text -> [Text] -> Text
T.intercalate Text
"\n" ((CSRFExpectation -> Text) -> [CSRFExpectation] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map CSRFExpectation -> Text
csrfLocation [CSRFExpectation]
expectedLocations)
]
where csrfLocation :: CSRFExpectation -> Text
csrfLocation CSRFExpectation
expected = case CSRFExpectation
expected of
CSRFHeader Text
k Maybe Text
v -> Text -> [Text] -> Text
T.intercalate Text
" " [Text
" - An HTTP header named", Text
k, (Maybe Text -> Text
formatValue Maybe Text
v)]
CSRFParam Text
k Maybe Text
v -> Text -> [Text] -> Text
T.intercalate Text
" " [Text
" - A POST parameter named", Text
k, (Maybe Text -> Text
formatValue Maybe Text
v)]
formatValue :: Maybe Text -> Text
formatValue :: Maybe Text -> Text
formatValue Maybe Text
maybeText = case Maybe Text
maybeText of
Maybe Text
Nothing -> Text
"(which is not currently set)"
Just Text
t -> [Text] -> Text
T.concat [Text
"(which has the current, incorrect value: '", Text
t, Text
"')"]
getSubYesod :: MonadHandler m => m (SubHandlerSite m)
getSubYesod :: forall (m :: * -> *). MonadHandler m => m (SubHandlerSite m)
getSubYesod = SubHandlerFor (SubHandlerSite m) (HandlerSite m) (SubHandlerSite m)
-> m (SubHandlerSite m)
forall a. SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
liftSubHandler (SubHandlerFor
(SubHandlerSite m) (HandlerSite m) (SubHandlerSite m)
-> m (SubHandlerSite m))
-> SubHandlerFor
(SubHandlerSite m) (HandlerSite m) (SubHandlerSite m)
-> m (SubHandlerSite m)
forall a b. (a -> b) -> a -> b
$ (HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (SubHandlerSite m))
-> SubHandlerFor
(SubHandlerSite m) (HandlerSite m) (SubHandlerSite m)
forall sub master a.
(HandlerData sub master -> IO a) -> SubHandlerFor sub master a
SubHandlerFor ((HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (SubHandlerSite m))
-> SubHandlerFor
(SubHandlerSite m) (HandlerSite m) (SubHandlerSite m))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (SubHandlerSite m))
-> SubHandlerFor
(SubHandlerSite m) (HandlerSite m) (SubHandlerSite m)
forall a b. (a -> b) -> a -> b
$ SubHandlerSite m -> IO (SubHandlerSite m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SubHandlerSite m -> IO (SubHandlerSite m))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> SubHandlerSite m)
-> HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (SubHandlerSite m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
-> SubHandlerSite m
forall child site. RunHandlerEnv child site -> child
rheChild (RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
-> SubHandlerSite m)
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> RunHandlerEnv (SubHandlerSite m) (HandlerSite m))
-> HandlerData (SubHandlerSite m) (HandlerSite m)
-> SubHandlerSite m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (SubHandlerSite m) (HandlerSite m)
-> RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv
getRouteToParent :: MonadHandler m => m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent :: forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent = SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Route (SubHandlerSite m) -> Route (HandlerSite m))
-> m (Route (SubHandlerSite m) -> Route (HandlerSite m))
forall a. SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
liftSubHandler (SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Route (SubHandlerSite m) -> Route (HandlerSite m))
-> m (Route (SubHandlerSite m) -> Route (HandlerSite m)))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Route (SubHandlerSite m) -> Route (HandlerSite m))
-> m (Route (SubHandlerSite m) -> Route (HandlerSite m))
forall a b. (a -> b) -> a -> b
$ (HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Route (SubHandlerSite m) -> Route (HandlerSite m)))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Route (SubHandlerSite m) -> Route (HandlerSite m))
forall sub master a.
(HandlerData sub master -> IO a) -> SubHandlerFor sub master a
SubHandlerFor ((HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Route (SubHandlerSite m) -> Route (HandlerSite m)))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Route (SubHandlerSite m) -> Route (HandlerSite m)))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Route (SubHandlerSite m) -> Route (HandlerSite m)))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Route (SubHandlerSite m) -> Route (HandlerSite m))
forall a b. (a -> b) -> a -> b
$ (Route (SubHandlerSite m) -> Route (HandlerSite m))
-> IO (Route (SubHandlerSite m) -> Route (HandlerSite m))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Route (SubHandlerSite m) -> Route (HandlerSite m))
-> IO (Route (SubHandlerSite m) -> Route (HandlerSite m)))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> Route (SubHandlerSite m) -> Route (HandlerSite m))
-> HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Route (SubHandlerSite m) -> Route (HandlerSite m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
-> Route (SubHandlerSite m) -> Route (HandlerSite m)
forall child site.
RunHandlerEnv child site -> Route child -> Route site
rheRouteToMaster (RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
-> Route (SubHandlerSite m) -> Route (HandlerSite m))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> RunHandlerEnv (SubHandlerSite m) (HandlerSite m))
-> HandlerData (SubHandlerSite m) (HandlerSite m)
-> Route (SubHandlerSite m)
-> Route (HandlerSite m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (SubHandlerSite m) (HandlerSite m)
-> RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv
getSubCurrentRoute :: MonadHandler m => m (Maybe (Route (SubHandlerSite m)))
getSubCurrentRoute :: forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (SubHandlerSite m)))
getSubCurrentRoute = SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Maybe (Route (SubHandlerSite m)))
-> m (Maybe (Route (SubHandlerSite m)))
forall a. SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
forall (m :: * -> *) a.
MonadHandler m =>
SubHandlerFor (SubHandlerSite m) (HandlerSite m) a -> m a
liftSubHandler (SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Maybe (Route (SubHandlerSite m)))
-> m (Maybe (Route (SubHandlerSite m))))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Maybe (Route (SubHandlerSite m)))
-> m (Maybe (Route (SubHandlerSite m)))
forall a b. (a -> b) -> a -> b
$ (HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Maybe (Route (SubHandlerSite m))))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Maybe (Route (SubHandlerSite m)))
forall sub master a.
(HandlerData sub master -> IO a) -> SubHandlerFor sub master a
SubHandlerFor ((HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Maybe (Route (SubHandlerSite m))))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Maybe (Route (SubHandlerSite m))))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Maybe (Route (SubHandlerSite m))))
-> SubHandlerFor
(SubHandlerSite m)
(HandlerSite m)
(Maybe (Route (SubHandlerSite m)))
forall a b. (a -> b) -> a -> b
$ Maybe (Route (SubHandlerSite m))
-> IO (Maybe (Route (SubHandlerSite m)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Route (SubHandlerSite m))
-> IO (Maybe (Route (SubHandlerSite m))))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> Maybe (Route (SubHandlerSite m)))
-> HandlerData (SubHandlerSite m) (HandlerSite m)
-> IO (Maybe (Route (SubHandlerSite m)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
-> Maybe (Route (SubHandlerSite m))
forall child site. RunHandlerEnv child site -> Maybe (Route child)
rheRoute (RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
-> Maybe (Route (SubHandlerSite m)))
-> (HandlerData (SubHandlerSite m) (HandlerSite m)
-> RunHandlerEnv (SubHandlerSite m) (HandlerSite m))
-> HandlerData (SubHandlerSite m) (HandlerSite m)
-> Maybe (Route (SubHandlerSite m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerData (SubHandlerSite m) (HandlerSite m)
-> RunHandlerEnv (SubHandlerSite m) (HandlerSite m)
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv