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

[blog] Split request handling, do HTTP better

Browse source 
* 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 2015-11-21 02:59:34 +01:00
parent 7610e79013
commit 308e859d56
No known key found for this signature in database
GPG key ID: 66F505681DB8F43B
2 changed files with 62 additions and 65 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
src/Blog.hs
View file

@ -184,7 +184,7 @@ adminLogin = adminTemplate "Login" $ [shamlet|
<div class="loginBox"> <div class="loginBox">
<div class="loginBoxTop">TazBlog Admin: Login <div class="loginBoxTop">TazBlog Admin: Login
<div class="loginBoxMiddle"> <div class="loginBoxMiddle">
<form action="/dologin" method="POST"> <form action="/admin" method="POST">
<p>Account ID <p>Account ID
<p><input type="text" style="font-size:2;" name="account" value="tazjin" readonly="1"> <p><input type="text" style="font-size:2;" name="account" value="tazjin" readonly="1">
<p>Passwort <p>Passwort
@ -195,40 +195,39 @@ adminLogin = adminTemplate "Login" $ [shamlet|
adminIndex :: Text -> Html adminIndex :: Text -> Html
adminIndex sUser = adminTemplate "Index" $ [shamlet| adminIndex sUser = adminTemplate "Index" $ [shamlet|
<div style="float:center;"> <div style="float:center;">
<form action="/admin/postentry" method="POST"> <form action="/admin/entry" method="POST">
<table> <table>
<tr> <tr>
<thead><td>Titel: <thead><td>Title:
<td><input type="text" name="title"> <td><input type="text" name="title">
<tr> <tr>
<thead><td>Sprache: <thead><td>Language:
<td><select name="lang"> <td><select name="lang">
<option value="en">English
<option value="de">Deutsch <option value="de">Deutsch
<option value="en">Englisch
<tr> <tr>
<thead><td>Text: <thead><td>Text:
<td> <td>
<textarea name="btext" cols="100" rows="15"> <textarea name="btext" cols="100" rows="15">
<tr> <tr>
<thead> <thead>
<td style="vertical-align:top;">Mehr Text: <td style="vertical-align:top;">Read more:
<td> <td>
<textarea name="mtext" cols="100" rows="15"> <textarea name="mtext" cols="100" rows="15">
<input type="hidden" name="author" value=#{sUser}> <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}
|] |]
adminFooter :: Html adminFooter :: Html
adminFooter = [shamlet| adminFooter = [shamlet|
<a href="/">Startseite <a href="/">Front page
\ -- Entrylist: #
<a href="/admin/entrylist/de">DE
\ & #
<a href="/admin/entrylist/en">EN
\ -- # \ -- #
<a href="#">Backup <a href="/admin">New article
\ (NYI) \ -- Entry list: #
<a href="/admin/entrylist/en">EN
\ & #
<a href="/admin/entrylist/de">DE
|] |]
adminEntryList :: [Entry] -> Html adminEntryList :: [Entry] -> Html
@ -237,7 +236,7 @@ adminEntryList entries = adminTemplate "EntryList" $ [shamlet|
<table> <table>
$forall entry <- entries $forall entry <- entries
<tr> <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} <td>#{formatPostDate $ edate entry}
|] |]
where where
@ -246,10 +245,10 @@ adminEntryList entries = adminTemplate "EntryList" $ [shamlet|
editPage :: Entry -> Html editPage :: Entry -> Html
editPage (Entry{..}) = adminTemplate "Index" $ [shamlet| editPage (Entry{..}) = adminTemplate "Index" $ [shamlet|
<div style="float:center;"> <div style="float:center;">
<form action="/admin/updateentry" method="POST"> <form action=#{append "/admin/entry/" (show' entryId)} method="POST">
<table> <table>
<tr> <tr>
<td>Titel: <td>Title:
<td> <td>
<input type="text" name="title" value=#{title}> <input type="text" name="title" value=#{title}>
<tr> <tr>
@ -257,11 +256,10 @@ editPage (Entry{..}) = adminTemplate "Index" $ [shamlet|
<td> <td>
<textarea name="btext" cols="100" rows="15">#{btext} <textarea name="btext" cols="100" rows="15">#{btext}
<tr> <tr>
<td style="vertical-align:top;">Mehr Text: <td style="vertical-align:top;">Read more:
<td> <td>
<textarea name="mtext" cols="100" rows="15">#{mtext} <textarea name="mtext" cols="100" rows="15">#{mtext}
<input type="hidden" name="eid" value=#{unEntryId entryId}> <input type="submit" style="margin-left:20px;" value="Submit">
<input type="submit" style="margin-left:20px;" value="Absenden">
<p>^{adminFooter} <p>^{adminFooter}
|] |]

85
src/Server.hs
View file

@ -37,37 +37,14 @@ runBlog acid port respath =
tazBlog :: AcidState Blog -> String -> ServerPart Response tazBlog :: AcidState Blog -> String -> ServerPart Response
tazBlog acid resDir = do tazBlog acid resDir = do
msum [ nullDir >> blogHandler acid EN msum [ path $ \(lang :: BlogLang) -> blogHandler acid lang
, path $ \(lang :: BlogLang) -> blogHandler acid lang , dir "admin" $ msum [
, dir "notice" $ ok $ toResponse showSiteNotice adminHandler acid -- this checks auth
{- :Admin handlers -} , method GET >> (ok $ toResponse adminLogin)
, do dirs "admin/postentry" nullDir , method POST >> processLogin acid ]
guardSession acid , dirs "static/blogv40.css" $ serveBlogStyle
postEntry acid , dir "static" $ staticHandler resDir
, do dirs "admin/entrylist" $ dir (show DE) nullDir , blogHandler acid EN
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
, notFound $ toResponse $ showError NotFound DE , notFound $ toResponse $ showError NotFound DE
] ]
@ -80,6 +57,30 @@ blogHandler acid lang =
, notFound $ toResponse $ showError NotFound 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 :: AcidState Blog -> BlogLang -> EntryId -> ServerPart Response
showEntry acid lang eId = do showEntry acid lang eId = do
entry <- query' acid (GetEntry eId) entry <- query' acid (GetEntry eId)
@ -114,6 +115,7 @@ showRSS acid lang = do
postEntry :: AcidState Blog -> ServerPart Response postEntry :: AcidState Blog -> ServerPart Response
postEntry acid = do postEntry acid = do
nullDir
decodeBody tmpPolicy decodeBody tmpPolicy
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let eId = timeToId now let eId = timeToId now
@ -142,25 +144,22 @@ entryList acid lang = do
ok $ toResponse $ adminEntryList entries ok $ toResponse $ adminEntryList entries
editEntry :: AcidState Blog -> Integer -> ServerPart Response editEntry :: AcidState Blog -> Integer -> ServerPart Response
editEntry acid i = do editEntry acid entryId = do
(Just entry) <- query' acid (GetEntry eId) (Just entry) <- query' acid (GetEntry $ EntryId entryId)
ok $ toResponse $ editPage entry ok $ toResponse $ editPage entry
where
eId = EntryId i
updateEntry :: AcidState Blog -> ServerPart Response -- TODO: Clean this up updateEntry :: AcidState Blog -> Integer -> ServerPart Response
updateEntry acid = do updateEntry acid entryId = do
decodeBody tmpPolicy decodeBody tmpPolicy
(eId :: Integer) <- lookRead "eid" (Just entry) <- query' acid (GetEntry $ EntryId entryId)
(Just entry) <- query' acid (GetEntry $ EntryId eId)
nTitle <- lookText' "title" nTitle <- lookText' "title"
nBtext <- lookText' "btext" nBtext <- lookText' "btext"
nMtext <- lookText' "mtext" nMtext <- lookText' "mtext"
let nEntry = entry { title = nTitle let newEntry = entry { title = nTitle
, btext = nBtext , btext = nBtext
, mtext = nMtext} , mtext = nMtext}
update' acid (UpdateEntry nEntry) update' acid (UpdateEntry newEntry)
seeOther (concat $ intersperse' "/" [show $ lang entry, show eId]) seeOther (concat $ intersperse' "/" [show $ lang entry, show entryId])
(toResponse ()) (toResponse ())
guardSession :: AcidState Blog -> ServerPartT IO () guardSession :: AcidState Blog -> ServerPartT IO ()
@ -186,7 +185,7 @@ processLogin acid = do
login <- query' acid (CheckUser (Username account) password) login <- query' acid (CheckUser (Username account) password)
if login if login
then createSession account then createSession account
else ok $ toResponse adminLogin else unauthorized $ toResponse adminLogin
where where
createSession account = do createSession account = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime