Yablog-0.0.1.1: Handler/Blog.hs
module Handler.Blog where
import Data.Time
import Import
import Control.Monad
import Yesod.Auth
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.List (sortBy)
import Data.Function
import Text.Hamlet.XML
import Text.XML
import Text.XML.Cursor
import Blaze.ByteString.Builder
import Data.Maybe
import Network.HTTP.Conduit
import Network.HTTP.Types
postCreateR :: Handler RepHtml
postCreateR = do
((result, widget), enctype) <- runFormPost articleForm
case result of
FormSuccess (article, tags, tbs) -> do
usr <- requireAuthId
when (articleAuthor article /= usr) $ redirect RootR
success <- runDB $ do
ans <- insertBy article
case ans of
Right key -> do
mapM_ (insertBy . Tag key) tags
return True
Left _ -> return False
if success
then do
errs <- catMaybes <$> mapM (pingTrackback article) tbs
unless (null errs) $ setMessageI $ T.unlines errs
redirect $ ArticleR (toEnum $ articleCreatedDate article) (articleIdent article)
else do
setMessageI $ MsgAlreadyExists $ articleTitle article
defaultLayout $(widgetFile "post-article")
_ -> do
setMessageI MsgInvalidInput
defaultLayout $(widgetFile "post-article")
getCreateR :: Handler RepHtml
getCreateR = do
(widget, enctype) <- generateFormPost articleForm
defaultLayout $ do
$(widgetFile "post-article")
getArticleR :: YablogDay -> Text -> Handler RepHtml
getArticleR (YablogDay date) ident = do
musr <- maybeAuthId
(article, comments, trackbacks, mprev, mnext) <- runDB $ do
Entity key article <- getBy404 (UniqueArticle (fromEnum date) ident)
cs <- map entityVal <$> selectList [CommentArticle ==. key] []
ts <- map entityVal <$> selectList [TrackbackArticle ==. key] []
mnext <- selectFirst [ ArticleCreatedDate >=. articleCreatedDate article
, FilterOr [ ArticleCreatedDate >. articleCreatedDate article
, ArticleCreatedTime >. articleCreatedTime article
]
]
[ Asc ArticleCreatedDate, Asc ArticleCreatedTime]
mprev <- selectFirst [ ArticleCreatedDate <=. articleCreatedDate article
, FilterOr [ ArticleCreatedDate <. articleCreatedDate article
, ArticleCreatedTime <. articleCreatedTime article
]
]
[ Desc ArticleCreatedDate, Desc ArticleCreatedTime ]
return (article, cs, ts, entityVal <$> mprev, entityVal <$> mnext)
(cWidget, cEnctype) <- generateFormPost $ commentForm Nothing article
let mCommentForm = Just (cWidget, cEnctype)
blogTitle <- getBlogTitle
render <- getUrlRender
defaultLayout $ do
when (isJust mprev) $ do
let prev = fromJust mprev
toWidgetHead
[hamlet|
<link rel="prev previous" href=@{articleLink prev} title=#{articleTitle prev}>
|]
when (isJust mnext) $ do
let next = fromJust mnext
toWidgetHead
[hamlet|
<link rel="next" href=@{articleLink next} title=#{articleTitle next}>
|]
setTitle $ toHtml $ T.concat [articleTitle article, " - ", blogTitle]
$(widgetFile "article")
pingTrackback :: Article -> String -> Handler (Maybe T.Text)
pingTrackback article tb = do
renderUrl <- getUrlRender
master <- getYesod
blogName <- getBlogTitle
let meta = [("title", T.encodeUtf8 $ articleTitle article)
,("excerpt", T.encodeUtf8 $ T.take 255 $ T.pack $ articleBody article)
,("url", T.encodeUtf8 $ renderUrl $ articleLink article)
,("blog_name", T.encodeUtf8 blogName)
]
man = httpManager master
rsp <- lift $ flip httpLbs man . urlEncodedBody meta =<< parseUrl tb
if responseStatus rsp /= status200
then return $ Just $ T.concat [ T.pack tb
, ": HTTP Error: "
, T.concat (LT.toChunks $ LT.decodeUtf8 $ responseBody rsp)
]
else do
case fromDocument <$> parseLBS def (responseBody rsp) of
Right root -> do
let code = T.concat $ root $// checkName (== "error") >=> descendant >=> content
msgs = T.concat $ root $// checkName (== "message") >=> descendant >=> content
if code == "0"
then return Nothing
else return $ Just $ T.concat [T.pack tb, ": ", msgs]
Left _ -> return $ Just $ T.concat [T.pack tb, ": malformed response"]
putArticleR :: YablogDay -> Text -> Handler RepHtml
putArticleR (YablogDay day) ident = do
((result, widget), enctype) <- runFormPost articleForm
usrId <- requireAuthId
time <- liftIO getCurrentTime
case result of
FormSuccess (article, tags, tbs) -> do
suc <- runDB $ do
Entity key old <- getBy404 $ UniqueArticle (fromEnum day) ident
if articleAuthor old == usrId
then do
replace key article { articleModifiedAt = Just time }
mapM_ (delete . entityKey) =<< selectList [TagArticle ==. key] []
mapM_ (insert . Tag key) tags
return True
else return False
if suc
then do
errs <- catMaybes <$> mapM (pingTrackback article) tbs
unless (null errs) $ setMessageI $ T.unlines errs
redirect $ ArticleR (YablogDay day) $ articleIdent article
else permissionDenied "You are not allowed to edit this article."
_ -> do
setMessageI MsgInvalidInput
let mCommentTrackbackForm = Nothing :: Maybe (Widget, Text, Widget, Text)
defaultLayout $(widgetFile "edit-article")
getDeleteR :: YablogDay -> Text -> Handler RepHtml
getDeleteR = deleteArticleR
getModifyR :: YablogDay -> Text -> Handler RepHtml
getModifyR (YablogDay day) ident = do
(artId, art, tags) <- runDB $ do
Entity key art <- getBy404 $ UniqueArticle (fromEnum day) ident
tags <- map (tagName . entityVal) <$> selectList [TagArticle ==. key] []
return (key, art, tags)
(widget, enctype) <- generateFormPost $ articleForm' (Just art) (Just tags)
(cWidget, cEnctype) <- generateFormPost $ commentDeleteForm artId
(tWidget, tEnctype) <- generateFormPost $ trackbackDeleteForm artId
let mCommentTrackbackForm = Just (cWidget, cEnctype, tWidget, tEnctype)
defaultLayout $ do
setTitleI $ MsgEdit $ articleTitle art
$(widgetFile "edit-article")
postDeleteCommentR :: YablogDay -> Text -> Handler ()
postDeleteCommentR = deleteCommentR
postModifyR :: YablogDay -> Text -> Handler RepHtml
postModifyR = putArticleR
deleteArticleR :: YablogDay -> Text -> Handler RepHtml
deleteArticleR (YablogDay day) ident = do
usrId <- requireAuthId
Entity key art <- runDB $ getBy404 $ UniqueArticle (fromEnum day) ident
if articleAuthor art == usrId
then do
runDB $ do
mapM_ (delete . entityKey) =<< selectList [TagArticle ==. key] []
delete key
redirect RootR
else do
permissionDenied "You are not allowed to delete that article."
postCommentR :: YablogDay -> Text -> Handler RepHtml
postCommentR (YablogDay date) ident = do
Entity key article <- runDB $ getBy404 $ UniqueArticle (fromEnum date) ident
((result, _), _) <- runFormPost $ commentForm' Nothing key
case result of
FormSuccess comment -> do
ans <- runDB $ insertBy comment
case ans of
Right _ -> do
render <- getUrlRender
let anchor = commentAnchor comment
let url = T.concat [render $ ArticleR (toEnum $ articleCreatedDate article) (articleIdent article)
, "#", anchor
]
msgRender <- getMessageRender
notice (articleAuthor article) (msgRender MsgNewComment) $
T.unlines [ msgRender (MsgYouHaveNewCommentFor url)
, ""
, "\"" `T.append` commentBody comment `T.append` "\""
, "\nby " `T.append` commentAuthor comment
]
redirect url
Left _ -> do
setMessageI $ MsgAlreadyExists $ articleTitle article
redirect $ ArticleR (toEnum $ articleCreatedDate article) (articleIdent article)
_ -> do
setMessageI MsgInvalidInput
redirect $ ArticleR (toEnum $ articleCreatedDate article) (articleIdent article)
putCommentR :: YablogDay -> Text -> Handler ()
putCommentR = undefined
deleteTrackbackR :: YablogDay -> Text -> Handler ()
deleteTrackbackR (YablogDay day) ident = do
Entity uid _ <- requireAuth
Entity aid art <- runDB $ getBy404 $ UniqueArticle (fromEnum day) ident
((result, _), _) <- runFormPost $ trackbackDeleteForm aid
when (uid /= articleAuthor art) $ do
permissionDenied "You are not allowed to delete those comment(s)."
case result of
FormSuccess cs -> do
when (any ((/= aid) . trackbackArticle) cs) $ permissionDenied "You can't delete that comment."
runDB $ mapM_ (\c -> deleteBy $ UniqueTrackback aid (trackbackUrl c)) cs
redirect $ ArticleR (YablogDay day) (articleIdent art)
_ -> do
setMessageI MsgInvalidInput
redirect $ ModifyR (YablogDay day) (articleIdent art)
postDeleteTrackbackR :: YablogDay -> Text -> Handler ()
postDeleteTrackbackR = deleteTrackbackR
deleteCommentR :: YablogDay -> Text -> Handler ()
deleteCommentR (YablogDay day) ident = do
Entity uid _ <- requireAuth
Entity aid art <- runDB $ getBy404 $ UniqueArticle (fromEnum day) ident
((result, _), _) <- runFormPost $ commentDeleteForm aid
when (uid /= articleAuthor art) $ do
permissionDenied "You are not allowed to delete those comment(s)."
case result of
FormSuccess cs -> do
when (any ((/= aid) . commentArticle) cs) $ permissionDenied "You can't delete that comment."
runDB $ mapM_ (\c -> deleteBy $ UniqueComment aid (commentAuthor c) (commentCreatedAt c)) cs
redirect $ ArticleR (YablogDay day) (articleIdent art)
_ -> do
setMessageI MsgInvalidInput
redirect $ ModifyR (YablogDay day) (articleIdent art)
postPreviewR :: Handler RepHtml
postPreviewR = do
author <- userScreenName . entityVal <$> requireAuth
((result, _), _) <- runFormPost articleForm
case result of
FormSuccess (article, tags, tbs) -> do
let editable = False
comments = []
mCommentTrackbackForm = Nothing :: Maybe (Widget, Text, Widget, Text)
title = articleTitle article
posted = show $ UTCTime (toEnum $ articleCreatedDate article) (toEnum $ articleCreatedTime article)
date = toEnum $ articleCreatedDate article :: Day
route = Nothing :: Maybe Text
ident = articleIdent article
mnext = Nothing
mprev = Nothing
blogTitle <- getBlogTitle
body <- markupRender Nothing article
defaultLayout $ do
$(widgetFile "article-view")
_ -> notFound
getTagR :: Text -> Handler RepHtml
getTagR tag = do
articles <- runDB $ do
mapM (get404 . tagArticle . entityVal) =<< selectList [TagName ==. tag] []
when (null articles) notFound
defaultLayout $ do
setTitleI $ MsgArticlesForTag tag
$(widgetFile "tag")
postTrackbackR :: YablogDay -> Text -> Handler RepXml
postTrackbackR (YablogDay date) ident = do
Entity aid _ <- runDB $ getBy404 $ UniqueArticle (fromEnum date) ident
trackback <- runInputPost $
Trackback aid <$> iopt textField "title"
<*> (liftM unTextarea <$> iopt textareaField "excerpt")
<*> ireq textField "url"
<*> iopt textField "blog_name"
man <- httpManager <$> getYesod
curUrl <- getUrlRender <*> pure (ArticleR (YablogDay date) ident)
alert <- lift $ do
rsp <- flip httpLbs man =<< parseUrl (T.unpack $ trackbackUrl trackback)
if responseStatus rsp == status200
then
if T.encodeUtf8 curUrl `BS.isInfixOf` BS.concat (LBS.toChunks (responseBody rsp))
then return Nothing
else return $ Just "Your page does not include link to my page."
else return $ Just "HTTP Error"
case alert of
Nothing -> do
runDB $ do
ans <- insertBy trackback
case ans of
Right _ -> return ()
Left (Entity k _) -> replace k trackback
return $ mkXmlResponse [xml|<error>0|]
Just err ->
return $ mkXmlResponse [xml|<error>1
<message>#{err}
|]
getTrackbackR :: YablogDay -> Text -> Handler RepXml
getTrackbackR (YablogDay date) ident = do
(art, ts) <- runDB $ do
Entity aid art <- getBy404 $ UniqueArticle (fromEnum date) ident
ts <- map entityVal <$> selectList [TrackbackArticle ==. aid] []
return (art, ts)
render <- getUrlRender
desc <- getBlogDescription
bTitle <- getBlogTitle
return $ mkXmlResponse [xml|
<error>
0
<rss version="0.91">
<channel>
<title>
#{articleTitle art} - #{bTitle}
<link>
#{render $ ArticleR (YablogDay date) ident}
<description>
#{articleTitle art} - #{bTitle}
<language>
ja
$forall t <- ts
<item>
<title>
#{fromMaybe (trackbackUrl t) $ trackbackTitle t}
<link>
#{trackbackUrl t}
$maybe e <- trackbackExcerpt t
<description>
#{e}
|]
mkXmlResponse :: [Node] -> RepXml
mkXmlResponse nodes = RepXml $
ContentBuilder (fromLazyByteString $ renderLBS def $
Document (Prologue [] Nothing []) body [])
Nothing
where
body = Element "response" [] nodes