{-# LANGUAGE ExistentialQuantification #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response -- Copyright : Michael Snoyman -- License : BSD3 -- -- Maintainer : Michael Snoyman -- Stability : Stable -- Portability : portable -- -- Generating responses. -- --------------------------------------------------------- module Web.Restful.Response ( -- * Response construction Response (..) , response -- ** Helper 'Response' instances -- *** Atom news feed , AtomFeed (..) , AtomFeedEntry (..) -- *** Sitemap , sitemap , SitemapUrl (..) , SitemapLoc (..) , SitemapChangeFreq (..) -- *** Generics -- **** List/detail , ListDetail (..) , ItemList (..) , ItemDetail (..) -- **** Multiple response types. , GenResponse (..) -- * FIXME , ResponseWrapper (..) , ErrorResponse (..) ) where import Data.ByteString.Class import qualified Hack import Data.Time.Format import Data.Time.Clock import Web.Encodings import System.Locale import Web.Restful.Request -- FIXME ultimately remove 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 AtomFeed = AtomFeed { atomTitle :: String , atomLinkSelf :: String , atomLinkHome :: String , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } instance Response AtomFeed where reps e = [ ("application/atom+xml", response 200 [] $ show e) ] data AtomFeedEntry = AtomFeedEntry { atomEntryLink :: String , atomEntryUpdated :: UTCTime , atomEntryTitle :: String , atomEntryContent :: String } instance Show AtomFeed where show f = concat [ "\n" , "" , "" , encodeHtml $ atomTitle f , "" , "" , "" , "" , formatW3 $ atomUpdated f , "" , "" , encodeHtml $ atomLinkHome f , "" , concatMap show $ atomEntries f , "" ] instance Show AtomFeedEntry where show e = concat [ "" , "" , encodeHtml $ atomEntryLink e , "" , "" , "" , formatW3 $ atomEntryUpdated e , "" , "" , encodeHtml $ atomEntryTitle e , "" , "" , "" ] formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- sitemaps data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always | Hourly | Daily | Weekly | Monthly | Yearly | Never instance Show SitemapChangeFreq where show Always = "always" show Hourly = "hourly" show Daily = "daily" show Weekly = "weekly" show Monthly = "monthly" show Yearly = "yearly" show Never = "never" data SitemapUrl = SitemapUrl { sitemapLoc :: SitemapLoc , sitemapLastMod :: UTCTime , sitemapChangeFreq :: SitemapChangeFreq , priority :: Double } data SitemapRequest = SitemapRequest String Int instance Request SitemapRequest where parseRequest = do env <- parseEnv return $! SitemapRequest (Hack.serverName env) (Hack.serverPort env) data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl] instance Show SitemapResponse where show (SitemapResponse (SitemapRequest host port) urls) = "\n" ++ "" ++ concatMap helper urls ++ "" where prefix = "http://" ++ host ++ case port of 80 -> "" _ -> ":" ++ show port helper (SitemapUrl loc modTime freq pri) = concat [ "" , encodeHtml $ showLoc loc , "" , formatW3 modTime , "" , show freq , "" , show pri , "" ] showLoc (AbsLoc s) = s showLoc (RelLoc s) = prefix ++ s instance Response SitemapResponse where reps res = [ ("text/xml", response 200 [] $ show res) ] sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse sitemap urls' req = do urls <- urls' return $ SitemapResponse req urls 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 = "

Redirecting to " ++ encodeHtml url ++ "

" reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] class ToObject a => ListDetail a where htmlDetail :: a -> String htmlDetail = treeToHtml . toObject detailTitle :: a -> String detailUrl :: a -> String htmlList :: [a] -> String htmlList l = "" where helper i = "
  • " ++ encodeHtml (detailTitle i) ++ "
    • " -- | Often times for the JSON response of the list, we don't need all -- the information. treeList :: [a] -> Object -- FIXME treeList = Sequence . map treeListSingle treeListSingle :: a -> Object treeListSingle = toObject newtype ItemList a = ItemList [a] instance ListDetail a => Response (ItemList a) where reps (ItemList l) = [ ("text/html", response 200 [] $ htmlList l) , ("application/json", response 200 [] $ treeToJson $ treeList l) ] newtype ItemDetail a = ItemDetail a instance ListDetail a => Response (ItemDetail a) where reps (ItemDetail i) = [ ("text/html", response 200 [] $ htmlDetail i) , ("application/json", response 200 [] $ treeToJson $ toObject i) ] -- 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) = "" treeToHtml (Mapping m) = "
    " ++ concatMap (\(k, v) -> "
    " ++ encodeHtml (fromStrictByteString k) ++ "
    " ++ "
    " ++ treeToHtml v ++ "
    ") m ++ "
    " instance Response Object where reps tree = [ ("text/html", response 200 [] $ treeToHtml tree) , ("application/json", response 200 [] $ treeToJson tree) ]