[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

2 files changed, 62 insertions, 65 deletions

diff --git a/src/Blog.hs b/src/Blog.hs
index 973382bc92..f4bdaa6986 100644
--- a/src/Blog.hs
+++ b/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}
 |]
 
diff --git a/src/Server.hs b/src/Server.hs
index 0522d9d7a8..69eff3a78f 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -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