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

* correctly serving 404s with status code 404 :|

Browse source
This commit is contained in:
Vincent Ambo 2012-03-18 23:49:50 +01:00
parent 515660fa7d
commit da38878212
3 changed files with 11 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/Blog.hs
View file

@ -237,9 +237,9 @@ editPage (Entry{..}) = adminTemplate "Index" $
-- Error pages -- Error pages
showError :: BlogError -> BlogLang -> Html showError :: BlogError -> BlogLang -> Html
showError NotFound l = blogTemplate l (T.append ": " $ notFound l) $ showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $
H.div ! A.class_ "innerBox" $ do H.div ! A.class_ "innerBox" $ do
H.div ! A.class_ "innerBoxTop" $ toHtml $ notFound l H.div ! A.class_ "innerBoxTop" $ toHtml $ notFoundTitle l
H.div ! A.class_ "innerBoxMiddle" $ do H.div ! A.class_ "innerBoxMiddle" $ do
H.p ! A.class_ "notFoundFace" $ toHtml (":'(" :: Text) H.p ! A.class_ "notFoundFace" $ toHtml (":'(" :: Text)
H.p ! A.class_ "notFoundText" $ toHtml $ notFoundText l H.p ! A.class_ "notFoundText" $ toHtml $ notFoundText l

6
src/Locales.hs
View file

@ -116,9 +116,9 @@ cSend DE = "Absenden"
cSend EN = "Submit" cSend EN = "Submit"
-- errors -- errors
notFound :: BlogLang -> Text notFoundTitle :: BlogLang -> Text
notFound DE = "Nicht gefunden" notFoundTitle DE = "Nicht gefunden"
notFound EN = "Not found" notFoundTitle EN = "Not found"
notFoundText :: BlogLang -> Text notFoundText :: BlogLang -> Text
notFoundText DE = "Das gewünschte Objekt wurde leider nicht gefunden." notFoundText DE = "Das gewünschte Objekt wurde leider nicht gefunden."

12
src/Main.hs
View file

@ -74,7 +74,7 @@ tazBlog acid =
, dir "admin" $ ok $ toResponse $ adminLogin , dir "admin" $ ok $ toResponse $ adminLogin
, dir "dologin" $ processLogin acid , dir "dologin" $ processLogin acid
, serveDirectory DisableBrowsing [] "../res" , serveDirectory DisableBrowsing [] "../res"
, ok $ toResponse $ showError NotFound DE , notFound $ toResponse $ showError NotFound DE
] ]
blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response blogHandler :: AcidState Blog -> BlogLang -> ServerPart Response
@ -85,7 +85,7 @@ blogHandler acid lang =
\(eId :: Integer) -> addComment acid lang $ EntryId eId \(eId :: Integer) -> addComment acid lang $ EntryId eId
, do nullDir , do nullDir
showIndex acid lang showIndex acid lang
, ok $ toResponse $ showError NotFound lang , notFound $ toResponse $ showError NotFound lang
] ]
formatOldLink :: Int -> Int -> String -> ServerPart Response formatOldLink :: Int -> Int -> String -> ServerPart Response
@ -96,11 +96,11 @@ formatOldLink y m id_ =
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)
ok $ tryEntry entry lang tryEntry entry lang
tryEntry :: Maybe Entry -> BlogLang -> Response tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
tryEntry Nothing lang = toResponse $ showError NotFound lang tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang
tryEntry (Just entry) _ = toResponse $ blogTemplate eLang eTitle $ renderEntry entry tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry
where where
eTitle = T.append ": " (title entry) eTitle = T.append ": " (title entry)
eLang = lang entry eLang = lang entry