Store categories directly in entry_category

config/models

@@ -39,11 +39,7 @@ Syndication
     profileId ProfileId
     url Text sqltype=varchar(255)
 
-Category
-    tag Slug sqltype=varchar(190)
-    UniqueTag tag
-
 EntryCategory
     entryId EntryId
-    categoryId CategoryId
-    UniqueEntryCategory entryId categoryId
+    category Category sqltype=varchar(190)
+    UniqueEntryCategory entryId category

config/routes

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

src/Foundation.hs

@@ -22,6 +22,7 @@ import qualified Yesod.Core.Unsafe as Unsafe
 
 import Package
 import Model.Cache ( getCached )
+import Model.Category ( Category )
 import Model.Entry ( entryTitle )
 import Model.Entry.Kind ( EntryKind, allEntryKinds, pluralise )
 

src/Handler/Categories.hs

@@ -5,18 +5,15 @@ module Handler.Categories where
 import Import hiding ( on, (==.) )
 
 import Database.Esqueleto
-import Web.Slug ( Slug, unSlug )
 import Widget.Feed ( hFeed )
+import Model.Category ( Category, asTag )
 
-import qualified Data.Text as T
-
-getCategoryR :: Slug -> Handler Html
+getCategoryR :: Category -> 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
+    entries <- runDB . select . from $ \(entry `InnerJoin` category) -> do
+        on $ entry ^. EntryId ==. category ^. EntryCategoryEntryId
+        where_ $ category ^. EntryCategoryCategory ==. val tag
         return entry
     defaultLayout $ do
-        setTitle . toHtml . T.cons '#' . unSlug $ tag
+        setTitle . toHtml . asTag $ tag
         hFeed entries

src/Handler/Common.hs

@@ -31,7 +31,6 @@ getRobotsR = robots SitemapR
 
 getSitemapR :: Handler TypedContent
 getSitemapR = do
-    categories <- runDB $ selectList [] [Asc CategoryTag]
     entries <- runDB $ selectList [] [Desc EntryPublished]
     sitemap $ do
         yield SitemapUrl
@@ -40,18 +39,9 @@ getSitemapR = do
             , sitemapChangeFreq = Just Daily
             , sitemapPriority = Nothing
             }
-        yieldMany $ categoryToSitemapUrl <$> categories
         yieldMany $ kindToSitemapUrl <$> allEntryKinds
         yieldMany $ entryToSitemapUrl <$> entries
 
-categoryToSitemapUrl :: Entity Category -> SitemapUrl (Route App)
-categoryToSitemapUrl (Entity _ cat) = SitemapUrl
-    { sitemapLoc = CategoryR $ categoryTag cat
-    , sitemapLastMod = Nothing
-    , sitemapChangeFreq = Nothing
-    , sitemapPriority = Nothing
-    }
-
 kindToSitemapUrl :: EntryKind -> SitemapUrl (Route App)
 kindToSitemapUrl kind = SitemapUrl
     { sitemapLoc = EntriesR kind

src/Model.hs

@@ -11,11 +11,11 @@ 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
 
+import Model.Category ( Category )
 import Model.Entry.Kind ( EntryKind )
 import Model.Markdown ( Markdown )
 

src/Model/Category.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Model.Category where
+
+import Database.Persist ( PersistField )
+import Web.Slug ( Slug, unSlug )
+import Yesod ( PathPiece )
+
+import qualified Data.Text as T
+
+newtype Category = Category { unCategory :: Slug }
+    deriving (Eq, Read, Show, PathPiece, PersistField)
+
+asTag :: Category -> T.Text
+asTag = T.cons '#' . unSlug . unCategory