* added RSS.hs: functions to create an RSS feed

* added RSS feed handler
* FromReqURI instance for BlogLang
* fixed RSS-feed link

5 files changed, 85 insertions, 13 deletions

diff --git a/src/Blog.hs b/src/Blog.hs
index f0760f0a0215..208552c10e24 100644
--- a/src/Blog.hs
+++ b/src/Blog.hs
@@ -42,7 +42,7 @@ blogTemplate :: BlogLang -> Text -> Html -> Html
 blogTemplate lang t_append body = H.docTypeHtml $ do --add body
     H.head $ do
         H.title $ (toHtml $ blogTitle lang t_append)
-        H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href "/rss"
+        H.link ! A.rel "alternate" ! A.type_ "application/rss+xml" ! A.title "RSS-Feed" ! A.href (toValue feedURL)
         H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/static/blogv312.css" ! A.media "all"
         --H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/res/blogstyle.css" ! A.media "all"
         H.meta ! A.httpEquiv "content-type" ! A.content "text/html;charset=UTF-8"
@@ -72,6 +72,7 @@ blogTemplate lang t_append body = H.docTypeHtml $ do --add body
             toHtml $ orText lang
             H.a ! A.class_ "link" ! A.href (toValue imu) ! A.target "_blank" $ "iMessage"
             "."
+        feedURL = "/" ++ show lang ++ "/rss"
 
 renderEntries :: Bool -> [Entry] -> Text -> Maybe Html -> Html
 renderEntries showAll entries topText footerLinks = do
diff --git a/src/BlogDB.hs b/src/BlogDB.hs
index 7a4f869eb71b..ea574c70842b 100644
--- a/src/BlogDB.hs
+++ b/src/BlogDB.hs
@@ -9,14 +9,16 @@ import Data.Acid
 import Data.Acid.Advanced 
 import Data.Acid.Local
 import Data.ByteString      (ByteString)
+import Data.Char            (toLower)
 import Data.Data            (Data, Typeable)
 import Data.IxSet           (Indexable(..), IxSet(..), (@=), Proxy(..), getOne, ixFun, ixSet)
-import Data.List 			(insert)
+import Data.List 			      (insert)
 import Data.SafeCopy        (SafeCopy, base, deriveSafeCopy)
 import Data.Text            (Text, pack)
 import Data.Text.Lazy       (toStrict)
 import Data.Time
-import System.Environment(getEnv)
+import Happstack.Server     (FromReqURI(..))
+import System.Environment   (getEnv)
 
 import qualified Crypto.Hash.SHA512 as SHA (hash)
 import qualified Data.ByteString.Char8 as B
@@ -38,6 +40,13 @@ instance Show BlogLang where
     show DE = "de"
     show EN = "en"
 
+instance FromReqURI BlogLang where
+  fromReqURI sub = 
+    case map toLower sub of
+      "de" -> Just DE
+      "en" -> Just EN
+      _    -> Nothing
+
 $(deriveSafeCopy 0 'base ''BlogLang)
 
 data Comment = Comment {
diff --git a/src/Locales.hs b/src/Locales.hs
index fc072ed61cb7..589235cea5da 100644
--- a/src/Locales.hs
+++ b/src/Locales.hs
@@ -3,8 +3,11 @@
 module Locales where
 
 import           Data.Data (Data, Typeable)
+import           Data.Maybe (fromMaybe)
 import           Data.Text (Text)
 import qualified Data.Text as T
+import           Network.URI
+
 
 import    BlogDB (BlogLang (..))
 
@@ -123,6 +126,18 @@ cTextPlaceholder :: BlogLang -> Text
 cTextPlaceholder DE = "Kommentartext hier eingeben :]"
 cTextPlaceholder EN = "Enter your comment here :]"
 
+-- RSS Strings
+rssTitle :: BlogLang -> String
+rssTitle DE = "Tazjins Blog"
+rssTitle EN = "Tazjin's Blog"
+
+rssDesc :: BlogLang -> String
+rssDesc DE = "Feed zu Tazjins Blog"
+rssDesc EN = "Feed for Tazjin's Blog"
+
+rssLink :: BlogLang -> URI
+rssLink l = fromMaybe nullURI $ parseURI ("http://tazj.in/" ++ show l)
+
 -- errors
 notFoundTitle :: BlogLang -> Text
 notFoundTitle DE = "Nicht gefunden"
diff --git a/src/Main.hs b/src/Main.hs
index f1bc9114a6cd..bf8b52b49b76 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -30,6 +30,7 @@ import           System.Locale (defaultTimeLocale)
 import           Blog
 import           BlogDB hiding (addComment, updateEntry)
 import           Locales
+import           RSS
 
 {- Server -}
 
@@ -47,12 +48,10 @@ main = do
 tazBlog :: AcidState Blog -> ServerPart Response
 tazBlog acid = do
     compr <- compressedResponseFilter
-    msum [ dir (show DE) $ blogHandler acid DE
-         , dir (show EN) $ blogHandler acid EN
-         , do nullDir
-              showIndex acid DE
-         , do dir " " $ nullDir
-              seeOther ("https://plus.google.com/115916629925754851590" :: Text) (toResponse ())
+    msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
+         , nullDir >> showIndex acid DE
+         , dir " " $ nullDir >>
+            seeOther ("https://plus.google.com/115916629925754851590" :: Text) (toResponse ())
          , path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_
          , dir "res" $ serveDirectory DisableBrowsing [] "../res"
          , dir "notice" $ ok $ toResponse showSiteNotice
@@ -68,8 +67,7 @@ tazBlog acid = do
               entryList acid EN
          , do guardSession acid
               dirs "admin/edit" $ path $ \(eId :: Integer) -> editEntry acid eId
-         , do dirs "admin/updateentry" $ nullDir
-              updateEntry acid
+         , dirs "admin/updateentry" $ nullDir >> updateEntry acid
          , do dir "admin" $ nullDir
               guardSession acid
               ok $ toResponse $ adminIndex ("tazjin" :: Text)
@@ -88,8 +86,8 @@ blogHandler acid lang =
          , do decodeBody tmpPolicy
               dir "postcomment" $ path $ 
                 \(eId :: Integer) -> addComment acid lang $ EntryId eId
-         , do nullDir
-              showIndex acid lang
+         , nullDir >> showIndex acid lang
+         , dir "rss" $ nullDir >> showRSS acid lang
          , notFound $ toResponse $ showError NotFound lang
          ]
 
@@ -121,6 +119,13 @@ showIndex acid lang = do
     eDrop (Just i) = drop ((i-1) * 6)
     eDrop Nothing = drop 0 
 
+showRSS :: AcidState Blog -> BlogLang -> ServerPart Response
+showRSS acid lang = do
+    entries <- query' acid (LatestEntries lang)
+    feed <- liftIO $ renderFeed lang $ take 6 entries
+    setHeaderM "content-type" "text/xml"
+    ok $ toResponse feed
+
 addComment :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
 addComment acid lang eId = do
   now <- liftIO $ getCurrentTime >>= return
diff --git a/src/RSS.hs b/src/RSS.hs
new file mode 100644
index 000000000000..05ae40ece58f
--- /dev/null
+++ b/src/RSS.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module RSS (renderFeed) where
+
+import qualified Data.Text as T
+
+import Data.Maybe (fromMaybe)
+import Data.Time (getCurrentTime, UTCTime)
+import Network.URI
+import Text.RSS
+
+import Locales
+import BlogDB hiding (Title)
+
+createChannel :: BlogLang -> UTCTime -> [ChannelElem]
+createChannel l  now = [ Language $ show l
+                       , Copyright "Vincent Ambo"
+                       , WebMaster "tazjin@googlemail.com"
+                       , ChannelPubDate now
+                       ]
+
+createRSS :: BlogLang -> UTCTime -> [Item] -> RSS
+createRSS l t i = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t) i
+
+createItem :: Entry -> Item
+createItem Entry{..} = [ Title $ T.unpack title 
+                       , Link $ makeLink lang entryId
+                       , Description $ T.unpack btext
+                       , PubDate edate]
+
+makeLink :: BlogLang -> EntryId -> URI
+makeLink l i = let url = "http://tazj.in/" ++ show l ++ "/" ++ show i
+               in fromMaybe nullURI $ parseURI url
+
+createItems :: [Entry] -> [Item]
+createItems = map createItem
+
+createFeed :: BlogLang -> [Entry] -> IO RSS
+createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e )
+
+renderFeed :: BlogLang -> [Entry] -> IO String
+renderFeed l e = createFeed l e >>= (\feed -> return $ showXML $ rssToXML feed)
\ No newline at end of file