diff --git a/Application.hs b/Application.hs --- a/Application.hs +++ b/Application.hs @@ -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) diff --git a/Forms.hs b/Forms.hs --- a/Forms.hs +++ b/Forms.hs @@ -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| - - Append -
- |] - 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 diff --git a/Foundation.hs b/Foundation.hs --- a/Foundation.hs +++ b/Foundation.hs @@ -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 diff --git a/Handler/Blog.hs b/Handler/Blog.hs --- a/Handler/Blog.hs +++ b/Handler/Blog.hs @@ -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| @@ -373,4 +393,4 @@ Document (Prologue [] Nothing []) body []) Nothing where - body = Element "response" [] nodes + body = Element "response" M.empty nodes diff --git a/Import.hs b/Import.hs --- a/Import.hs +++ b/Import.hs @@ -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 diff --git a/Markups.hs b/Markups.hs --- a/Markups.hs +++ b/Markups.hs @@ -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 diff --git a/Settings.hs b/Settings.hs --- a/Settings.hs +++ b/Settings.hs @@ -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") diff --git a/Settings/Development.hs b/Settings/Development.hs new file mode 100644 --- /dev/null +++ b/Settings/Development.hs @@ -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 diff --git a/Yablog.cabal b/Yablog.cabal --- a/Yablog.cabal +++ b/Yablog.cabal @@ -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 diff --git a/config/mongoDB.yml b/config/mongoDB.yml --- a/config/mongoDB.yml +++ b/config/mongoDB.yml @@ -3,8 +3,8 @@ password: Yablog host: localhost port: 27017 + connections: 5 database: Yablog - poolsize: 10 Development: <<: *defaults diff --git a/config/routes b/config/routes --- a/config/routes +++ b/config/routes @@ -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 diff --git a/config/settings.yml b/config/settings.yml --- a/config/settings.yml +++ b/config/settings.yml @@ -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 diff --git a/messages/en.msg b/messages/en.msg --- a/messages/en.msg +++ b/messages/en.msg @@ -39,4 +39,6 @@ Settings: Settings Bans: BANs Image: Image - +Attachments: Attachments +AttachmentNotFound fp@FilePath: Attachment file not found: #{fp} +AddAttachments: Add attachments diff --git a/messages/ja.msg b/messages/ja.msg --- a/messages/ja.msg +++ b/messages/ja.msg @@ -39,3 +39,6 @@ Settings: 設定 Bans: BANs Image: 画像 +Attachments: 添付ファイル +AttachmentNotFound fp@FilePath: 添付ファイルが見付かりませんでした: #{fp} +AddAttachments: 添付ファイルの追加 diff --git a/templates/edit-article.hamlet b/templates/edit-article.hamlet --- a/templates/edit-article.hamlet +++ b/templates/edit-article.hamlet @@ -5,6 +5,9 @@ _{MsgEditOn}
  • + + _{MsgAttachments} +
  • _{MsgPreview} $maybe _ <- mCommentTrackbackForm @@ -21,6 +24,20 @@