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

This commit is contained in:
Danielle McLean 2017-10-14 14:59:51 +11:00
parent dfafe33e06
commit 474ed3cf28
Signed by: 00dani
GPG key ID: 5A5D2D1AFF12EEC5
5 changed files with 35 additions and 0 deletions

View file

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

View file

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

View file

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

22
src/Handler/Categories.hs Normal file
View file

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

View file

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