Add basic support for h-entry categories, which are actually more like tags than categories really

config/models

@@ -37,3 +37,12 @@ Syndication
     entryId EntryId
     profileId ProfileId
     url Text sqltype=varchar(255)
+
+Category
+    tag Slug sqltype=varchar(190)
+    UniqueTag tag
+
+EntryCategory
+    entryId EntryId
+    categoryId CategoryId
+    UniqueEntryCategory entryId categoryId

config/routes

@@ -8,6 +8,8 @@
 
 / HomeR GET
 /avatars/#UserId AvatarR GET
+/categories/#Slug CategoryR GET
+
 /feed FeedR GET
 !/#EntryKind/feed FeedKindR GET
 

src/Application.hs

@@ -50,6 +50,7 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
 -- Don't forget to add new modules to your cabal file!
 import Handler.Avatars
 import Handler.Common
+import Handler.Categories
 import Handler.Entries
 import Handler.Feed
 import Handler.Home

src/Handler/Categories.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.Categories where
+
+import Import hiding ( on, (==.) )
+
+import Database.Esqueleto
+import Web.Slug ( Slug, unSlug )
+import Widget.Feed ( hFeed )
+
+import qualified Data.Text as T
+
+getCategoryR :: Slug -> Handler Html
+getCategoryR tag = do
+    entries <- runDB . select . from $ \(category `InnerJoin` ec `InnerJoin` entry) -> do
+        on $ entry ^. EntryId ==. ec ^. EntryCategoryEntryId
+        on $ category ^. CategoryId ==. ec ^. EntryCategoryCategoryId
+        where_ $ category ^. CategoryTag ==. val tag
+        return entry
+    defaultLayout $ do
+        setTitle . toHtml . T.cons '#' . unSlug $ tag
+        hFeed entries

src/Model.hs

@@ -11,6 +11,7 @@ module Model where
 
 import ClassyPrelude.Yesod
 import Database.Persist.Quasi
+import Web.Slug ( Slug )
 import Yesod.Auth.HashDB ( HashDBUser(..) )
 import Text.Mustache ( (~>) )
 import qualified Text.Mustache as M