Permalink
Browse files

Basic blog post handling

  • Loading branch information...
1 parent c72fd54 commit 9e521ecc36755c435548d7d9cdd361ab2a3d0439 @snoyberg snoyberg committed Jan 1, 2012
Showing with 68 additions and 15 deletions.
  1. +1 −0 Application.hs
  2. +4 −3 Foundation.hs
  3. +8 −0 Handler/Blog.hs
  4. +1 −1 Handler/Page.hs
  5. +1 −1 Handler/Root.hs
  6. +1 −1 Handler/Wiki.hs
  7. +21 −6 Import/Content.hs
  8. +17 −1 Model.hs
  9. +10 −1 config/models
  10. +1 −0 config/routes
  11. +1 −1 content
  12. +2 −0 yesodweb.cabal
View
@@ -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
View
@@ -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
View
@@ -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
View
@@ -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":)
View
@@ -3,4 +3,4 @@ module Handler.Root where
import Import
getRootR :: Handler RepHtml
-getRootR = returnContent [unsafeHtmlFormat] ["homepage"]
+getRootR = returnContent [unsafeHtmlFormat] $ ContentPath ["homepage"]
View
@@ -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":)
View
@@ -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
View
@@ -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
View
@@ -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)
View
@@ -7,3 +7,4 @@
/ RootR GET
/wiki/*Texts WikiR GET
/page/*Texts PageR GET
+/blog/#Year/#Month/#Slug BlogPostR GET
Submodule content updated 1 files
+8 −0 blog/2012/01/test.md
View
@@ -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

0 comments on commit 9e521ec

Please sign in to comment.