Begin adding rudimentary support for posting new entries to the site - needs to be prettier and a lot smarter, but it exists now

config/models

@@ -21,3 +21,11 @@ Profile
     userId UserId
     siteId SiteId
     username Text sqltype=varchar(255)
+
+Entry
+    kind EntryKind
+    name Text maxlen=255
+    content Text sqltype=longtext
+    published UTCTime
+    updated UTCTime
+    authorId UserId

config/routes

@@ -7,3 +7,5 @@
 /sitemap.xml SitemapR GET
 
 / HomeR GET
+
+!/#EntryKind EntriesR GET

src/Application.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application
     ( getApplicationDev
@@ -48,6 +49,7 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
 import Handler.Common
+import Handler.Entries
 import Handler.Home
 
 -- This line actually creates our YesodDispatch instance. It is the second half

src/Entry/Kind.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Entry.Kind where
+
+import Database.Persist.TH ( derivePersistField )
+import Yesod.Core.Dispatch ( PathPiece, toPathPiece, fromPathPiece )
+
+import qualified Data.Text as T
+import Text.Read ( readMaybe )
+
+data EntryKind = Note | Article | Photo | Video | Audio
+               | Reply | Repost | Like | Favourite | Bookmark | Quote | Rsvp
+               | Listen | Jam | Watch | Play | Read
+              deriving (Eq, Read, Show)
+derivePersistField "EntryKind"
+
+singularise :: T.Text -> Maybe EntryKind
+singularise "replies" = Just Reply
+singularise "watches" = Just Watch
+singularise k = readMaybe . T.unpack . T.toTitle . T.init $ k
+
+pluralise :: EntryKind -> T.Text
+pluralise Reply = "replies"
+pluralise Watch = "watches"
+pluralise k = T.toLower . flip T.snoc 's' . T.pack . show $ k
+
+instance PathPiece EntryKind where
+    toPathPiece = pluralise
+    fromPathPiece = singularise

src/Foundation.hs

@@ -20,6 +20,7 @@ import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
 
 import Package
+import Entry.Kind ( EntryKind )
 
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application

src/Handler/Entries.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Handler.Entries where
+
+import Import
+
+import qualified Entry.Kind as K
+import Widget.Feed ( hFeed )
+
+getEntriesR :: K.EntryKind -> Handler Html
+getEntriesR kind = do
+    entries <- runDB $ selectList [EntryKind ==. kind] [Desc EntryPublished]
+    defaultLayout $(widgetFile "entries")

src/Model.hs

@@ -13,6 +13,8 @@ import ClassyPrelude.Yesod
 import Database.Persist.Quasi
 import Yesod.Auth.HashDB ( HashDBUser(..) )
 
+import Entry.Kind ( EntryKind )
+
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:

src/Widget/Entry.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Widget.Entry ( hEntry ) where
+
+import Import
+
+hEntry :: Entity Entry -> Widget
+hEntry (Entity entryId entry) = do
+    maybeAuthor <- handlerToWidget . runDB . get . entryAuthorId $ entry
+    $(widgetFile "mf2/h-entry")

src/Widget/Feed.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Widget.Feed ( hFeed ) where
+
+import Import
+import Widget.Entry ( hEntry )
+
+hFeed :: [Entity Entry] -> Widget
+hFeed entries = $(widgetFile "mf2/h-feed")

templates/entries.hamlet

@@ -0,0 +1 @@
+^{hFeed entries}

templates/mf2/h-entry.hamlet

@@ -0,0 +1,12 @@
+<article .h-entry>
+  <h1.p-name>#{entryName entry}
+  <p>
+    Published
+    $maybe author <- maybeAuthor
+      \ by
+      <a .p-author.h-card href=@{HomeR}>
+        #{userFullName author}
+    on
+    <time .dt-published datetime=#{show $ entryPublished entry}>
+  <div .e-content>
+    #{entryContent entry}

templates/mf2/h-feed.hamlet

@@ -0,0 +1,3 @@
+<ol .h-feed>
+  $forall entry <- entries
+    <li>^{hEntry entry}