diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Blog.hs | 38 | ||||
| -rw-r--r-- | src/Server.hs | 89 |
2 files changed, 62 insertions, 65 deletions
diff --git a/src/Blog.hs b/src/Blog.hs index 973382bc9263..f4bdaa698695 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 0522d9d7a807..69eff3a78f62 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 |