Location datatype

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

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

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 "<?xml version='1.0' encoding='utf-8' ?>\n"
         , cs "<feed xmlns='http://www.w3.org/2005/Atom'>"
         , cs "<title>"
         , encodeHtml $ cs $ atomTitle f
         , cs "</title>"
         , cs "<link rel='self' href='"
-        , encodeHtml $ cs $ atomLinkSelf f
+        , encodeHtml $ cs $ showLocation ar $ atomLinkSelf f
         , cs "'/>"
         , cs "<link href='"
-        , encodeHtml $ cs $ atomLinkHome f
+        , encodeHtml $ cs $ showLocation ar $ atomLinkHome f
         , cs "'/>"
         , cs "<updated>"
         , cs $ formatW3 $ atomUpdated f
         , cs "</updated>"
         , cs "<id>"
-        , encodeHtml $ cs $ atomLinkHome f
+        , encodeHtml $ cs $ showLocation ar $ atomLinkHome f
         , cs "</id>"
-        , TL.concat $ map cs $ atomEntries f
+        , TL.concat $ map cs $ zip (atomEntries f) $ repeat ar
         , cs "</feed>"
         ]
 
-instance ConvertSuccess AtomFeedEntry Text where
-    convertSuccess e = TL.concat
+instance ConvertSuccess (AtomFeedEntry, Approot) Text where
+    convertSuccess (e, ar) = TL.concat
         [ cs "<entry>"
         , cs "<id>"
-        , encodeHtml $ cs $ atomEntryLink e
+        , encodeHtml $ cs $ showLocation ar $ atomEntryLink e
         , cs "</id>"
         , cs "<link href='"
-        , encodeHtml $ cs $ atomEntryLink e
+        , encodeHtml $ cs $ showLocation ar $ atomEntryLink e
         , cs "' />"
         , cs "<updated>"
         , cs $ formatW3 $ atomEntryUpdated e

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 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
         , cs "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">"
         , 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?
                 [ "<url><loc>"
-                , encodeHtml $ showLoc loc
+                , encodeHtml $ showLocation ar loc
                 , "</loc><lastmod>"
                 , formatW3 modTime
                 , "</lastmod><changefreq>"
@@ -79,24 +78,20 @@ instance ConvertSuccess SitemapResponse Text where
                 , show pri
                 , "</priority></url>"
                 ]
-            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")