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

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

config/routes

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

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

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
+getEntryR :: a -> EntryId -> Handler Html
-checkMatching kind slug entry = (kind == entryKind entry) && (slug == entrySlug entry)
+getEntryR _ entryId = getEntry <=< fmap (Entity entryId) . runDB . get404 $ entryId
 
-getEntryNoSlugR :: a -> EntryId -> Handler Html
+getEntryWithSlugR :: a -> EntryId -> b -> Handler Html
-getEntryNoSlugR _ entryId = do
+getEntryWithSlugR kind = const . getEntryR kind
-    entry <- fmap (Entity entryId) . runDB . get404 $ entryId
-    redirectWith movedPermanently301 . entryR $ entry
 
-getEntryR :: K.EntryKind -> EntryId -> Slug -> Handler Html
+getEntry :: (Entity Entry) -> Handler Html
-getEntryR kind entryId slug = do
+getEntry entry = do
-    entry <- fmap (Entity entryId) . runDB . get404 $ entryId
+    let correctRoute = entryR entry
-    if checkMatching kind slug $ entityVal entry
+    actualRoute <- getCurrentRoute
-       then defaultLayout $ do
+    when (actualRoute /= Just correctRoute) $
+        redirectWith movedPermanently301 correctRoute
+    defaultLayout $ do
         setTitle . toHtml . entryName . entityVal $ entry
         $(widgetFile "entry")
-       else redirectWith movedPermanently301 $ entryR entry

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