Split up Web.Restful.Response

2009-08-28 11:01:19 +03:00 · 2009-08-28 11:01:19 +03:00 · 1caa0c4891
commit 1caa0c4891
parent 2b8131b29b
6 changed files with 258 additions and 190 deletions
--- 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 "<!DOCTYPE html>\n<html><body>"
        , helper o
        , toStrictByteString "</body></html>"
--- a/Web/Restful/Generic/ListDetail.hs
+++ b/Web/Restful/Generic/ListDetail.hs
@ -0,0 +1,55 @@
+---------------------------------------------------------
+--
+-- Module        : Web.Restful.Generic.ListDetail
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- 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 = "<ul>" ++ concatMap helper l ++ "</ul>"
+        where
+            helper i = "<li><a href=\"" ++ encodeHtml (detailUrl i) ++
+                       "\">" ++ encodeHtml (detailTitle i) ++
+                       "</a></li>"
+    -- | 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)
+        ]
--- 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
-        [ "<?xml version='1.0' encoding='utf-8' ?>\n"
-        , "<feed xmlns='http://www.w3.org/2005/Atom'>"
-        , "<title>"
-        , encodeHtml $ atomTitle f
-        , "</title>"
-        , "<link rel='self' href='"
-        , encodeHtml $ atomLinkSelf f
-        , "'/>"
-        , "<link href='"
-        , encodeHtml $ atomLinkHome f
-        , "'/>"
-        , "<updated>"
-        , formatW3 $ atomUpdated f
-        , "</updated>"
-        , "<id>"
-        , encodeHtml $ atomLinkHome f
-        , "</id>"
-        , concatMap show $ atomEntries f
-        , "</feed>"
-        ]
-
-instance Show AtomFeedEntry where
-    show e = concat
-        [ "<entry>"
-        , "<id>"
-        , encodeHtml $ atomEntryLink e
-        , "</id>"
-        , "<link href='"
-        , encodeHtml $ atomEntryLink e
-        , "' />"
-        , "<updated>"
-        , formatW3 $ atomEntryUpdated e
-        , "</updated>"
-        , "<title>"
-        , encodeHtml $ atomEntryTitle e
-        , "</title>"
-        , "<content type='html'><![CDATA["
-        , atomEntryContent e
-        , "]]></content>"
-        , "</entry>"
-        ]
-
-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) =
-        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
-        "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">" ++
-        concatMap helper urls ++
-        "</urlset>"
-        where
-            prefix = "http://" ++ host ++
-                        case port of
-                            80 -> ""
-                            _ -> ":" ++ show port
-            helper (SitemapUrl loc modTime freq pri) = concat
-                [ "<url><loc>"
-                , encodeHtml $ showLoc loc
-                , "</loc><lastmod>"
-                , formatW3 modTime
-                , "</lastmod><changefreq>"
-                , show freq
-                , "</changefreq><priority>"
-                , show pri
-                , "</priority></url>"
-                ]
-            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 ++ "</a></p>"
    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 = "<ul>" ++ concatMap helper l ++ "</ul>"
-        where
-            helper i = "<li><a href=\"" ++ encodeHtml (detailUrl i) ++
-                       "\">" ++ encodeHtml (detailTitle i) ++
-                       "</a></li>"
-    -- | 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"
--- a/Web/Restful/Response/AtomFeed.hs
+++ b/Web/Restful/Response/AtomFeed.hs
@ -0,0 +1,88 @@
+---------------------------------------------------------
+--
+-- Module        : Web.Restful.Response.AtomFeed
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- 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
+        [ "<?xml version='1.0' encoding='utf-8' ?>\n"
+        , "<feed xmlns='http://www.w3.org/2005/Atom'>"
+        , "<title>"
+        , encodeHtml $ atomTitle f
+        , "</title>"
+        , "<link rel='self' href='"
+        , encodeHtml $ atomLinkSelf f
+        , "'/>"
+        , "<link href='"
+        , encodeHtml $ atomLinkHome f
+        , "'/>"
+        , "<updated>"
+        , formatW3 $ atomUpdated f
+        , "</updated>"
+        , "<id>"
+        , encodeHtml $ atomLinkHome f
+        , "</id>"
+        , concatMap show $ atomEntries f
+        , "</feed>"
+        ]
+
+instance Show AtomFeedEntry where
+    show e = concat
+        [ "<entry>"
+        , "<id>"
+        , encodeHtml $ atomEntryLink e
+        , "</id>"
+        , "<link href='"
+        , encodeHtml $ atomEntryLink e
+        , "' />"
+        , "<updated>"
+        , formatW3 $ atomEntryUpdated e
+        , "</updated>"
+        , "<title>"
+        , encodeHtml $ atomEntryTitle e
+        , "</title>"
+        , "<content type='html'><![CDATA["
+        , atomEntryContent e
+        , "]]></content>"
+        , "</entry>"
+        ]
--- a/Web/Restful/Response/Sitemap.hs
+++ b/Web/Restful/Response/Sitemap.hs
@ -0,0 +1,90 @@
+---------------------------------------------------------
+--
+-- Module        : Web.Restful.Response.AtomFeed
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- 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) =
+        "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
+        "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">" ++
+        concatMap helper urls ++
+        "</urlset>"
+        where
+            prefix = "http://" ++ host ++
+                        case port of
+                            80 -> ""
+                            _ -> ":" ++ show port
+            helper (SitemapUrl loc modTime freq pri) = concat
+                [ "<url><loc>"
+                , encodeHtml $ showLoc loc
+                , "</loc><lastmod>"
+                , formatW3 modTime
+                , "</lastmod><changefreq>"
+                , show freq
+                , "</changefreq><priority>"
+                , show pri
+                , "</priority></url>"
+                ]
+            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
--- 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