module Network.HTTP.RedHandler.Response where
import Network.HTTP.RedHandler.HTTP_Fork.HTTP (Header(..), HasHeaders, getHeaders, setHeaders, insertHeaders,
Response(..), ResponseBody(..), HeaderName(..))
import Control.Monad (liftM)
data HandlerRsp a = HandlerRsp {
hanRspHeaders :: [Header],
hanRspBody :: Either Non200Response a
}
data Non200Response =
RedirectResp
instance Monad HandlerRsp where
return x = HandlerRsp [] (Right x)
(HandlerRsp hdrs (Right x)) >>= f = insertHeaders hdrs $ f x
(HandlerRsp hdrs (Left non200resp)) >>= f = (HandlerRsp hdrs (Left non200resp))
instance Functor HandlerRsp where
fmap = liftM
instance HasHeaders (HandlerRsp a) where
getHeaders = hanRspHeaders
setHeaders rsp hdrs = rsp { hanRspHeaders = hdrs }
non200response :: Non200Response -> Response
non200response _ = redirectResponse
okHTTPStrResponse :: String -> Response
okHTTPStrResponse s = Response (2,0,0) "" [] (StringRespBody s)
redirectResponse :: Response
redirectResponse = Response (3,0,2) "" [] (StringRespBody "")
redirectToRsp ::String -> HandlerRsp a
redirectToRsp url = HandlerRsp [Header HdrLocation url] (Left RedirectResp)
type BasicRsp = HandlerRsp BasicRspBody
data BasicRspBody = FileResp Integer FilePath
| StrResp String
basicRspWith :: (a -> String) -> HandlerRsp a -> BasicRsp
basicRspWith f = fmap (StrResp . f)
fileRsp :: Integer -> FilePath -> BasicRsp
fileRsp i name = return (FileResp i name)
maybeBasicRspToResponse :: Maybe BasicRsp -> Response
maybeBasicRspToResponse Nothing = notFoundResponse
maybeBasicRspToResponse (Just rsp) = basicRspToResponse rsp
notFoundResponse :: Response
notFoundResponse = okHTTPStrResponse "File not found!"
basicRspToResponse :: BasicRsp -> Response
basicRspToResponse (HandlerRsp hrHeaders (Left resp)) = setHeaders (non200response resp) hrHeaders
basicRspToResponse (HandlerRsp hrHeaders (Right rspBd)) = setHeaders (basicRspBodyToResponse rspBd) hrHeaders
basicRspBodyToResponse :: BasicRspBody -> Response
basicRspBodyToResponse (StrResp s) = Response (2,0,0) "" [] (StringRespBody s)
basicRspBodyToResponse (FileResp i path) = Response (2,0,0) "" [] (FileBody i path)