From 967923406279a43d6323fb720a17e029eb951ce4 Mon Sep 17 00:00:00 2001
From: Danielle McLean <dani@00dani.me>
Date: Mon, 9 Oct 2017 08:51:42 +1100
Subject: [PATCH] Add slugs to entries and use them to create individual entry
 routes

---
 config/models          |  1 +
 config/routes          |  2 ++
 package.yaml           |  1 +
 src/Foundation.hs      |  1 +
 src/Handler/Entries.hs | 24 ++++++++++++++++++++++++
 src/Model.hs           |  1 +
 templates/entry.hamlet |  1 +
 7 files changed, 31 insertions(+)
 create mode 100644 templates/entry.hamlet

diff --git a/config/models b/config/models
index d32d5b3..65d8f4a 100644
--- a/config/models
+++ b/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
diff --git a/config/routes b/config/routes
index 6d3980c..f90eee3 100644
--- a/config/routes
+++ b/config/routes
@@ -9,3 +9,5 @@
 / HomeR GET
 
 !/#EntryKind EntriesR GET
+!/#EntryKind/#EntryId EntryNoSlugR GET
+!/#EntryKind/#EntryId/#Slug EntryR GET
diff --git a/package.yaml b/package.yaml
index efbf6c4..859a5b0 100644
--- a/package.yaml
+++ b/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
diff --git a/src/Foundation.hs b/src/Foundation.hs
index ca56b0e..c7ee463 100644
--- a/src/Foundation.hs
+++ b/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
diff --git a/src/Handler/Entries.hs b/src/Handler/Entries.hs
index 0439ab2..b9d735a 100644
--- a/src/Handler/Entries.hs
+++ b/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
diff --git a/src/Model.hs b/src/Model.hs
index a48d670..90b4c0c 100644
--- a/src/Model.hs
+++ b/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 )
 
diff --git a/templates/entry.hamlet b/templates/entry.hamlet
new file mode 100644
index 0000000..0907ce8
--- /dev/null
+++ b/templates/entry.hamlet
@@ -0,0 +1 @@
+^{hEntry entry}