From 474ed3cf28dbcefe6160690e6625ff74c58fac88 Mon Sep 17 00:00:00 2001
From: Danielle McLean <dani@00dani.me>
Date: Sat, 14 Oct 2017 14:59:51 +1100
Subject: [PATCH] Add basic support for h-entry categories, which are actually
 more like tags than categories really

---
 config/models             |  9 +++++++++
 config/routes             |  2 ++
 src/Application.hs        |  1 +
 src/Handler/Categories.hs | 22 ++++++++++++++++++++++
 src/Model.hs              |  1 +
 5 files changed, 35 insertions(+)
 create mode 100644 src/Handler/Categories.hs

diff --git a/config/models b/config/models
index 17a4302..f103a40 100644
--- a/config/models
+++ b/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
diff --git a/config/routes b/config/routes
index 5bab231..bbdd21e 100644
--- a/config/routes
+++ b/config/routes
@@ -8,6 +8,8 @@
 
 / HomeR GET
 /avatars/#UserId AvatarR GET
+/categories/#Slug CategoryR GET
+
 /feed FeedR GET
 !/#EntryKind/feed FeedKindR GET
 
diff --git a/src/Application.hs b/src/Application.hs
index a9bcf5e..43e41b9 100644
--- a/src/Application.hs
+++ b/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
diff --git a/src/Handler/Categories.hs b/src/Handler/Categories.hs
new file mode 100644
index 0000000..6a66cde
--- /dev/null
+++ b/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
diff --git a/src/Model.hs b/src/Model.hs
index 98d0306..8864b63 100644
--- a/src/Model.hs
+++ b/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