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

config/models

@@ -23,6 +23,7 @@ Profile
     username Text sqltype=varchar(255)
 
 Entry
+    slug Slug
     kind EntryKind
     name Text maxlen=255
     content Text sqltype=longtext

config/routes

@@ -9,3 +9,5 @@
 / HomeR GET
 
 !/#EntryKind EntriesR GET
+!/#EntryKind/#EntryId EntryNoSlugR GET
+!/#EntryKind/#EntryId/#Slug EntryR GET

package.yaml

@@ -49,6 +49,7 @@ dependencies:
 
 - conduit-combinators >= 1.1 && < 1.2
 - libravatar >=0.4 && <0.5
+- slug >=0.1 && <0.2
 - split >=0.2 && <0.3
 - yesod-auth-hashdb >=1.6.2 && <1.7
 - yesod-sitemap >=1.4 && <1.5

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 )
 

templates/entry.hamlet

@@ -0,0 +1 @@
+^{hEntry entry}