Merge pull request #9 from koterpillar/rss

Rss

multiblog.cabal

@@ -17,10 +17,12 @@ Executable multiblog
 
   Build-depends:
     blaze-html >= 0.7,
+    blaze-markup >= 0.6,
     boomerang >= 1.4,
     bytestring >= 0.10,
     containers >= 0.5,
     directory >= 1.2,
+    feed >= 0.3,
     filepath >= 1.3,
     happstack >= 7.0,
     happstack-server >= 7.3,
@@ -64,6 +66,7 @@ Test-Suite tests
     shakespeare >= 2.0,
     split >= 0.2,
     time >= 1.4 && < 1.6,
+    xml >= 1.3,
     derive >= 2.5,
     HTF >= 0.12,
     HUnit >= 1.2,

src/App.hs

@@ -21,24 +21,28 @@ import Models
 import Routes
 import Utils
 import Views
+import Views.Feed
 
 -- TODO: This should be a ReaderT
 type App = StateT AppState IO
 
 type AppPart a = RouteT Sitemap (ServerPartT App) a
 
-loadApp :: String -> IO AppState
-loadApp dataDirectory = do
+loadApp :: String -- directory to load from
+        -> String -- site address
+        -> IO AppState
+loadApp dataDirectory siteAddress = do
     app <- loadFromDirectory dataDirectory
     case app of
         Left err -> error err
-        Right appState -> return appState
+        Right appState -> return appState { appAddress = siteAddress }
 
 runApp :: AppState -> App a -> IO a
 runApp app a = evalStateT a app
 
-site :: String -> ServerPartT App Response
-site address = do
+site :: ServerPartT App Response
+site = do
+    address <- lift $ gets appAddress
     appDir <- lift $ gets appDirectory
     let routedSite = boomerangSiteRouteT handler sitemap
     let staticSite = serveDirectory DisableBrowsing [] $ appDir ++ "/static"
@@ -52,6 +56,7 @@ handler route = case route of
     Daily d -> dailyIndex d
     ArticleView d s -> article d s
     MetaView s -> meta s
+    Feed lang -> feedIndex lang
 
 index :: AppPart Response
 index = articleList $ const True
@@ -96,3 +101,9 @@ meta slug = do
     language <- languageHeaderM
     m <- getMeta slug
     metaDisplay language m >>= html
+
+feedIndex :: Language -> AppPart Response
+feedIndex language = do
+    articles <- lift $ getFiltered (const True)
+    let sorted = sortBy reverseCompare articles
+    feedDisplay language sorted >>= html

src/Import.hs

@@ -100,7 +100,7 @@ loadFromDirectory path = do
     return $ do
         state <- fromSources sources
         strings <- loadStrings stringsFile
-        return $ state { appDirectory = path, appStrings = strings }
+        return $ state { appDirectory = path, appStrings = strings, appAddress = "" }
 
 -- All content sources from a directory
 sourcesFromDirectory :: FilePath -> IO [ContentSource]
@@ -134,6 +134,7 @@ fromSources sources = do
     extracted <- mapM makeArticle grouped
     let (articles, meta) = partitionEithers extracted
     return AppState { appDirectory = ""
+                    , appAddress = ""
                     , appArticles = articles
                     , appMeta = meta
                     , appStrings = M.empty

src/Language.hs

@@ -5,13 +5,16 @@ module Language where
 import Control.Applicative
 import Control.Monad
 
+import Data.Function
 import Data.LanguageCodes
 import Data.List
 import Data.List.Split
 import qualified Data.Map as M
 import Data.Maybe
 import qualified Data.Yaml as Y
 
+import Utils
+
 
 type Language = ISO639_1
 
@@ -33,6 +36,9 @@ defaultLanguage = EN
 singleLanguage :: Language -> LanguagePreference
 singleLanguage lang = LanguagePreference $ M.singleton lang 1
 
+bestLanguage :: LanguagePreference -> Language
+bestLanguage = fst . head . sortBy (reverseCompare `on` snd) . M.toList . unLanguagePreference
+
 rankLanguage :: Language -> LanguagePreference -> Float
 rankLanguage lang = fromMaybe 0 . M.lookup lang . unLanguagePreference
 
@@ -50,6 +56,9 @@ parseLanguage [c1, c2] = case fromChars c1 c2 of
                              Nothing -> mzero
 parseLanguage _ = mzero
 
+showLanguage :: Language -> String
+showLanguage = (\(a, b) -> a:b:[]) . toChars
+
 -- TODO: Parsec or library
 languageHeader :: Maybe String -> LanguagePreference
 languageHeader Nothing = LanguagePreference $ M.singleton defaultLanguage 1
@@ -62,6 +71,5 @@ languageHeader (Just str) = LanguagePreference $ M.fromList $ mapMaybe parsePref
 
 instance Show LanguagePreference where
     show = intercalate "," . map (uncurry showPref) . M.toList . unLanguagePreference
-        where showPref lang 1 = languageStr lang
-              showPref lang qvalue = languageStr lang ++ ";q=" ++ show qvalue
-              languageStr = (\(a, b) -> a:b:[]) . toChars
+        where showPref lang 1 = showLanguage lang
+              showPref lang qvalue = showLanguage lang ++ ";q=" ++ show qvalue

src/Main.hs

@@ -55,13 +55,13 @@ listenPort = liftM (read . fromMaybe "8000") (lookupEnv "LISTEN_PORT")
 -- Run the actual site
 runSite :: IO ()
 runSite = do
-    -- TODO: parametrise?
-    app <- loadApp "content"
     address <- siteAddress
+    -- TODO: directory name as parameter?
+    app <- loadApp "content" address
     lport <- listenPort
     let conf = nullConf { port = lport }
     -- Manually bind the socket to close it on exception
     bracket
         (bindPort conf)
         close
-        (\sock -> simpleHTTPWithSocket' (runApp app) sock conf $ site address)
+        (\sock -> simpleHTTPWithSocket' (runApp app) sock conf site)

src/Models.hs

@@ -53,6 +53,7 @@ instance HasSlug Meta where
     getSlug = mtSlug
 
 data AppState = AppState { appDirectory :: String
+                         , appAddress   :: String
                          , appArticles  :: [Article]
                          , appMeta      :: [Meta]
                          , appStrings   :: M.Map String (LanguageMap String)

src/Routes.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeOperators   #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeOperators     #-}
 module Routes where
 
 import Prelude hiding ((.))
@@ -14,12 +15,15 @@ import Text.Boomerang.TH (makeBoomerangs)
 
 import Web.Routes.Boomerang
 
+import Language
+
 data Sitemap = Index
            | Yearly Integer
            | Monthly Integer Int
            | Daily Day
            | ArticleView Day String
            | MetaView String
+           | Feed Language
            deriving (Eq, Show)
 
 makeBoomerangs ''Sitemap
@@ -29,6 +33,12 @@ rDay = xpure mkDay parseDay . (integer </> int </> int)
     where mkDay (y :- m :- d :- x) = fromGregorian y m d :- x
           parseDay (day :- x) = let (y, m, d) = toGregorian day in Just $ y :- m :- d :- x
 
+-- TODO: This will error on strings which are not language codes
+rLanguage :: Boomerang TextsError [T.Text] r (Language :- r)
+rLanguage = xpure mkLang parseLang . anyString
+    where mkLang (str :- x) = let Just lang = parseLanguage str in lang :- x
+          parseLang (lang :- x) = Just $ showLanguage lang :- x
+
 rString :: Boomerang e tok i (T.Text :- o) -> Boomerang e tok i (String :- o)
 rString = xmaph T.unpack (Just . T.pack)
 
@@ -43,4 +53,5 @@ sitemap = mconcat
     , rDaily . rDay
     , rArticleView . rDay </> anyString
     , rMetaView . anyString
+    , rFeed . "feed" </> rLanguage
     ]

src/Utils.hs

@@ -37,4 +37,4 @@ isSpecial ".." = True
 isSpecial _ = False
 
 reverseCompare :: Ord a => a -> a -> Ordering
-reverseCompare a b = compare b a
+reverseCompare = flip compare

src/Views.hs

@@ -54,13 +54,21 @@ render html = do
     route <- liftM convRender askRouteFn
     return $ html route
 
+getLangStringFn :: MonadState AppState m => LanguagePreference -> m (String -> String)
+getLangStringFn lang = do
+    strings <- gets appStrings
+    let fn str = fromMaybe str $ M.lookup str strings >>= matchLanguage lang
+    return fn
+
+getLangString :: MonadState AppState m => LanguagePreference -> String -> m String
+getLangString lang str = getLangStringFn lang >>= (\fn -> return $ fn str)
+
 template :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m, MonadPlus m) =>
     LanguagePreference -> PageContent (URL m) -> m Markup
 template lang page = do
     -- TODO: need to be able to get any meta inside
     about <- getMeta "about"
-    strings <- gets appStrings
-    let langString str = fromMaybe str $ M.lookup str strings >>= matchLanguage lang
+    langString <- getLangStringFn lang
     render $(hamletFile "templates/base.hamlet")
 
 articleListDisplay :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m, MonadPlus m) =>
@@ -92,14 +100,21 @@ inlineToStr inline = writePlain def $ Pandoc undefined [Plain inline]
 langContent :: HasContent a => LanguagePreference -> a -> Pandoc
 langContent lang = fromJust . matchLanguage lang . getContent
 
+-- Generate a link to some content
+linkTo :: (Linkable a, MonadRoute m, URL m ~ Sitemap)
+       => a
+       -> m String
+linkTo a = do
+    routeFn <- askRouteFn
+    return $ T.unpack $ routeFn (link a) []
+
 -- Modify the content to have a link to itself and have no anchors
 linkedContent :: (HasContent a, Linkable a, MonadRoute m, URL m ~ Sitemap)
               => LanguagePreference
               -> a
               -> m Pandoc
 linkedContent lang a = do
-    routeFn <- askRouteFn
-    let target = T.unpack $ routeFn (link a) []
+    target <- linkTo a
     return $ linkedHeader target $ langContent lang a
 
 -- Modify the first header to be a link to a given place

src/Views/Feed.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Views.Feed where
+
+import Control.Monad.State
+
+import Data.Time
+
+import Text.Atom.Feed (Date, Entry (..), EntryContent (..), Feed (..),
+                       TextContent (..), nullEntry, nullFeed, nullLink)
+import Text.Atom.Feed.Export (xmlFeed)
+
+import Text.Blaze.Renderer.String (renderMarkup)
+
+import Text.Pandoc (def, writeHtml)
+
+import Text.XML.Light.Output (showTopElement)
+
+import Web.Routes
+
+import Language
+import Models
+import Routes
+import Views
+
+-- TODO: show time properly when it's parsed
+atomDate :: UTCTime -> Date
+atomDate = (++ "T00:00:00Z") . showGregorian . utctDay
+
+articleEntry :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m) => Language -> Article -> m Entry
+articleEntry lang article = do
+    let lpref = singleLanguage lang
+    articleLink <- linkTo article
+    let entry = nullEntry articleLink (TextString $ langTitle lpref article) (atomDate $ arAuthored article)
+    let content = renderMarkup $ writeHtml def $ langContent lpref article
+    return entry { entryContent = Just $ HTMLContent content
+                 , entryLinks = [nullLink articleLink]
+                 }
+
+feedDisplay :: (MonadRoute m, URL m ~ Sitemap, MonadState AppState m, MonadPlus m) =>
+    Language -> [Article] -> m String
+feedDisplay lang articles = do
+    siteName <- getLangString (singleLanguage lang) "siteName"
+    siteId <- gets appAddress
+    let lastUpdated = arAuthored $ head articles
+    let blankFeed = nullFeed siteId (TextString siteName) (atomDate lastUpdated)
+    entries <- mapM (articleEntry lang) articles
+    let feed = blankFeed { feedEntries = entries }
+    return $ showTopElement $ xmlFeed feed

templates/base.hamlet

@@ -9,6 +9,7 @@ $doctype 5
         #{langString "siteName"}
     <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.1/css/bootstrap.min.css">
     <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.1/css/bootstrap-theme.min.css">
+    <link rel="alternate" type="application/atom+xml" href="@{Feed $ bestLanguage lang}">
     <meta name="viewport" content="width=device-width, initial-scale=1">
   <body>
     <div .container>

testsuite/Integration/Base.hs

@@ -24,15 +24,14 @@ import Import
 import Language
 
 
--- Site handler with a test address
-testHandler :: ServerPartT App Response
-testHandler = site "http://test"
+testAddress :: String
+testAddress = "http://test"
 
 -- Make a request to the application
 testRequest :: Request -> IO Response
 testRequest req = do
-    app <- loadApp "testsuite/Integration/content"
-    runApp app $ simpleHTTP'' testHandler req
+    app <- loadApp "testsuite/Integration/content" testAddress
+    runApp app $ simpleHTTP'' site req
 
 assertContains :: (Eq a, Show a) => [a] -> [a] -> Assertion
 assertContains needle haystack =
@@ -96,3 +95,6 @@ responseContent f@(SendFile _ _ _ _ _ _ _) = do
     let offset = fromIntegral $ sfOffset f
     let count = fromIntegral $ sfCount f
     return $ drop offset $ take count contents
+
+testResponse :: Request -> IO String
+testResponse = testRequest >=> responseContent

testsuite/Integration/TestArticle.hs

@@ -15,8 +15,7 @@ import Test.Framework
 
 test_article = do
     req <- mkRequest "/2015/01/01/first-test"
-    article <- testRequest req
-    resp <- responseContent article
+    article <- testResponse req
     assertContains
         "<h2 id=\"first-test-article\">First test article</h2>"
-        resp
+        article

testsuite/Integration/TestHome.hs

@@ -13,19 +13,16 @@ import Integration.Base
 
 test_home = do
     req <- mkRequest "/"
-    home <- testRequest req
-    resp <- responseContent home
-    assertContains "Test site" resp
-    assertContainsBefore "Another article" "First test article" resp
+    home <- testResponse req
+    assertContains "Test site" home
+    assertContainsBefore "Another article" "First test article" home
 
 test_home_lang = do
     req <- liftM (withLang1 RU) (mkRequest "/")
-    home <- testRequest req
-    resp <- responseContent home
-    assertContains "Главная" resp
+    home <- testResponse req
+    assertContains "Главная" home
 
 test_explicit_lang = do
     req <- mkRequest "/?lang=ru"
-    home <- testRequest req
-    resp <- responseContent home
-    assertContains "Главная" resp
+    home <- testResponse req
+    assertContains "Главная" home