[blog] Split request handling, do HTTP better
* request handling split into multiple smaller handlers * use request methods in various places instead of different routes * some minor updates to admin page
This commit is contained in:
Vincent Ambo
parent
7610e79013
commit
308e859d56
2 changed files with 62 additions and 65 deletions
38
src/Blog.hs
38
src/Blog.hs
|
|
@ -184,7 +184,7 @@ adminLogin = adminTemplate "Login" $ [shamlet|
|
|||
<div class="loginBox">
|
||||
<div class="loginBoxTop">TazBlog Admin: Login
|
||||
<div class="loginBoxMiddle">
|
||||
<form action="/dologin" method="POST">
|
||||
<form action="/admin" method="POST">
|
||||
<p>Account ID
|
||||
<p><input type="text" style="font-size:2;" name="account" value="tazjin" readonly="1">
|
||||
<p>Passwort
|
||||
|
|
@ -195,40 +195,39 @@ adminLogin = adminTemplate "Login" $ [shamlet|
|
|||
adminIndex :: Text -> Html
|
||||
adminIndex sUser = adminTemplate "Index" $ [shamlet|
|
||||
<div style="float:center;">
|
||||
<form action="/admin/postentry" method="POST">
|
||||
<form action="/admin/entry" method="POST">
|
||||
<table>
|
||||
<tr>
|
||||
<thead><td>Titel:
|
||||
<thead><td>Title:
|
||||
<td><input type="text" name="title">
|
||||
<tr>
|
||||
<thead><td>Sprache:
|
||||
<thead><td>Language:
|
||||
<td><select name="lang">
|
||||
<option value="en">English
|
||||
<option value="de">Deutsch
|
||||
<option value="en">Englisch
|
||||
<tr>
|
||||
<thead><td>Text:
|
||||
<td>
|
||||
<textarea name="btext" cols="100" rows="15">
|
||||
<tr>
|
||||
<thead>
|
||||
<td style="vertical-align:top;">Mehr Text:
|
||||
<td style="vertical-align:top;">Read more:
|
||||
<td>
|
||||
<textarea name="mtext" cols="100" rows="15">
|
||||
<input type="hidden" name="author" value=#{sUser}>
|
||||
<input style="margin-left:20px;" type="submit" value="Absenden">
|
||||
<input style="margin-left:20px;" type="submit" value="Submit">
|
||||
^{adminFooter}
|
||||
|]
|
||||
|
||||
adminFooter :: Html
|
||||
adminFooter = [shamlet|
|
||||
<a href="/">Startseite
|
||||
\ -- Entrylist: #
|
||||
<a href="/admin/entrylist/de">DE
|
||||
\ & #
|
||||
<a href="/admin/entrylist/en">EN
|
||||
<a href="/">Front page
|
||||
\ -- #
|
||||
<a href="#">Backup
|
||||
\ (NYI)
|
||||
<a href="/admin">New article
|
||||
\ -- Entry list: #
|
||||
<a href="/admin/entrylist/en">EN
|
||||
\ & #
|
||||
<a href="/admin/entrylist/de">DE
|
||||
|]
|
||||
|
||||
adminEntryList :: [Entry] -> Html
|
||||
|
|
@ -237,7 +236,7 @@ adminEntryList entries = adminTemplate "EntryList" $ [shamlet|
|
|||
<table>
|
||||
$forall entry <- entries
|
||||
<tr>
|
||||
<td><a href=#{append "/admin/edit/" (show' $ entryId entry)}>#{title entry}
|
||||
<td><a href=#{append "/admin/entry/" (show' $ entryId entry)}>#{title entry}
|
||||
<td>#{formatPostDate $ edate entry}
|
||||
|]
|
||||
where
|
||||
|
|
@ -246,10 +245,10 @@ adminEntryList entries = adminTemplate "EntryList" $ [shamlet|
|
|||
editPage :: Entry -> Html
|
||||
editPage (Entry{..}) = adminTemplate "Index" $ [shamlet|
|
||||
<div style="float:center;">
|
||||
<form action="/admin/updateentry" method="POST">
|
||||
<form action=#{append "/admin/entry/" (show' entryId)} method="POST">
|
||||
<table>
|
||||
<tr>
|
||||
<td>Titel:
|
||||
<td>Title:
|
||||
<td>
|
||||
<input type="text" name="title" value=#{title}>
|
||||
<tr>
|
||||
|
|
@ -257,11 +256,10 @@ editPage (Entry{..}) = adminTemplate "Index" $ [shamlet|
|
|||
<td>
|
||||
<textarea name="btext" cols="100" rows="15">#{btext}
|
||||
<tr>
|
||||
<td style="vertical-align:top;">Mehr Text:
|
||||
<td style="vertical-align:top;">Read more:
|
||||
<td>
|
||||
<textarea name="mtext" cols="100" rows="15">#{mtext}
|
||||
<input type="hidden" name="eid" value=#{unEntryId entryId}>
|
||||
<input type="submit" style="margin-left:20px;" value="Absenden">
|
||||
<input type="submit" style="margin-left:20px;" value="Submit">
|
||||
<p>^{adminFooter}
|
||||
|]
|
||||
|
||||
|
|
|
|||
|
|
@ -37,37 +37,14 @@ runBlog acid port respath =
|
|||
|
||||
tazBlog :: AcidState Blog -> String -> ServerPart Response
|
||||
tazBlog acid resDir = do
|
||||
msum [ nullDir >> blogHandler acid EN
|
||||
, path $ \(lang :: BlogLang) -> blogHandler acid lang
|
||||
, 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 guardSession acid
|
||||
dirs "admin/updateentry" $ nullDir >> updateEntry acid
|
||||
, do dir "admin" nullDir
|
||||
guardSession acid
|
||||
ok $ toResponse $ adminIndex ("tazjin" :: Text)
|
||||
, dir "admin" $ ok $ toResponse adminLogin
|
||||
, dir "dologin" $ processLogin acid
|
||||
, do dirs "static/blogv40.css" nullDir
|
||||
setHeaderM "content-type" "text/css"
|
||||
setHeaderM "cache-control" "max-age=630720000"
|
||||
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
||||
ok $ toResponse blogStyle
|
||||
, do setHeaderM "cache-control" "max-age=630720000"
|
||||
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
||||
dir "static" $ serveDirectory DisableBrowsing [] resDir
|
||||
, serveDirectory DisableBrowsing [] resDir
|
||||
msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
|
||||
, dir "admin" $ msum [
|
||||
adminHandler acid -- this checks auth
|
||||
, method GET >> (ok $ toResponse adminLogin)
|
||||
, method POST >> processLogin acid ]
|
||||
, dirs "static/blogv40.css" $ serveBlogStyle
|
||||
, dir "static" $ staticHandler resDir
|
||||
, blogHandler acid EN
|
||||
, notFound $ toResponse $ showError NotFound DE
|
||||
]
|
||||
|
||||
|
|
@ -80,6 +57,30 @@ blogHandler acid lang =
|
|||
, notFound $ toResponse $ showError NotFound lang
|
||||
]
|
||||
|
||||
staticHandler :: String -> ServerPart Response
|
||||
staticHandler resDir = do
|
||||
setHeaderM "cache-control" "max-age=630720000"
|
||||
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
||||
serveDirectory DisableBrowsing [] resDir
|
||||
|
||||
serveBlogStyle :: ServerPart Response
|
||||
serveBlogStyle = do
|
||||
setHeaderM "content-type" "text/css"
|
||||
setHeaderM "cache-control" "max-age=630720000"
|
||||
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
|
||||
ok $ toResponse $ blogStyle
|
||||
|
||||
adminHandler :: AcidState Blog -> ServerPart Response
|
||||
adminHandler acid = do
|
||||
guardSession acid
|
||||
msum [ dir "entry" $ method POST >> postEntry acid
|
||||
, dir "entry" $ path $ \(entry :: Integer) -> msum [
|
||||
method GET >> editEntry acid entry
|
||||
, method POST >> updateEntry acid entry ]
|
||||
, dir "entrylist" $ path $ \(lang :: BlogLang) -> entryList acid lang
|
||||
, ok $ toResponse $ adminIndex "tazjin"
|
||||
]
|
||||
|
||||
showEntry :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
|
||||
showEntry acid lang eId = do
|
||||
entry <- query' acid (GetEntry eId)
|
||||
|
|
@ -114,6 +115,7 @@ showRSS acid lang = do
|
|||
|
||||
postEntry :: AcidState Blog -> ServerPart Response
|
||||
postEntry acid = do
|
||||
nullDir
|
||||
decodeBody tmpPolicy
|
||||
now <- liftIO getCurrentTime
|
||||
let eId = timeToId now
|
||||
|
|
@ -142,25 +144,22 @@ entryList acid lang = do
|
|||
ok $ toResponse $ adminEntryList entries
|
||||
|
||||
editEntry :: AcidState Blog -> Integer -> ServerPart Response
|
||||
editEntry acid i = do
|
||||
(Just entry) <- query' acid (GetEntry eId)
|
||||
editEntry acid entryId = do
|
||||
(Just entry) <- query' acid (GetEntry $ EntryId entryId)
|
||||
ok $ toResponse $ editPage entry
|
||||
where
|
||||
eId = EntryId i
|
||||
|
||||
updateEntry :: AcidState Blog -> ServerPart Response -- TODO: Clean this up
|
||||
updateEntry acid = do
|
||||
updateEntry :: AcidState Blog -> Integer -> ServerPart Response
|
||||
updateEntry acid entryId = do
|
||||
decodeBody tmpPolicy
|
||||
(eId :: Integer) <- lookRead "eid"
|
||||
(Just entry) <- query' acid (GetEntry $ EntryId eId)
|
||||
(Just entry) <- query' acid (GetEntry $ EntryId entryId)
|
||||
nTitle <- lookText' "title"
|
||||
nBtext <- lookText' "btext"
|
||||
nMtext <- lookText' "mtext"
|
||||
let nEntry = entry { title = nTitle
|
||||
, btext = nBtext
|
||||
, mtext = nMtext}
|
||||
update' acid (UpdateEntry nEntry)
|
||||
seeOther (concat $ intersperse' "/" [show $ lang entry, show eId])
|
||||
let newEntry = entry { title = nTitle
|
||||
, btext = nBtext
|
||||
, mtext = nMtext}
|
||||
update' acid (UpdateEntry newEntry)
|
||||
seeOther (concat $ intersperse' "/" [show $ lang entry, show entryId])
|
||||
(toResponse ())
|
||||
|
||||
guardSession :: AcidState Blog -> ServerPartT IO ()
|
||||
|
|
@ -186,7 +185,7 @@ processLogin acid = do
|
|||
login <- query' acid (CheckUser (Username account) password)
|
||||
if login
|
||||
then createSession account
|
||||
else ok $ toResponse adminLogin
|
||||
else unauthorized $ toResponse adminLogin
|
||||
where
|
||||
createSession account = do
|
||||
now <- liftIO getCurrentTime
|
||||
|
|
|
|||
Loading…
Reference in a new issue