mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* comment deletion (this doesn't look nice, but nobody except for me sees the admin page so I DON'T CARE :D)

Browse source
This commit is contained in:
Vincent Ambo 2012-04-04 04:10:26 +02:00
parent 533463511f
commit d15a01007e
3 changed files with 39 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
src/Blog.hs
View file

@ -266,9 +266,26 @@ editPage (Entry{..}) = adminTemplate "Index" $
H.td $ H.textarea ! A.name "mtext" ! A.cols "100" ! A.rows "15" $ toHtml mtext
H.input ! A.type_ "hidden" ! A.name "eid" ! A.value (toValue $ unEntryId entryId)
H.input ! A.style "margin-left: 20px" ! A.type_ "submit" ! A.value "Absenden"
H.div ! A.class_ "editComments" $ editComments comments entryId
H.p $ do preEscapedText "<a href=/>Startseite</a> -- Entrylist: <a href=/admin/entrylist/de>DE</a>"
preEscapedText " & <a href=/admin/entrylist/en>EN</a> -- <a href=#>Backup</a> (NYI)"
editComments :: [Comment] -> EntryId -> Html
editComments clist eId = H.table $ mapM_ editComment clist
where
editComment (Comment{..}) = H.tr $ do H.td $ toHtml cauthor
H.td $ toHtml $ formatTime defaultTimeLocale "%c" cdate
H.td $ cDeleteLink cdate
cDeleteLink cdate = H.a ! A.href (toValue $ "/admin/cdelete/" ++ show eId
++ formatTime defaultTimeLocale "/%s%Q" cdate) $ "Löschen"
commentDeleted :: EntryId -> Html
commentDeleted eId = adminTemplate "Kommentar gelöscht" $ do
H.div $ "Der Kommentar wurde gelöscht."
H.br
H.a ! A.href (toValue $ "/de/" ++ show eId) $ "Eintrag ansehen | "
H.a ! A.href (toValue $ "/admin/edit/" ++ show eId) $ "Eintrag bearbeiten"
-- Error pages
showError :: BlogError -> BlogLang -> Html
showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ do

9
src/BlogDB.hs
View file

@ -150,6 +150,14 @@ addComment eId c =
put $ b { blogEntries = IxSet.updateIx eId newEntry blogEntries }
return newEntry
deleteComment :: EntryId -> UTCTime -> Update Blog Entry
deleteComment eId cDate =
do b@Blog{..} <- get
let (Just e) = getOne $ blogEntries @= eId
let newEntry = e {comments = filter (\c -> cdate c /= cDate) (comments e)}
put $ b { blogEntries = IxSet.updateIx eId newEntry blogEntries }
return newEntry
updateEntry :: Entry -> Update Blog Entry
updateEntry e =
do b@Blog{..} <- get
@ -210,6 +218,7 @@ hashString = B64.encode . SHA.hash . B.pack
$(makeAcidic ''Blog
[ 'insertEntry
, 'addComment
, 'deleteComment
, 'updateEntry
, 'getEntry
, 'latestEntries

15
src/Main.hs
View file

@ -17,6 +17,7 @@ import Data.Acid.Local
import qualified Data.ByteString.Base64 as B64 (encode)
import Data.ByteString.Char8 (ByteString, pack, unpack)
import Data.Data (Data, Typeable)
import Data.Maybe (fromJust)
import Data.Monoid (mempty)
import Data.Text (Text)
import qualified Data.Text as T
@ -29,7 +30,7 @@ import Options
import System.Locale (defaultTimeLocale)
import Blog
import BlogDB hiding (addComment, updateEntry)
import BlogDB hiding (addComment, updateEntry, deleteComment)
import Locales
import RSS
@ -77,7 +78,11 @@ tazBlog acid captchakey = do
entryList acid EN
, do guardSession acid
dirs "admin/edit" $ path $ \(eId :: Integer) -> editEntry acid eId
, dirs "admin/updateentry" $ nullDir >> updateEntry acid
, do guardSession acid
dirs "admin/updateentry" $ nullDir >> updateEntry acid
, do guardSession acid
dirs "admin/cdelete" $ path $ \(eId :: Integer) -> path $ \(cId :: String) ->
deleteComment acid (EntryId eId) cId
, do dir "admin" $ nullDir
guardSession acid
ok $ toResponse $ adminIndex ("tazjin" :: Text)
@ -223,6 +228,12 @@ updateEntry acid = do
seeOther (concat $ intersperse' "/" [show $ lang entry, show eId])
(toResponse ())
deleteComment :: AcidState Blog -> EntryId -> String -> ServerPart Response
deleteComment acid eId cId = do
nEntry <- update' acid (DeleteComment eId cDate)
ok $ toResponse $ commentDeleted eId
where
(cDate :: UTCTime) = fromJust $ parseTime defaultTimeLocale "%s%Q" cId
guardSession :: AcidState Blog -> ServerPartT IO ()
guardSession acid = do