00dani/lebd
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

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

Browse source
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
Download patch file Download diff file Expand all files Collapse all files

28
src/Handler/Entries.hs
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
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")