From 7d2f3594b6f8bfb9386487f8fb5629cae8b93c51 Mon Sep 17 00:00:00 2001 From: Artyom Date: Sat, 19 Mar 2016 21:36:21 +0300 Subject: [PATCH] Add feeds for items in categories --- INSTALL.md | 4 +-- README.md | 6 ++++ guide.cabal | 3 ++ src/Main.hs | 61 +++++++++++++++++++++++++++++++------- src/Types.hs | 5 ++++ src/Utils.hs | 14 +++++++-- src/View.hs | 83 +++++++++++++++++++++++++++++++++------------------- 7 files changed, 132 insertions(+), 44 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index d51adeb..cd87dd8 100644 --- a/INSTALL.md +++ b/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 diff --git a/README.md b/README.md index 01a5d77..45ec6ee 100644 --- a/README.md +++ b/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 diff --git a/guide.cabal b/guide.cabal index ed73ec3..e1f3587 100644 --- a/guide.cabal +++ b/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" diff --git a/src/Main.hs b/src/Main.hs index a8b4597..16f61c3 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Types.hs b/src/Types.hs index 508ca2e..73bfb13 100644 --- a/src/Types.hs +++ b/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. diff --git a/src/Utils.hs b/src/Utils.hs index e184ba6..8ad8eaa 100644 --- a/src/Utils.hs +++ b/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))) diff --git a/src/View.hs b/src/View.hs index 4783e88..f826829 100644 --- a/src/View.hs +++ b/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 ()