From 96b52fcdeab7030a409ed85d7f8c1a942d81c310 Mon Sep 17 00:00:00 2001
From: rnhmjoj <micheleguerinirocco@me.com>
Date: Sun, 10 May 2015 15:37:59 +0200
Subject: [PATCH] Set status codes on error

---
 breve.cabal        |  3 ++-
 src/Application.hs | 22 +++++++++++++++-------
 2 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/breve.cabal b/breve.cabal
index 8ac6fc4..0bcfe38 100644
--- a/breve.cabal
+++ b/breve.cabal
@@ -30,8 +30,9 @@ executable breve
                      Breve.Generator, Breve.UrlTable
   other-extensions:  OverloadedStrings
   build-depends:     base >=4.8 && <5.0, warp,
-                     Spock, blaze-html, transformers, mtl,
+                     Spock, blaze-html, http-types,
                      wai, wai-middleware-static, wai-extra,
+                     transformers, mtl,
                      text, aeson, bytestring, binary,
                      hashtables, cryptohash, random,
                      xdg-basedir, configurator, directory
diff --git a/src/Application.hs b/src/Application.hs
index d6a4c77..7f21693 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -15,6 +15,7 @@ import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Text.Lazy          (toStrict)
 
 import Web.Spock.Safe
+import Network.HTTP.Types.Status
 import Network.Wai (Middleware)
 import Network.Wai.Middleware.Static
 import Network.Wai.Middleware.RequestLogger
@@ -27,6 +28,10 @@ serveStatic :: FilePath -> Middleware
 serveStatic = staticPolicy . addBase
 
 
+reply :: Status -> String -> ActionT IO ()
+reply code text = setStatus code >> render (message text)
+
+
 app :: Url -> UrlTable -> SpockT IO ()
 app url' table = do
   static <- liftIO (getDataFileName "static/")
@@ -39,15 +44,15 @@ app url' table = do
   get var $ \name -> do
     url <- liftIO (extract table name)
     case url of
-      Nothing  -> html (render $ message "404: this one does not exist")
+      Nothing  -> reply status404 "404: does not exist"
       Just url -> do
         logStr (printf "Resolved %s -> %s" name url)
         redirect (pack url)
 
   post "/" $ do
-    url <- fmap unpack <$> param "url"
-    case url of
-      Nothing  -> html (render $ message "bad request")
+    url <- param "url"
+    case unpack <$> url of
+      Nothing  -> reply status400 "400: bad request"
       Just url -> do
         name <- liftIO (insert table url)
         logStr (printf "Registered %s -> %s " url name)
@@ -55,9 +60,12 @@ app url' table = do
         render (done link)
 
   post "api" $ do
-    url <- fmap unpack <$> param "url"
-    case url of
-      Nothing  -> text "bad request"
+    url <- param "url"
+    case unpack <$> url of
+      Nothing  -> do
+        setStatus status400
+        json $ object [ "error" .= pack "bad request"
+                      , "msg"   .= pack "missing url field" ]
       Just url -> do
         name <- liftIO (insert table url)
         logStr (printf "Registered %s -> %s " url name)