Show a 404 when a nonexistant page is accessed

This commit is contained in:
Christine Dodrill 2015-07-29 22:23:13 -07:00
parent a0beb7cc6b
commit a8147c2461
3 changed files with 29 additions and 3 deletions

View File

@ -8,6 +8,7 @@ import qualified Data.Map as Map
import qualified Data.Text as Text
import Data.Text.Lazy (toStrict)
import qualified Database.SQLite.Simple as Db
import qualified Network.HTTP.Types.Status as Status
import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
import qualified Network.Wai.Middleware.Static as Static
import Text.Blaze.Renderer.Text
@ -15,6 +16,7 @@ import Web.Spock ((<//>))
import qualified Web.Spock as S
import qualified Within.DBMemorial.Post as Post
import qualified Within.DBMemorial.User as User
import qualified Within.DBMemorial.Views.Error as ErrorView
import qualified Within.DBMemorial.Views.Materialize as Materialize
import qualified Within.DBMemorial.Views.Thread as Thread
@ -49,6 +51,14 @@ main = do
Db.query conn "SELECT * FROM Posts WHERE page=?" (Db.Only (id_ :: Int))
:: S.ActionT IO [Post.Post]
case posts of
[] -> do
S.setStatus Status.status404
let page = ErrorView.render ("no data for page number " ++ (show id_))
S.html $ toStrict $ (renderMarkup (Materialize.render (Text.pack ("Can't find page " ++ (show id_))) page))
_ -> do
let title = "Thread page " ++ (show id_)
page = Thread.render id_ posts userMap

View File

@ -0,0 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
module Within.DBMemorial.Views.Error where
import Text.Blaze.Html
import Text.Blaze.Html5 as H hiding (map)
import Text.Blaze.Html5.Attributes as A
render :: String -> Html
render why = do
H.div ! A.class_ "card red darken-3" $ do
H.div ! A.class_ "card-content white-text center user-card" $ do
H.h1 ! A.class_ "center text-orange" $ "404"
H.p $ "Sorry! We couldn't find any data. If this isn't meant to be seen, please let the maintainers know:"
H.pre $ H.toHtml why

View File

@ -70,6 +70,7 @@ executable time-wasting-thread-memorial
, containers >=0.5.0.0
, transformers >=0.4.3.0
, clay >=0.10.1
, http-types >=0.8.6
-- Directories containing source files.
hs-source-dirs: src