{-# 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 contentType :: ByteString
contentType message :: ByteString
message =
let res :: Response
res = Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response 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 "Content-Type") ByteString
contentType Response
res
class ToMessage a where
toContentType :: a -> B.ByteString
toContentType _ = String -> ByteString
B.pack "text/plain"
toMessage :: a -> L.ByteString
toMessage = String -> a -> ByteString
forall a. HasCallStack => String -> a
error "Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined"
toResponse :: a -> Response
toResponse val :: 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 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 "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 "text/plain"
toMessage :: () -> ByteString
toMessage () = ByteString
L.empty
instance ToMessage String where
toContentType :: String -> ByteString
toContentType _ = String -> ByteString
B.pack "text/plain; charset=UTF-8"
toMessage :: String -> ByteString
toMessage = String -> ByteString
LU.fromString
instance ToMessage T.Text where
toContentType :: Text -> ByteString
toContentType _ = String -> ByteString
B.pack "text/plain; charset=UTF-8"
toMessage :: Text -> ByteString
toMessage t :: Text
t = [ByteString] -> ByteString
L.fromChunks [Text -> ByteString
T.encodeUtf8 Text
t]
instance ToMessage LT.Text where
toContentType :: Text -> ByteString
toContentType _ = String -> ByteString
B.pack "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 _ = a -> ByteString
forall a. ToMessage a => a -> ByteString
toContentType (a
forall a. HasCallStack => a
undefined :: a)
toMessage :: Maybe a -> ByteString
toMessage Nothing = String -> ByteString
forall a. ToMessage a => a -> ByteString
toMessage "nothing"
toMessage (Just x :: a
x) = a -> ByteString
forall a. ToMessage a => a -> ByteString
toMessage a
x
instance ToMessage Html where
toContentType :: Html -> ByteString
toContentType _ = String -> ByteString
B.pack "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 _ = String -> ByteString
B.pack "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 _ = String -> ByteString
B.pack "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 bs :: ByteString
bs = Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response 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 bs :: 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 modTime :: UTCTime
modTime request :: Request
request response :: Response
response =
let repr :: String
repr = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%a, %d %b %Y %X GMT" UTCTime
modTime
notmodified :: Bool
notmodified = String -> Request -> Maybe ByteString
forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader "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 304 ""
else String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader "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 code :: 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
$ \r :: Response
r -> Response
r{rsCode :: Int
rsCode = Int
code}
resp :: (FilterMonad Response m) =>
Int
-> b
-> m b
resp :: Int -> b -> m b
resp status :: Int
status val :: 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 200
noContent :: (FilterMonad Response m) => a -> m a
noContent :: a -> m a
noContent val :: a
val = (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter (\r :: Response
r -> Response -> Response
noContentLength (Response
r { rsCode :: Int
rsCode = 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 uri :: a
uri res :: 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 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
uri res :: 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 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
uri res :: 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 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 val :: a
val res :: 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 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 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 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 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 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 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 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 502
prettyResponse :: Response -> String
prettyResponse :: Response -> String
prettyResponse res :: Response
res@Response{} =
String -> ShowS
showString "================== Response ================" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString "\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 "\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 "\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 "\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 "\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 "================== Response ================" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> ShowS
showString "\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 "\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 "\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 "\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 "\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 "\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 "\nsfCount = " ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (Response -> Integer
sfCount Response
res)