diff options
| -rw-r--r-- | src/Blog.hs | 33 | ||||
| -rw-r--r-- | src/Main.hs | 71 |
2 files changed, 78 insertions, 26 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index 8e53046edddf..f7e5f5f3b727 100644 --- a/src/Blog.hs +++ b/src/Blog.hs @@ -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)" diff --git a/src/Main.hs b/src/Main.hs index b05599de588a..fdf2134c921f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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" |