From 1caa0c4891bfe2fffdcf1909b589cccd153a4506 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 28 Aug 2009 11:01:19 +0300 Subject: [PATCH] Split up Web.Restful.Response --- Data/Object/Instances.hs | 23 ++-- Web/Restful/Generic/ListDetail.hs | 55 +++++++++ Web/Restful/Response.hs | 187 ++---------------------------- Web/Restful/Response/AtomFeed.hs | 88 ++++++++++++++ Web/Restful/Response/Sitemap.hs | 90 ++++++++++++++ restful.cabal | 5 +- 6 files changed, 258 insertions(+), 190 deletions(-) create mode 100644 Web/Restful/Generic/ListDetail.hs create mode 100644 Web/Restful/Response/AtomFeed.hs create mode 100644 Web/Restful/Response/Sitemap.hs diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 6f2301ef..8b3ba8ef 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} --------------------------------------------------------- -- -- Module : Data.Object.Instances @@ -15,6 +16,7 @@ module Data.Object.Instances ( Json (..) , Yaml (..) , Html (..) + , SafeFromObject (..) ) where import Data.Object @@ -23,9 +25,12 @@ import Data.ByteString.Class import Web.Encodings (encodeJson) import qualified Text.Yaml as Y -newtype Json = Json B.ByteString -instance FromObject Json where - fromObject = return . Json . helper where +class SafeFromObject a where + safeFromObject :: Object -> a + +newtype Json = Json { unJson :: B.ByteString } +instance SafeFromObject Json where + safeFromObject = Json . helper where helper :: Object -> B.ByteString helper (Scalar s) = B.concat [ toStrictByteString "\"" @@ -50,19 +55,19 @@ instance FromObject Json where , helper v ] -newtype Yaml = Yaml B.ByteString -instance FromObject Yaml where - fromObject = return . Yaml . Y.encode +newtype Yaml = Yaml { unYaml :: B.ByteString } +instance SafeFromObject Yaml where + safeFromObject = Yaml . Y.encode -- | Represents as an entire HTML 5 document by using the following: -- -- * A scalar is a paragraph. -- * A sequence is an unordered list. -- * A mapping is a definition list. -newtype Html = Html B.ByteString +newtype Html = Html { unHtml :: B.ByteString } -instance FromObject Html where - fromObject o = return $ Html $ B.concat +instance SafeFromObject Html where + safeFromObject o = Html $ B.concat [ toStrictByteString "\n" , helper o , toStrictByteString "" diff --git a/Web/Restful/Generic/ListDetail.hs b/Web/Restful/Generic/ListDetail.hs new file mode 100644 index 00000000..00d48d57 --- /dev/null +++ b/Web/Restful/Generic/ListDetail.hs @@ -0,0 +1,55 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Generic.ListDetail +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generic responses for listing items and then detailing them. +-- +--------------------------------------------------------- +module Web.Restful.Generic.ListDetail + ( ListDetail (..) + , ItemList (..) + , ItemDetail (..) + ) where + +import Web.Restful.Response +import Web.Encodings +import Data.Object +import Data.Object.Instances +import Data.ByteString.Class + +class ToObject a => ListDetail a where + htmlDetail :: a -> String + htmlDetail = fromStrictByteString . unHtml . safeFromObject . 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 [] $ unJson $ safeFromObject $ 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 [] $ unJson $ safeFromObject $ toObject i) + ] diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index c950ab86..9d5e8221 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -18,25 +18,12 @@ 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 + , GenResponse (..) , ResponseWrapper (..) , ErrorResponse (..) + , formatW3 + , UTCTime ) where import Data.ByteString.Class @@ -45,10 +32,8 @@ 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) -import Data.Object.Instances type ContentType = String @@ -80,138 +65,6 @@ 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 @@ -230,36 +83,6 @@ instance Response GenResponse where "'>" ++ 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 @@ -296,3 +119,7 @@ instance Response Object where 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" diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs new file mode 100644 index 00000000..c79d9d3b --- /dev/null +++ b/Web/Restful/Response/AtomFeed.hs @@ -0,0 +1,88 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Response.AtomFeed +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generating atom news feeds. +-- +--------------------------------------------------------- + +module Web.Restful.Response.AtomFeed + ( AtomFeed (..) + , AtomFeedEntry (..) + ) where + +import Web.Restful.Response + +import Data.Time.Format +import Data.Time.Clock +import Web.Encodings +import System.Locale + +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 + , "" + , "" + , "" + ] diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs new file mode 100644 index 00000000..0167a9f5 --- /dev/null +++ b/Web/Restful/Response/Sitemap.hs @@ -0,0 +1,90 @@ +--------------------------------------------------------- +-- +-- Module : Web.Restful.Response.AtomFeed +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Generating Google sitemap files. +-- +--------------------------------------------------------- + +module Web.Restful.Response.Sitemap + ( sitemap + , SitemapUrl (..) + , SitemapLoc (..) + , SitemapChangeFreq (..) + ) where + +import Web.Restful.Response +import Web.Encodings +import qualified Hack +import Web.Restful.Request + +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 diff --git a/restful.cabal b/restful.cabal index b8ee84d9..8a8efa37 100644 --- a/restful.cabal +++ b/restful.cabal @@ -42,5 +42,8 @@ library Web.Restful.Resource, Data.Object.Instances, Hack.Middleware.MethodOverride, - Web.Restful.Helpers.Auth + Web.Restful.Helpers.Auth, + Web.Restful.Response.AtomFeed, + Web.Restful.Response.Sitemap, + Web.Restful.Generic.ListDetail ghc-options: -Wall