diff --git a/Forms.hs b/Forms.hs --- a/Forms.hs +++ b/Forms.hs @@ -15,13 +15,18 @@ import Control.Arrow import Markups import Yesod.Default.Config +import qualified Network.Wai as W import qualified Data.Text as T +import Data.Monoid +import qualified Data.Map as M +import Control.Monad.Writer.Class +import Control.Monad.RWS () type URL = String -articleForm :: Form (Article, [Text], [URL]) +articleForm :: Form (Article, [Text], [URL], [FileInfo]) articleForm = articleForm' Nothing Nothing -articleForm' :: Maybe Article -> Maybe [Text] -> Form (Article, [Text], [URL]) +articleForm' :: Maybe Article -> Maybe [Text] -> Form (Article, [Text], [URL], [FileInfo]) articleForm' mart mtags htm = do Entity usrId usr <- lift requireAuth lift $ do @@ -29,13 +34,17 @@ unless accessible $ do permissionDenied "You are not in admins" now <- liftIO getCurrentTime + fs <- askFiles + let files = concat $ maybeToList (M.elems . M.filterWithKey (const . T.isPrefixOf "file") <$> fs) + tell Multipart markup <- extraMarkup . appExtra . settings <$> lift getYesod ident <- maybe (lift newIdent) return $ articleIdent <$> mart let day = utctDay now time = timeToTimeOfDay $ utctDayTime now if maybe False ((/= usrId) . articleAuthor) mart then lift $ permissionDenied "You cannot edit that article." - else flip renderBootstrap htm $ + else do + (r, widget) <- flip renderBootstrap htm $ let titleSettings = FieldSettings { fsLabel = SomeMessage MsgTitle , fsName = Just "title" , fsId = Just "title" @@ -99,9 +108,16 @@ <*> pure (articleModifiedAt =<< mart) tags = T.words . fromMaybe "" <$> aopt textField tagsSettings (Just . T.unwords <$> mtags) tbs = maybe [] (lines . T.unpack . unTextarea) <$> aopt textareaField trackbackUrls Nothing - in (,,) <$> art <*> tags <*> tbs + in (,,,) <$> art <*> tags <*> tbs <*> pure files + let appendFileWidget = + [whamlet| + + Append +
+ |] + return (r, widget `mappend` appendFileWidget) -commentDeleteForm :: ArticleId -> Form [Comment] +commentDeleteForm :: ArticleId -> Form ([Comment], Bool) commentDeleteForm art html = do let commentSettings = FieldSettings { fsLabel = SomeMessage MsgComments , fsAttrs = [("class", "span8")] @@ -109,9 +125,16 @@ , fsId = Just "delete-contents" , fsTooltip = Nothing } + isSpamSettings = FieldSettings { fsLabel = SomeMessage MsgIsSpam + , fsAttrs = [] + , fsName = Just "report-as-spam" + , fsId = Just "report-as-spam" + , fsTooltip = Nothing + } cs <- lift $ runDB $ selectList [CommentArticle ==. art] [] flip renderBootstrap html $ - areq (multiSelectFieldList [(mkOptName c, c) | Entity _ c <- cs]) commentSettings Nothing + (,) <$> areq (multiSelectFieldList [(mkOptName c, c) | Entity _ c <- cs]) commentSettings Nothing + <*> areq checkBoxField isSpamSettings (Just False) where mkOptName c = T.concat [ commentBody c, " - ", commentAuthor c, " / " , T.pack$ show $ commentCreatedAt c @@ -132,9 +155,9 @@ mkOptName t = fromMaybe (fromMaybe (trackbackUrl t) $ trackbackBlogName t) $ trackbackTitle t - commentForm' :: Maybe Comment -> ArticleId -> Form Comment commentForm' mcom art html = do + ipaddr <- hostToString . W.remoteHost <$> lift waiRequest musr <- lift maybeAuth time <- liftIO getCurrentTime let commentField = FieldSettings { fsLabel = SomeMessage MsgComment @@ -155,6 +178,7 @@ <*> pure (commentPassword =<< mcom) <*> pure time <*> pure art + <*> pure ipaddr commentForm :: Maybe Comment -> Article -> Form Comment commentForm mcom art html = do diff --git a/Foundation.hs b/Foundation.hs --- a/Foundation.hs +++ b/Foundation.hs @@ -18,6 +18,8 @@ , isAdmin , notice , commentAnchor + , dayToString + , hostToString ) where import Prelude @@ -53,6 +55,12 @@ import Markups import Network.HTTP.Types import qualified Data.ByteString.Lazy.Char8 as LBS +import Network.Socket +import Control.Monad +import Network.URI +import System.IO.Unsafe +import Text.Pandoc +import Data.List (isPrefixOf) -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -109,9 +117,29 @@ extra <- appExtra . settings <$> getYesod usr <- runDB $ get404 $ articleAuthor article let markup = fromMaybe "markdown" $ articleMarkup article <|> extraMarkup extra - trans = maybe id (addAmazonAssociateLink . T.unpack) $ userAmazon usr + trans = bottomUp (procAttach article) . (maybe id (addAmazonAssociateLink . T.unpack) $ userAmazon usr) return $ renderMarkup mid markup trans $ articleBody article +dayToString :: Day -> String +dayToString = formatTime defaultTimeLocale "%Y%m%d" + +procAttach :: Article -> Inline -> Inline +procAttach article inl = + case inl of + Link is targ -> Link is $ rewriteUrl targ + Image is targ -> Image is $ rewriteUrl targ + _ -> inl + where + rewriteUrl t@(url, title) + | isRelativeReference url && not ("/" `isPrefixOf` url) + = (concat [ "/static/files/" + , dayToString (toEnum $ articleCreatedDate article) + , "/" + , T.unpack $ articleIdent article + , "/" + , url], title) + | otherwise = t + -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod Yablog where @@ -257,3 +285,9 @@ , "-" , T.pack $ formatTime defaultTimeLocale "%Y-%m-%d-%H-%M-%S" $ commentCreatedAt c ] +hostToString :: SockAddr -> String +hostToString (SockAddrUnix str) = str +hostToString (SockAddrInet _ host) = unsafePerformIO $ inet_ntoa host +hostToString addr@(SockAddrInet6 _ _ _ _) = unsafePerformIO $ + fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>= + maybe (fail "showsPrec: impossible internal error") return diff --git a/Handler/Blog.hs b/Handler/Blog.hs --- a/Handler/Blog.hs +++ b/Handler/Blog.hs @@ -3,6 +3,7 @@ import Import import Control.Monad import Yesod.Auth +import Yesod.Static import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as LT @@ -16,14 +17,19 @@ import Text.XML.Cursor import Blaze.ByteString.Builder import Data.Maybe -import Network.HTTP.Conduit +import Network.HTTP.Conduit hiding (def) import Network.HTTP.Types +import qualified Network.Wai as W +import Settings +import System.FilePath +import System.Directory +import System.Locale postCreateR :: Handler RepHtml postCreateR = do ((result, widget), enctype) <- runFormPost articleForm case result of - FormSuccess (article, tags, tbs) -> do + FormSuccess (article, tags, tbs, mfinfo) -> do usr <- requireAuthId when (articleAuthor article /= usr) $ redirect RootR success <- runDB $ do @@ -35,6 +41,7 @@ Left _ -> return False if success then do + procAttachment article mfinfo errs <- catMaybes <$> mapM (pingTrackback article) tbs unless (null errs) $ setMessageI $ T.unlines errs redirect $ ArticleR (toEnum $ articleCreatedDate article) (articleIdent article) @@ -45,6 +52,17 @@ setMessageI MsgInvalidInput defaultLayout $(widgetFile "post-article") +procAttachment :: Article -> [FileInfo] -> Handler () +procAttachment article fs = forM_ fs $ \finfo -> do + renderUrl <- getUrlRender + let dir = staticDir "files" + dayToString (toEnum $ articleCreatedDate article :: Day) + T.unpack (articleIdent article) + liftIO $ do + createDirectoryIfMissing True dir + LBS.writeFile (dir T.unpack (fileName finfo)) (fileContent finfo) +procAttachment _ _ = return () + getCreateR :: Handler RepHtml getCreateR = do (widget, enctype) <- generateFormPost articleForm @@ -124,7 +142,7 @@ usrId <- requireAuthId time <- liftIO getCurrentTime case result of - FormSuccess (article, tags, tbs) -> do + FormSuccess (article, tags, tbs, mfinfo) -> do suc <- runDB $ do Entity key old <- getBy404 $ UniqueArticle (fromEnum day) ident if articleAuthor old == usrId @@ -136,6 +154,7 @@ else return False if suc then do + procAttachment article mfinfo errs <- catMaybes <$> mapM (pingTrackback article) tbs unless (null errs) $ setMessageI $ T.unlines errs redirect $ ArticleR (YablogDay day) $ articleIdent article @@ -183,6 +202,9 @@ postCommentR :: YablogDay -> Text -> Handler RepHtml postCommentR (YablogDay date) ident = do + addr <- hostToString . W.remoteHost <$> waiRequest + ans <- runDB $ selectFirst [BannedIp ==. Just addr] [] + when (isJust ans) $ permissionDenied "YOU ARE BANNED TO COMMENT" Entity key article <- runDB $ getBy404 $ UniqueArticle (fromEnum date) ident ((result, _), _) <- runFormPost $ commentForm' Nothing key case result of @@ -240,9 +262,11 @@ when (uid /= articleAuthor art) $ do permissionDenied "You are not allowed to delete those comment(s)." case result of - FormSuccess cs -> do + FormSuccess (cs, spam) -> do when (any ((/= aid) . commentArticle) cs) $ permissionDenied "You can't delete that comment." - runDB $ mapM_ (\c -> deleteBy $ UniqueComment aid (commentAuthor c) (commentCreatedAt c)) cs + runDB $ forM_ cs $ \c -> do + deleteBy $ UniqueComment aid (commentAuthor c) (commentCreatedAt c) + insert $ Banned (Just $ commentIpAddress c) Nothing redirect $ ArticleR (YablogDay day) (articleIdent art) _ -> do setMessageI MsgInvalidInput @@ -253,7 +277,7 @@ author <- userScreenName . entityVal <$> requireAuth ((result, _), _) <- runFormPost articleForm case result of - FormSuccess (article, tags, tbs) -> do + FormSuccess (article, tags, tbs, mfinfo) -> do let editable = False comments = [] mCommentTrackbackForm = Nothing :: Maybe (Widget, Text, Widget, Text) diff --git a/Handler/User.hs b/Handler/User.hs --- a/Handler/User.hs +++ b/Handler/User.hs @@ -1,6 +1,8 @@ module Handler.User where import Import import qualified Data.Text as T +import Data.Maybe +import Control.Monad userForm :: Form User userForm html = do @@ -21,10 +23,37 @@ <*> (T.filter (/= '\r') . unTextarea <$> areq textareaField "profile" (Just $ Textarea profile)) <*> aopt textField "Amazon Associate" (Just amazon) +banForm :: Form [Entity Banned] +banForm html = do + bans <- lift $ runDB $ filter (isJust . bannedIp . entityVal) <$> selectList [] [] + let bansSettings = FieldSettings { fsLabel = SomeMessage MsgBans + , fsAttrs = [("class", "span8")] + , fsName = Just "delete-bans" + , fsId = Just "delete-bans" + , fsTooltip = Nothing + } + flip renderBootstrap html $ + areq (multiSelectFieldList [(mkOptName b, e) | e@(Entity _ b) <- bans]) bansSettings Nothing + where + mkOptName b = T.pack $ fromJust $ bannedIp b + +postBanSettingsR :: Handler RepHtml +postBanSettingsR = do + isAdm <- isAdmin . entityVal =<< requireAuth + unless isAdm $ permissionDenied "!!! YOU ARE NOT ALLOWED TO CHANGE BAN !!!" + ((result, _), _) <- runFormPost banForm + liftIO $ print result + case result of + FormSuccess bans -> do + runDB $ mapM_ (delete . entityKey) bans + redirect UserSettingsR + _ -> permissionDenied "!!!!YOU ARE NOT ALLOWED TO CHANGE!!!!" + getUserSettingsR :: Handler RepHtml getUserSettingsR = do Entity key usr <- requireAuth (widget, enctype) <- generateFormPost userForm + (banWidget, banEnctype) <- generateFormPost banForm defaultLayout $ do setTitle "Settings" $(widgetFile "user-settings") diff --git a/Import.hs b/Import.hs --- a/Import.hs +++ b/Import.hs @@ -10,6 +10,7 @@ , Text , articleView , articleLink + , makeBrief , makeSnippet #if __GLASGOW_HASKELL__ < 740 , (<>) @@ -28,6 +29,7 @@ import Yesod.Auth import Data.Time import Forms +import Data.Maybe articleView :: Maybe String -> Article -> Widget articleView mid article = do @@ -56,6 +58,28 @@ makeSnippet len t | T.length t <= len = t | otherwise = T.take len t `T.append` "..." +makeBrief :: Article -> Article +makeBrief art@Article{articleBody=body} = art {articleBody = truncated} + where + Just reader = lookup (fromMaybe "markdown" $ articleMarkup art) readers + Just writer = lookup (fromMaybe "markdown" $ articleMarkup art) writers + opts = defaultWriterOptions + { writerHTMLMathMethod = + MathJax "http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" + , writerHighlight = True + , writerHtml5 = True + , writerIdentifierPrefix = "" + } + pandoc@(Pandoc metas bs) = reader defaultParserState body + truncated = + case span (not . isPara) bs of + (src, takeWhile (not . isHead) -> as) -> + writer opts (Pandoc metas $ src ++ take 3 as) + isPara (Para _) = True + isPara _ = False + isHead (Header _ _) = True + isHead _ = False + #if __GLASGOW_HASKELL__ < 740 infixr 5 <> (<>) :: Monoid m => m -> m -> m diff --git a/Yablog.cabal b/Yablog.cabal --- a/Yablog.cabal +++ b/Yablog.cabal @@ -1,5 +1,5 @@ name: Yablog -version: 0.0.1.3 +version: 0.1.1 license: BSD3 license-file: LICENSE author: Hiromi ISHII @@ -58,6 +58,7 @@ GADTs GeneralizedNewtypeDeriving FlexibleContexts + ViewPatterns EmptyDataDecls executable Yablog @@ -82,6 +83,7 @@ TypeFamilies GADTs GeneralizedNewtypeDeriving + ViewPatterns FlexibleContexts EmptyDataDecls @@ -111,6 +113,7 @@ , hjsmin >= 0.1 && < 0.2 , monad-control >= 0.3 && < 0.4 , wai-extra >= 1.2 && < 1.3 + , wai >= 1.2 && < 1.3 , yaml >= 0.7 && < 0.8 , http-conduit >= 1.4 && < 1.5 , time >= 1.2 && < 1.3 @@ -119,10 +122,15 @@ , pandoc-types >= 1.9 && < 2.0 , xml-hamlet >= 0.3 && < 0.4 , xml-conduit >= 0.7 && < 0.8 + , network >= 2.3 && < 2.4 + , filepath >= 1.2 && < 1.3 + , directory >= 1.1 && < 1.2 + , containers >= 0.4 && < 0.5 + , mtl >= 2.0 && < 2.1 source-repository head type: git - location: http://gitweb.konn-san.com/repo/Yablog/tree/master + location: https://github.com/konn/Yablog source-repository this type: git diff --git a/config/models b/config/models --- a/config/models +++ b/config/models @@ -28,6 +28,7 @@ password Text Maybe createdAt UTCTime Asc article ArticleId + ipAddress String UniqueComment article author createdAt deriving Show Eq @@ -43,6 +44,11 @@ url Text Eq blogName Text Maybe UniqueTrackback article url + deriving Show Eq + +Banned + ip String Eq Maybe + author String Eq Maybe deriving Show Eq -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff --git a/config/routes b/config/routes --- a/config/routes +++ b/config/routes @@ -18,3 +18,4 @@ /article/#YablogDay/#T.Text/trackback/delete DeleteTrackbackR POST /user/settings UserSettingsR GET PUT POST +/settings/ban BanSettingsR POST diff --git a/config/settings.yml b/config/settings.yml --- a/config/settings.yml +++ b/config/settings.yml @@ -3,7 +3,8 @@ port: 3000 copyright: Insert copyright here title: "My Great Blog" - admins: [] # specify users' idents who can write articles. + admins: ["konn.jinro@gmail.com"] + # specify users' idents who can write articles. # For example, for Gmail or BrowserId, email-address must be used. description: "This is my tiny little blog." # analytics: PUT-UA-CODEHERE diff --git a/messages/en.msg b/messages/en.msg --- a/messages/en.msg +++ b/messages/en.msg @@ -32,3 +32,11 @@ NewComment: You have new comment YouHaveNewCommentFor url@T.Text: You have new comment for: #{url} Search: Search +ReadMore: Read More +IsSpam: Report as SPAM +UserSettings: User Settings +BanSettings: BAN Settings +Settings: Settings +Bans: BANs +Image: Image + diff --git a/messages/ja.msg b/messages/ja.msg --- a/messages/ja.msg +++ b/messages/ja.msg @@ -32,3 +32,10 @@ NewComment: 新規コメントのお知らせ YouHaveNewCommentFor url@T.Text: あなたの記事にコメントが付きました: #{url} Search: 検索 +ReadMore: 続きを読む +IsSpam: スパムとして報告 +UserSettings: ユーザ設定 +BanSettings: BAN 設定 +Settings: 設定 +Bans: BANs +Image: 画像 diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -7,6 +7,7 @@ + #{pageTitle pc} <meta name="description" content=""> <meta name="author" content=""> diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -16,13 +16,12 @@ <li> <a href=@{ArticleR (toEnum $ articleCreatedDate art) (articleIdent art)}> #{articleTitle art} - <li .nav-header> - <i .icon-tags> # - Tags - $forall tag <- tags + $maybe cse <- mcse + <li .nav-header> + <i .icon-search> # + Search <li> - <a href=@{TagR tag}> - #{tag} + ^{cse} <li .nav-header> <i .icon-comment> # Recent Comments @@ -30,12 +29,13 @@ <li> <a href="@{ArticleR (toEnum $ articleCreatedDate article) (articleIdent article)}##{commentAnchor comment}"> #{show $ utctDay $ commentCreatedAt comment} #{commentAuthor comment} - $maybe cse <- mcse - <li .nav-header> - <i .icon-search> # - Search + <li .nav-header> + <i .icon-tags> # + Tags + $forall tag <- tags <li> - ^{cse} + <a href=@{TagR tag}> + #{tag} <li .nav-header> Control $if accessible diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -19,4 +19,3 @@ code > span.al { color: #ff0000; font-weight: bold; } code > span.fu { color: #06287e; } code > span.er { color: #ff0000; font-weight: bold; } - diff --git a/templates/edit-article.julius b/templates/edit-article.julius --- a/templates/edit-article.julius +++ b/templates/edit-article.julius @@ -1,4 +1,5 @@ $(document).ready(function(){ + var filecount = 0; function updatePreview(data, type) { $("#preview-contents").html(data); } @@ -7,5 +8,10 @@ var title = $('#title').val() $("#preview-contents").contents().find("html").load("/preview", $("#edit-form").serializeArray()); } + function appendFileForm() { + filecount += 1; + $(":file:last").after("<br /><input type=\"file\" name=\"file" + filecount + "\" id=\"file"+filecount+"\">") + } $('#show-preview').click(function(){ reloadPreview(); }); + $('#append-file').click(function() { appendFileForm(); }); }); diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -11,8 +11,11 @@ $forall (no, ents) <- articles $with (art, cs, ts) <- ents <div .well> - ^{articleView (Just $ (++) "art" $ (++) (show no) "-") art} + ^{articleView (Just $ (++) "art" ((++) (show no) "-")) $ makeBrief art} <div .navi-links> + <a href=@{articleLink art} .btn> + _{MsgReadMore} » + <br /> <a href=@{articleLink art}> Permalink \ | # diff --git a/templates/post-article.julius b/templates/post-article.julius --- a/templates/post-article.julius +++ b/templates/post-article.julius @@ -1,4 +1,5 @@ $(document).ready(function(){ + var filecount = 0; function updatePreview(data, type) { $("#preview-contents").html(data); } @@ -7,5 +8,10 @@ var title = $('#title').val() $("#preview-contents").contents().find("html").load("/preview", $("#edit-form").serializeArray()); } + function appendFileForm() { + filecount += 1; + $(":file:last").after("<br /><input type=\"file\" name=\"file" + filecount + "\" id=\"file"+filecount+"\">") + } $('#show-preview').click(function(){ reloadPreview(); }); + $('#append-file').click(function() { appendFileForm(); }); }); diff --git a/templates/user-settings.hamlet b/templates/user-settings.hamlet --- a/templates/user-settings.hamlet +++ b/templates/user-settings.hamlet @@ -1,5 +1,19 @@ <h2> - Settings -<form method=post action=@{UserSettingsR} enctype=#{enctype}> - ^{widget} - <input type=submit> + _{MsgSettings} +<div .tabbalble> + <ul .nav .nav-tabs> + <li .active> + <a href="#settings" data-toggle="tab"> + _{MsgUserSettings} + <li> + <a href="#ban-settings" data-toggle="tab" #show-ban-settings> + _{MsgBanSettings} + <div .tab-content> + <div .active .tab-pane #settings> + <form method=post action=@{UserSettingsR} enctype=#{enctype}> + ^{widget} + <input type=submit> + <div .tab-pane #ban-settings> + <form method=post action=@{BanSettingsR} enctype=#{banEnctype}> + ^{banWidget} + <input type=submit>