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")