Store categories directly in entry_category

This commit is contained in:
Danielle McLean 2017-10-16 13:47:49 +11:00
parent 6f18f1b5d8
commit 1364a2e36b
Signed by: 00dani
GPG key ID: 5A5D2D1AFF12EEC5
7 changed files with 25 additions and 27 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

14
src/Model/Category.hs Normal file
View file

@ -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