Make slugs optional - they don't really make sense for notes, only really for entries with names like articles

This commit is contained in:
Danielle McLean 2017-10-11 10:33:29 +11:00
parent 5f4e94bfd2
commit efdca09b1c
Signed by: 00dani
GPG key ID: 5A5D2D1AFF12EEC5
5 changed files with 22 additions and 20 deletions

View file

@ -26,7 +26,7 @@ Profile
displayName Text Maybe sqltype=varchar(255)
Entry
slug Slug
slug Slug Maybe
kind EntryKind
name Text maxlen=255
content Text sqltype=longtext

View file

@ -11,5 +11,5 @@
!/#EntryKind/feed FeedKindR GET
!/#EntryKind EntriesR GET
!/#EntryKind/#EntryId EntryNoSlugR GET
!/#EntryKind/#EntryId/#Slug EntryR GET
!/#EntryKind/#EntryId EntryR GET
!/#EntryKind/#EntryId/#Slug EntryWithSlugR GET

View file

@ -176,9 +176,10 @@ rightMenuItems = loggedOutItems `maybe` loggedInItems
instance YesodBreadcrumbs App where
breadcrumb (AuthR _) = return ("log in", Just HomeR)
breadcrumb (EntriesR kind) = return (pluralise kind, Just HomeR)
breadcrumb (EntryR kind entryId _) = do
breadcrumb (EntryR kind entryId) = do
entry <- runDB . get404 $ entryId
return (entryName entry, Just $ EntriesR kind)
breadcrumb (EntryWithSlugR kind entryId _) = breadcrumb $ EntryR kind entryId
breadcrumb _ = return ("home", Nothing)
jsonLdBreadcrumbList :: [(Route App, Text)] -> (Route App -> [(Text, Text)] -> Text) -> Value

View file

@ -5,7 +5,6 @@ module Handler.Entries where
import Import
import Web.Slug ( Slug )
import Yesod.AtomFeed ( atomLink )
import qualified Data.Text as T
@ -22,19 +21,18 @@ getEntriesR kind = do
atomLink (FeedKindR kind) $ T.concat [K.pluralise kind, " ~ ", title]
$(widgetFile "entries")
checkMatching :: K.EntryKind -> Slug -> Entry -> Bool
checkMatching kind slug entry = (kind == entryKind entry) && (slug == entrySlug entry)
getEntryR :: a -> EntryId -> Handler Html
getEntryR _ entryId = getEntry <=< fmap (Entity entryId) . runDB . get404 $ entryId
getEntryNoSlugR :: a -> EntryId -> Handler Html
getEntryNoSlugR _ entryId = do
entry <- fmap (Entity entryId) . runDB . get404 $ entryId
redirectWith movedPermanently301 . entryR $ entry
getEntryWithSlugR :: a -> EntryId -> b -> Handler Html
getEntryWithSlugR kind = const . getEntryR kind
getEntryR :: K.EntryKind -> EntryId -> Slug -> Handler Html
getEntryR kind entryId slug = do
entry <- fmap (Entity entryId) . runDB . get404 $ entryId
if checkMatching kind slug $ entityVal entry
then defaultLayout $ do
getEntry :: (Entity Entry) -> Handler Html
getEntry entry = do
let correctRoute = entryR entry
actualRoute <- getCurrentRoute
when (actualRoute /= Just correctRoute) $
redirectWith movedPermanently301 correctRoute
defaultLayout $ do
setTitle . toHtml . entryName . entityVal $ entry
$(widgetFile "entry")
else redirectWith movedPermanently301 $ entryR entry

View file

@ -1,5 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Widget.Entry ( entryR, hEntry ) where
@ -21,7 +22,9 @@ toFormattedTime time = FormattedTime (unfriendly time) <$> friendly time
friendly = liftIO . humanReadableTime
entryR :: Entity Entry -> Route App
entryR (Entity entryId entry) = EntryR (entryKind entry) entryId (entrySlug entry)
entryR (Entity entryId Entry {..}) = route entrySlug entryKind entryId
where route (Just s) = \k i -> EntryWithSlugR k i s
route Nothing = EntryR
hEntry :: Entity Entry -> Widget
hEntry (Entity entryId entry) = do