module Ella.Response (
Response
, content
, headers
, status
, cookies
, HeaderName(HeaderName)
, Cookie(..)
, buildResponse
, addContent
, setStatus
, setHeader
, addCookie
, deleteCookie
, standardCookie
, expireCookie
, textResponse
, utf8TextResponse
, htmlResponse
, utf8HtmlResponse
, emptyResponse
, redirectResponse
, formatResponse
) where
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy.Char8 (pack)
import qualified Data.ByteString.Lazy as BS
import Data.List (intersperse)
import Ella.CGI.Header (Headers, HeaderName(HeaderName))
import Network.CGI (ContentType(ContentType), showContentType)
import Network.CGI.Cookie (Cookie(..), showCookie)
import Ella.GenUtils (apply)
import System.Time (ClockTime(..), toUTCTime)
data Response = Response {
content :: ByteString
, headers :: Headers
, status :: Int
, cookies :: [Cookie]
} deriving (Show, Eq)
emptyResponse :: Response
emptyResponse = Response { content = BS.empty
, headers = []
, status = 200
, cookies = []
}
addContent :: ByteString -> Response -> Response
addContent c resp = resp { content = BS.append (content resp) c }
setStatus :: Int -> Response -> Response
setStatus s resp = resp { status = s }
setHeader :: String -> String -> Response -> Response
setHeader h val resp = let headername = HeaderName h
removed = filter ((/= headername) . fst) (headers resp)
updated = removed ++ [(headername, val)]
in resp { headers = updated }
addCookie :: Cookie -> Response -> Response
addCookie cookie resp = resp { cookies = cookies resp ++ [cookie] }
standardCookie = Cookie { cookieName = ""
, cookieValue = ""
, cookieExpires = Nothing
, cookieDomain = Nothing
, cookiePath = Just "/"
, cookieSecure = False
}
expireCookie cookie = cookie { cookieExpires = Just $ toUTCTime $ TOD 1 0 }
oldCookie name = expireCookie $ standardCookie { cookieName = name }
deleteCookie :: String -> Response -> Response
deleteCookie name resp = resp { cookies = cookies resp ++ [oldCookie name] }
contentTypeName = HeaderName "Content-type"
textContent charset = "text/plain; charset=" ++ charset
htmlContent charset = "text/html; charset=" ++ charset
textResponse :: String -> Response
textResponse charset = emptyResponse {
headers = [(contentTypeName, textContent charset)]
}
htmlResponse :: String -> Response
htmlResponse charset = emptyResponse {
headers = [(contentTypeName, htmlContent charset)]
}
utf8TextResponse :: Response
utf8TextResponse = textResponse "UTF-8"
utf8HtmlResponse :: Response
utf8HtmlResponse = htmlResponse "UTF-8"
buildResponse :: [Response -> Response] -> Response -> Response
buildResponse = apply
allHeaders resp =
let statusHeader = (HeaderName "Status", show $ status resp)
cookieHeaders = map (\c -> (HeaderName "Set-Cookie", showCookie c)) $ cookies resp
in headers resp ++ cookieHeaders ++ [statusHeader]
formatResponse :: Response -> ByteString
formatResponse resp =
unlinesCrLf ([pack (n++": "++v) | (HeaderName n,v) <- allHeaders resp]
++ [BS.empty, content resp])
where unlinesCrLf = BS.concat . intersperse (pack "\r\n")
redirectResponse :: String -> Response
redirectResponse location =
buildResponse [ setStatus 302
, setHeader "Location" location
] emptyResponse