Yablog 0.1.1 → 0.2.0
raw patch · 16 files changed
+373/−234 lines, 16 filesdep +blaze-htmldep +conduitdep +data-defaultdep ~clientsessiondep ~filepathdep ~hamlet
Dependencies added: blaze-html, conduit, data-default, resourcet, temporary, yesod-recaptcha
Dependency ranges changed: clientsession, filepath, hamlet, http-conduit, http-types, mime-mail, mtl, pandoc-types, persistent, persistent-mongoDB, shakespeare-js, time, wai, wai-extra, xml-conduit, xml-hamlet, yaml, yesod, yesod-auth, yesod-core, yesod-default, yesod-form, yesod-newsfeed, yesod-platform, yesod-static
Files
- Application.hs +13/−20
- Forms.hs +28/−31
- Foundation.hs +92/−52
- Handler/Blog.hs +81/−61
- Import.hs +30/−15
- Markups.hs +8/−6
- Settings.hs +19/−6
- Settings/Development.hs +15/−0
- Yablog.cabal +43/−37
- config/mongoDB.yml +1/−1
- config/routes +2/−0
- config/settings.yml +6/−3
- messages/en.msg +3/−1
- messages/ja.msg +3/−0
- templates/edit-article.hamlet +17/−0
- templates/edit-article.julius +12/−1
Application.hs view
@@ -10,13 +10,8 @@ import Yesod.Default.Config import Yesod.Default.Main import Yesod.Default.Handlers-#if DEVELOPMENT-import Yesod.Logger (Logger, logBS)-import Network.Wai.Middleware.RequestLogger (logCallbackDev)-#else-import Yesod.Logger (Logger, logBS, toProduction)-import Network.Wai.Middleware.RequestLogger (logCallback)-#endif+import Settings.Development+import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout) import qualified Database.Persist.Store import Network.HTTP.Conduit (newManager, def) @@ -34,25 +29,23 @@ -- performs initialization and creates a WAI application. This is also the -- place to put your migrate statements to have automatic database -- migrations handled by Yesod.-getApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application-getApplication conf logger = do+getApplication :: AppConfig DefaultEnv Extra -> IO Application+getApplication conf = do+ foundation <- makeFoundation conf+ app <- toWaiAppPlain foundation+ return $ logWare app+ where+ logWare = if development then logStdoutDev+ else logStdout+makeFoundation :: AppConfig DefaultEnv Extra -> IO Yablog+makeFoundation conf = do manager <- newManager def s <- staticSite dbconf <- withYamlEnvironment "config/mongoDB.yml" (appEnv conf) Database.Persist.Store.loadConfig >>= Database.Persist.Store.applyEnv p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)- let foundation = Yablog conf setLogger s p manager dbconf- app <- toWaiAppPlain foundation- return $ logWare app- where-#ifdef DEVELOPMENT- logWare = logCallbackDev (logBS setLogger)- setLogger = logger-#else- setLogger = toProduction logger -- by default the logger is set for development- logWare = logCallback (logBS setLogger)-#endif+ return $ Yablog conf s p manager dbconf -- for yesod devel getApplicationDev :: IO (Int, Application)
Forms.hs view
@@ -2,31 +2,32 @@ , commentForm, commentForm', trackbackForm , trackbackDeleteForm ) where-import Yesod.Form-import Prelude-import Model-import Control.Applicative-import Foundation-import Yesod hiding (Route(..))-import Data.Text (Text)-import Data.Time-import Control.Monad-import Data.Maybe-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 ()+import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.RWS hiding (lift)+import Control.Monad.Writer.Class+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Foundation+import Markups+import Model+import qualified Network.Wai as W+import Prelude+import Yesod hiding (Route (..))+import Yesod.Default.Config+import Yesod.Form+import Yesod.ReCAPTCHA type URL = String-articleForm :: Form (Article, [Text], [URL], [FileInfo])+articleForm :: Form (Article, [Text], [URL]) articleForm = articleForm' Nothing Nothing -articleForm' :: Maybe Article -> Maybe [Text] -> Form (Article, [Text], [URL], [FileInfo])+articleForm' :: Maybe Article -> Maybe [Text] -> Form (Article, [Text], [URL]) articleForm' mart mtags htm = do Entity usrId usr <- lift requireAuth lift $ do@@ -36,7 +37,6 @@ 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@@ -108,14 +108,8 @@ <*> 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 <*> pure files- let appendFileWidget =- [whamlet|- <input type=file #file0 name=file0>- <a .btn #append-file>Append- <br>- |]- return (r, widget `mappend` appendFileWidget)+ in (,,) <$> art <*> tags <*> tbs+ return (r, widget) commentDeleteForm :: ArticleId -> Form ([Comment], Bool) commentDeleteForm art html = do@@ -157,7 +151,8 @@ commentForm' :: Maybe Comment -> ArticleId -> Form Comment commentForm' mcom art html = do- ipaddr <- hostToString . W.remoteHost <$> lift waiRequest+ mRecap <- lift $ extraReCAPTCHA . appExtra . settings <$> getYesod+ ipaddr <- lift getIPAddrProxy musr <- lift maybeAuth time <- liftIO getCurrentTime let commentField = FieldSettings { fsLabel = SomeMessage MsgComment@@ -172,6 +167,7 @@ , fsName = Just "comment-author" , fsTooltip = Nothing }+ recap = if isJust mRecap then recaptchaAForm else pure () flip renderBootstrap html $ Comment <$> areq textField nameField (userScreenName . entityVal <$> musr) <*> (unTextarea <$> areq textareaField commentField (Textarea . commentBody <$> mcom))@@ -179,6 +175,7 @@ <*> pure time <*> pure art <*> pure ipaddr+ <* recap commentForm :: Maybe Comment -> Article -> Form Comment commentForm mcom art html = do
Foundation.hs view
@@ -15,63 +15,71 @@ , getBlogTitle , getBlogDescription , markupRender+ , markupRender' , isAdmin , notice , commentAnchor , dayToString , hostToString+ , attachmentDir+ , getIPAddrProxy ) where -import Prelude-import Yesod-import Yesod.Static-import Settings.StaticFiles-import Yesod.RssFeed-import Yesod.AtomFeed-import Yesod.Auth-import Yesod.Auth.BrowserId-import Yesod.Auth.GoogleEmail-import Yesod.Default.Config-import Yesod.Default.Util (addStaticContentExternal)-import Yesod.Logger (Logger, logMsg, formatLogText)-import Network.HTTP.Conduit (Manager)-import qualified Settings-import qualified Data.ByteString.Lazy as L+import Control.Applicative+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Data+import Data.Default (def)+import Data.List (isPrefixOf, nub, sort)+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time+import Database.Persist.MongoDB hiding (master) import qualified Database.Persist.Store-import Database.Persist.MongoDB hiding (master)-import Settings (widgetFile, Extra (..))-import Model-import Text.Jasmine (minifym)-import Web.ClientSession (getKey)-import Text.Hamlet (hamletFile)-import Data.List (nub, sort)-import Data.Maybe-import Network.Mail.Mime-import Data.Time-import System.Locale-import Control.Applicative-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-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)+import Markups+import Model+import Network.HTTP.Conduit (Manager)+import Network.HTTP.Types+import Network.Mail.Mime+import Network.Socket+import Network.URI+import qualified Network.Wai as W+import Prelude+import Settings+import qualified Settings+import Settings.Development+import Settings.StaticFiles+import System.FilePath hiding (joinPath)+import System.IO.Unsafe+import System.Locale+import Text.Blaze.Html.Renderer.String+import Text.Hamlet (hamletFile)+import Text.Jasmine (minifym)+import Text.Pandoc+import Web.ClientSession (getKey)+import Yesod+import Yesod.AtomFeed+import Yesod.Auth+import Yesod.Auth.BrowserId+import Yesod.Auth.GoogleEmail+import Yesod.Default.Config+import Yesod.Default.Util (addStaticContentExternal)+import Yesod.ReCAPTCHA+import Yesod.RssFeed+import Yesod.Static -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have -- access to the data present here. data Yablog = Yablog- { settings :: AppConfig DefaultEnv Extra- , getLogger :: Logger- , getStatic :: Static -- ^ Settings for static file serving.- , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.- , httpManager :: Manager+ { settings :: AppConfig DefaultEnv Extra+ , getStatic :: Static -- ^ Settings for static file serving.+ , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.+ , httpManager :: Manager , persistConfig :: Settings.PersistConfig } @@ -112,17 +120,30 @@ as <- extraAdmins . appExtra . settings <$> getYesod return $ userIdent usr `elem` as -markupRender :: Maybe String -> Article -> GHandler sub Yablog Html-markupRender mid article = do+markupRender' :: Data a => Maybe String+ -> (a -> GHandler sub Yablog a)+ -> Article+ -> GHandler sub Yablog Html+markupRender' mid tran article = do extra <- appExtra . settings <$> getYesod usr <- runDB $ get404 $ articleAuthor article let markup = fromMaybe "markdown" $ articleMarkup article <|> extraMarkup extra- trans = bottomUp (procAttach article) . (maybe id (addAmazonAssociateLink . T.unpack) $ userAmazon usr)- return $ renderMarkup mid markup trans $ articleBody article+ let trans = bottomUpM tran . bottomUp (procAttach article)+ . maybe id (addAmazonAssociateLink . T.unpack) (userAmazon usr)+ renderMarkup mid markup trans $ articleBody article +markupRender :: Maybe String -> Article -> GHandler sub Yablog Html+markupRender mid = markupRender' mid (return :: Pandoc -> GHandler sub Yablog Pandoc)+ dayToString :: Day -> String dayToString = formatTime defaultTimeLocale "%Y%m%d" +attachmentDir :: Article -> FilePath+attachmentDir article =+ staticDir </> "files"+ </> dayToString (toEnum $ articleCreatedDate article :: Day)+ </> T.unpack (articleIdent article)+ procAttach :: Article -> Inline -> Inline procAttach article inl = case inl of@@ -180,6 +201,7 @@ addStylesheet $ StaticR css_bootstrap_responsive_css addStylesheet $ StaticR css_bootstrap_css setTitle $ toHtml blogTitle+ recaptchaOptions def { theme = Just "clean" } $(widgetFile "normalize") $(widgetFile "default-layout") hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")@@ -193,9 +215,6 @@ -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - messageLogger y loc level msg =- formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)- -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of@@ -204,6 +223,8 @@ -- Place Javascript at bottom of the body tag so the rest of the page loads first jsLoader _ = BottomOfBody+ shouldLog _ _source level =+ development || level == LevelWarn || level == LevelError -- How to run database actions. instance YesodPersist Yablog where@@ -227,7 +248,7 @@ x <- getBy $ UniqueUser $ credsIdent creds case x of Just (Entity uid _) -> return $ Just uid- Nothing -> do+ Nothing -> fmap Just $ insert $ User (credsIdent creds) (credsIdent creds) Nothing Nothing "ja" "" Nothing @@ -240,6 +261,17 @@ deliver :: Yablog -> L.ByteString -> IO () deliver _ = sendmail +instance YesodReCAPTCHA Yablog where+ recaptchaPublicKey = getReCAPTCHA fst+ recaptchaPrivateKey = getReCAPTCHA snd++getReCAPTCHA :: ((T.Text, T.Text) -> b) -> GHandler sub Yablog b+getReCAPTCHA f = do+ mRe <- extraReCAPTCHA . appExtra . settings <$> getYesod+ case mRe of+ Nothing -> fail "ReCAPTCHA is not enabled."+ Just re -> return $ f re+ -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage Yablog FormMessage where@@ -288,6 +320,14 @@ hostToString :: SockAddr -> String hostToString (SockAddrUnix str) = str hostToString (SockAddrInet _ host) = unsafePerformIO $ inet_ntoa host-hostToString addr@(SockAddrInet6 _ _ _ _) = unsafePerformIO $+hostToString addr@SockAddrInet6{} = unsafePerformIO $ fst `liftM` getNameInfo [NI_NUMERICHOST] True False addr >>= maybe (fail "showsPrec: impossible internal error") return++getIPAddrProxy :: GHandler sub Yablog String+getIPAddrProxy = do+ waiReq <- waiRequest+ let addr = maybe (hostToString $ W.remoteHost waiReq) (T.unpack . T.decodeUtf8) $+ lookup "X-Forwarded-For" (W.requestHeaders waiReq)++ return addr
Handler/Blog.hs view
@@ -3,15 +3,17 @@ 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 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.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@@ -20,16 +22,17 @@ 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+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, mfinfo) -> do+ FormSuccess (article, tags, tbs) -> do usr <- requireAuthId when (articleAuthor article /= usr) $ redirect RootR success <- runDB $ do@@ -41,7 +44,6 @@ 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)@@ -52,17 +54,6 @@ 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@@ -70,10 +61,11 @@ $(widgetFile "post-article") getArticleR :: YablogDay -> Text -> Handler RepHtml-getArticleR (YablogDay date) ident = do+getArticleR = withArticle $ \(Entity key article) -> do+ let date = toEnum $ articleCreatedDate article+ ident = articleIdent article musr <- maybeAuthId- (article, comments, trackbacks, mprev, mnext) <- runDB $ do- Entity key article <- getBy404 (UniqueArticle (fromEnum date) ident)+ (comments, trackbacks, mprev, mnext) <- runDB $ do cs <- map entityVal <$> selectList [CommentArticle ==. key] [] ts <- map entityVal <$> selectList [TrackbackArticle ==. key] [] mnext <- selectFirst [ ArticleCreatedDate >=. articleCreatedDate article@@ -88,7 +80,7 @@ ] ] [ Desc ArticleCreatedDate, Desc ArticleCreatedTime ]- return (article, cs, ts, entityVal <$> mprev, entityVal <$> mnext)+ return (cs, ts, entityVal <$> mprev, entityVal <$> mnext) (cWidget, cEnctype) <- generateFormPost $ commentForm Nothing article let mCommentForm = Just (cWidget, cEnctype) blogTitle <- getBlogTitle@@ -138,11 +130,11 @@ putArticleR :: YablogDay -> Text -> Handler RepHtml putArticleR (YablogDay day) ident = do- ((result, widget), enctype) <- runFormPost articleForm+ ((result, _), _) <- runFormPost articleForm usrId <- requireAuthId time <- liftIO getCurrentTime case result of- FormSuccess (article, tags, tbs, mfinfo) -> do+ FormSuccess (article, tags, tbs) -> do suc <- runDB $ do Entity key old <- getBy404 $ UniqueArticle (fromEnum day) ident if articleAuthor old == usrId@@ -154,33 +146,58 @@ 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 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")+ redirect $ ModifyR (YablogDay day) ident 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)+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 @@ -188,24 +205,17 @@ 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."+deleteArticleR = withArticleAuth $ \(Entity key _) -> do+ runDB $ do+ mapM_ (delete . entityKey) =<< selectList [TagArticle ==. key] []+ delete key+ redirect RootR 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+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@@ -236,7 +246,9 @@ putCommentR = undefined deleteTrackbackR :: YablogDay -> Text -> Handler ()-deleteTrackbackR (YablogDay day) ident = do+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@@ -255,29 +267,37 @@ postDeleteTrackbackR = deleteTrackbackR deleteCommentR :: YablogDay -> Text -> Handler ()-deleteCommentR (YablogDay day) ident = do- Entity uid _ <- requireAuth- Entity aid art <- runDB $ getBy404 $ UniqueArticle (fromEnum day) ident+deleteCommentR = withArticleAuth $ \(Entity aid art) -> do+ let day = toEnum $ articleCreatedDate art ((result, _), _) <- runFormPost $ commentDeleteForm aid- when (uid /= articleAuthor art) $ do- permissionDenied "You are not allowed to delete those comment(s)." case result of- FormSuccess (cs, spam) -> do+ 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)- insert $ Banned (Just $ commentIpAddress c) Nothing+ 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, mfinfo) -> do+ FormSuccess (article, tags, tbs) -> do let editable = False comments = [] mCommentTrackbackForm = Nothing :: Maybe (Widget, Text, Widget, Text)@@ -304,8 +324,9 @@ $(widgetFile "tag") postTrackbackR :: YablogDay -> Text -> Handler RepXml-postTrackbackR (YablogDay date) ident = do- Entity aid _ <- runDB $ getBy404 $ UniqueArticle (fromEnum date) ident+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")@@ -341,7 +362,6 @@ ts <- map entityVal <$> selectList [TrackbackArticle ==. aid] [] return (art, ts) render <- getUrlRender- desc <- getBlogDescription bTitle <- getBlogTitle return $ mkXmlResponse [xml| <error>@@ -373,4 +393,4 @@ Document (Prologue [] Nothing []) body []) Nothing where- body = Element "response" [] nodes+ body = Element "response" M.empty nodes
Import.hs view
@@ -11,25 +11,29 @@ , articleView , articleLink , makeBrief+ , withArticle+ , withArticleAuth , makeSnippet #if __GLASGOW_HASKELL__ < 740 , (<>) #endif ) where--import Prelude hiding (writeFile, readFile, head, tail, init, last)-import Yesod hiding (Route(..), Header(..))-import Foundation-import Data.Monoid (Monoid (mappend, mempty, mconcat))-import Control.Applicative ((<$>), (<*>), pure)-import Data.Text (Text)-import qualified Data.Text as T-import Settings.StaticFiles-import Text.Pandoc hiding (Null)-import Yesod.Auth-import Data.Time-import Forms-import Data.Maybe+import Control.Applicative (pure, (<$>), (<*>))+import Control.Monad+import Data.Maybe+import Data.Monoid (Monoid (mappend, mempty, mconcat))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Forms+import Foundation+import Prelude hiding (head, init, last, readFile, tail,+ writeFile)+import Settings.Development+import Settings.StaticFiles+import Text.Pandoc hiding (Null)+import Yesod hiding (Header (..), Route (..))+import Yesod.Auth articleView :: Maybe String -> Article -> Widget articleView mid article = do@@ -79,7 +83,18 @@ isPara _ = False isHead (Header _ _) = True isHead _ = False- ++withArticle :: (Entity Article -> Handler a) -> YablogDay -> Text -> Handler a+withArticle act (YablogDay day) ident = do+ act =<< runDB (getBy404 $ UniqueArticle (fromEnum day) ident)++withArticleAuth :: (Entity Article -> Handler a) -> YablogDay -> Text -> Handler a+withArticleAuth act = withArticle $ \ent@(Entity _ art) -> do+ Entity uid _ <- requireAuth+ when (uid /= articleAuthor art) $ do+ permissionDenied "You are not allowed to delete those comment(s)."+ act ent+ #if __GLASGOW_HASKELL__ < 740 infixr 5 <> (<>) :: Monoid m => m -> m -> m
Markups.hs view
@@ -12,6 +12,7 @@ import Data.Maybe import Prelude import Data.Char+import Control.Monad renderTwitterLink :: Pandoc -> Pandoc renderTwitterLink = bottomUp go@@ -24,13 +25,14 @@ addAmazonAssociateLink :: String -> Pandoc -> Pandoc addAmazonAssociateLink = bottomUp . procAmazon -renderMarkup :: Maybe String- -> String -- ^ markup language- -> (Pandoc -> Pandoc) -- ^ pandoc transformer- -> String -- ^ source- -> Html -- ^ Html+renderMarkup :: Monad m+ => Maybe String+ -> String -- ^ markup language+ -> (Pandoc -> m Pandoc) -- ^ pandoc transformer+ -> String -- ^ source+ -> m Html -- ^ Html renderMarkup mid lang trans =- writeHtml opts+ liftM (writeHtml opts) . trans . renderTwitterLink . fromMaybe readMarkdown (lookup (map toLower lang) readers) defaultParserState where
Settings.hs view
@@ -12,15 +12,18 @@ , parseExtra ) where +import Text.Hamlet+import Data.Default (def) import Prelude import Text.Shakespeare.Text (st) import Language.Haskell.TH.Syntax import Database.Persist.MongoDB (MongoConf) import Yesod.Default.Config-import qualified Yesod.Default.Util+import Yesod.Default.Util import Data.Text (Text) import Data.Yaml import Control.Applicative+import Settings.Development -- | Which Persistent backend this site is using. type PersistConfig = MongoConf@@ -48,16 +51,23 @@ staticRoot :: AppConfig DefaultEnv x -> Text staticRoot conf = [st|#{appRoot conf}/static|] +-- | Settings for 'widgetFile', such as which template languages to support and+-- default Hamlet settings.+widgetFileSettings :: WidgetFileSettings+widgetFileSettings = def+ { wfsHamletSettings = defaultHamletSettings+ { hamletNewlines = AlwaysNewlines+ }+ } + -- The rest of this file contains settings which rarely need changing by a -- user. widgetFile :: String -> Q Exp-#if DEVELOPMENT-widgetFile = Yesod.Default.Util.widgetFileReload-#else-widgetFile = Yesod.Default.Util.widgetFileNoReload-#endif+widgetFile = (if development then widgetFileReload+ else widgetFileNoReload)+ widgetFileSettings data Extra = Extra { extraCopyright :: Text@@ -69,6 +79,7 @@ , extraMarkup :: Maybe String , extraMailAddress :: Maybe Text , extraGoogleCSE :: Maybe Text+ , extraReCAPTCHA :: Maybe (Text, Text) } deriving Show parseExtra :: DefaultEnv -> Object -> Parser Extra@@ -82,3 +93,5 @@ <*> o .:? "markup" <*> o .:? "admin-mail" <*> o .:? "google-cse"+ <*> (liftA2 (,) <$> o .:? "recaptcha-public-key"+ <*> o .:? "recaptcha-private-key")
+ Settings/Development.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE CPP #-}+module Settings.Development where++import Prelude++development :: Bool+development =+#if DEVELOPMENT+ True+#else+ False+#endif++production :: Bool+production = not development
Yablog.cabal view
@@ -1,5 +1,5 @@ name: Yablog-version: 0.1.1+version: 0.2.0 license: BSD3 license-file: LICENSE author: Hiromi ISHII@@ -32,7 +32,6 @@ Buildable: True else Buildable: False- exposed-modules: Application other-modules: Foundation Import@@ -40,12 +39,13 @@ Markups Forms Settings+ Settings.Development Settings.StaticFiles Handler.Root Handler.Blog Handler.User - ghc-options: -Wall -threaded -O0+ ghc-options: -Wall -O0 cpp-options: -DDEVELOPMENT extensions: TemplateHaskell@@ -87,46 +87,52 @@ FlexibleContexts EmptyDataDecls - build-depends: base >= 4 && < 5- , yesod-platform == 1.0.*- , yesod >= 1.0 && < 1.1- , yesod-core >= 1.0 && < 1.1- , yesod-auth >= 1.0 && < 1.1- , yesod-static >= 1.0 && < 1.1- , yesod-default >= 1.0 && < 1.1- , yesod-form >= 1.0 && < 1.1- , yesod-newsfeed >= 1.0 && < 1.1- , mime-mail >= 0.3.0.3 && < 0.5- , clientsession >= 0.7.3 && < 0.8+ build-depends: base >= 4 && < 5+ , yesod-platform == 1.1.*+ , yesod == 1.1.*+ , yesod-core == 1.1.*+ , yesod-auth == 1.1.*+ , yesod-static == 1.1.*+ , yesod-default == 1.1.*+ , yesod-form == 1.2.*+ , yesod-recaptcha == 1.1.*+ , yesod-newsfeed == 1.1.*+ , mime-mail == 0.4.*+ , clientsession == 0.8.* , bytestring >= 0.9 && < 0.10- , blaze-builder >= 0.3 && < 0.4+ , blaze-builder == 0.3.*+ , blaze-html == 0.5.* , text >= 0.11 && < 0.12- , persistent >= 0.9 && < 0.10- , case-insensitive >= 0.4 && < 0.5- , http-types >= 0.6 && < 0.7- , persistent-mongoDB >= 0.9 && < 0.10+ , persistent == 1.0.*+ , case-insensitive == 0.4.*+ , http-types == 0.7.*+ , persistent-mongoDB == 1.0.* , template-haskell- , hamlet >= 1.0 && < 1.1- , shakespeare-css >= 1.0 && < 1.1- , shakespeare-js >= 1.0 && < 1.1- , shakespeare-text >= 1.0 && < 1.1- , 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+ , hamlet == 1.1.*+ , shakespeare-css == 1.0.*+ , shakespeare-js == 1.1.*+ , shakespeare-text == 1.0.*+ , hjsmin == 0.1.*+ , monad-control == 0.3.*+ , wai-extra == 1.3.*+ , wai == 1.3.*+ , yaml == 0.8.*+ , http-conduit == 1.8.*+ , time >= 1.2 && < 1.5 , old-locale >= 1.0 && < 1.1- , pandoc >= 1.9 && < 1.10- , pandoc-types >= 1.9 && < 2.0- , xml-hamlet >= 0.3 && < 0.4- , xml-conduit >= 0.7 && < 0.8+ , pandoc == 1.9.*+ , pandoc-types == 1.9.*+ , xml-hamlet == 0.4.*+ , xml-conduit == 1.0.* , network >= 2.3 && < 2.4- , filepath >= 1.2 && < 1.3+ , filepath >= 1.2 && < 1.4 , directory >= 1.1 && < 1.2 , containers >= 0.4 && < 0.5- , mtl >= 2.0 && < 2.1+ , mtl >= 2.0 && < 2.2+ , temporary == 1.1.*+ , resourcet == 0.4.*+ , data-default == 0.5.*+ , conduit == 0.5.* source-repository head type: git@@ -135,4 +141,4 @@ source-repository this type: git location: https://github.com/konn/Yablog- tag: 0.0.1.3+ tag: 0.2.0
config/mongoDB.yml view
@@ -3,8 +3,8 @@ password: Yablog host: localhost port: 27017+ connections: 5 database: Yablog- poolsize: 10 Development: <<: *defaults
config/routes view
@@ -11,6 +11,8 @@ /article/#YablogDay/#T.Text/edit ModifyR GET POST /article/#YablogDay/#T.Text ArticleR GET PUT DELETE /article/#YablogDay/#T.Text/delete DeleteR GET+/article/#YablogDay/#T.Text/delete/#FilePath DeleteAttachmentR GET+/article/#YablogDay/#T.Text/upload AttachR POST /article/#YablogDay/#T.Text/comment CommentR POST PUT DELETE /tag/#T.Text TagR GET /article/#YablogDay/#T.Text/comment/delete DeleteCommentR POST
config/settings.yml view
@@ -1,11 +1,12 @@ Default: &defaults- host: "127.0.0.1"+ host: "*4" port: 3000+ approot: "http://localhost:3000" copyright: Insert copyright here title: "My Great Blog" admins: ["konn.jinro@gmail.com"] # specify users' idents who can write articles.- # For example, for Gmail or BrowserId, email-address must be used.+ # For example, for Gmail or BrowserId, email-address must be used. description: "This is my tiny little blog." # analytics: PUT-UA-CODEHERE # amazon-associate: amazon-associate-code@@ -13,6 +14,8 @@ #hatenastar: "" # hatenastar-id admin-mail: "email@example.com" # admin mail # google-cse: "" # ids for google cse+ # recaptcha-public-key: "" # recaptcha public key+ # recaptcha-private-key: "" # recaptcha private key Development: port: 3000@@ -25,5 +28,5 @@ <<: *defaults Production:- approot: "http://localhost:3000"+ approot: "http://www.example.com" <<: *defaults
messages/en.msg view
@@ -39,4 +39,6 @@ Settings: Settings Bans: BANs Image: Image-+Attachments: Attachments+AttachmentNotFound fp@FilePath: Attachment file not found: #{fp}+AddAttachments: Add attachments
messages/ja.msg view
@@ -39,3 +39,6 @@ Settings: 設定 Bans: BANs Image: 画像+Attachments: 添付ファイル+AttachmentNotFound fp@FilePath: 添付ファイルが見付かりませんでした: #{fp}+AddAttachments: 添付ファイルの追加
templates/edit-article.hamlet view
@@ -5,6 +5,9 @@ <a href="#editor" data-toggle="tab"> _{MsgEditOn} <li>+ <a href="#attachments" data-toggle="tab" #show-attachments>+ _{MsgAttachments}+ <li> <a href="#preview" data-toggle="tab" #show-preview> _{MsgPreview} $maybe _ <- mCommentTrackbackForm@@ -21,6 +24,20 @@ <input type=submit .btn> <div .tab-pane #preview> <iframe src=@{PreviewR} #preview-contents .span7 height="400px">+ <div .tab-pane #attachments>+ <h2>_{MsgAttachments}+ $maybe as <- mAttachments+ <ul>+ $forall path <- as+ <li>+ <a href=#{path} target=_blank>+ #{takeFileName path}+ \ - + <a href=@{DeleteAttachmentR (YablogDay day) ident (takeFileName path)} .btn>_{MsgDelete}+ <h3>_{MsgAddAttachments}+ <form enctype="multipart/form-data" action=@{AttachR (YablogDay day) ident} .uploader>+ <input type=file name=file #file>+ <a .btn #append-file>Append $maybe (cWidget, cEnctype, tWidget, tEnctype) <- mCommentTrackbackForm <div .tab-pane #comment-delete> <form action=@{DeleteCommentR (YablogDay day) ident} method=post enctype=#{cEnctype}>
templates/edit-article.julius view
@@ -10,8 +10,19 @@ } function appendFileForm() { filecount += 1;- $(":file:last").after("<br /><input type=\"file\" name=\"file" + filecount + "\" id=\"file"+filecount+"\">")+ var newForm = $("<form enctype=\"multipart/form-data\" action=\"@{AttachR (YablogDay day) ident}\" class=uploader><input type=file name=file #file></form>");+ newForm.insertAfter(".uploader:last");+ newForm.find(':file').change(function() {+ $(this).upload("@{AttachR (YablogDay day) ident}",+ $(this).parent().serialize(),+ function(html){});+ }); } $('#show-preview').click(function(){ reloadPreview(); }); $('#append-file').click(function() { appendFileForm(); });+ $(':file').change(function() {+ $(this).upload("@{AttachR (YablogDay day) ident}",+ $(this).parent().serialize(),+ function(html){});+ }); });