Yablog-0.2.0: 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, isPrefixOf)
import Data.Function
import qualified Data.Map as M
import qualified Data.Conduit.Binary as BC
import Data.Conduit
import Text.Hamlet.XML
import Text.XML
import Text.XML.Cursor
import Blaze.ByteString.Builder
import Data.Maybe
import Network.HTTP.Conduit hiding (def)
import Network.HTTP.Types
import qualified Network.Wai as W
import System.Directory
import Control.Monad.Trans.Resource
import System.FilePath
import System.IO.Temp
import Network.URI
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 = withArticle $ \(Entity key article) -> do
let date = toEnum $ articleCreatedDate article
ident = articleIdent article
musr <- maybeAuthId
(comments, trackbacks, mprev, mnext) <- runDB $ do
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 (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, _), _) <- 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
redirect $ ModifyR (YablogDay day) ident
getDeleteR :: YablogDay -> Text -> Handler RepHtml
getDeleteR = deleteArticleR
getModifyR :: YablogDay -> Text -> Handler RepHtml
getModifyR = withArticleAuth $ \(Entity artId art) -> do
tags <- runDB $ map (tagName . entityVal) <$> selectList [TagArticle ==. artId] []
(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)
day = toEnum $ articleCreatedDate art
ident = articleIdent art
mAttachments <- articleAttachments art
defaultLayout $ do
setTitleI $ MsgEdit $ articleTitle art
addScript $ StaticR js_jquery_upload_1_0_2_min_js
$(widgetFile "edit-article")
articleAttachments :: Article -> Handler (Maybe [FilePath])
articleAttachments art = liftIO $ do
let dir = attachmentDir art
exists <- doesDirectoryExist dir
if exists
then do
children <- filter (not . ("." `isPrefixOf`)) <$> getDirectoryContents dir
if null children
then return Nothing
else return $ Just $ map (("/" </> dir) </>) children
else return Nothing
getDeleteAttachmentR :: YablogDay -> Text -> FilePath -> Handler ()
getDeleteAttachmentR d@(YablogDay day) ident fp = withArticleAuth act d ident
where
act (Entity artId art) = do
usr <- requireAuthId
tags <- runDB $ map (tagName . entityVal) <$> selectList [TagArticle ==. artId] []
exc <- liftIO $ doesFileExist $ attachmentDir art </> fp
unless exc $ do
setMessageI $ MsgAttachmentNotFound fp
redirect $ ModifyR (YablogDay day) ident
liftIO $ removeFile $ attachmentDir art </> fp
render <- getUrlRender
redirect $ render (ModifyR (YablogDay day) ident) `T.append` "#attachments"
postDeleteCommentR :: YablogDay -> Text -> Handler ()
postDeleteCommentR = deleteCommentR
postModifyR :: YablogDay -> Text -> Handler RepHtml
postModifyR = putArticleR
deleteArticleR :: YablogDay -> Text -> Handler RepHtml
deleteArticleR = withArticleAuth $ \(Entity key _) -> do
runDB $ do
mapM_ (delete . entityKey) =<< selectList [TagArticle ==. key] []
delete key
redirect RootR
postCommentR :: YablogDay -> Text -> Handler RepHtml
postCommentR = withArticle $ \(Entity key article) -> do
addr <- getIPAddrProxy
isBanned <- isJust <$> runDB (selectFirst [BannedIp ==. Just addr] [])
when isBanned $ permissionDenied "YOU ARE BANNED TO COMMENT"
((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 = withArticleAuth $ \(Entity aid art) -> do
let day = toEnum $ articleCreatedDate art
ident = articleIdent art
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 = withArticleAuth $ \(Entity aid art) -> do
let day = toEnum $ articleCreatedDate art
((result, _), _) <- runFormPost $ commentDeleteForm aid
case result of
FormSuccess (cs, ban) -> do
when (any ((/= aid) . commentArticle) cs) $ permissionDenied "You can't delete that comment."
runDB $ forM_ cs $ \c -> do
deleteBy $ UniqueComment aid (commentAuthor c) (commentCreatedAt c)
when ban $ void $ insert $ Banned (Just $ commentIpAddress c) Nothing
redirect $ ArticleR (YablogDay day) (articleIdent art)
_ -> do
setMessageI MsgInvalidInput
redirect $ ModifyR (YablogDay day) (articleIdent art)
postAttachR :: YablogDay -> Text -> Handler ()
postAttachR = withArticleAuth $ \(Entity _ article) -> do
(_, files) <- runRequestBody
case lookup "file" files of
Just finfo -> do
let dir = attachmentDir article
liftIO $ do
createDirectoryIfMissing True dir
lift $ fileSource finfo $$ BC.sinkFile (dir </> T.unpack (fileName finfo))
Nothing -> notFound
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 = withArticle $ \(Entity aid article) -> do
let date = toEnum $ articleCreatedDate article
ident = articleIdent article
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
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" M.empty nodes