Yablog 0.0.1.3 → 0.1.1
raw patch · 18 files changed
+229/−34 lines, 18 filesdep +containersdep +directorydep +filepath
Dependencies added: containers, directory, filepath, mtl, network, wai
Files
- Forms.hs +31/−7
- Foundation.hs +35/−1
- Handler/Blog.hs +30/−6
- Handler/User.hs +29/−0
- Import.hs +24/−0
- Yablog.cabal +10/−2
- config/models +6/−0
- config/routes +1/−0
- config/settings.yml +2/−1
- messages/en.msg +8/−0
- messages/ja.msg +7/−0
- templates/default-layout-wrapper.hamlet +1/−0
- templates/default-layout.hamlet +11/−11
- templates/default-layout.lucius +0/−1
- templates/edit-article.julius +6/−0
- templates/homepage.hamlet +4/−1
- templates/post-article.julius +6/−0
- templates/user-settings.hamlet +18/−4
Forms.hs view
@@ -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|+ <input type=file #file0 name=file0>+ <a .btn #append-file>Append+ <br>+ |]+ 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
Foundation.hs view
@@ -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
Handler/Blog.hs view
@@ -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)
Handler/User.hs view
@@ -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")
Import.hs view
@@ -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
Yablog.cabal view
@@ -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
config/models view
@@ -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)
config/routes view
@@ -18,3 +18,4 @@ /article/#YablogDay/#T.Text/trackback/delete DeleteTrackbackR POST /user/settings UserSettingsR GET PUT POST+/settings/ban BanSettingsR POST
config/settings.yml view
@@ -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
messages/en.msg view
@@ -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+
messages/ja.msg view
@@ -32,3 +32,10 @@ NewComment: 新規コメントのお知らせ YouHaveNewCommentFor url@T.Text: あなたの記事にコメントが付きました: #{url} Search: 検索+ReadMore: 続きを読む+IsSpam: スパムとして報告+UserSettings: ユーザ設定+BanSettings: BAN 設定+Settings: 設定+Bans: BANs+Image: 画像
templates/default-layout-wrapper.hamlet view
@@ -7,6 +7,7 @@ <head> <meta charset="UTF-8"> + <meta name="viewport" content="width=device-width"> <title>#{pageTitle pc} <meta name="description" content=""> <meta name="author" content="">
templates/default-layout.hamlet view
@@ -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
templates/default-layout.lucius view
@@ -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; }-
templates/edit-article.julius view
@@ -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(); }); });
templates/homepage.hamlet view
@@ -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 \ | #
templates/post-article.julius view
@@ -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(); }); });
templates/user-settings.hamlet view
@@ -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>