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

* updating entries and entrylist

Browse source 
* entryEscape ("\n" -> "<br>")
This commit is contained in:
Vincent Ambo 2012-03-15 18:32:01 +01:00
parent 47e1be1f78
commit df9a17b695
2 changed files with 78 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
src/Blog.hs
View file

@ -193,6 +193,39 @@ adminIndex sUser = adminTemplate "Index" $
H.td $ H.textarea ! A.name "mtext" ! A.cols "100" ! A.rows "15" $ mempty
H.input ! A.type_ "hidden" ! A.name "author" ! A.value (toValue sUser)
H.input ! A.style "margin-left: 20px" ! A.type_ "submit" ! A.value "Absenden"
adminFooter
adminFooter :: Html
adminFooter = 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)"
adminEntryList :: [Entry] -> Html
adminEntryList entries = adminTemplate "Entrylist" $
H.div ! A.style "float: center;" $ do
H.table $ do
sequence_ $ map showEntryItem entries
adminFooter
where
showEntryItem :: Entry -> Html
showEntryItem (Entry{..}) = H.tr $ do
H.td $ H.a ! A.href (toValue $ "/admin/edit/" ++ show entryId) $ toHtml title
H.td $ toHtml $ formatTime defaultTimeLocale "[On %D at %H:%M]" edate
editPage :: Entry -> Html
editPage (Entry{..}) = adminTemplate "Index" $
H.div ! A.style "float: center;" $
H.form ! A.action "/admin/updateentry" ! A.method "POST" $ do
H.table $ do
H.tr $ do H.td $ "Titel:"
H.td $ H.input ! A.type_ "text" ! A.name "title" ! A.value (toValue title)
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Text:"
H.td $ H.textarea ! A.name "btext" ! A.cols "100" ! A.rows "15" $ toHtml btext
H.tr $ do H.td ! A.style "vertical-align: top;" $ "Mehr Text:"
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.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)"

71
src/Main.hs
View file

@ -54,9 +54,20 @@ tazBlog acid =
, path $ \(year :: Int) -> path $ \(month :: Int) -> path $ \(id_ :: String) -> formatOldLink year month id_
, dir "res" $ serveDirectory DisableBrowsing [] "../res"
, dir "notice" $ ok $ toResponse showSiteNotice
{- :Admin handlers -}
, do dirs "admin/postentry" $ nullDir
guardSession acid
postEntry acid
, do dirs "admin/entrylist" $ dir (show DE) $ nullDir
guardSession acid
entryList acid DE
, do dirs "admin/entrylist" $ dir (show EN) $ nullDir
guardSession acid
entryList acid EN
, do guardSession acid
dirs "admin/edit" $ path $ \(eId :: Integer) -> editEntry acid eId
, do dirs "admin/updateentry" $ nullDir
updateEntry acid
, do dir "admin" $ nullDir
guardSession acid
ok $ toResponse $ adminIndex ("tazjin" :: Text)
@ -65,18 +76,6 @@ tazBlog acid =
, serveDirectory DisableBrowsing [] "../res"
]
{-
adminHandler :: AcidState Blog -> ServerPart Response
adminHandler acid =
msum [ dir "postentry" $ postEntry acid
, dir "entrylist" $ dir (show DE) $ entryList DE
, dir "entrylist" $ dir (show EN) $ entryList EN
, dir "edit" $ path $ \(eId :: Integer) -> editEntry eId
, dir "doedit" $ updateEntry
, ok $ toResponse $ adminIndex ("tazjin" :: Text) --User NYI
]
-}
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
blogHandler acid lang =
msum [ path $ \(eId :: Integer) -> showEntry acid lang $ EntryId eId
@ -124,45 +123,65 @@ addComment acid lang eId = do
update' acid (AddComment eId nComment)
seeOther ("/" ++ show lang ++ "/" ++ show eId) (toResponse())
{- ADMIN stuff -}
updateEntry :: ServerPart Response
updateEntry = undefined
{- ADMIN stuff -}
postEntry :: AcidState Blog -> ServerPart Response
postEntry acid = do
decodeBody tmpPolicy
now <- liftIO $ getCurrentTime
let eId = timeToId now
lang <- lookText' "lang"
lang <- look "lang"
nBtext <- lookText' "btext"
nMtext <- lookText' "mtext"
nEntry <- Entry <$> pure eId
<*> getLang lang
<*> lookText' "author"
<*> lookText' "title"
<*> lookText' "btext"
<*> lookText' "mtext"
<*> pure (entryEscape nBtext)
<*> pure (entryEscape nMtext)
<*> pure now
<*> pure [] -- NYI
<*> pure []
update' acid (InsertEntry nEntry)
seeOther ("/" ++ (T.unpack lang) ++ "/" ++ show eId) (toResponse())
seeOther ("/" ++ lang ++ "/" ++ show eId) (toResponse())
where
timeToId :: UTCTime -> EntryId
timeToId t = EntryId . read $ formatTime defaultTimeLocale "%s" t
getLang :: Text -> ServerPart BlogLang
getLang :: String -> ServerPart BlogLang
getLang "de" = return DE
getLang "en" = return EN
entryEscape :: Text -> Text
entryEscape = T.replace "\n" "<br>"
entryList :: BlogLang -> ServerPart Response
entryList lang = undefined
entryList :: AcidState Blog -> BlogLang -> ServerPart Response
entryList acid lang = do
entries <- query' acid (LatestEntries lang)
ok $ toResponse $ adminEntryList entries
editEntry :: Integer -> ServerPart Response
editEntry i = undefined
editEntry :: AcidState Blog -> Integer -> ServerPart Response
editEntry acid i = do
(Just entry) <- query' acid (GetEntry eId)
ok $ toResponse $ editPage entry
where
eId = EntryId i
updateEntry :: AcidState Blog -> ServerPart Response
updateEntry acid = do
decodeBody tmpPolicy
(eId :: Integer) <- lookRead "eid"
(Just entry) <- query' acid (GetEntry $ EntryId eId)
nTitle <- lookText' "title"
nBtext <- lookText' "btext"
nMtext <- lookText' "mtext"
let nEntry = entry { title = nTitle
, btext = entryEscape nBtext
, mtext = entryEscape nMtext}
update' acid (UpdateEntry nEntry)
seeOther (concat $ intersperse' "/" [show $ lang entry, show eId])
(toResponse ())
guardSession :: AcidState Blog -> ServerPartT IO ()
guardSession acid = do
(sId :: Text) <- readCookieValue "session"