diff --git a/config/models b/config/models index c4bcbb1..d91155a 100644 --- a/config/models +++ b/config/models @@ -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 diff --git a/config/routes b/config/routes index 81852ee..0fd5278 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index ed59f27..b74db1f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Entries.hs b/src/Handler/Entries.hs index 42212e3..49dba54 100644 --- a/src/Handler/Entries.hs +++ b/src/Handler/Entries.hs @@ -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 - setTitle . toHtml . entryName . entityVal $ entry - $(widgetFile "entry") - else redirectWith movedPermanently301 $ entryR entry +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") diff --git a/src/Widget/Entry.hs b/src/Widget/Entry.hs index a2e85ee..d73ad9e 100644 --- a/src/Widget/Entry.hs +++ b/src/Widget/Entry.hs @@ -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