From dc355edf7d1a32f909e06e7699f770f97df2e8ee Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Dec 2009 23:18:17 +0200 Subject: [PATCH] Location datatype --- TODO | 4 ---- Yesod/Definitions.hs | 11 +++++++++++ Yesod/Helpers/AtomFeed.hs | 41 ++++++++++++++++++++++++--------------- Yesod/Helpers/Sitemap.hs | 23 +++++++++------------- 4 files changed, 45 insertions(+), 34 deletions(-) diff --git a/TODO b/TODO index 394ef3dc..b87b2101 100644 --- a/TODO +++ b/TODO @@ -1,9 +1,5 @@ -HTML sitemap generation Cleanup Data.Object.Translate Cleanup Parameter stuff. Own module? Interface with formlets? Authentication via e-mail address built in. (eaut.org) OpenID 2 stuff (for direct Google login). -Is there a mimetype package on hackage for Yesod.Helpers.Static? Native support for HStringTemplate groups. -AtomFeed uses RelLoc and AbsLoc like Sitemap -Fix type of sitemap diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index f77d8fcc..e86fc6b9 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -19,6 +19,8 @@ module Yesod.Definitions , Resource , Approot (..) , Language + , Location (..) + , showLocation ) where import qualified Hack @@ -55,3 +57,12 @@ type Resource = [String] newtype Approot = Approot { unApproot :: String } type Language = String + +-- | A location string. Can either be given absolutely or as a suffix for the +-- 'Approot'. +data Location = AbsLoc String | RelLoc String + +-- | Display a 'Location' in absolute form. +showLocation :: Approot -> Location -> String +showLocation _ (AbsLoc s) = s +showLocation (Approot ar) (RelLoc s) = ar ++ s diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs index ed93952d..ca63fba0 100644 --- a/Yesod/Helpers/AtomFeed.hs +++ b/Yesod/Helpers/AtomFeed.hs @@ -17,6 +17,8 @@ module Yesod.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) + , AtomFeedResponse (..) + , atomFeed ) where import Yesod @@ -26,58 +28,65 @@ import qualified Data.Text.Lazy as TL import Data.Time.Clock import Web.Encodings +data AtomFeedResponse = AtomFeedResponse AtomFeed Approot + +atomFeed :: YesodApproot y => AtomFeed -> Handler y AtomFeedResponse +atomFeed f = do + y <- getYesod + return $ AtomFeedResponse f $ approot y + data AtomFeed = AtomFeed { atomTitle :: String - , atomLinkSelf :: String - , atomLinkHome :: String + , atomLinkSelf :: Location + , atomLinkHome :: Location , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } -instance HasReps AtomFeed where +instance HasReps AtomFeedResponse where reps = [ (TypeAtom, return . cs) ] data AtomFeedEntry = AtomFeedEntry - { atomEntryLink :: String + { atomEntryLink :: Location , atomEntryUpdated :: UTCTime , atomEntryTitle :: String , atomEntryContent :: Html } -instance ConvertSuccess AtomFeed Content where - convertSuccess = cs . (cs :: AtomFeed -> Text) -instance ConvertSuccess AtomFeed Text where - convertSuccess f = TL.concat +instance ConvertSuccess AtomFeedResponse Content where + convertSuccess = (cs :: Text -> Content) . cs +instance ConvertSuccess AtomFeedResponse Text where + convertSuccess (AtomFeedResponse f ar) = TL.concat [ cs "\n" , cs "" , cs "" , encodeHtml $ cs $ atomTitle f , cs "" , cs "" , cs "" , cs "" , cs $ formatW3 $ atomUpdated f , cs "" , cs "" - , encodeHtml $ cs $ atomLinkHome f + , encodeHtml $ cs $ showLocation ar $ atomLinkHome f , cs "" - , TL.concat $ map cs $ atomEntries f + , TL.concat $ map cs $ zip (atomEntries f) $ repeat ar , cs "" ] -instance ConvertSuccess AtomFeedEntry Text where - convertSuccess e = TL.concat +instance ConvertSuccess (AtomFeedEntry, Approot) Text where + convertSuccess (e, ar) = TL.concat [ cs "" , cs "" - , encodeHtml $ cs $ atomEntryLink e + , encodeHtml $ cs $ showLocation ar $ atomEntryLink e , cs "" , cs "" , cs "" , cs $ formatW3 $ atomEntryUpdated e diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs index 581b363b..d41c1ebc 100644 --- a/Yesod/Helpers/Sitemap.hs +++ b/Yesod/Helpers/Sitemap.hs @@ -19,7 +19,6 @@ module Yesod.Helpers.Sitemap ( sitemap , robots , SitemapUrl (..) - , SitemapLoc (..) , SitemapChangeFreq (..) , SitemapResponse (..) ) where @@ -34,7 +33,6 @@ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL import Yesod.Yesod -data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always | Hourly | Daily @@ -52,7 +50,7 @@ instance ConvertSuccess SitemapChangeFreq String where convertSuccess Never = "never" data SitemapUrl = SitemapUrl - { sitemapLoc :: SitemapLoc + { sitemapLoc :: Location , sitemapLastMod :: UTCTime , sitemapChangeFreq :: SitemapChangeFreq , priority :: Double @@ -61,7 +59,7 @@ data SitemapResponse = SitemapResponse [SitemapUrl] Approot instance ConvertSuccess SitemapResponse Content where convertSuccess = cs . (cs :: SitemapResponse -> Text) instance ConvertSuccess SitemapResponse Text where - convertSuccess (SitemapResponse urls (Approot ar)) = TL.concat + convertSuccess (SitemapResponse urls ar) = TL.concat [ cs "\n" , cs "" , TL.concat $ map helper urls @@ -69,8 +67,9 @@ instance ConvertSuccess SitemapResponse Text where ] where helper (SitemapUrl loc modTime freq pri) = cs $ concat + -- FIXME use HTML? [ "" - , encodeHtml $ showLoc loc + , encodeHtml $ showLocation ar loc , "" , formatW3 modTime , "" @@ -79,24 +78,20 @@ instance ConvertSuccess SitemapResponse Text where , show pri , "" ] - showLoc (AbsLoc s) = s - showLoc (RelLoc s) = ar ++ s instance HasReps SitemapResponse where reps = [ (TypeXml, return . cs) ] -sitemap :: YesodApproot yesod - => IO [SitemapUrl] - -> Handler yesod SitemapResponse -sitemap urls' = do +sitemap :: YesodApproot y => [SitemapUrl] -> Handler y SitemapResponse +sitemap urls = do yesod <- getYesod - urls <- liftIO urls' return $ SitemapResponse urls $ approot yesod robots :: YesodApproot yesod => Handler yesod Plain robots = do yesod <- getYesod - return $ plain $ "Sitemap: " ++ unApproot (approot yesod) - ++ "sitemap.xml" + return $ plain $ "Sitemap: " ++ showLocation + (approot yesod) + (RelLoc "sitemap.xml")