Split up Web.Restful.Response
This commit is contained in:
Michael Snoyman
parent
2b8131b29b
commit
1caa0c4891
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
--
|
--
|
||||||
-- Module : Data.Object.Instances
|
-- Module : Data.Object.Instances
|
||||||
@ -15,6 +16,7 @@ module Data.Object.Instances
|
|||||||
( Json (..)
|
( Json (..)
|
||||||
, Yaml (..)
|
, Yaml (..)
|
||||||
, Html (..)
|
, Html (..)
|
||||||
|
, SafeFromObject (..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Object
|
import Data.Object
|
||||||
@ -23,9 +25,12 @@ import Data.ByteString.Class
|
|||||||
import Web.Encodings (encodeJson)
|
import Web.Encodings (encodeJson)
|
||||||
import qualified Text.Yaml as Y
|
import qualified Text.Yaml as Y
|
||||||
|
|
||||||
newtype Json = Json B.ByteString
|
class SafeFromObject a where
|
||||||
instance FromObject Json where
|
safeFromObject :: Object -> a
|
||||||
fromObject = return . Json . helper where
|
|
||||||
|
newtype Json = Json { unJson :: B.ByteString }
|
||||||
|
instance SafeFromObject Json where
|
||||||
|
safeFromObject = Json . helper where
|
||||||
helper :: Object -> B.ByteString
|
helper :: Object -> B.ByteString
|
||||||
helper (Scalar s) = B.concat
|
helper (Scalar s) = B.concat
|
||||||
[ toStrictByteString "\""
|
[ toStrictByteString "\""
|
||||||
@ -50,19 +55,19 @@ instance FromObject Json where
|
|||||||
, helper v
|
, helper v
|
||||||
]
|
]
|
||||||
|
|
||||||
newtype Yaml = Yaml B.ByteString
|
newtype Yaml = Yaml { unYaml :: B.ByteString }
|
||||||
instance FromObject Yaml where
|
instance SafeFromObject Yaml where
|
||||||
fromObject = return . Yaml . Y.encode
|
safeFromObject = Yaml . Y.encode
|
||||||
|
|
||||||
-- | Represents as an entire HTML 5 document by using the following:
|
-- | Represents as an entire HTML 5 document by using the following:
|
||||||
--
|
--
|
||||||
-- * A scalar is a paragraph.
|
-- * A scalar is a paragraph.
|
||||||
-- * A sequence is an unordered list.
|
-- * A sequence is an unordered list.
|
||||||
-- * A mapping is a definition list.
|
-- * A mapping is a definition list.
|
||||||
newtype Html = Html B.ByteString
|
newtype Html = Html { unHtml :: B.ByteString }
|
||||||
|
|
||||||
instance FromObject Html where
|
instance SafeFromObject Html where
|
||||||
fromObject o = return $ Html $ B.concat
|
safeFromObject o = Html $ B.concat
|
||||||
[ toStrictByteString "<!DOCTYPE html>\n<html><body>"
|
[ toStrictByteString "<!DOCTYPE html>\n<html><body>"
|
||||||
, helper o
|
, helper o
|
||||||
, toStrictByteString "</body></html>"
|
, toStrictByteString "</body></html>"
|
||||||
|
|||||||
55
Web/Restful/Generic/ListDetail.hs
Normal file
55
Web/Restful/Generic/ListDetail.hs
Normal file
@ -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)
|
||||||
|
]
|
||||||
@ -18,25 +18,12 @@ module Web.Restful.Response
|
|||||||
-- * Response construction
|
-- * Response construction
|
||||||
Response (..)
|
Response (..)
|
||||||
, 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
|
-- * FIXME
|
||||||
|
, GenResponse (..)
|
||||||
, ResponseWrapper (..)
|
, ResponseWrapper (..)
|
||||||
, ErrorResponse (..)
|
, ErrorResponse (..)
|
||||||
|
, formatW3
|
||||||
|
, UTCTime
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.ByteString.Class
|
import Data.ByteString.Class
|
||||||
@ -45,10 +32,8 @@ import Data.Time.Format
|
|||||||
import Data.Time.Clock
|
import Data.Time.Clock
|
||||||
import Web.Encodings
|
import Web.Encodings
|
||||||
import System.Locale
|
import System.Locale
|
||||||
import Web.Restful.Request -- FIXME ultimately remove
|
|
||||||
import Data.Object
|
import Data.Object
|
||||||
import Data.List (intercalate)
|
import Data.List (intercalate)
|
||||||
import Data.Object.Instances
|
|
||||||
|
|
||||||
type ContentType = String
|
type ContentType = String
|
||||||
|
|
||||||
@ -80,138 +65,6 @@ data ResponseWrapper = forall res. Response res => ResponseWrapper res
|
|||||||
instance Response ResponseWrapper where
|
instance Response ResponseWrapper where
|
||||||
reps (ResponseWrapper res) = reps res
|
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
|
data GenResponse = HtmlResponse String
|
||||||
| ObjectResponse Object
|
| ObjectResponse Object
|
||||||
| HtmlOrObjectResponse String Object
|
| HtmlOrObjectResponse String Object
|
||||||
@ -230,36 +83,6 @@ instance Response GenResponse where
|
|||||||
"'>" ++ encodeHtml url ++ "</a></p>"
|
"'>" ++ encodeHtml url ++ "</a></p>"
|
||||||
reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)]
|
reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)]
|
||||||
reps (NotFoundResponse s) = [("text/plain", response 404 [] 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
|
-- FIXME remove treeTo functions, replace with Object instances
|
||||||
treeToJson :: Object -> String
|
treeToJson :: Object -> String
|
||||||
@ -296,3 +119,7 @@ instance Response Object where
|
|||||||
|
|
||||||
instance Response [(String, Hack.Response)] where
|
instance Response [(String, Hack.Response)] where
|
||||||
reps = id
|
reps = id
|
||||||
|
|
||||||
|
-- FIXME put in a separate module (maybe Web.Encodings)
|
||||||
|
formatW3 :: UTCTime -> String
|
||||||
|
formatW3 = formatTime defaultTimeLocale "%FT%X-08:00"
|
||||||
|
|||||||
88
Web/Restful/Response/AtomFeed.hs
Normal file
88
Web/Restful/Response/AtomFeed.hs
Normal file
@ -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>"
|
||||||
|
]
|
||||||
90
Web/Restful/Response/Sitemap.hs
Normal file
90
Web/Restful/Response/Sitemap.hs
Normal file
@ -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
|
||||||
@ -42,5 +42,8 @@ library
|
|||||||
Web.Restful.Resource,
|
Web.Restful.Resource,
|
||||||
Data.Object.Instances,
|
Data.Object.Instances,
|
||||||
Hack.Middleware.MethodOverride,
|
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
|
ghc-options: -Wall
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user