Add slugs to entries and use them to create individual entry routes

src/Foundation.hs

@@ -11,6 +11,7 @@ import Import.NoFoundation
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 import Text.Jasmine         (minifym)
+import Web.Slug             (Slug)
 
 import Yesod.Auth.HashDB    (authHashDBWithForm)
 import qualified Yesod.Auth.Message as AuthMsg

src/Handler/Entries.hs

@@ -1,12 +1,36 @@
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Handler.Entries where
 
 import Import
 
+import Web.Slug ( Slug )
+
 import qualified Entry.Kind as K
+import Widget.Entry ( hEntry )
 import Widget.Feed ( hFeed )
 
 getEntriesR :: K.EntryKind -> Handler Html
 getEntriesR kind = do
     entries <- runDB $ selectList [EntryKind ==. kind] [Desc EntryPublished]
     defaultLayout $(widgetFile "entries")
+
+entryR :: Entity Entry -> Route App
+entryR (Entity entryId entry) = EntryR (entryKind entry) entryId (entrySlug entry)
+
+checkMatching :: K.EntryKind -> Slug -> Entry -> Bool
+checkMatching kind slug entry = (kind == entryKind entry) && (slug == entrySlug entry)
+
+getEntryNoSlugR :: a -> EntryId -> Handler Html
+getEntryNoSlugR _ entryId = do
+    entry <- fmap (Entity entryId) . runDB . get404 $ entryId
+    redirectWith movedPermanently301 . entryR $ entry
+
+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

src/Model.hs

@@ -12,6 +12,7 @@ module Model where
 import ClassyPrelude.Yesod
 import Database.Persist.Quasi
 import Yesod.Auth.HashDB ( HashDBUser(..) )
+import Web.Slug ( Slug )
 
 import Entry.Kind ( EntryKind )