126 lines
4.0 KiB
Haskell
126 lines
4.0 KiB
Haskell
{-# LANGUAGE ExistentialQuantification #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- Module : Web.Restful.Response
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : Stable
|
|
-- Portability : portable
|
|
--
|
|
-- Generating responses.
|
|
--
|
|
---------------------------------------------------------
|
|
module Web.Restful.Response
|
|
(
|
|
-- * Response construction
|
|
Response (..)
|
|
, response
|
|
-- * FIXME
|
|
, GenResponse (..)
|
|
, ResponseWrapper (..)
|
|
, ErrorResponse (..)
|
|
, formatW3
|
|
, UTCTime
|
|
) where
|
|
|
|
import Data.ByteString.Class
|
|
import qualified Hack
|
|
import Data.Time.Format
|
|
import Data.Time.Clock
|
|
import Web.Encodings
|
|
import System.Locale
|
|
import Data.Object
|
|
import Data.List (intercalate)
|
|
|
|
type ContentType = String
|
|
|
|
-- | The output for a resource.
|
|
class Response a where
|
|
-- | Provide an ordered list of possible responses, depending on content
|
|
-- type. If the user asked for a specific response type (like
|
|
-- text/html), then that will get priority. If not, then the first
|
|
-- element in this list will be used.
|
|
reps :: a -> [(ContentType, Hack.Response)]
|
|
|
|
-- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be
|
|
-- used for the body.
|
|
response :: LazyByteString lbs
|
|
=> Int
|
|
-> [(String, String)]
|
|
-> lbs
|
|
-> Hack.Response
|
|
response a b c = Hack.Response a b $ toLazyByteString c
|
|
|
|
instance Response () where
|
|
reps _ = [("text/plain", response 200 [] "")]
|
|
|
|
newtype ErrorResponse = ErrorResponse String
|
|
instance Response ErrorResponse where
|
|
reps (ErrorResponse s) = [("text/plain", response 500 [] s)]
|
|
|
|
data ResponseWrapper = forall res. Response res => ResponseWrapper res
|
|
instance Response ResponseWrapper where
|
|
reps (ResponseWrapper res) = reps res
|
|
|
|
data GenResponse = HtmlResponse String
|
|
| ObjectResponse Object
|
|
| HtmlOrObjectResponse String Object
|
|
| RedirectResponse String
|
|
| PermissionDeniedResult String
|
|
| NotFoundResponse String
|
|
instance Response GenResponse where
|
|
reps (HtmlResponse h) = [("text/html", response 200 [] h)]
|
|
reps (ObjectResponse t) = reps t
|
|
reps (HtmlOrObjectResponse h t) =
|
|
("text/html", response 200 [] h) : reps t
|
|
reps (RedirectResponse url) = [("text/html", response 303 heads body)]
|
|
where
|
|
heads = [("Location", url)]
|
|
body = "<p>Redirecting to <a href='" ++ encodeHtml url ++
|
|
"'>" ++ encodeHtml url ++ "</a></p>"
|
|
reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)]
|
|
reps (NotFoundResponse s) = [("text/plain", response 404 [] s)]
|
|
|
|
-- FIXME remove treeTo functions, replace with Object instances
|
|
treeToJson :: Object -> String
|
|
treeToJson (Scalar s) = '"' : encodeJson (fromStrictByteString s) ++ "\""
|
|
treeToJson (Sequence l) =
|
|
"[" ++ intercalate "," (map treeToJson l) ++ "]"
|
|
treeToJson (Mapping m) =
|
|
"{" ++ intercalate "," (map helper m) ++ "}" where
|
|
helper (k, v) =
|
|
treeToJson (Scalar k) ++
|
|
":" ++
|
|
treeToJson v
|
|
|
|
treeToHtml :: Object -> String
|
|
treeToHtml (Scalar s) = encodeHtml $ fromStrictByteString s
|
|
treeToHtml (Sequence l) =
|
|
"<ul>" ++ concatMap (\e -> "<li>" ++ treeToHtml e ++ "</li>") l ++
|
|
"</ul>"
|
|
treeToHtml (Mapping m) =
|
|
"<dl>" ++
|
|
concatMap (\(k, v) -> "<dt>" ++
|
|
encodeHtml (fromStrictByteString k) ++
|
|
"</dt>" ++
|
|
"<dd>" ++
|
|
treeToHtml v ++
|
|
"</dd>") m ++
|
|
"</dl>"
|
|
|
|
instance Response Object where
|
|
reps tree =
|
|
[ ("text/html", response 200 [] $ treeToHtml tree)
|
|
, ("application/json", response 200 [] $ treeToJson tree)
|
|
]
|
|
|
|
instance Response [(String, Hack.Response)] where
|
|
reps = id
|
|
|
|
-- FIXME put in a separate module (maybe Web.Encodings)
|
|
formatW3 :: UTCTime -> String
|
|
formatW3 = formatTime defaultTimeLocale "%FT%X-08:00"
|