Yablog-0.0.1.1: Forms.hs
module Forms ( articleForm, articleForm', commentDeleteForm
, 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 Data.Text as T
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
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 $
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
commentDeleteForm :: ArticleId -> Form [Comment]
commentDeleteForm art html = do
let commentSettings = FieldSettings { fsLabel = SomeMessage MsgComments
, fsAttrs = [("class", "span8")]
, fsName = Just "delete-contents"
, fsId = Just "delete-contents"
, fsTooltip = Nothing
}
cs <- lift $ runDB $ selectList [CommentArticle ==. art] []
flip renderBootstrap html $
areq (multiSelectFieldList [(mkOptName c, c) | Entity _ c <- cs]) commentSettings Nothing
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
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
}
flip renderBootstrap html $
Comment <$> areq textField nameField (userScreenName . entityVal <$> musr)
<*> (unTextarea <$> areq textareaField commentField (Textarea . commentBody <$> mcom))
<*> pure (commentPassword =<< mcom)
<*> pure time
<*> pure art
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" }