Yablog-0.2.0: Forms.hs
module Forms ( articleForm, articleForm', commentDeleteForm
, commentForm, commentForm', trackbackForm
, trackbackDeleteForm
) where
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])
articleForm = articleForm' Nothing Nothing
articleForm' :: Maybe Article -> Maybe [Text] -> Form (Article, [Text], [URL])
articleForm' mart mtags htm = do
Entity usrId usr <- lift requireAuth
lift $ do
accessible <- isAdmin usr
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)
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 do
(r, widget) <- flip renderBootstrap htm $
let titleSettings = FieldSettings { fsLabel = SomeMessage MsgTitle
, fsName = Just "title"
, fsId = Just "title"
, fsAttrs = [("class", "span8")]
, fsTooltip = Nothing
}
bodySettings = FieldSettings { fsLabel = SomeMessage MsgArticle
, fsId = Just "src"
, fsName = Just "src"
, fsAttrs = [("class", "span8")]
, fsTooltip = Nothing
}
tagsSettings = FieldSettings { fsLabel = SomeMessage MsgTags
, fsId = Just "tags"
, fsName = Just "tags"
, fsAttrs = [("class", "span8")]
, fsTooltip = Nothing
}
identSettings = FieldSettings { fsLabel = SomeMessage MsgIdentifier
, fsId = Just "ident"
, fsName = Just "ident"
, fsAttrs = [("class", "span8")]
, fsTooltip = Nothing
}
cDateSettings = FieldSettings { fsLabel = SomeMessage MsgCreatedDate
, fsId = Just "created_date"
, fsName = Just "created_date"
, fsAttrs = []
, fsTooltip = Nothing
}
cTimeSettings = FieldSettings { fsLabel = SomeMessage MsgCreatedTime
, fsName = Just "created_time"
, fsId = Just "created_time"
, fsAttrs = []
, fsTooltip = Nothing
}
markupSettings = FieldSettings { fsLabel = "Markup"
, fsName = Just "markup"
, fsId = Just "markup"
, fsAttrs = []
, fsTooltip = Nothing
}
trackbackUrls = FieldSettings { fsLabel = "Trackback(s)"
, fsName = Just "trackbacks"
, fsId = Just "trackbacks"
, fsAttrs = [("class", "span8")]
, fsTooltip = Nothing
}
art = Article <$> pure usrId
<*> areq textField titleSettings (articleTitle <$> mart)
<*> areq textField identSettings (Just ident)
<*> aopt (selectFieldList $ map ((T.pack &&& id).fst) readers) markupSettings
(Just $ (articleMarkup =<< mart) <|> markup)
<*> (T.unpack . T.filter (/='\r') . unTextarea <$>
areq textareaField bodySettings
(Textarea . T.pack . articleBody <$> mart))
<*> (fromEnum . fromMaybe day <$> aopt dayField cDateSettings
(Just $ toEnum . articleCreatedDate <$> mart))
<*> (fromEnum . timeOfDayToTime . fromMaybe time <$> aopt timeField cTimeSettings
(Just $ timeToTimeOfDay . toEnum . articleCreatedTime <$> mart))
<*> 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
return (r, widget)
commentDeleteForm :: ArticleId -> Form ([Comment], Bool)
commentDeleteForm art html = do
let commentSettings = FieldSettings { fsLabel = SomeMessage MsgComments
, fsAttrs = [("class", "span8")]
, fsName = Just "delete-contents"
, 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 checkBoxField isSpamSettings (Just False)
where
mkOptName c = T.concat [ commentBody c, " - ", commentAuthor c, " / "
, T.pack$ show $ commentCreatedAt c
]
trackbackDeleteForm :: ArticleId -> Form [Trackback]
trackbackDeleteForm art html = do
let tbsSettings = FieldSettings { fsLabel = SomeMessage MsgTrackbacks
, fsAttrs = [("class", "span8")]
, fsName = Just "delete-tbs"
, fsId = Just "delete-tbs"
, fsTooltip = Nothing
}
cs <- lift $ runDB $ selectList [TrackbackArticle ==. art] []
flip renderBootstrap html $
areq (multiSelectFieldList [(mkOptName c, c) | Entity _ c <- cs]) tbsSettings Nothing
where
mkOptName t = fromMaybe (fromMaybe (trackbackUrl t) $ trackbackBlogName t) $
trackbackTitle t
commentForm' :: Maybe Comment -> ArticleId -> Form Comment
commentForm' mcom art html = do
mRecap <- lift $ extraReCAPTCHA . appExtra . settings <$> getYesod
ipaddr <- lift getIPAddrProxy
musr <- lift maybeAuth
time <- liftIO getCurrentTime
let commentField = FieldSettings { fsLabel = SomeMessage MsgComment
, fsAttrs = [("class", "span8")]
, fsName = Just "comment-contents"
, fsId = Just "comment-contents"
, fsTooltip = Nothing
}
nameField = FieldSettings { fsLabel = SomeMessage MsgName
, fsAttrs = []
, fsId = Just "comment-author"
, 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))
<*> pure (commentPassword =<< mcom)
<*> pure time
<*> pure art
<*> pure ipaddr
<* recap
commentForm :: Maybe Comment -> Article -> Form Comment
commentForm mcom art html = do
Entity key _ <- lift $ runDB $ getBy404 $
UniqueArticle (articleCreatedDate art) (articleIdent art)
commentForm' mcom key html
trackbackForm :: ArticleId -> Form Trackback
trackbackForm aid = renderBootstrap $
Trackback <$> pure aid
<*> aopt textField titleSettings Nothing
<*> (liftM unTextarea <$> aopt textareaField excerptSettings Nothing)
<*> areq textField urlSettings Nothing
<*> aopt textField blogSettings Nothing
where
titleSettings = "title" { fsName = Just "title" }
excerptSettings = "excerpt" { fsName = Just "excerpt" }
urlSettings = "url" { fsName = Just "url" }
blogSettings = "blog_name" { fsName = Just "blog_name" }