Basic blog post handling

Application.hs

@@ -26,6 +26,7 @@ import Database.Persist.GenericSql (runMigration)
 import Handler.Root
 import Handler.Wiki
 import Handler.Page
+import Handler.Blog
 
 -- This line actually creates our YesodSite instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see

Foundation.hs

@@ -20,7 +20,8 @@ import Yesod
 import Yesod.Static (Static, base64md5, StaticRoute(..))
 import Settings.StaticFiles
 import Yesod.Auth
-import Yesod.Auth.OpenId
+import Yesod.Auth.BrowserId
+import Yesod.Auth.GoogleEmail
 import Yesod.Default.Config
 import Yesod.Default.Util (addStaticContentExternal)
 import Yesod.Logger (Logger, logMsg, formatLogText)
@@ -144,7 +145,7 @@ instance YesodAuth YesodWeb where
                 fmap Just $ insert $ User (credsIdent creds) Nothing
 
     -- You can add other plugins like BrowserID, email or OAuth here
-    authPlugins = [authOpenId]
+    authPlugins = [authBrowserId', authGoogleEmail]
 
 -- Sends off your mail. Requires sendmail in production!
 deliver :: YesodWeb -> L.ByteString -> IO ()
@@ -157,4 +158,4 @@ deliver _ = sendmail
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
 instance RenderMessage YesodWeb FormMessage where
-    renderMessage _ _ = defaultFormMessage
+    renderMessage _ _ = defaultFormMessage

Handler/Blog.hs

@@ -0,0 +1,8 @@
+module Handler.Blog where
+
+import Import
+
+getBlogPostR :: Year -> Month -> Slug -> Handler RepHtml
+getBlogPostR y m s = do
+    (_, blog) <- runDB $ getBy404 $ UniqueBlog y m s
+    returnContent [markdownFormat, htmlFormat] $ blogPath blog

Handler/Page.hs

@@ -3,4 +3,4 @@ module Handler.Page where
 import Import
 
 getPageR :: [Text] -> Handler RepHtml
-getPageR = returnContent [unsafeHtmlFormat, markdownFormat] . ("page":)
+getPageR = returnContent [unsafeHtmlFormat, markdownFormat] . ContentPath . ("page":)

Handler/Root.hs

@@ -3,4 +3,4 @@ module Handler.Root where
 import Import
 
 getRootR :: Handler RepHtml
-getRootR = returnContent [unsafeHtmlFormat] ["homepage"]
+getRootR = returnContent [unsafeHtmlFormat] $ ContentPath ["homepage"]

Handler/Wiki.hs

@@ -3,5 +3,5 @@ module Handler.Wiki where
 import Import
 
 getWikiR :: [Text] -> Handler RepHtml
-getWikiR = returnContent [markdownFormat, htmlFormat] . ("wiki":)
+getWikiR = returnContent [markdownFormat, htmlFormat] . ContentPath . ("wiki":)
 

Import/Content.hs

@@ -2,15 +2,19 @@
 -- | Load page contents from the content folder.
 module Import.Content
     ( ContentFormat (..)
+    , ContentPath (..)
     , htmlFormat
     , unsafeHtmlFormat
     , markdownFormat
     , loadContent
     , returnContent
     ) where
 
-import Prelude ((.), ($), IO, Maybe (..), return, (==), maybe)
-import Data.Text (Text)
+import Prelude
+    ( (.), ($), IO, Maybe (..), return, (==), maybe
+    , Eq, Show, Read
+    )
+import Data.Text (Text, splitOn, intercalate)
 import qualified Data.Conduit as C
 import qualified Data.Conduit.List as CL
 import qualified Data.Conduit.Text as CT
@@ -27,8 +31,10 @@ import Control.Arrow (second)
 import Yesod
     ( liftIO, GHandler, Yesod, RepHtml, notFound, defaultLayout
     , setTitle, toWidget
+    , PersistField (..)
     )
 import qualified Text.Markdown as Markdown
+import Database.Persist.Store (SqlType (SqlString))
 
 data ContentFormat = ContentFormat
     { cfExtension :: Text
@@ -65,23 +71,23 @@ markdownFormat = ContentFormat "md" $
 
 -- | Try to load 'Html' from the given path.
 loadContent :: [ContentFormat]
-            -> [Text]
+            -> ContentPath
             -> IO (Maybe (Maybe Html, Html))
 loadContent [] _ = return Nothing
-loadContent (cf:cfs) pieces = do
+loadContent (cf:cfs) cp@(ContentPath pieces) = do
     e <- isFile path
     if e
         -- FIXME caching
         then Just <$> (C.runResourceT $ CB.sourceFile path C.$$ cfLoad cf)
-        else loadContent cfs pieces
+        else loadContent cfs cp
   where
     path = foldl' go "content" pieces <.> cfExtension cf
     go x y = x </> fromText y
 
 -- | Return some content as a 'Handler'.
 returnContent :: Yesod master
               => [ContentFormat]
-              -> [Text]
+              -> ContentPath
               -> GHandler sub master RepHtml
 returnContent cfs pieces = do
     mc <- liftIO $ loadContent cfs pieces
@@ -90,3 +96,12 @@ returnContent cfs pieces = do
         Just (mtitle, body) -> defaultLayout $ do
             maybe (return ()) setTitle mtitle
             toWidget body
+
+newtype ContentPath = ContentPath { unContentPath :: [Text] }
+    deriving (Eq, Show, Read)
+instance PersistField ContentPath where
+    toPersistValue = toPersistValue . intercalate "/" . unContentPath
+    fromPersistValue v = do
+        t <- fromPersistValue v
+        return $ ContentPath $ splitOn "/" t
+    sqlType _ = SqlString

Model.hs

@@ -2,9 +2,25 @@ module Model where
 
 import Prelude
 import Yesod
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Database.Persist.Quasi
+import Data.Time (UTCTime)
+import Import.Content (ContentPath)
 
+newtype Slug = Slug Text
+    deriving (Read, Eq, Show, PersistField, PathPiece, Ord)
+type Year = Int
+newtype Month = Month Int
+    deriving (Read, Eq, Show, PersistField, Ord)
+instance PathPiece Month where
+    toPathPiece (Month i)
+        | i < 10 && i >= 0 = pack $ '0' : show i
+        | otherwise = toPathPiece i
+    fromPathPiece t = do
+        i <- fromPathPiece t
+        if i >= 1 && i <= 12
+            then Just $ Month i
+            else Nothing
 
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities

config/models

@@ -7,5 +7,14 @@ Email
     user UserId Maybe
     verkey Text Maybe
     UniqueEmail email
+Blog
+    posted UTCTime
+    path ContentPath
+    slug Slug
+    year Int
+    month Month
+    author UserId
+    title Text
+    UniqueBlog year month slug
 
- -- By default this file is used in Model.hs (which is imported by Foundation.hs)
+ -- By default this file is used in Model.hs (which is imported by Foundation.hs)

config/routes

@@ -7,3 +7,4 @@
 / RootR GET
 /wiki/*Texts WikiR GET
 /page/*Texts PageR GET
+/blog/#Year/#Month/#Slug BlogPostR GET

yesodweb.cabal

@@ -38,6 +38,7 @@ library
                      Handler.Root
                      Handler.Wiki
                      Handler.Page
+                     Handler.Blog
 
     ghc-options:   -Wall -threaded -O0
     cpp-options:   -DDEVELOPMENT
@@ -110,3 +111,4 @@ executable         yesodweb
                  , attoparsec-conduit            >= 0.0        && < 0.1
                  , attoparsec                    >= 0.10       && < 0.11
                  , data-default                  >= 0.3        && < 0.4
+                 , time