diff options
| -rw-r--r-- | src/Blog.hs | 3 | ||||
| -rw-r--r-- | src/BlogDB.hs | 13 | ||||
| -rw-r--r-- | src/Locales.hs | 15 | ||||
| -rw-r--r-- | src/Main.hs | 25 | ||||
| -rw-r--r-- | src/RSS.hs | 42 |
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 |