{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-}
module Happstack.Server.Response
(
ToMessage(..)
, flatten
, toResponseBS
, ok
, noContent
, internalServerError
, badGateway
, badRequest
, unauthorized
, forbidden
, notFound
, prettyResponse
, requestEntityTooLarge
, seeOther
, found
, movedPermanently
, tempRedirect
, setResponseCode
, resp
, ifModifiedSince
) where
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as LU (fromString)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Happstack.Server.Internal.Monads (FilterMonad(composeFilter))
import Happstack.Server.Internal.Types
import Happstack.Server.Types (Response(..), Request(..), nullRsFlags, getHeader, noContentLength, redirect, result, setHeader, setHeaderBS)
import Happstack.Server.SURI (ToSURI)
import qualified Text.Blaze.Html as Blaze
import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
import Text.Html (Html, renderHtml)
import qualified Text.XHtml as XHtml (Html, renderHtml)
#if MIN_VERSION_time(1,5,0)
import Data.Time (UTCTime, formatTime, defaultTimeLocale)
#else
import Data.Time (UTCTime, formatTime)
import System.Locale (defaultTimeLocale)
#endif
toResponseBS :: B.ByteString
-> L.ByteString
-> Response
toResponseBS :: ByteString -> ByteString -> Response
toResponseBS ByteString
contentType ByteString
message =
let res :: Response
res = Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response Int
200 Headers
forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
message Maybe (Response -> IO Response)
forall a. Maybe a
Nothing
in ByteString -> ByteString -> Response -> Response
forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS (String -> ByteString
B.pack String
"Content-Type") ByteString
contentType Response
res
class ToMessage a where
toContentType :: a -> B.ByteString
toContentType a
_ = String -> ByteString
B.pack String
"text/plain"
toMessage :: a -> L.ByteString
toMessage = String -> a -> ByteString
forall a. HasCallStack => String -> a
error String
"Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined"
toResponse :: a -> Response
toResponse a
val =
let bs :: ByteString
bs = a -> ByteString
forall a. ToMessage a => a -> ByteString
toMessage a
val
res :: Response
res = Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response Int
200 Headers
forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
bs Maybe (Response -> IO Response)
forall a. Maybe a
Nothing
in ByteString -> ByteString -> Response -> Response
forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS (String -> ByteString
B.pack String
"Content-Type") (a -> ByteString
forall a. ToMessage a => a -> ByteString
toContentType a
val)
Response
res
instance ToMessage () where
toContentType :: () -> ByteString
toContentType ()
_ = String -> ByteString
B.pack String
"text/plain"
toMessage :: () -> ByteString
toMessage () = ByteString
L.empty
instance ToMessage String where
toContentType :: String -> ByteString
toContentType String
_ = String -> ByteString
B.pack String
"text/plain; charset=UTF-8"
toMessage :: String -> ByteString
toMessage = String -> ByteString
LU.fromString
instance ToMessage T.Text where
toContentType :: Text -> ByteString
toContentType Text
_ = String -> ByteString
B.pack String
"text/plain; charset=UTF-8"
toMessage :: Text -> ByteString
toMessage Text
t = [ByteString] -> ByteString
L.fromChunks [Text -> ByteString
T.encodeUtf8 Text
t]
instance ToMessage LT.Text where
toContentType :: Text -> ByteString
toContentType Text
_ = String -> ByteString
B.pack String
"text/plain; charset=UTF-8"
toMessage :: Text -> ByteString
toMessage = Text -> ByteString
LT.encodeUtf8
instance ToMessage Integer where
toMessage :: Integer -> ByteString
toMessage = String -> ByteString
forall a. ToMessage a => a -> ByteString
toMessage (String -> ByteString)
-> (Integer -> String) -> Integer -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show
instance ToMessage a => ToMessage (Maybe a) where
toContentType :: Maybe a -> ByteString
toContentType Maybe a
_ = a -> ByteString
forall a. ToMessage a => a -> ByteString
toContentType (a
forall a. HasCallStack => a
undefined :: a)
toMessage :: Maybe a -> ByteString
toMessage Maybe a
Nothing = String -> ByteString
forall a. ToMessage a => a -> ByteString
toMessage String
"nothing"
toMessage (Just a
x) = a -> ByteString
forall a. ToMessage a => a -> ByteString
toMessage a
x
instance ToMessage Html where
toContentType :: Html -> ByteString
toContentType Html
_ = String -> ByteString
B.pack String
"text/html; charset=UTF-8"
toMessage :: Html -> ByteString
toMessage = String -> ByteString
LU.fromString (String -> ByteString) -> (Html -> String) -> Html -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> String
forall html. HTML html => html -> String
renderHtml
instance ToMessage XHtml.Html where
toContentType :: Html -> ByteString
toContentType Html
_ = String -> ByteString
B.pack String
"text/html; charset=UTF-8"
toMessage :: Html -> ByteString
toMessage = String -> ByteString
LU.fromString (String -> ByteString) -> (Html -> String) -> Html -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> String
forall html. HTML html => html -> String
XHtml.renderHtml
instance ToMessage Blaze.Html where
toContentType :: Html -> ByteString
toContentType Html
_ = String -> ByteString
B.pack String
"text/html; charset=UTF-8"
toMessage :: Html -> ByteString
toMessage = Html -> ByteString
Blaze.renderHtml
instance ToMessage Response where
toResponse :: Response -> Response
toResponse = Response -> Response
forall a. a -> a
id
instance ToMessage L.ByteString where
toResponse :: ByteString -> Response
toResponse ByteString
bs = Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response Int
200 Headers
forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
bs Maybe (Response -> IO Response)
forall a. Maybe a
Nothing
instance ToMessage B.ByteString where
toResponse :: ByteString -> Response
toResponse ByteString
bs = ByteString -> Response
forall a. ToMessage a => a -> Response
toResponse ([ByteString] -> ByteString
L.fromChunks [ByteString
bs])
flatten :: (ToMessage a, Functor f) => f a -> f Response
flatten :: f a -> f Response
flatten = (a -> Response) -> f a -> f Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Response
forall a. ToMessage a => a -> Response
toResponse
ifModifiedSince :: UTCTime
-> Request
-> Response
-> Response
ifModifiedSince :: UTCTime -> Request -> Response -> Response
ifModifiedSince UTCTime
modTime Request
request Response
response =
let repr :: String
repr = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%a, %d %b %Y %X GMT" UTCTime
modTime
notmodified :: Bool
notmodified = String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"if-modified-since" Request
request Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
repr)
in if Bool
notmodified
then Response -> Response
noContentLength (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Int -> String -> Response
result Int
304 String
""
else String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Last-modified" String
repr Response
response
modifyResponse :: (FilterMonad a m) => (a -> a) -> m()
modifyResponse :: (a -> a) -> m ()
modifyResponse = (a -> a) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
{-# DEPRECATED modifyResponse "Use composeFilter" #-}
setResponseCode :: FilterMonad Response m =>
Int
-> m ()
setResponseCode :: Int -> m ()
setResponseCode Int
code
= (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \Response
r -> Response
r{rsCode :: Int
rsCode = Int
code}
resp :: (FilterMonad Response m) =>
Int
-> b
-> m b
resp :: Int -> b -> m b
resp Int
status b
val = Int -> m ()
forall (m :: * -> *). FilterMonad Response m => Int -> m ()
setResponseCode Int
status m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
val
ok :: (FilterMonad Response m) => a -> m a
ok :: a -> m a
ok = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
200
noContent :: (FilterMonad Response m) => a -> m a
noContent :: a -> m a
noContent a
val = (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter (\Response
r -> Response -> Response
noContentLength (Response
r { rsCode :: Int
rsCode = Int
204, rsBody :: ByteString
rsBody = ByteString
L.empty })) m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
movedPermanently :: a -> res -> m res
movedPermanently a
uri res
res = do (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> a -> Response -> Response
forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
301 a
uri
res -> m res
forall (m :: * -> *) a. Monad m => a -> m a
return res
res
found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
found :: uri -> res -> m res
found uri
uri res
res = do (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> uri -> Response -> Response
forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
302 uri
uri
res -> m res
forall (m :: * -> *) a. Monad m => a -> m a
return res
res
seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
seeOther :: uri -> res -> m res
seeOther uri
uri res
res = do (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> uri -> Response -> Response
forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
303 uri
uri
res -> m res
forall (m :: * -> *) a. Monad m => a -> m a
return res
res
tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
tempRedirect :: a -> res -> m res
tempRedirect a
val res
res = do (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> a -> Response -> Response
forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
307 a
val
res -> m res
forall (m :: * -> *) a. Monad m => a -> m a
return res
res
badRequest :: (FilterMonad Response m) => a -> m a
badRequest :: a -> m a
badRequest = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
400
unauthorized :: (FilterMonad Response m) => a -> m a
unauthorized :: a -> m a
unauthorized = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
401
forbidden :: (FilterMonad Response m) => a -> m a
forbidden :: a -> m a
forbidden = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
403
notFound :: (FilterMonad Response m) => a -> m a
notFound :: a -> m a
notFound = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
404
requestEntityTooLarge :: (FilterMonad Response m) => a -> m a
requestEntityTooLarge :: a -> m a
requestEntityTooLarge = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
413
internalServerError :: (FilterMonad Response m) => a -> m a
internalServerError :: a -> m a
internalServerError = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
500
badGateway :: (FilterMonad Response m) => a -> m a
badGateway :: a -> m a
badGateway = Int -> a -> m a
forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
502
prettyResponse :: Response -> String
prettyResponse :: Response -> String
prettyResponse res :: Response
res@Response{} =
String -> ShowS
showString String
"================== Response ================" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsCode = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> Int
rsCode Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsHeaders = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> Headers
rsHeaders Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsFlags = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RsFlags -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> RsFlags
rsFlags Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsBody = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> ByteString
rsBody Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsValidator = " ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Maybe (Response -> IO Response) -> String
showRsValidator (Response -> Maybe (Response -> IO Response)
rsValidator Response
res)
prettyResponse res :: Response
res@SendFile{} =
String -> ShowS
showString String
"================== Response ================" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsCode = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> Int
rsCode Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsHeaders = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Headers -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> Headers
rsHeaders Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsFlags = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RsFlags -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> RsFlags
rsFlags Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nrsValidator = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows (Maybe (Response -> IO Response) -> String
showRsValidator (Response -> Maybe (Response -> IO Response)
rsValidator Response
res)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nsfFilePath = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> String
sfFilePath Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nsfOffset = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ShowS
forall a. Show a => a -> ShowS
shows (Response -> Integer
sfOffset Response
res) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString String
"\nsfCount = " ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (Response -> Integer
sfCount Response
res)