Add feeds for items in categories

INSTALL.md

@@ -82,9 +82,9 @@ env LC_ALL=en_US.UTF-8
 exec dist/build/guide/guide
 ~~~
 
-(Also possibly `env GUIDE_TRACKING=1`.)
+If you want tracking, add `env GUIDE_TRACKING=1`. If you want e.g. feeds to work correctly, add `env GUIDE_URL="url of your instance here"` (and don't forget about `http://` or `https://`).
 
-And start the daemon:
+Start the daemon:
 
     $ service guide start
 

README.md

@@ -7,6 +7,12 @@ Installation instructions are here: [INSTALL.md](INSTALL.md).
 
 The beta version is running at [guide.aelve.com](http://guide.aelve.com).
 
+## Environment variables
+
+* `GUIDE_TRACKING=1` enables tracking
+
+* `GUIDE_URL="url of your instance here"` (and don't forget about `http://` or `https://`) is needed for some things (like feeds) to work correctly
+
 ## Contributing
 
 If you want to contribute but don't know where to start, grep the source for

guide.cabal

@@ -47,6 +47,8 @@ executable guide
                      , containers >= 0.5
                      , ekg
                      , ekg-core
+                     , feed >= 0.3.11 && < 0.4
+                     , filepath
                      , lucid
                      , megaparsec
                      , microlens-platform >= 0.2.3
@@ -63,6 +65,7 @@ executable guide
                      , uniplate
                      , wai-middleware-metrics
                      , wai-middleware-static
+                     , xml
                      , xss-sanitize
   ghc-options:         -Wall -fno-warn-unused-do-bind
                        -threaded "-with-rtsopts=-T -N"

src/Main.hs

@@ -4,7 +4,6 @@ ScopedTypeVariables,
 TypeFamilies,
 DataKinds,
 MultiWayIf,
-ViewPatterns,
 NoImplicitPrelude
   #-}
 
@@ -22,19 +21,27 @@ import Lens.Micro.Platform hiding ((&))
 import qualified Data.Map as M
 -- Text
 import Data.Text (Text)
-import qualified Data.Text as T
+import qualified Data.Text          as T
 import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as TL
+-- Paths
+import System.FilePath ((</>))
 -- Web
 import Web.Spock hiding (head, get, text)
 import qualified Web.Spock as Spock
 import Web.Spock.Lucid
+import qualified Lucid
 import Network.Wai.Middleware.Static
+-- Feeds
+import qualified Text.Feed.Types as Feed
+import qualified Text.Feed.Util  as Feed
+import qualified Text.Atom.Feed  as Atom
 -- Highlighting
 import Cheapskate.Highlight
 -- Monitoring
 import qualified System.Remote.Monitoring as EKG
-import qualified Network.Wai.Metrics as EKG
-import qualified System.Metrics.Gauge as EKG.Gauge
+import qualified Network.Wai.Metrics      as EKG
+import qualified System.Metrics.Gauge     as EKG.Gauge
 import Data.Generics.Uniplate.Data
 -- acid-state
 import Data.Acid as Acid
@@ -252,6 +259,43 @@ otherMethods = do
     Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
       dbUpdate (DeleteTrait itemId traitId)
 
+  -- Feeds
+  baseUrl <- fromMaybe "" <$> liftIO (lookupEnv "GUIDE_URL")
+  Spock.subcomponent "feed" $ do
+    -- Feed for items in a category
+    Spock.get categoryVar $ \catId -> do
+      category <- dbQuery (GetCategory catId)
+      let sortedItems = reverse $ sortBy cmp (category^.items)
+            where cmp = comparing (^.created) <> comparing (^.uid)
+      let route = "feed" <//> categoryVar
+      let feedUrl = baseUrl </> T.unpack (renderRoute route (category^.uid))
+          feedTitle = Atom.TextString (T.unpack (category^.title) ++
+                                       " – Aelve Guide")
+          feedLastUpdate = case sortedItems of
+            (item:_) -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)
+            _        -> ""
+      let feedBase = Atom.nullFeed feedUrl feedTitle feedLastUpdate
+      atomFeed $ feedBase {
+        Atom.feedEntries = map (itemToFeedEntry baseUrl category) sortedItems,
+        Atom.feedLinks   = [Atom.nullLink feedUrl] }
+
+itemToFeedEntry :: String -> Category -> Item -> Atom.Entry
+itemToFeedEntry baseUrl category item =
+  entryBase {
+    Atom.entryLinks = [Atom.nullLink entryLink],
+    Atom.entryContent = Just (Atom.HTMLContent (TL.unpack entryContent)) }
+  where
+    entryLink = baseUrl </>
+                T.unpack (format "{}#item-{}"
+                                 (categorySlug category, item^.uid))
+    entryContent = Lucid.renderText (renderItemForFeed item)
+    entryBase = Atom.nullEntry
+      (T.unpack (uidToText (item^.uid)))
+      (Atom.TextString (T.unpack (item^.name)))
+      (Feed.toFeedDateStringUTC Feed.AtomKind (item^.created))
+
+-- TODO: add # links to items
+
 main :: IO ()
 main = do
   let emptyState = GlobalState mempty
@@ -312,18 +356,17 @@ main = do
       Spock.get var $ \path -> do
         -- The links look like /generating-feeds-gao238b1 (because it's nice
         -- when you can find out where a link leads just by looking at it)
-        let (T.init -> urlSlug, catId) = T.breakOnEnd "-" path
+        let (_, catId) = T.breakOnEnd "-" path
         when (T.null catId) $
           Spock.jumpNext
         mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
         case mbCategory of
           Nothing -> Spock.jumpNext
           Just category -> do
-            let slug = makeSlug (category^.title)
             -- If the slug in the url is old or something (i.e. if it doesn't
             -- match the one we would've generated now), let's do a redirect
-            when (urlSlug /= slug) $
-              Spock.redirect (format "/{}-{}" (slug, category^.uid))
+            when (categorySlug category /= path) $
+              Spock.redirect ("/" <> categorySlug category)
             lucidIO $ renderCategoryPage category
       -- The add/set methods return rendered parts of the structure (added
       -- categories, changed items, etc) so that the Javascript part could
@@ -334,8 +377,6 @@ main = do
       addMethods
       otherMethods
 
--- TODO: RSS feeds for categories
-
 -- TODO: when a category with the same name exists, show an error message and
 -- redirect to that other category
 

src/Types.hs

@@ -31,6 +31,7 @@ module Types
     title,
     groups,
     items,
+    categorySlug,
   GlobalState(..),
     categories,
 
@@ -277,6 +278,10 @@ data Category = Category {
 deriveSafeCopy 2 'extension ''Category
 makeFields ''Category
 
+categorySlug :: Category -> Text
+categorySlug category =
+  format "{}-{}" (makeSlug (category^.title), category^.uid)
+
 -- Old version, needed for safe migration. It can most likely be already
 -- deleted (if a checkpoint has been created), but it's been left here as a
 -- template for future migrations.

src/Utils.hs

@@ -34,6 +34,7 @@ module Utils
   includeCSS,
 
   -- * Spock
+  atomFeed,
 )
 where
 
@@ -45,8 +46,9 @@ import Control.Monad.IO.Class
 -- Random
 import System.Random
 -- Text
-import qualified Data.Text as T
 import Data.Text (Text)
+import qualified Data.Text          as T
+import qualified Data.Text.Encoding as T
 import qualified Data.Text.Lazy as TL
 -- Formatting
 import           Data.Text.Format hiding (format)
@@ -58,6 +60,10 @@ import Lucid
 import Web.Spock
 import Text.HTML.SanitizeXSS (sanitaryURI)
 import Web.PathPieces
+-- Feeds
+import qualified Text.Atom.Feed        as Atom
+import qualified Text.Atom.Feed.Export as Atom
+import qualified Text.XML.Light.Output as XML
 -- acid-state
 import Data.SafeCopy
 
@@ -105,7 +111,7 @@ makeSlug =
 
 -- | Unique id, used for many things – categories, items, and anchor ids.
 newtype Uid = Uid {uidToText :: Text}
-  deriving (Eq, Show, PathPiece, Format.Buildable, Data)
+  deriving (Eq, Ord, Show, PathPiece, Format.Buildable, Data)
 
 deriveSafeCopy 0 'base ''Uid
 
@@ -142,3 +148,7 @@ includeJS url = with (script_ "") [src_ url]
 includeCSS :: Monad m => Url -> HtmlT m ()
 includeCSS url = link_ [rel_ "stylesheet", type_ "text/css", href_ url]
 
+atomFeed :: MonadIO m => Atom.Feed -> ActionCtxT ctx m ()
+atomFeed feed = do
+  setHeader "Content-Type" "application/atom+xml; charset=utf-8"
+  bytes $ T.encodeUtf8 (T.pack (XML.ppElement (Atom.xmlFeed feed)))

src/View.hs

@@ -34,6 +34,9 @@ module View
   -- ** Traits
   renderTrait,
 
+  -- * Rendering for feeds
+  renderItemForFeed,
+
   -- * Miscellaneous
   getItemHue,
   newGroupValue,
@@ -251,8 +254,7 @@ renderCategoryTitle category = do
       this   = JS.selectId thisId
   h2_ [id_ thisId] $ do
     sectionSpan "normal" [shown, noScriptShown] $ do
-      let slug = makeSlug (category^.title)
-      a_ [href_ (format "/{}-{}" (slug, category^.uid))] $
+      a_ [href_ ("/" <> categorySlug category)] $
         toHtml (category^.title)
       emptySpan "1em"
       textButton "edit" $
@@ -311,6 +313,7 @@ getItemHue category item = case item^.group_ of
 -- instead of using arrows? Touch Punch works on mobile, too
 renderItem :: Category -> Item -> HtmlT IO ()
 renderItem category item =
+  -- The id is used for links in feeds
   div_ [id_ ("item-" <> uidToText (item^.uid)), class_ "item"] $ do
     renderItemInfo category item
     -- TODO: replace “edit description” with a big half-transparent pencil
@@ -331,6 +334,37 @@ renderItem category item =
 
 -- TODO: warn when a library isn't on Hackage but is supposed to be
 
+renderItemHeader :: Monad m => Item -> HtmlT m ()
+renderItemHeader item = do
+  let hackageLink x = "https://hackage.haskell.org/package/" <> x
+  case item^.kind of
+    -- If the library is on Hackage, the title links to its Hackage
+    -- page; otherwise, it doesn't link anywhere. Even if the link
+    -- field is present, it's going to be rendered as “(site)”, not
+    -- linked in the title.
+    Library hackageName' -> do
+      case hackageName' of
+        Just x  -> a_ [href_ (hackageLink x)] (toHtml (item^.name))
+        Nothing -> toHtml (item^.name)
+      case item^.link of
+        Just l  -> " (" >> a_ [href_ l] "site" >> ")"
+        Nothing -> return ()
+    -- For tools, it's the opposite – the title links to the item site
+    -- (if present), and there's a separate “(Hackage)” link if the
+    -- tool is on Hackage.
+    Tool hackageName' -> do
+      case item^.link of
+        Just l  -> a_ [href_ l] (toHtml (item^.name))
+        Nothing -> toHtml (item^.name)
+      case hackageName' of
+        Just x  -> " (" >> a_ [href_ (hackageLink x)] "Hackage" >> ")"
+        Nothing -> return ()
+    -- And now everything else
+    Other -> do
+      case item^.link of
+        Just l  -> a_ [href_ l] (toHtml (item^.name))
+        Nothing -> toHtml (item^.name)
+
 -- TODO: give a link to oldest available docs when the new docs aren't there
 renderItemInfo :: Category -> Item -> HtmlT IO ()
 renderItemInfo cat item = do
@@ -343,34 +377,7 @@ renderItemInfo cat item = do
     section "normal" [shown, noScriptShown] $ do
       -- TODO: [very-easy] move this style_ into css.css
       span_ [style_ "font-size:150%"] $ do
-        let hackageLink x = "https://hackage.haskell.org/package/" <> x
-        case item^.kind of
-          -- If the library is on Hackage, the title links to its Hackage
-          -- page; otherwise, it doesn't link anywhere. Even if the link
-          -- field is present, it's going to be rendered as “(site)”, not
-          -- linked in the title.
-          Library hackageName' -> do
-            case hackageName' of
-              Just x  -> a_ [href_ (hackageLink x)] (toHtml (item^.name))
-              Nothing -> toHtml (item^.name)
-            case item^.link of
-              Just l  -> " (" >> a_ [href_ l] "site" >> ")"
-              Nothing -> return ()
-          -- For tools, it's the opposite – the title links to the item site
-          -- (if present), and there's a separate “(Hackage)” link if the
-          -- tool is on Hackage.
-          Tool hackageName' -> do
-            case item^.link of
-              Just l  -> a_ [href_ l] (toHtml (item^.name))
-              Nothing -> toHtml (item^.name)
-            case hackageName' of
-              Just x  -> " (" >> a_ [href_ (hackageLink x)] "Hackage" >> ")"
-              Nothing -> return ()
-          -- And now everything else
-          Other -> do
-            case item^.link of
-              Just l  -> a_ [href_ l] (toHtml (item^.name))
-              Nothing -> toHtml (item^.name)
+        renderItemHeader item
       emptySpan "2em"
       toHtml (fromMaybe "other" (item^.group_))
       span_ [class_ "controls"] $ do
@@ -653,6 +660,22 @@ renderItemNotes item = do
 -- TODO: a shortcut for editing (when you press Ctrl-something, whatever was
 -- selected becomes editable)
 
+renderItemForFeed :: Item -> Html ()
+renderItemForFeed item = do
+  h1_ $ renderItemHeader item
+  when (item^.description /= "") $
+    toHtml (item^.description)
+  h2_ "Pros"
+  ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.pros)
+  h2_ "Cons"
+  ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.cons)
+  when (item^.ecosystem /= "") $ do
+    h2_ "Ecosystem"
+    toHtml (item^.ecosystem)
+  when (item^.notes /= "") $ do
+    h2_ "Notes"
+    toHtml (item^.notes)
+
 -- Utils
 
 onPageLoad :: JS -> HtmlT IO ()