{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-}
-- | Functions and classes related to generating a 'Response' and setting the response code. For detailed instruction see the Happstack Crash Course: <http://www.happstack.com/docs/crashcourse/index.html#creating-a-response>
module Happstack.Server.Response
    ( -- * Converting values to a 'Response'
      ToMessage(..)
    , flatten
    , toResponseBS
      -- * Setting the Response Code
    , ok
    , noContent
    , internalServerError
    , badGateway
    , badRequest
    , unauthorized
    , forbidden
    , notFound
    , prettyResponse
    , requestEntityTooLarge
    , seeOther
    , found
    , movedPermanently
    , tempRedirect
    , setResponseCode
    , resp
    -- * Handling if-modified-since
    , 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

-- | A low-level function to build a 'Response' from a content-type
-- and a 'ByteString'.
--
-- Creates a 'Response' in a manner similar to the 'ToMessage' class,
-- but without requiring an instance declaration.
--
-- example:
--
-- > import Data.ByteString.Char8 as C
-- > import Data.ByteString.Lazy.Char8 as L
-- > import Happstack.Server
-- >
-- > main = simpleHTTP nullConf $ ok $ toResponseBS (C.pack "text/plain") (L.pack "hello, world")
--
-- (note: 'C.pack' and 'L.pack' only work for ascii. For unicode strings you would need to use @utf8-string@, @text@, or something similar to create a valid 'ByteString').
toResponseBS :: B.ByteString -- ^ content-type
             -> L.ByteString -- ^ response body
             -> 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 forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
message forall a. Maybe a
Nothing
    in forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS (String -> ByteString
B.pack String
"Content-Type") ByteString
contentType Response
res


-- | 'toResponse' will convert a value into a 'Response' body,
-- set the @content-type@, and set the default response code for that type.
--
-- @happstack-server@ Example:
--
-- > main = simpleHTTP nullConf $ toResponse "hello, world!"
--
-- will generate a 'Response' with the content-type @text/plain@,
-- the response code @200 OK@, and the body: @hello, world!@.
--
-- 'simpleHTTP' will call 'toResponse' automatically, so the above can be shortened to:
--
--  > main = simpleHTTP nullConf $ "hello, world!"
--
-- @happstack-lite@ Example:
--
-- > main = serve Nothing $ toResponse "hello, world!"
--
-- Minimal definition: 'toMessage' (and usually 'toContentType').
class ToMessage a where
    toContentType :: a -> B.ByteString
    toContentType a
_ = String -> ByteString
B.pack String
"text/plain"
    toMessage :: a -> L.ByteString
    toMessage = forall a. HasCallStack => String -> a
error String
"Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined"
    toResponse :: a -> Response
    toResponse a
val =
        let bs :: ByteString
bs = forall a. ToMessage a => a -> ByteString
toMessage a
val
            res :: Response
res = Int
-> Headers
-> RsFlags
-> ByteString
-> Maybe (Response -> IO Response)
-> Response
Response Int
200 forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
bs forall a. Maybe a
Nothing
        in forall r. HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS (String -> ByteString
B.pack String
"Content-Type") (forall a. ToMessage a => a -> ByteString
toContentType a
val)
           Response
res
{-
instance ToMessage [Element] where
    toContentType _ = B.pack "application/xml; charset=UTF-8"
    toMessage [el] = LU.fromString $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE
    toMessage x    = error ("Happstack.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x)
-}

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 = forall a. ToMessage a => a -> ByteString
toMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

instance ToMessage a => ToMessage (Maybe a) where
    toContentType :: Maybe a -> ByteString
toContentType Maybe a
_ = forall a. ToMessage a => a -> ByteString
toContentType (forall a. HasCallStack => a
undefined :: a)
    toMessage :: Maybe a -> ByteString
toMessage Maybe a
Nothing = forall a. ToMessage a => a -> ByteString
toMessage String
"nothing"
    toMessage (Just a
x) = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 forall k a. Map k a
M.empty RsFlags
nullRsFlags ByteString
bs forall a. Maybe a
Nothing

instance ToMessage B.ByteString where
    toResponse :: ByteString -> Response
toResponse ByteString
bs = forall a. ToMessage a => a -> Response
toResponse ([ByteString] -> ByteString
L.fromChunks [ByteString
bs])

{-

-- This instances causes awful error messages. I am removing it and
-- seeing if anyone complains. I doubt they will.

instance (Xml a)=>ToMessage a where
    toContentType = toContentType . toXml
    toMessage = toMessage . toPublicXml
-}

--    toMessageM = toMessageM . toPublicXml

-- | alias for: @fmap toResponse@
--
-- turns @m a@ into @m 'Response'@ using 'toResponse'.
--
-- > main = simpleHTTP nullConf $ flatten $ do return "flatten me."
flatten :: (ToMessage a, Functor f) => f a -> f Response
flatten :: forall a (f :: * -> *).
(ToMessage a, Functor f) =>
f a -> f Response
flatten = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToMessage a => a -> Response
toResponse


-- |Honor an @if-modified-since@ header in a 'Request'.
-- If the 'Request' includes the @if-modified-since@ header and the
-- 'Response' has not been modified, then return 304 (Not Modified),
-- otherwise return the 'Response'.
ifModifiedSince :: UTCTime -- ^ mod-time for the 'Response' (MUST NOT be later than server's time of message origination)
                -> Request -- ^ incoming request (used to check for if-modified-since)
                -> Response -- ^ Response to send if there are modifications
                -> Response
ifModifiedSince :: UTCTime -> Request -> Response -> Response
ifModifiedSince UTCTime
modTime Request
request Response
response =
    let repr :: String
repr = forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%a, %d %b %Y %X GMT" UTCTime
modTime
        notmodified :: Bool
notmodified = forall r. HasHeaders r => String -> r -> Maybe ByteString
getHeader String
"if-modified-since" Request
request forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ String
repr)
    in if Bool
notmodified
          then Response -> Response
noContentLength forall a b. (a -> b) -> a -> b
$ Int -> String -> Response
result Int
304 String
"" -- Not Modified
          else forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Last-modified" String
repr Response
response

-- | Deprecated:  use 'composeFilter'.
modifyResponse :: (FilterMonad a m) => (a -> a) -> m()
modifyResponse :: forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse = forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter
{-# DEPRECATED modifyResponse "Use composeFilter" #-}

-- | Set an arbitrary return code in your response.
--
-- A filter for setting the response code. Generally you will use a
-- helper function like 'ok' or 'seeOther'.
--
-- > main = simpleHTTP nullConf $ do setResponseCode 200
-- >                                 return "Everything is OK"
--
-- see also: 'resp'
setResponseCode :: FilterMonad Response m =>
                   Int -- ^ response code
                -> m ()
setResponseCode :: forall (m :: * -> *). FilterMonad Response m => Int -> m ()
setResponseCode Int
code
    = forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter forall a b. (a -> b) -> a -> b
$ \Response
r -> Response
r{rsCode :: Int
rsCode = Int
code}

-- | Same as @'setResponseCode' status >> return val@.
--
-- Use this if you want to set a response code that does not already
-- have a helper function.
--
-- > main = simpleHTTP nullConf $ resp 200 "Everything is OK"
resp :: (FilterMonad Response m) =>
        Int -- ^ response code
     -> b   -- ^ value to return
     -> m b
resp :: forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
status b
val = forall (m :: * -> *). FilterMonad Response m => Int -> m ()
setResponseCode Int
status forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return b
val

-- | Respond with @200 OK@.
--
-- > main = simpleHTTP nullConf $ ok "Everything is OK"
ok :: (FilterMonad Response m) => a -> m a
ok :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
ok = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
200

-- | Respond with @204 No Content@
--
-- A @204 No Content@ response may not contain a message-body. If you try to supply one, it will be dutifully ignored.
--
-- > main = simpleHTTP nullConf $ noContent "This will be ignored."
noContent :: (FilterMonad Response m) => a -> m a
noContent :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
noContent a
val = 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 })) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Respond with @301 Moved Permanently@.
--
-- > main = simpleHTTP nullConf $ movedPermanently "http://example.org/" "What you are looking for is now at http://example.org/"
movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
movedPermanently :: forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
movedPermanently a
uri res
res = do forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
301 a
uri
                              forall (m :: * -> *) a. Monad m => a -> m a
return res
res

-- | Respond with @302 Found@.
--
-- You probably want 'seeOther'. This method is not in popular use anymore, and is generally treated like 303 by most user-agents anyway.
found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
found :: forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
found uri
uri res
res = do forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
302 uri
uri
                   forall (m :: * -> *) a. Monad m => a -> m a
return res
res

-- | Respond with @303 See Other@.
--
-- > main = simpleHTTP nullConf $ seeOther "http://example.org/" "What you are looking for is now at http://example.org/"
--
-- NOTE: The second argument of 'seeOther' is the message body which will sent to the browser. According to the HTTP 1.1 spec,
--
-- @the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).@
--
-- This is because pre-HTTP\/1.1 user agents do not support 303. However, in practice you can probably just use @\"\"@ as the second argument.
seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res
seeOther :: forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
seeOther uri
uri res
res = do forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
303 uri
uri
                      forall (m :: * -> *) a. Monad m => a -> m a
return res
res

-- | Respond with @307 Temporary Redirect@.
--
-- > main = simpleHTTP nullConf $ tempRedirect "http://example.org/" "What you are looking for is temporarily at http://example.org/"
tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res
tempRedirect :: forall (m :: * -> *) a res.
(FilterMonad Response m, ToSURI a) =>
a -> res -> m res
tempRedirect a
val res
res = do forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
modifyResponse forall a b. (a -> b) -> a -> b
$ forall s. ToSURI s => Int -> s -> Response -> Response
redirect Int
307 a
val
                          forall (m :: * -> *) a. Monad m => a -> m a
return res
res

-- | Respond with @400 Bad Request@.
--
-- > main = simpleHTTP nullConf $ badRequest "Bad Request."
badRequest :: (FilterMonad Response m) => a -> m a
badRequest :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
badRequest = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
400

-- | Respond with @401 Unauthorized@.
--
-- > main = simpleHTTP nullConf $ unauthorized "You are not authorized."
unauthorized :: (FilterMonad Response m) => a -> m a
unauthorized :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
unauthorized = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
401

-- | Respond with @403 Forbidden@.
--
-- > main = simpleHTTP nullConf $ forbidden "Sorry, it is forbidden."
forbidden :: (FilterMonad Response m) => a -> m a
forbidden :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
forbidden = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
403

-- | Respond with @404 Not Found@.
--
-- > main = simpleHTTP nullConf $ notFound "What you are looking for has not been found."
notFound :: (FilterMonad Response m) => a -> m a
notFound :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
404

-- | Respond with @413 Request Entity Too Large@.
--
-- > main = simpleHTTP nullConf $ requestEntityTooLarge "That's too big for me to handle."
requestEntityTooLarge :: (FilterMonad Response m) => a -> m a
requestEntityTooLarge :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
requestEntityTooLarge = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
413

-- | Respond with @500 Internal Server Error@.
--
-- > main = simpleHTTP nullConf $ internalServerError "Sorry, there was an internal server error."
internalServerError :: (FilterMonad Response m) => a -> m a
internalServerError :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
internalServerError = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
500

-- | Responds with @502 Bad Gateway@.
--
-- > main = simpleHTTP nullConf $ badGateway "Bad Gateway."
badGateway :: (FilterMonad Response m) => a -> m a
badGateway :: forall (m :: * -> *) a. FilterMonad Response m => a -> m a
badGateway = forall (m :: * -> *) b. FilterMonad Response m => Int -> b -> m b
resp Int
502

-- | A nicely formatted rendering of a 'Response'
prettyResponse :: Response -> String
prettyResponse :: Response -> String
prettyResponse res :: Response
res@Response{}  =
    String -> String -> String
showString   String
"================== Response ================"       forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsCode      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> Int
rsCode Response
res)           forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsHeaders   = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> Headers
rsHeaders Response
res)        forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsFlags     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> RsFlags
rsFlags Response
res)          forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsBody      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> ByteString
rsBody Response
res)           forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsValidator = " 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 -> String -> String
showString   String
"================== Response ================"                    forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsCode      = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> Int
rsCode Response
res)                        forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsHeaders   = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> Headers
rsHeaders Response
res)                     forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsFlags     = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> RsFlags
rsFlags Response
res)                       forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nrsValidator = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Maybe (Response -> IO Response) -> String
showRsValidator (Response -> Maybe (Response -> IO Response)
rsValidator Response
res)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nsfFilePath  = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> String
sfFilePath Response
res)                    forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nsfOffset    = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows      (Response -> Integer
sfOffset Response
res)                      forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
showString String
"\nsfCount     = " forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show       (Response -> Integer
sfCount Response
res)