{-# 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.Handler
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : stable
-- Portability   : portable
--
-- Define Handler stuff.
--
---------------------------------------------------------
module Yesod.Core.Handler
    ( -- * Handler monad
      HandlerT
    , HandlerFor
      -- ** Read information from handler
    , getYesod
    , getsYesod
    , getUrlRender
    , getUrlRenderParams
    , getPostParams
    , getCurrentRoute
    , getRequest
    , waiRequest
    , runRequestBody
    , rawRequestBody
      -- ** Request information
      -- *** Request datatype
    , RequestBodyContents
    , YesodRequest (..)
    , FileInfo
    , fileName
    , fileContentType
    , fileSource
    , fileSourceByteString
    , fileMove
      -- *** Convenience functions
    , languages
      -- *** Lookup parameters
    , lookupGetParam
    , lookupPostParam
    , lookupCookie
    , lookupFile
    , lookupHeader
      -- **** Lookup authentication data
    , lookupBasicAuth
    , lookupBearerAuth
      -- **** Multi-lookup
    , lookupGetParams
    , lookupPostParams
    , lookupCookies
    , lookupFiles
    , lookupHeaders
      -- * Responses
      -- ** Pure
    , respond
      -- ** Streaming
    , respondSource
    , sendChunk
    , sendFlush
    , sendChunkBS
    , sendChunkLBS
    , sendChunkText
    , sendChunkLazyText
    , sendChunkHtml
      -- ** Redirecting
    , RedirectUrl (..)
    , redirect
    , redirectWith
    , redirectToPost
    , Fragment(..)
      -- ** Errors
    , notFound
    , badMethod
    , notAuthenticated
    , permissionDenied
    , permissionDeniedI
    , invalidArgs
    , invalidArgsI
      -- ** Short-circuit responses
      -- $rollbackWarning
    , sendFile
    , sendFilePart
    , sendResponse
    , sendResponseStatus
      -- ** Type specific response with custom status
    , sendStatusJSON
    , sendResponseCreated
    , sendResponseNoContent
    , sendWaiResponse
    , sendWaiApplication
    , sendRawResponse
    , sendRawResponseNoConduit
    , notModified
      -- * Different representations
      -- $representations
    , selectRep
    , provideRep
    , provideRepType
    , ProvidedRep
      -- * Setting headers
    , setCookie
    , getExpires
    , deleteCookie
    , addHeader
    , setHeader
    , replaceOrAddHeader
    , setLanguage
    , addContentDispositionFileName
      -- ** Content caching and expiration
    , cacheSeconds
    , neverExpires
    , alreadyExpired
    , expiresAt
    , setEtag
    , setWeakEtag
      -- * Session
    , SessionMap
    , lookupSession
    , lookupSessionBS
    , getSession
    , setSession
    , setSessionBS
    , deleteSession
    , clearSession
      -- ** Ultimate destination
    , setUltDest
    , setUltDestCurrent
    , setUltDestReferer
    , redirectUltDest
    , clearUltDest
      -- ** Messages
    , addMessage
    , addMessageI
    , getMessages
    , setMessage
    , setMessageI
    , getMessage
      -- * Subsites
    , SubHandlerFor
    , getSubYesod
    , getRouteToParent
    , getSubCurrentRoute
      -- * Helpers for specific content
      -- ** Hamlet
    , hamletToRepHtml
    , giveUrlRenderer
    , withUrlRenderer
      -- ** Misc
    , newIdent
      -- * Lifting
    , handlerToIO
    , forkHandler
      -- * i18n
    , getMessageRender
      -- * Per-request caching
    , cached
    , cacheGet
    , cacheSet
    , cachedBy
    , cacheByGet
    , cacheBySet
      -- * AJAX CSRF protection

      -- $ajaxCSRFOverview

      -- ** Setting CSRF Cookies
    , setCsrfCookie
    , setCsrfCookieWithCookie
    , defaultCsrfCookieName
      -- ** Looking up CSRF Headers
    , checkCsrfHeaderNamed
    , hasValidCsrfHeaderNamed
    , defaultCsrfHeaderName
      -- ** Looking up CSRF POST Parameters
    , hasValidCsrfParamNamed
    , checkCsrfParamNamed
    , defaultCsrfParamName
      -- ** Checking CSRF Headers or POST Parameters
    , 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           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 :: * -> *) = HandlerFor site
{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}

get :: MonadHandler m => m GHState
get :: m GHState
get = HandlerFor (HandlerSite m) GHState -> m GHState
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 :: GHState -> m ()
put GHState
x = HandlerFor (HandlerSite m) () -> m ()
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 :: (GHState -> GHState) -> m ()
modify GHState -> GHState
f = HandlerFor (HandlerSite m) () -> m ()
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 :: 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 :: Endo [Header]
ghsHeaders = GHState -> Endo [Header]
ghsHeaders GHState
g Endo [Header] -> Endo [Header] -> Endo [Header]
forall a. Monoid a => a -> a -> a
`mappend` Endo [Header]
hs }

handlerError :: MonadHandler m => HandlerContents -> m a
handlerError :: HandlerContents -> m a
handlerError = 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. Exception e => e -> IO a
throwIO

hcError :: MonadHandler m => ErrorResponse -> m a
hcError :: 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 :: m YesodRequest
getRequest = HandlerFor (HandlerSite m) YesodRequest -> m YesodRequest
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 (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 :: m RequestBodyContents
runRequestBody = do
    HandlerData
        { handlerEnv :: forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv = RunHandlerEnv {Maybe (Route (HandlerSite m))
Text
HandlerSite m
Loc -> Text -> LogLevel -> LogStr -> IO ()
RequestBodyLength -> FileUpload
Route (HandlerSite m) -> Route (HandlerSite m)
Route (HandlerSite m) -> [(Text, Text)] -> Text
ErrorResponse -> YesodApp
rheMaxExpires :: forall child site. RunHandlerEnv child site -> Text
rheOnError :: forall child site.
RunHandlerEnv child site -> ErrorResponse -> YesodApp
rheLog :: forall child site.
RunHandlerEnv child site
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
rheUpload :: forall child site.
RunHandlerEnv child site -> RequestBodyLength -> FileUpload
rheChild :: forall child site. RunHandlerEnv child site -> child
rheSite :: forall child site. RunHandlerEnv child site -> site
rheRouteToMaster :: forall child site.
RunHandlerEnv child site -> Route child -> Route site
rheRoute :: forall child site. RunHandlerEnv child site -> Maybe (Route child)
rheRender :: forall child site.
RunHandlerEnv child site -> Route site -> [(Text, Text)] -> Text
rheMaxExpires :: Text
rheOnError :: ErrorResponse -> YesodApp
rheLog :: Loc -> Text -> LogLevel -> LogStr -> IO ()
rheUpload :: RequestBodyLength -> FileUpload
rheChild :: HandlerSite m
rheSite :: HandlerSite m
rheRouteToMaster :: Route (HandlerSite m) -> Route (HandlerSite m)
rheRoute :: Maybe (Route (HandlerSite m))
rheRender :: Route (HandlerSite m) -> [(Text, Text)] -> Text
..}
        , handlerRequest :: forall child site. HandlerData child site -> YesodRequest
handlerRequest = YesodRequest
req
        } <- HandlerFor
  (HandlerSite m) (HandlerData (HandlerSite m) (HandlerSite m))
-> m (HandlerData (HandlerSite m) (HandlerSite m))
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 (m :: * -> *) a. Monad m => a -> m a
return
    let len :: RequestBodyLength
len = Request -> RequestBodyLength
W.requestBodyLength (Request -> RequestBodyLength) -> Request -> RequestBodyLength
forall a b. (a -> b) -> a -> b
$ YesodRequest -> Request
reqWaiRequest YesodRequest
req
        upload :: FileUpload
upload = RequestBodyLength -> FileUpload
rheUpload RequestBodyLength
len
    GHState
x <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
    case GHState -> Maybe RequestBodyContents
ghsRBC GHState
x of
        Just RequestBodyContents
rbc -> RequestBodyContents -> m RequestBodyContents
forall (m :: * -> *) a. Monad m => a -> m a
return RequestBodyContents
rbc
        Maybe RequestBodyContents
Nothing -> do
            Request
rr <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
            InternalState
internalState <- ResourceT IO InternalState -> m InternalState
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT ResourceT IO InternalState
forall (m :: * -> *). Monad m => ResourceT m InternalState
getInternalState
            RequestBodyContents
rbc <- IO RequestBodyContents -> m RequestBodyContents
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RequestBodyContents -> m RequestBodyContents)
-> IO RequestBodyContents -> m RequestBodyContents
forall a b. (a -> b) -> a -> b
$ FileUpload -> Request -> InternalState -> IO RequestBodyContents
rbHelper FileUpload
upload Request
rr InternalState
internalState
            GHState -> m ()
forall (m :: * -> *). MonadHandler m => GHState -> m ()
put GHState
x { ghsRBC :: Maybe RequestBodyContents
ghsRBC = RequestBodyContents -> Maybe RequestBodyContents
forall a. a -> Maybe a
Just RequestBodyContents
rbc }
            RequestBodyContents -> m RequestBodyContents
forall (m :: * -> *) a. Monad m => a -> m a
return RequestBodyContents
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' :: BackEnd x
-> (Text -> Text -> x -> FileInfo)
-> Request
-> IO RequestBodyContents
rbHelper' BackEnd x
backend Text -> Text -> x -> FileInfo
mkFI Request
req =
    (((ByteString, ByteString) -> (Text, Text))
-> [(ByteString, ByteString)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, ByteString) -> (Text, Text)
fix1 ([(ByteString, ByteString)] -> [(Text, Text)])
-> ([(ByteString, FileInfo x)] -> [(Text, FileInfo)])
-> ([(ByteString, ByteString)], [(ByteString, FileInfo x)])
-> RequestBodyContents
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ((ByteString, FileInfo x) -> Maybe (Text, FileInfo))
-> [(ByteString, FileInfo x)] -> [(Text, FileInfo)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ByteString, FileInfo x) -> Maybe (Text, FileInfo)
fix2) (([(ByteString, ByteString)], [(ByteString, FileInfo x)])
 -> RequestBodyContents)
-> IO ([(ByteString, ByteString)], [(ByteString, FileInfo x)])
-> IO RequestBodyContents
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BackEnd x
-> Request
-> IO ([(ByteString, ByteString)], [(ByteString, FileInfo x)])
forall y.
BackEnd y -> Request -> IO ([(ByteString, ByteString)], [File y])
NWP.parseRequestBody BackEnd x
backend Request
req
  where
    fix1 :: (ByteString, ByteString) -> (Text, Text)
fix1 = ByteString -> Text
go (ByteString -> Text)
-> (ByteString -> Text) -> (ByteString, ByteString) -> (Text, Text)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
go
    fix2 :: (ByteString, FileInfo 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
'"' = ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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
'\'' = ByteString -> ByteString
S.tail (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 :: m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv = HandlerFor
  (HandlerSite m) (RunHandlerEnv (HandlerSite m) (HandlerSite m))
-> m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
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 (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

-- | Get the master site application argument.
getYesod :: MonadHandler m => m (HandlerSite m)
getYesod :: 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

-- | Get a specific component of the master site application argument.
--   Analogous to the 'gets' function for operating on 'StateT'.
getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a
getsYesod :: (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

-- | Get the URL rendering function.
getUrlRender :: MonadHandler m => m (Route (HandlerSite m) -> Text)
getUrlRender :: m (Route (HandlerSite m) -> Text)
getUrlRender = do
    Route (HandlerSite m) -> [(Text, Text)] -> Text
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
    (Route (HandlerSite m) -> Text)
-> m (Route (HandlerSite m) -> Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Route (HandlerSite m) -> Text)
 -> m (Route (HandlerSite m) -> Text))
-> (Route (HandlerSite m) -> Text)
-> m (Route (HandlerSite m) -> Text)
forall a b. (a -> b) -> a -> b
$ (Route (HandlerSite m) -> [(Text, Text)] -> Text)
-> [(Text, Text)] -> Route (HandlerSite m) -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Route (HandlerSite m) -> [(Text, Text)] -> Text
x []

-- | The URL rendering function with query-string parameters.
getUrlRenderParams
    :: MonadHandler m
    => m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams :: 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

-- | Get all the post parameters passed to the handler. To also get
-- the submitted files (if any), you have to use 'runRequestBody'
-- instead of this function.
--
-- @since 1.4.33
getPostParams
  :: MonadHandler m
  => m [(Text, Text)]
getPostParams :: m [(Text, Text)]
getPostParams = do
  RequestBodyContents
reqBodyContent <- m RequestBodyContents
forall (m :: * -> *). MonadHandler m => m RequestBodyContents
runRequestBody
  [(Text, Text)] -> m [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)] -> m [(Text, Text)])
-> [(Text, Text)] -> m [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ RequestBodyContents -> [(Text, Text)]
forall a b. (a, b) -> a
fst RequestBodyContents
reqBodyContent

-- | Get the route requested by the user. If this is a 404 response- where the
-- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute :: 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

-- | Returns a function that runs 'HandlerFor' actions inside @IO@.
--
-- Sometimes you want to run an inner 'HandlerFor' action outside
-- the control flow of an HTTP request (on the outer 'HandlerFor'
-- action).  For example, you may want to spawn a new thread:
--
-- @
-- getFooR :: Handler RepHtml
-- getFooR = do
--   runInnerHandler <- handlerToIO
--   liftIO $ forkIO $ runInnerHandler $ do
--     /Code here runs inside HandlerFor but on a new thread./
--     /This is the inner HandlerFor./
--     ...
--   /Code here runs inside the request's control flow./
--   /This is the outer HandlerFor./
--   ...
-- @
--
-- Another use case for this function is creating a stream of
-- server-sent events using 'HandlerFor' actions (see
-- @yesod-eventsource@).
--
-- Most of the environment from the outer 'HandlerFor' is preserved
-- on the inner 'HandlerFor', however:
--
--  * The request body is cleared (otherwise it would be very
--  difficult to prevent huge memory leaks).
--
--  * The cache is cleared (see 'cached').
--
-- Changes to the response made inside the inner 'HandlerFor' are
-- ignored (e.g., session variables, cookies, response headers).
-- This allows the inner 'HandlerFor' to outlive the outer
-- 'HandlerFor' (e.g., on the @forkIO@ example above, a response
-- may be sent to the client without killing the new thread).
handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
handlerToIO :: 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
    -- Take just the bits we need from oldHandlerData.
    let newReq :: YesodRequest
newReq = YesodRequest
oldReq { reqWaiRequest :: Request
reqWaiRequest = Request
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 { requestBody :: IO ByteString
W.requestBody = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
forall a. Monoid a => a
mempty
                                  , requestBodyLength :: RequestBodyLength
W.requestBodyLength = Word64 -> RequestBodyLength
W.KnownLength Word64
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
    GHState
newState <- IO GHState -> IO GHState
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
      GHState
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)
      GHState -> IO GHState
forall (m :: * -> *) a. Monad m => a -> m a
return (GHState -> IO GHState) -> GHState -> IO GHState
forall a b. (a -> b) -> a -> b
$ GHState
oldState { ghsRBC :: Maybe RequestBodyContents
ghsRBC = Maybe RequestBodyContents
forall a. Maybe a
Nothing
                        , ghsIdent :: Int
ghsIdent = Int
1
                        , ghsCache :: TypeMap
ghsCache = TypeMap
forall a. Monoid a => a
mempty
                        , ghsCacheBy :: KeyedTypeMap
ghsCacheBy = KeyedTypeMap
forall a. Monoid a => a
mempty
                        , ghsHeaders :: Endo [Header]
ghsHeaders = Endo [Header]
forall a. Monoid a => a
mempty }

    -- xx From this point onwards, no references to oldHandlerData xx
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
evaluate (YesodRequest
newReq YesodRequest -> () -> ()
`seq` RunHandlerEnv site site
oldEnv RunHandlerEnv site site -> () -> ()
`seq` GHState
newState GHState -> () -> ()
`seq` ())

    -- Return HandlerFor running function.
    (HandlerFor site a -> m a) -> IO (HandlerFor site a -> m a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((HandlerFor site a -> m a) -> IO (HandlerFor site a -> m a))
-> (HandlerFor site a -> m a) -> IO (HandlerFor site a -> m a)
forall a b. (a -> b) -> a -> b
$ \(HandlerFor HandlerData site site -> IO a
f) ->
      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
        -- The state IORef needs to be created here, otherwise it
        -- will be shared by different invocations of this function.
        IORef GHState
newStateIORef <- IO (IORef GHState) -> IO (IORef GHState)
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 site site
newHandlerData =
              HandlerData :: forall child site.
YesodRequest
-> RunHandlerEnv child site
-> IORef GHState
-> InternalState
-> HandlerData child site
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
                }
        IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HandlerData site site -> IO a
f HandlerData site site
newHandlerData)

-- | forkIO for a Handler (run an action in the background)
--
-- Uses 'handlerToIO', liftResourceT, and resourceForkIO
-- for correctness and efficiency
--
-- @since 1.2.8
forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
              -> HandlerFor site ()
              -> HandlerFor site ()
forkHandler :: (SomeException -> HandlerFor site ())
-> HandlerFor site () -> HandlerFor site ()
forkHandler SomeException -> HandlerFor site ()
onErr HandlerFor site ()
handler = do
    HandlerFor site () -> IO ()
yesRunner <- HandlerFor site (HandlerFor site () -> IO ())
forall (m :: * -> *) site a.
MonadIO m =>
HandlerFor site (HandlerFor site a -> m a)
handlerToIO
    HandlerFor site ThreadId -> HandlerFor site ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (HandlerFor site ThreadId -> HandlerFor site ())
-> HandlerFor site ThreadId -> HandlerFor site ()
forall a b. (a -> b) -> a -> b
$ ResourceT IO ThreadId -> HandlerFor site ThreadId
forall (m :: * -> *) a. MonadResource m => ResourceT IO a -> m a
liftResourceT (ResourceT IO ThreadId -> HandlerFor site ThreadId)
-> ResourceT IO ThreadId -> HandlerFor site ThreadId
forall a b. (a -> b) -> a -> b
$ ResourceT IO () -> ResourceT IO ThreadId
forall (m :: * -> *).
MonadUnliftIO m =>
ResourceT m () -> ResourceT m ThreadId
resourceForkIO (ResourceT IO () -> ResourceT IO ThreadId)
-> ResourceT IO () -> ResourceT IO ThreadId
forall a b. (a -> b) -> a -> b
$
      IO () -> ResourceT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ResourceT IO ()) -> IO () -> ResourceT IO ()
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (HandlerFor site () -> IO ()
yesRunner (HandlerFor site () -> IO ())
-> (SomeException -> HandlerFor site ()) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> HandlerFor site ()
onErr) (HandlerFor site () -> IO ()
yesRunner HandlerFor site ()
handler)

-- | Redirect to the given route.
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
-- This is the appropriate choice for a get-following-post
-- technique, which should be the usual use case.
--
-- If you want direct control of the final status code, or need a different
-- status code, please use 'redirectWith'.
redirect :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
         => url -> m a
redirect :: url -> m a
redirect url
url = do
    Request
req <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
    let status :: Status
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
    Status -> url -> m a
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
Status -> url -> m a
redirectWith Status
status url
url

-- | Redirect to the given URL with the specified status code.
redirectWith :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
             => H.Status
             -> url
             -> m a
redirectWith :: Status -> url -> m a
redirectWith Status
status url
url = do
    Text
urlText <- url -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
toTextUrl url
url
    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
$ Status -> Text -> HandlerContents
HCRedirect Status
status Text
urlText

ultDestKey :: Text
ultDestKey :: Text
ultDestKey = Text
"_ULT"

-- | Sets the ultimate destination variable to the given route.
--
-- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'.
setUltDest :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
           => url
           -> m ()
setUltDest :: url -> m ()
setUltDest url
url = do
    Text
urlText <- url -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
toTextUrl url
url
    Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
ultDestKey Text
urlText

-- | Same as 'setUltDest', but uses the current page.
--
-- If this is a 404 handler, there is no current page, and then this call does
-- nothing.
setUltDestCurrent :: MonadHandler m => m ()
setUltDestCurrent :: m ()
setUltDestCurrent = do
    Maybe (Route (HandlerSite m))
route <- m (Maybe (Route (HandlerSite m)))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
    case Maybe (Route (HandlerSite m))
route of
        Maybe (Route (HandlerSite m))
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Route (HandlerSite m)
r -> do
            [(Text, Text)]
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
            (Route (HandlerSite m), [(Text, Text)]) -> m ()
forall (m :: * -> *) url.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m ()
setUltDest (Route (HandlerSite m)
r, [(Text, Text)]
gets')

-- | Sets the ultimate destination to the referer request header, if present.
--
-- This function will not overwrite an existing ultdest.
setUltDestReferer :: MonadHandler m => m ()
setUltDestReferer :: m ()
setUltDestReferer = do
    Maybe Text
mdest <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
ultDestKey
    m () -> (Text -> m ()) -> Maybe Text -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest m Request -> (Request -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> (ByteString -> m ()) -> Maybe ByteString -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ByteString -> m ()
setUltDestBS (Maybe ByteString -> m ())
-> (Request -> Maybe ByteString) -> Request -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"referer" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
W.requestHeaders)
        (m () -> Text -> m ()
forall a b. a -> b -> a
const (m () -> Text -> m ()) -> m () -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        Maybe Text
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

-- | Redirect to the ultimate destination in the user's session. Clear the
-- value from the session.
--
-- The ultimate destination is set with 'setUltDest'.
--
-- This function uses 'redirect', and thus will perform a temporary redirect to
-- a GET request.
redirectUltDest :: (RedirectUrl (HandlerSite m) url, MonadHandler m)
                => url -- ^ default destination if nothing in session
                -> m a
redirectUltDest :: url -> m a
redirectUltDest url
defaultDestination = do
    Maybe Text
mdest <- Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
ultDestKey
    Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
ultDestKey
    m a -> (Text -> m a) -> Maybe Text -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (url -> m a
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect url
defaultDestination) Text -> m a
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Maybe Text
mdest

-- | Remove a previously set ultimate destination. See 'setUltDest'.
clearUltDest :: MonadHandler m => m ()
clearUltDest :: m ()
clearUltDest = Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
ultDestKey

msgKey :: Text
msgKey :: Text
msgKey = Text
"_MSG"

-- | Adds a status and message in the user's session.
--
-- See 'getMessages'.
--
-- @since 1.4.20
addMessage :: MonadHandler m
           => Text -- ^ status
           -> Html -- ^ message
           -> m ()
addMessage :: Text -> Html -> m ()
addMessage Text
status Html
msg = do
    Maybe ByteString
val <- Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
msgKey
    Text -> ByteString -> m ()
forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
msgKey (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> ByteString
addMsg Maybe ByteString
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))

-- | Adds a message in the user's session but uses RenderMessage to allow for i18n
--
-- See 'getMessages'.
--
-- @since 1.4.20
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
            => Text -> msg -> m ()
addMessageI :: Text -> msg -> m ()
addMessageI Text
status msg
msg = do
    msg -> Text
mr <- m (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    Text -> Html -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Html -> m ()
addMessage Text
status (Html -> m ()) -> Html -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ msg -> Text
mr msg
msg

-- | Gets all messages in the user's session, and then clears the variable.
--
-- See 'addMessage'.
--
-- @since 1.4.20
getMessages :: MonadHandler m => m [(Text, Html)]
getMessages :: m [(Text, Html)]
getMessages = do
    Maybe ByteString
bs <- Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
msgKey
    let ms :: [(Text, Html)]
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
    Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
msgKey
    [(Text, Html)] -> m [(Text, Html)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text, Html)]
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

-- | Calls 'addMessage' with an empty status
setMessage :: MonadHandler m => Html -> m ()
setMessage :: Html -> m ()
setMessage = Text -> Html -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Html -> m ()
addMessage Text
""

-- | Calls 'addMessageI' with an empty status
setMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg)
            => msg -> m ()
setMessageI :: msg -> m ()
setMessageI = Text -> msg -> m ()
forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
Text -> msg -> m ()
addMessageI Text
""

-- | Gets just the last message in the user's session,
-- discards the rest and the status
getMessage :: MonadHandler m => m (Maybe Html)
getMessage :: m (Maybe Html)
getMessage = ([(Text, Html)] -> Maybe Html)
-> m [(Text, Html)] -> m (Maybe Html)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Text, Html) -> Html) -> Maybe (Text, Html) -> Maybe Html
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

-- $rollbackWarning
--
-- Note that since short-circuiting is implemented by using exceptions,
-- using e.g. 'sendStatusJSON' inside a runDB block
-- will result in the database actions getting rolled back:
--
-- @
-- runDB $ do
--   userId <- insert $ User "username" "email@example.com"
--   postId <- insert $ BlogPost "title" "hi there!"
--     /The previous two inserts will be rolled back./
--   sendStatusJSON Status.status200 ()
-- @

-- | Bypass remaining handler code and output the given file.
--
-- For some backends, this is more efficient than reading in the file to
-- memory, since they can optimize file sending via a system call to sendfile.
sendFile :: MonadHandler m => ContentType -> FilePath -> m a
sendFile :: 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

-- | Same as 'sendFile', but only sends part of a file.
sendFilePart :: MonadHandler m
             => ContentType
             -> FilePath
             -> Integer -- ^ offset
             -> Integer -- ^ count
             -> m a
sendFilePart :: ByteString -> FilePath -> Integer -> Integer -> m a
sendFilePart ByteString
ct FilePath
fp Integer
off Integer
count = do
    FileStatus
fs <- IO FileStatus -> m FileStatus
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
    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 -> HandlerContents)
-> Maybe FilePart -> HandlerContents
forall a b. (a -> b) -> a -> b
$ FilePart -> Maybe FilePart
forall a. a -> Maybe a
Just FilePart :: Integer -> Integer -> Integer -> FilePart
W.FilePart
        { filePartOffset :: Integer
W.filePartOffset = Integer
off
        , filePartByteCount :: Integer
W.filePartByteCount = Integer
count
        , filePartFileSize :: Integer
W.filePartFileSize = FileOffset -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Integer) -> FileOffset -> Integer
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
PC.fileSize FileStatus
fs
        }

-- | Bypass remaining handler code and output the given content with a 200
-- status code.
sendResponse :: (MonadHandler m, ToTypedContent c) => c -> m a
sendResponse :: 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

-- | Bypass remaining handler code and output the given content with the given
-- status code.
sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a
sendResponseStatus :: 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

-- | Bypass remaining handler code and output the given JSON with the given
-- status code.
--
-- @since 1.4.18
sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a
sendStatusJSON :: 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)

-- | Send a 201 "Created" response with the given route as the Location
-- response header.
sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a
sendResponseCreated :: Route (HandlerSite m) -> m a
sendResponseCreated Route (HandlerSite m)
url = do
    Route (HandlerSite m) -> Text
r <- m (Route (HandlerSite m) -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
    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
$ Text -> HandlerContents
HCCreated (Text -> HandlerContents) -> Text -> HandlerContents
forall a b. (a -> b) -> a -> b
$ Route (HandlerSite m) -> Text
r Route (HandlerSite m)
url

-- | Bypass remaining handler code and output no content with a 204 status code.
--
-- @since 1.6.9
sendResponseNoContent :: MonadHandler m => m a
sendResponseNoContent :: 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 -> [(HeaderName, ByteString)] -> Builder -> Response
W.responseBuilder Status
H.status204 [] Builder
forall a. Monoid a => a
mempty

-- | Send a 'W.Response'. Please note: this function is rarely
-- necessary, and will /disregard/ any changes to response headers and session
-- that you have already specified. This function short-circuits. It should be
-- considered only for very specific needs. If you are not sure if you need it,
-- you don't.
sendWaiResponse :: MonadHandler m => W.Response -> m b
sendWaiResponse :: 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

-- | Switch over to handling the current request with a WAI @Application@.
--
-- @since 1.2.17
sendWaiApplication :: MonadHandler m => W.Application -> m b
sendWaiApplication :: 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

-- | Send a raw response without conduit. This is used for cases such as
-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw
-- responses (e.g., Warp).
--
-- @since 1.2.16
sendRawResponseNoConduit
    :: (MonadHandler m, MonadUnliftIO m)
    => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
    -> m a
sendRawResponseNoConduit :: (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 (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 (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. 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 -> [(HeaderName, ByteString)] -> ByteString -> Response
W.responseLBS Status
H.status500 [(HeaderName
"Content-Type", ByteString
"text/plain")]
        ByteString
"sendRawResponse: backend does not support raw responses"

-- | Send a raw response. This is used for cases such as WebSockets. Requires
-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,
-- Warp).
--
-- @since 1.2.7
sendRawResponse
  :: (MonadHandler m, MonadUnliftIO m)
  => (ConduitT () S8.ByteString IO () -> ConduitT S8.ByteString Void IO () -> m ())
  -> m a
sendRawResponse :: (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 (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 (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. 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 -> [(HeaderName, ByteString)] -> ByteString -> Response
W.responseLBS Status
H.status500 [(HeaderName
"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
        ByteString
bs <- IO ByteString -> ConduitT i ByteString m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
src
        Bool -> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (ConduitT i ByteString m () -> ConduitT i ByteString m ())
-> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString -> ConduitT i ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
            IO ByteString -> ConduitT i ByteString m ()
src' IO ByteString
src

-- | Send a 304 not modified response immediately. This is a short-circuiting
-- action.
--
-- @since 1.4.4
notModified :: MonadHandler m => m a
notModified :: 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 -> [(HeaderName, ByteString)] -> Builder -> Response
W.responseBuilder Status
H.status304 [] Builder
forall a. Monoid a => a
mempty

-- | Return a 404 not found page. Also denotes no handler available.
notFound :: MonadHandler m => m a
notFound :: m a
notFound = ErrorResponse -> m a
forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError ErrorResponse
NotFound

-- | Return a 405 method not supported page.
badMethod :: MonadHandler m => m a
badMethod :: m a
badMethod = do
    Request
w <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
    ErrorResponse -> m a
forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError (ErrorResponse -> m a) -> ErrorResponse -> m a
forall a b. (a -> b) -> a -> b
$ ByteString -> ErrorResponse
BadMethod (ByteString -> ErrorResponse) -> ByteString -> ErrorResponse
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
W.requestMethod Request
w

-- | Return a 401 status code
notAuthenticated :: MonadHandler m => m a
notAuthenticated :: m a
notAuthenticated = ErrorResponse -> m a
forall (m :: * -> *) a. MonadHandler m => ErrorResponse -> m a
hcError ErrorResponse
NotAuthenticated

-- | Return a 403 permission denied page.
permissionDenied :: MonadHandler m => Text -> m a
permissionDenied :: 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

-- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, MonadHandler m)
                  => msg
                  -> m a
permissionDeniedI :: msg -> m a
permissionDeniedI msg
msg = do
    msg -> Text
mr <- m (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    Text -> m a
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ msg -> Text
mr msg
msg

-- | Return a 400 invalid arguments page.
invalidArgs :: MonadHandler m => [Text] -> m a
invalidArgs :: [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

-- | Return a 400 invalid arguments page.
invalidArgsI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
invalidArgsI :: [msg] -> m a
invalidArgsI [msg]
msg = do
    msg -> Text
mr <- m (msg -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
    [Text] -> m a
forall (m :: * -> *) a. MonadHandler m => [Text] -> m a
invalidArgs ([Text] -> m a) -> [Text] -> m a
forall a b. (a -> b) -> a -> b
$ (msg -> Text) -> [msg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map msg -> Text
mr [msg]
msg

------- Headers
-- | Set the cookie on the client.

setCookie :: MonadHandler m => SetCookie -> m ()
setCookie :: 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)

-- | Helper function for setCookieExpires value
getExpires :: MonadIO m
           => Int -- ^ minutes
           -> m UTCTime
getExpires :: Int -> m UTCTime
getExpires Int
m = do
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    UTCTime -> m UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime -> m UTCTime) -> UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60) NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
now


-- | Unset the cookie on the client.
--
-- Note: although the value used for key and path is 'Text', you should only
-- use ASCII values to be HTTP compliant.
deleteCookie :: MonadHandler m
             => Text -- ^ key
             -> Text -- ^ path
             -> m ()
deleteCookie :: 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


-- | Set the language in the user session. Will show up in 'languages' on the
-- next request.
setLanguage :: MonadHandler m => Text -> m ()
setLanguage :: Text -> m ()
setLanguage = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
forall a. IsString a => a
langKey

-- | Set attachment file name.
--
-- Allows Unicode characters by encoding to UTF-8.
-- Some modurn browser parse UTF-8 characters with out encoding setting.
-- But, for example IE9 can't parse UTF-8 characters.
-- This function use
-- <https://tools.ietf.org/html/rfc6266 RFC 6266>(<https://tools.ietf.org/html/rfc5987 RFC 5987>)
--
-- @since 1.6.4
addContentDispositionFileName :: MonadHandler m => T.Text -> m ()
addContentDispositionFileName :: 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

-- | <https://tools.ietf.org/html/rfc6266 RFC 6266> Unicode attachment filename.
--
-- > rfc6266Utf8FileName (Data.Text.pack "€")
-- "attachment; filename*=UTF-8''%E2%82%AC"
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))

-- | Set an arbitrary response header.
--
-- Note that, while the data type used here is 'Text', you must provide only
-- ASCII value to be HTTP compliant.
--
-- @since 1.2.0
addHeader :: MonadHandler m => Text -> Text -> m ()
addHeader :: Text -> Text -> m ()
addHeader 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
. HeaderName -> ByteString -> Header
Header (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName) -> ByteString -> HeaderName
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

-- | Deprecated synonym for addHeader.
setHeader :: MonadHandler m => Text -> Text -> m ()
setHeader :: Text -> Text -> m ()
setHeader = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader
{-# DEPRECATED setHeader "Please use addHeader instead" #-}

-- | Replace an existing header with a new value or add a new header
-- if not present.
--
-- Note that, while the data type used here is 'Text', you must provide only
-- ASCII value to be HTTP compliant.
--
-- @since 1.4.36
replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
replaceOrAddHeader :: Text -> Text -> m ()
replaceOrAddHeader 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 :: Endo [Header]
ghsHeaders = Endo [Header] -> Endo [Header]
replaceHeader (GHState -> Endo [Header]
ghsHeaders GHState
g)}
  where
    repHeader :: Header
repHeader = HeaderName -> ByteString -> Header
Header (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> HeaderName) -> ByteString -> HeaderName
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 HeaderName
n1 ByteString
_) (Header HeaderName
n2 ByteString
_) = HeaderName
n1 HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
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)

-- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds.
cacheSeconds :: MonadHandler m => Int -> m ()
cacheSeconds :: 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"
    ]

-- | Set the Expires header to some date in 2037. In other words, this content
-- is never (realistically) expired.
neverExpires :: MonadHandler m => m ()
neverExpires :: 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

-- | Set an Expires header in the past, meaning this content should not be
-- cached.
alreadyExpired :: MonadHandler m => m ()
alreadyExpired :: m ()
alreadyExpired = Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setHeader Text
"Expires" Text
"Thu, 01 Jan 1970 05:05:05 GMT"

-- | Set an Expires header to the given date.
expiresAt :: MonadHandler m => UTCTime -> m ()
expiresAt :: 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
  -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are
  -- semantically identical but make no guarantees about being bytewise identical.
  | StrongEtag !S.ByteString
  -- ^ Signifies that contents should be byte-for-byte identical if they match
  -- the provided ETag
  | InvalidEtag !S.ByteString
  -- ^ Anything else that ends up in a header that expects an ETag but doesn't
  -- properly follow the ETag format specified in RFC 7232, section 2.3
  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
showList :: [Etag] -> ShowS
$cshowList :: [Etag] -> ShowS
show :: Etag -> FilePath
$cshow :: Etag -> FilePath
showsPrec :: Int -> Etag -> ShowS
$cshowsPrec :: Int -> Etag -> ShowS
Show, Etag -> Etag -> Bool
(Etag -> Etag -> Bool) -> (Etag -> Etag -> Bool) -> Eq Etag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Etag -> Etag -> Bool
$c/= :: Etag -> Etag -> Bool
== :: Etag -> Etag -> Bool
$c== :: Etag -> Etag -> Bool
Eq)

-- | Check the if-none-match header and, if it matches the given value, return
-- a 304 not modified response. Otherwise, set the etag header to the given
-- value.
--
-- Note that it is the responsibility of the caller to ensure that the provided
-- value is a valid etag value, no sanity checking is performed by this
-- function.
--
-- @since 1.4.4
setEtag :: MonadHandler m => Text -> m ()
setEtag :: Text -> m ()
setEtag Text
etag = do
    Maybe ByteString
mmatch <- HeaderName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Maybe ByteString)
lookupHeader HeaderName
"if-none-match"
    let matches :: [Etag]
matches = [Etag] -> (ByteString -> [Etag]) -> Maybe ByteString -> [Etag]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [Etag]
parseMatch Maybe ByteString
mmatch
        baseTag :: ByteString
baseTag = Text -> ByteString
encodeUtf8 Text
etag
        strongTag :: Etag
strongTag = ByteString -> Etag
StrongEtag ByteString
baseTag
        badTag :: Etag
badTag = ByteString -> Etag
InvalidEtag ByteString
baseTag
    if (Etag -> Bool) -> [Etag] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
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) [Etag]
matches
        then m ()
forall (m :: * -> *) a. MonadHandler m => m a
notModified
        else Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"etag" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"\"", Text
etag, Text
"\""]


-- | Parse an if-none-match field according to the spec.
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
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.spanEnd Word8 -> Bool
W8.isSpace (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
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
&& ByteString -> Word8
S.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._quotedbl Bool -> Bool -> Bool
&& 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
$ ByteString -> ByteString
S.init (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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
&&
          ByteString -> Word8
S.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
W8._W Bool -> Bool -> Bool
&&
          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
&&
          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
&&
          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
$ 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

-- | Check the if-none-match header and, if it matches the given value, return
-- a 304 not modified response. Otherwise, set the etag header to the given
-- value.
--
-- A weak etag is only expected to be semantically identical to the prior content,
-- but doesn't have to be byte-for-byte identical. Therefore it can be useful for
-- dynamically generated content that may be difficult to perform bytewise hashing
-- upon.
--
-- Note that it is the responsibility of the caller to ensure that the provided
-- value is a valid etag value, no sanity checking is performed by this
-- function.
--
-- @since 1.4.37
setWeakEtag :: MonadHandler m => Text -> m ()
setWeakEtag :: Text -> m ()
setWeakEtag Text
etag = do
    Maybe ByteString
mmatch <- HeaderName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Maybe ByteString)
lookupHeader HeaderName
"if-none-match"
    let matches :: [Etag]
matches = [Etag] -> (ByteString -> [Etag]) -> Maybe ByteString -> [Etag]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [Etag]
parseMatch Maybe ByteString
mmatch
    if ByteString -> Etag
WeakEtag (Text -> ByteString
encodeUtf8 Text
etag) Etag -> [Etag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Etag]
matches
        then m ()
forall (m :: * -> *) a. MonadHandler m => m a
notModified
        else Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
addHeader Text
"etag" (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text
"W/\"", Text
etag, Text
"\""]

-- | Set a variable in the user's session.
--
-- The session is handled by the clientsession package: it sets an encrypted
-- and hashed cookie on the client. This ensures that all data is secure and
-- not tampered with.
setSession :: MonadHandler m
           => Text -- ^ key
           -> Text -- ^ value
           -> m ()
setSession :: 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

-- | Same as 'setSession', but uses binary data for the value.
setSessionBS :: MonadHandler m
             => Text
             -> S.ByteString
             -> m ()
setSessionBS :: 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

-- | Unsets a session variable. See 'setSession'.
deleteSession :: MonadHandler m => Text -> m ()
deleteSession :: 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

-- | Clear all session variables.
--
-- @since: 1.0.1
clearSession :: MonadHandler m => m ()
clearSession :: 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 :: SessionMap
ghsSession = SessionMap
forall k a. Map k a
Map.empty }

modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession SessionMap -> SessionMap
f GHState
x = GHState
x { ghsSession :: SessionMap
ghsSession = SessionMap -> SessionMap
f (SessionMap -> SessionMap) -> SessionMap -> SessionMap
forall a b. (a -> b) -> a -> b
$ GHState -> SessionMap
ghsSession GHState
x }

-- | Internal use only, not to be confused with 'setHeader'.
addHeaderInternal :: MonadHandler m => Header -> m ()
addHeaderInternal :: Header -> m ()
addHeaderInternal = 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
. (:)

-- | Some value which can be turned into a URL for redirects.
class RedirectUrl master a where
    -- | Converts the value to the URL and a list of query-string parameters.
    toTextUrl :: (MonadHandler m, HandlerSite m ~ master) => a -> m Text

instance RedirectUrl master Text where
    toTextUrl :: Text -> m Text
toTextUrl = Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return

instance RedirectUrl master String where
    toTextUrl :: FilePath -> m Text
toTextUrl = Text -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> 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 :: Route master -> m Text
toTextUrl Route master
url = do
        Route master -> Text
r <- m (Route master -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> Text)
getUrlRender
        Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Route master -> Text
r Route master
url

instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where
    toTextUrl :: (Route master, [(key, val)]) -> m Text
toTextUrl (Route master
url, [(key, val)]
params) = do
        Route master -> [(key, val)] -> Text
r <- m (Route master -> [(key, val)] -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams
        Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Route master -> [(key, val)] -> Text
r Route master
url [(key, val)]
params

instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where
    toTextUrl :: (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
toTextUrl (Route master
url, Map key val -> [(key, val)]
forall k a. Map k a -> [(k, a)]
Map.toList Map key val
params)

-- | Add a fragment identifier to a route to be used when
-- redirecting.  For example:
--
-- > redirect (NewsfeedR :#: storyId)
--
-- @since 1.2.9.
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
showList :: [Fragment a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [Fragment a b] -> ShowS
show :: Fragment a b -> FilePath
$cshow :: forall a b. (Show a, Show b) => Fragment a b -> FilePath
showsPrec :: Int -> Fragment a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Fragment a b -> ShowS
Show

instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
  toTextUrl :: 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
toTextUrl a
a


-- | Lookup for session data.
lookupSession :: MonadHandler m => Text -> m (Maybe Text)
lookupSession :: Text -> m (Maybe Text)
lookupSession = ((Maybe ByteString -> Maybe Text)
-> m (Maybe ByteString) -> m (Maybe Text)
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 (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

-- | Lookup for session data in binary format.
lookupSessionBS :: MonadHandler m => Text -> m (Maybe S.ByteString)
lookupSessionBS :: Text -> m (Maybe ByteString)
lookupSessionBS Text
n = do
    SessionMap
m <- (GHState -> SessionMap) -> m GHState -> m SessionMap
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
    Maybe ByteString -> m (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> m (Maybe ByteString))
-> Maybe ByteString -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> SessionMap -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n SessionMap
m

-- | Get all session variables.
getSession :: MonadHandler m => m SessionMap
getSession :: m SessionMap
getSession = (GHState -> SessionMap) -> m GHState -> m SessionMap
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

-- | Get a unique identifier.
newIdent :: MonadHandler m => m Text
newIdent :: m Text
newIdent = do
    GHState
x <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
    let i' :: Int
i' = GHState -> Int
ghsIdent GHState
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    GHState -> m ()
forall (m :: * -> *). MonadHandler m => GHState -> m ()
put GHState
x { ghsIdent :: Int
ghsIdent = Int
i' }
    Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"hident" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i'

-- | Redirect to a POST resource.
--
-- This is not technically a redirect; instead, it returns an HTML page with a
-- POST form, and some Javascript to automatically submit the form. This can be
-- useful when you need to post a plain link somewhere that needs to cause
-- changes on the server.
redirectToPost :: (MonadHandler m, RedirectUrl (HandlerSite m) url)
               => url
               -> m a
redirectToPost :: url -> m a
redirectToPost url
url = do
    Text
urlText <- url -> m Text
forall master a (m :: * -> *).
(RedirectUrl master a, MonadHandler m, HandlerSite m ~ master) =>
a -> m Text
toTextUrl url
url
    YesodRequest
req <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> Html)
-> m Html
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
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(); };
|] m Html -> (Html -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Html -> m a
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse

-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: MonadHandler m => HtmlUrl (Route (HandlerSite m)) -> m Html
hamletToRepHtml :: HtmlUrl (Route (HandlerSite m)) -> m Html
hamletToRepHtml = HtmlUrl (Route (HandlerSite m)) -> m Html
forall (m :: * -> *) output.
MonadHandler m =>
((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer
{-# DEPRECATED hamletToRepHtml "Use withUrlRenderer instead" #-}

-- | Deprecated synonym for 'withUrlRenderer'.
--
-- @since 1.2.0
giveUrlRenderer :: MonadHandler m
                => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
                -> m output
giveUrlRenderer :: ((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" #-}

-- | Provide a URL rendering function to the given function and return the
-- result. Useful for processing Shakespearean templates.
--
-- @since 1.2.20
withUrlRenderer :: MonadHandler m
                => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
                -> m output
withUrlRenderer :: ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
withUrlRenderer (Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output
f = do
    Route (HandlerSite m) -> [(Text, Text)] -> Text
render <- m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams
    output -> m output
forall (m :: * -> *) a. Monad m => a -> m a
return (output -> m output) -> output -> m output
forall a b. (a -> b) -> a -> b
$ (Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output
f Route (HandlerSite m) -> [(Text, Text)] -> Text
render

-- | Get the request\'s 'W.Request' value.
waiRequest :: MonadHandler m => m W.Request
waiRequest :: 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 :: m (message -> Text)
getMessageRender = do
    RunHandlerEnv (HandlerSite m) (HandlerSite m)
env <- m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
forall (m :: * -> *).
MonadHandler m =>
m (RunHandlerEnv (HandlerSite m) (HandlerSite m))
askHandlerEnv
    [Text]
l <- m [Text]
forall (m :: * -> *). MonadHandler m => m [Text]
languages
    (message -> Text) -> m (message -> Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ((message -> Text) -> m (message -> Text))
-> (message -> Text) -> m (message -> Text)
forall a b. (a -> b) -> a -> b
$ HandlerSite m -> [Text] -> message -> Text
forall master message.
RenderMessage master message =>
master -> [Text] -> message -> Text
renderMessage (RunHandlerEnv (HandlerSite m) (HandlerSite m) -> HandlerSite m
forall child site. RunHandlerEnv child site -> site
rheSite RunHandlerEnv (HandlerSite m) (HandlerSite m)
env) [Text]
l

-- | Use a per-request cache to avoid performing the same action multiple times.
-- Values are stored by their type, the result of typeOf from Typeable.
-- Therefore, you should use different newtype wrappers at each cache site.
--
-- For example, yesod-auth uses an un-exported newtype, CachedMaybeAuth and exports functions that utilize it such as maybeAuth.
-- This means that another module can create its own newtype wrapper to cache the same type from a different action without any cache conflicts.
--
-- See the original announcement: <http://www.yesodweb.com/blog/2013/03/yesod-1-2-cleaner-internals>
--
-- @since 1.2.0
cached :: (MonadHandler m, Typeable a)
       => m a
       -> m a
cached :: m a -> m a
cached m a
action = do
    TypeMap
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
    Either (TypeMap, a) a
eres <- TypeMap -> m a -> m (Either (TypeMap, a) a)
forall (m :: * -> *) a.
(Monad m, Typeable a) =>
TypeMap -> m a -> m (Either (TypeMap, a) a)
Cache.cached TypeMap
cache m a
action
    case Either (TypeMap, a) a
eres of
      Right a
res -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
      Left (TypeMap
newCache, a
res) -> do
          GHState
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
          let merged :: TypeMap
merged = TypeMap
newCache TypeMap -> TypeMap -> TypeMap
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` GHState -> TypeMap
ghsCache GHState
gs
          GHState -> m ()
forall (m :: * -> *). MonadHandler m => GHState -> m ()
put (GHState -> m ()) -> GHState -> m ()
forall a b. (a -> b) -> a -> b
$ GHState
gs { ghsCache :: TypeMap
ghsCache = TypeMap
merged }
          a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Retrieves a value from the cache used by 'cached'.
--
-- @since 1.6.10
cacheGet :: (MonadHandler m, Typeable a)
         => m (Maybe a)
cacheGet :: m (Maybe a)
cacheGet = do
  TypeMap
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
  Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ TypeMap -> Maybe a
forall a. Typeable a => TypeMap -> Maybe a
Cache.cacheGet TypeMap
cache

-- | Sets a value in the cache used by 'cached'.
--
-- @since 1.6.10
cacheSet :: (MonadHandler m, Typeable a)
         => a
         -> m ()
cacheSet :: a -> m ()
cacheSet a
value = do
  GHState
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
  let cache :: TypeMap
cache = GHState -> TypeMap
ghsCache GHState
gs
      newCache :: TypeMap
newCache = a -> TypeMap -> TypeMap
forall a. Typeable a => a -> TypeMap -> TypeMap
Cache.cacheSet a
value TypeMap
cache
  GHState -> m ()
forall (m :: * -> *). MonadHandler m => GHState -> m ()
put (GHState -> m ()) -> GHState -> m ()
forall a b. (a -> b) -> a -> b
$ GHState
gs { ghsCache :: TypeMap
ghsCache = TypeMap
newCache }

-- | a per-request cache. just like 'cached'.
-- 'cached' can only cache a single value per type.
-- 'cachedBy' stores multiple values per type by usage of a ByteString key
--
-- 'cached' is ideal to cache an action that has only one value of a type, such as the session's current user
-- 'cachedBy' is required if the action has parameters and can return multiple values per type.
-- You can turn those parameters into a ByteString cache key.
-- For example, caching a lookup of a Link by a token where multiple token lookups might be performed.
--
-- @since 1.4.0
cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a
cachedBy :: ByteString -> m a -> m a
cachedBy ByteString
k m a
action = do
    KeyedTypeMap
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
    Either (KeyedTypeMap, a) a
eres <- KeyedTypeMap -> ByteString -> m a -> m (Either (KeyedTypeMap, a) a)
forall (m :: * -> *) a.
(Monad m, Typeable a) =>
KeyedTypeMap -> ByteString -> m a -> m (Either (KeyedTypeMap, a) a)
Cache.cachedBy KeyedTypeMap
cache ByteString
k m a
action
    case Either (KeyedTypeMap, a) a
eres of
      Right a
res -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
      Left (KeyedTypeMap
newCache, a
res) -> do
          GHState
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
          let merged :: KeyedTypeMap
merged = KeyedTypeMap
newCache KeyedTypeMap -> KeyedTypeMap -> KeyedTypeMap
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` GHState -> KeyedTypeMap
ghsCacheBy GHState
gs
          GHState -> m ()
forall (m :: * -> *). MonadHandler m => GHState -> m ()
put (GHState -> m ()) -> GHState -> m ()
forall a b. (a -> b) -> a -> b
$ GHState
gs { ghsCacheBy :: KeyedTypeMap
ghsCacheBy = KeyedTypeMap
merged }
          a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Retrieves a value from the cache used by 'cachedBy'.
--
-- @since 1.6.10
cacheByGet :: (MonadHandler m, Typeable a)
           => S.ByteString
           -> m (Maybe a)
cacheByGet :: ByteString -> m (Maybe a)
cacheByGet ByteString
key = do
  KeyedTypeMap
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
  Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ ByteString -> KeyedTypeMap -> Maybe a
forall a. Typeable a => ByteString -> KeyedTypeMap -> Maybe a
Cache.cacheByGet ByteString
key KeyedTypeMap
cache

-- | Sets a value in the cache used by 'cachedBy'.
--
-- @since 1.6.10
cacheBySet :: (MonadHandler m, Typeable a)
           => S.ByteString
           -> a
           -> m ()
cacheBySet :: ByteString -> a -> m ()
cacheBySet ByteString
key a
value = do
  GHState
gs <- m GHState
forall (m :: * -> *). MonadHandler m => m GHState
get
  let cache :: KeyedTypeMap
cache = GHState -> KeyedTypeMap
ghsCacheBy GHState
gs
      newCache :: KeyedTypeMap
newCache = ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
forall a.
Typeable a =>
ByteString -> a -> KeyedTypeMap -> KeyedTypeMap
Cache.cacheBySet ByteString
key a
value KeyedTypeMap
cache
  GHState -> m ()
forall (m :: * -> *). MonadHandler m => GHState -> m ()
put (GHState -> m ()) -> GHState -> m ()
forall a b. (a -> b) -> a -> b
$ GHState
gs { ghsCacheBy :: KeyedTypeMap
ghsCacheBy = KeyedTypeMap
newCache }

-- | Get the list of supported languages supplied by the user.
--
-- Languages are determined based on the following (in descending order
-- of preference):
--
-- * The _LANG get parameter.
--
-- * The _LANG user session variable.
--
-- * The _LANG cookie.
--
-- * Accept-Language HTTP header.
--
-- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates.
-- If a matching language is not found the default language will be used.
--
-- This is handled by parseWaiRequest (not exposed).
--
-- __NOTE__: Before version @1.6.19.0@, this function prioritized the session
-- variable above all other sources.
--
languages :: MonadHandler m => m [Text]
languages :: 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' :: 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)

-- | Lookup a request header.
--
-- @since 1.2.2
lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString)
lookupHeader :: HeaderName -> m (Maybe ByteString)
lookupHeader = ([ByteString] -> Maybe ByteString)
-> m [ByteString] -> m (Maybe ByteString)
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))
-> (HeaderName -> m [ByteString])
-> HeaderName
-> m (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> m [ByteString]
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m [ByteString]
lookupHeaders

-- | Lookup a request header.
--
-- @since 1.2.2
lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString]
lookupHeaders :: HeaderName -> m [ByteString]
lookupHeaders HeaderName
key = do
    Request
req <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
    [ByteString] -> m [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> m [ByteString]) -> [ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> [ByteString]
forall a b. Eq a => a -> [(a, b)] -> [b]
lookup' HeaderName
key ([(HeaderName, ByteString)] -> [ByteString])
-> [(HeaderName, ByteString)] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
W.requestHeaders Request
req

-- | Lookup basic authentication data from __Authorization__ header of
-- request. Returns user name and password
--
-- @since 1.4.9
lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text))
lookupBasicAuth :: m (Maybe (Text, Text))
lookupBasicAuth = (Maybe ByteString -> Maybe (Text, Text))
-> m (Maybe ByteString) -> m (Maybe (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ByteString
-> (ByteString -> Maybe (Text, Text)) -> Maybe (Text, Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (Text, Text)
getBA) (HeaderName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Maybe ByteString)
lookupHeader HeaderName
"Authorization")
  where
    getBA :: ByteString -> Maybe (Text, Text)
getBA ByteString
bs = (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text)
-> (ByteString -> Text) -> (ByteString, ByteString) -> (Text, Text)
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)
               ((ByteString, ByteString) -> (Text, Text))
-> Maybe (ByteString, ByteString) -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (ByteString, ByteString)
extractBasicAuth ByteString
bs

-- | Lookup bearer authentication datafrom __Authorization__ header of
-- request. Returns bearer token value
--
-- @since 1.4.9
lookupBearerAuth :: (MonadHandler m) => m (Maybe Text)
lookupBearerAuth :: m (Maybe Text)
lookupBearerAuth = (Maybe ByteString -> Maybe Text)
-> m (Maybe ByteString) -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe ByteString -> (ByteString -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Text
getBR)
                   (HeaderName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Maybe ByteString)
lookupHeader HeaderName
"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


-- | Lookup for GET parameters.
lookupGetParams :: MonadHandler m => Text -> m [Text]
lookupGetParams :: Text -> m [Text]
lookupGetParams Text
pn = do
    YesodRequest
rr <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Text]
forall a b. Eq a => a -> [(a, b)] -> [b]
lookup' Text
pn ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ YesodRequest -> [(Text, Text)]
reqGetParams YesodRequest
rr

-- | Lookup for GET parameters.
lookupGetParam :: MonadHandler m => Text -> m (Maybe Text)
lookupGetParam :: Text -> m (Maybe Text)
lookupGetParam = ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
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

-- | Lookup for POST parameters.
lookupPostParams :: (MonadResource m, MonadHandler m) => Text -> m [Text]
lookupPostParams :: Text -> m [Text]
lookupPostParams Text
pn = do
    ([(Text, Text)]
pp, [(Text, FileInfo)]
_) <- m RequestBodyContents
forall (m :: * -> *). MonadHandler m => m RequestBodyContents
runRequestBody
    [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Text]
forall a b. Eq a => a -> [(a, b)] -> [b]
lookup' Text
pn [(Text, Text)]
pp

lookupPostParam :: (MonadResource m, MonadHandler m)
                => Text
                -> m (Maybe Text)
lookupPostParam :: Text -> m (Maybe Text)
lookupPostParam = ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
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

-- | Lookup for POSTed files.
lookupFile :: MonadHandler m
           => Text
           -> m (Maybe FileInfo)
lookupFile :: Text -> m (Maybe FileInfo)
lookupFile = ([FileInfo] -> Maybe FileInfo)
-> m [FileInfo] -> m (Maybe FileInfo)
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

-- | Lookup for POSTed files.
lookupFiles :: MonadHandler m
            => Text
            -> m [FileInfo]
lookupFiles :: Text -> m [FileInfo]
lookupFiles Text
pn = do
    ([(Text, Text)]
_, [(Text, FileInfo)]
files) <- m RequestBodyContents
forall (m :: * -> *). MonadHandler m => m RequestBodyContents
runRequestBody
    [FileInfo] -> m [FileInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FileInfo] -> m [FileInfo]) -> [FileInfo] -> m [FileInfo]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, FileInfo)] -> [FileInfo]
forall a b. Eq a => a -> [(a, b)] -> [b]
lookup' Text
pn [(Text, FileInfo)]
files

-- | Lookup for cookie data.
lookupCookie :: MonadHandler m => Text -> m (Maybe Text)
lookupCookie :: Text -> m (Maybe Text)
lookupCookie = ([Text] -> Maybe Text) -> m [Text] -> m (Maybe Text)
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

-- | Lookup for cookie data.
lookupCookies :: MonadHandler m => Text -> m [Text]
lookupCookies :: Text -> m [Text]
lookupCookies Text
pn = do
    YesodRequest
rr <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
    [Text] -> m [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> m [Text]) -> [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> [Text]
forall a b. Eq a => a -> [(a, b)] -> [b]
lookup' Text
pn ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> a -> b
$ YesodRequest -> [(Text, Text)]
reqCookies YesodRequest
rr

-- $representations
--
-- HTTP allows content negotation to determine what /representation/ of data
-- you would like to use. The most common example of this is providing both a
-- user-facing HTML page and an API facing JSON response from the same URL. The
-- means of achieving this is the Accept HTTP header, which provides a list of
-- content types the client will accept, sorted by preference.
--
-- By using 'selectRep' and 'provideRep', you can provide a number of different
-- representations, e.g.:
--
-- > selectRep $ do
-- >   provideRep produceHtmlOutput
-- >   provideRep produceJsonOutput
--
-- The first provided representation will be used if no matches are found.

-- | Select a representation to send to the client based on the representations
-- provided inside this do-block. Should be used together with 'provideRep'.
--
-- @since 1.2.0
selectRep :: MonadHandler m
          => Writer.Writer (Endo [ProvidedRep m]) ()
          -> m TypedContent
selectRep :: Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep Writer (Endo [ProvidedRep m]) ()
w = do
    -- the content types are already sorted by q values
    -- which have been stripped
    [ByteString]
cts <- (YesodRequest -> [ByteString]) -> m YesodRequest -> m [ByteString]
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 (ByteString -> Maybe (ProvidedRep m))
-> [ByteString] -> [ProvidedRep m]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByteString -> Maybe (ProvidedRep m)
tryAccept [ByteString]
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 (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

    -- match on the type for sub-type wildcards.
    -- If the accept is text/ * it should match a provided text/html
    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
_) -> ((ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> (ByteString, ByteString)
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 -> (ByteString, ByteString)
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 (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 (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

    -- Mime types such as "text/html; charset=foo" get converted to
    -- "text/html;charset=foo"
    noSpace :: ByteString -> ByteString
noSpace = (Char -> Bool) -> ByteString -> ByteString
S8.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ')

-- | Internal representation of a single provided representation.
--
-- @since 1.2.0
data ProvidedRep m = ProvidedRep !ContentType !(m Content)

-- | Provide a single representation to be used, based on the request of the
-- client. Should be used together with 'selectRep'.
--
-- @since 1.2.0
provideRep :: (Monad m, HasContentType a)
           => m a
           -> Writer.Writer (Endo [ProvidedRep m]) ()
provideRep :: 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
getContentType m a
handler) m a
handler

-- | Same as 'provideRep', but instead of determining the content type from the
-- type of the value itself, you provide the content type separately. This can
-- be a convenience instead of creating newtype wrappers for uncommonly used
-- content types.
--
-- > provideRepType "application/x-special-format" "This is the content"
--
-- @since 1.2.0
provideRepType :: (Monad m, ToContent a)
               => ContentType
               -> m a
               -> Writer.Writer (Endo [ProvidedRep m]) ()
provideRepType :: ByteString -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType ByteString
ct m a
handler =
    Endo [ProvidedRep m] -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell (Endo [ProvidedRep m] -> Writer (Endo [ProvidedRep m]) ())
-> Endo [ProvidedRep m] -> Writer (Endo [ProvidedRep m]) ()
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]
:)

-- | Stream in the raw request body without any parsing.
--
-- @since 1.2.0
rawRequestBody :: MonadHandler m => ConduitT i S.ByteString m ()
rawRequestBody :: ConduitT i ByteString m ()
rawRequestBody = do
    Request
req <- m Request -> ConduitT i ByteString m Request
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 :: ConduitT i ByteString m ()
loop = do
            ByteString
bs <- IO ByteString -> ConduitT i ByteString m ByteString
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
            Bool -> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (ConduitT i ByteString m () -> ConduitT i ByteString m ())
-> ConduitT i ByteString m () -> ConduitT i ByteString m ()
forall a b. (a -> b) -> a -> b
$ do
                ByteString -> ConduitT i ByteString m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
                ConduitT i ByteString m ()
loop
    ConduitT i ByteString m ()
loop

-- | Stream the data from the file. Since Yesod 1.2, this has been generalized
-- to work in any @MonadResource@.
fileSource :: MonadResource m => FileInfo -> ConduitT () S.ByteString m ()
fileSource :: 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 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

-- | Extract a strict `ByteString` body from a `FileInfo`.
--
-- This function will block while reading the file.
--
-- > do
-- >     fileByteString <- fileSourceByteString fileInfo
--
-- @since 1.6.5
fileSourceByteString :: MonadResource m => FileInfo -> m S.ByteString
fileSourceByteString :: 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 ()
-> ConduitM ByteString Void m ByteString
-> ConduitT () Void m ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void m ByteString
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy))

-- | Provide a pure value for the response body.
--
-- > respond ct = return . TypedContent ct . toContent
--
-- @since 1.2.0
respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent
respond :: ByteString -> a -> m TypedContent
respond ByteString
ct = TypedContent -> m TypedContent
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

-- | Use a @Source@ for the response body.
--
-- Note that, for ease of use, the underlying monad is a @HandlerFor@. This
-- implies that you can run any @HandlerFor@ action. However, since a streaming
-- response occurs after the response headers have already been sent, some
-- actions make no sense here. For example: short-circuit responses, setting
-- headers, changing status codes, etc.
--
-- @since 1.2.0
respondSource :: ContentType
              -> ConduitT () (Flush Builder) (HandlerFor site) ()
              -> HandlerFor site TypedContent
respondSource :: 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 ->
    -- Note that this implementation relies on the fact that the ResourceT
    -- environment provided by the server is the same one used in HandlerFor.
    -- This is a safe assumption assuming the HandlerFor is run correctly.
    TypedContent -> IO TypedContent
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 (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

-- | In a streaming response, send a single chunk of data. This function works
-- on most datatypes, such as @ByteString@ and @Html@.
--
-- @since 1.2.0
sendChunk :: Monad m => ToFlushBuilder a => a -> ConduitT i (Flush Builder) m ()
sendChunk :: 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

-- | In a streaming response, send a flush command, causing all buffered data
-- to be immediately sent to the client.
--
-- @since 1.2.0
sendFlush :: Monad m => ConduitT i (Flush Builder) m ()
sendFlush :: 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

-- | Type-specialized version of 'sendChunk' for strict @ByteString@s.
--
-- @since 1.2.0
sendChunkBS :: Monad m => S.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkBS :: 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

-- | Type-specialized version of 'sendChunk' for lazy @ByteString@s.
--
-- @since 1.2.0
sendChunkLBS :: Monad m => L.ByteString -> ConduitT i (Flush Builder) m ()
sendChunkLBS :: 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

-- | Type-specialized version of 'sendChunk' for strict @Text@s.
--
-- @since 1.2.0
sendChunkText :: Monad m => T.Text -> ConduitT i (Flush Builder) m ()
sendChunkText :: 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

-- | Type-specialized version of 'sendChunk' for lazy @Text@s.
--
-- @since 1.2.0
sendChunkLazyText :: Monad m => TL.Text -> ConduitT i (Flush Builder) m ()
sendChunkLazyText :: 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

-- | Type-specialized version of 'sendChunk' for @Html@s.
--
-- @since 1.2.0
sendChunkHtml :: Monad m => Html -> ConduitT i (Flush Builder) m ()
sendChunkHtml :: 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

-- $ajaxCSRFOverview
-- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in.
-- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.
-- This is known as a <https://en.wikipedia.org/wiki/Cross-site_request_forgery Cross Site Request Forgery> (CSRF) attack.
--
-- To combat this attack, you need a way to verify that the request is valid.
-- This is achieved by generating a random string ("token"), storing it in your encrypted session so that the server can look it up (see 'reqToken'), and adding the token to HTTP requests made to your server.
-- When a request comes in, the token in the request is compared to the one from the encrypted session. If they match, you can be sure the request is valid.
--
-- Yesod implements this behavior in two ways:
--
-- (1) The yesod-form package <http://www.yesodweb.com/book/forms#forms_running_forms stores the CSRF token in a hidden field> in the form, then validates it with functions like 'Yesod.Form.Functions.runFormPost'.
--
-- (2) Yesod can store the CSRF token in a cookie which is accessible by Javascript. Requests made by Javascript can lookup this cookie and add it as a header to requests. The server then checks the token in the header against the one in the encrypted session.
--
-- The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfParamNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam').
--
-- The easiest way to check both sources is to add the 'Yesod.Core.defaultCsrfMiddleware' to your Yesod Middleware.
--
-- === Opting-out of CSRF checking for specific routes
--
-- (Note: this code is generic to opting out of any Yesod middleware)
--
-- @
-- 'yesodMiddleware' app = do
--   maybeRoute <- 'getCurrentRoute'
--   let dontCheckCsrf = case maybeRoute of
--                         Just HomeR                     -> True  -- Don't check HomeR
--                         Nothing                        -> True  -- Don't check for 404s
--                         _                              -> False -- Check other routes
--
--   'defaultYesodMiddleware' $ 'defaultCsrfSetCookieMiddleware' $ (if dontCheckCsrf then 'id' else 'defaultCsrfCheckMiddleware') $ app
-- @
--
-- This can also be implemented using the 'csrfCheckMiddleware' function.

-- | The default cookie name for the CSRF token ("XSRF-TOKEN").
--
-- @since 1.4.14
defaultCsrfCookieName :: S8.ByteString
defaultCsrfCookieName :: ByteString
defaultCsrfCookieName = ByteString
"XSRF-TOKEN"

-- | Sets a cookie with a CSRF token, using 'defaultCsrfCookieName' for the cookie name.
--
-- The cookie's path is set to @/@, making it valid for your whole website.
--
-- @since 1.4.14
setCsrfCookie :: MonadHandler m => m ()
setCsrfCookie :: m ()
setCsrfCookie = SetCookie -> m ()
forall (m :: * -> *). MonadHandler m => SetCookie -> m ()
setCsrfCookieWithCookie SetCookie
defaultSetCookie
  { setCookieName :: ByteString
setCookieName = ByteString
defaultCsrfCookieName
  , setCookiePath :: Maybe ByteString
setCookiePath = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/"
  }

-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.
--
-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.
--
-- @since 1.4.14
setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m ()
setCsrfCookieWithCookie :: SetCookie -> m ()
setCsrfCookieWithCookie SetCookie
cookie  = do
    Maybe Text
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
    Maybe Text -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
Fold.forM_ Maybe Text
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 :: ByteString
setCookieValue = Text -> ByteString
encodeUtf8 Text
token })

-- | The default header name for the CSRF token ("X-XSRF-TOKEN").
--
-- @since 1.4.14
defaultCsrfHeaderName :: CI S8.ByteString
defaultCsrfHeaderName :: HeaderName
defaultCsrfHeaderName = HeaderName
"X-XSRF-TOKEN"

-- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session,
-- this function throws a 'PermissionDenied' error.
--
-- @since 1.4.14
checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m ()
checkCsrfHeaderNamed :: HeaderName -> m ()
checkCsrfHeaderNamed HeaderName
headerName = do
  (Bool
valid, Maybe Text
mHeader) <- HeaderName -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' HeaderName
headerName
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
valid (Text -> m ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [CSRFExpectation] -> Text
csrfErrorMessage [Text -> Maybe Text -> CSRFExpectation
CSRFHeader (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
headerName) Maybe Text
mHeader])

-- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session.
--
-- @since 1.4.14
hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool
hasValidCsrfHeaderNamed :: HeaderName -> m Bool
hasValidCsrfHeaderNamed HeaderName
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
<$> HeaderName -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' HeaderName
headerName

-- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages.
hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' :: HeaderName -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' HeaderName
headerName = do
  Maybe Text
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
  Maybe ByteString
mXsrfHeader <- HeaderName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Maybe ByteString)
lookupHeader HeaderName
headerName

  (Bool, Maybe Text) -> m (Bool, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Maybe Text) -> m (Bool, Maybe Text))
-> (Bool, Maybe Text) -> m (Bool, Maybe Text)
forall a b. (a -> b) -> a -> b
$ (Maybe Text -> Maybe ByteString -> Bool
validCsrf Maybe Text
mCsrfToken Maybe ByteString
mXsrfHeader, ByteString -> Text
decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
mXsrfHeader)

-- CSRF Parameter checking

-- | The default parameter name for the CSRF token ("_token")
--
-- @since 1.4.14
defaultCsrfParamName :: Text
defaultCsrfParamName :: Text
defaultCsrfParamName = Text
"_token"

-- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session,
-- this function throws a 'PermissionDenied' error.
--
-- @since 1.4.14
checkCsrfParamNamed :: MonadHandler m => Text -> m ()
checkCsrfParamNamed :: Text -> m ()
checkCsrfParamNamed Text
paramName = do
  (Bool
valid, Maybe Text
mParam) <- Text -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' Text
paramName
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
valid (Text -> m ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ [CSRFExpectation] -> Text
csrfErrorMessage [Text -> Maybe Text -> CSRFExpectation
CSRFParam Text
paramName Maybe Text
mParam])

-- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session.
--
-- @since 1.4.14
hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool
hasValidCsrfParamNamed :: 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

-- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages.
hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' :: Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' Text
paramName = do
  Maybe Text
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
  Maybe Text
mCsrfParam <- Text -> m (Maybe Text)
forall (m :: * -> *).
(MonadResource m, MonadHandler m) =>
Text -> m (Maybe Text)
lookupPostParam Text
paramName

  (Bool, Maybe Text) -> m (Bool, Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bool, Maybe Text) -> m (Bool, Maybe Text))
-> (Bool, Maybe Text) -> m (Bool, Maybe Text)
forall a b. (a -> b) -> a -> b
$ (Maybe Text -> Maybe ByteString -> Bool
validCsrf Maybe Text
mCsrfToken (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mCsrfParam), Maybe Text
mCsrfParam)

-- | Checks that a valid CSRF token is present in either the request headers or POST parameters.
-- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error.
--
-- @since 1.4.14
checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m)
                       => CI S8.ByteString -- ^ The header name to lookup the CSRF token
                       -> Text -- ^ The POST parameter name to lookup the CSRF token
                       -> m ()
checkCsrfHeaderOrParam :: HeaderName -> Text -> m ()
checkCsrfHeaderOrParam HeaderName
headerName Text
paramName = do
  (Bool
validHeader, Maybe Text
mHeader) <- HeaderName -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
HeaderName -> m (Bool, Maybe Text)
hasValidCsrfHeaderNamed' HeaderName
headerName
  (Bool
validParam, Maybe Text
mParam) <- Text -> m (Bool, Maybe Text)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Bool, Maybe Text)
hasValidCsrfParamNamed' Text
paramName
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
validHeader Bool -> Bool -> Bool
|| Bool
validParam) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let errorMessage :: Text
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
$ HeaderName -> ByteString
forall s. CI s -> s
original HeaderName
headerName) Maybe Text
mHeader, Text -> Maybe Text -> CSRFExpectation
CSRFParam Text
paramName Maybe Text
mParam]
    Text -> Text -> m ()
$logWarnS Text
"yesod-core" Text
errorMessage
    Text -> m ()
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
errorMessage

validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool
-- It's important to use constant-time comparison (constEq) in order to avoid timing attacks.
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 = CSRFHeader Text (Maybe Text) -- Key/Value
                     | CSRFParam Text (Maybe Text) -- Key/Value

csrfErrorMessage :: [CSRFExpectation]
                  -> Text -- ^ Error message
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 :: m (SubHandlerSite m)
getSubYesod = SubHandlerFor (SubHandlerSite m) (HandlerSite m) (SubHandlerSite m)
-> m (SubHandlerSite m)
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 (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 :: 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 (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 (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 :: m (Maybe (Route (SubHandlerSite m)))
getSubCurrentRoute = SubHandlerFor
  (SubHandlerSite m)
  (HandlerSite m)
  (Maybe (Route (SubHandlerSite m)))
-> m (Maybe (Route (SubHandlerSite m)))
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 (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