Return RFC 7807 compliant JSON on 404 when "Accept: application/json"

package.yaml

@@ -29,6 +29,7 @@ dependencies:
   - wai
   - warp
   - http-types
+  - http-media
   - stm
   - text
   - network

src/Client.hs

@@ -20,6 +20,7 @@ client dir args = case args of
     hPutStrLn stderr $ "Usage: seito [ --color | --no-color ]"
     return (False, "")
   where
+    run :: Bool -> IO (Bool, L.ByteString)
     run color = handleSocketFileDoesNotExist name $ do
       manager <- newManager defaultManagerSettings {managerRawConnection = return newConnection}
       let

src/HTTP.hs

@@ -16,9 +16,12 @@ import           Imports hiding (strip, encodeUtf8)
 import           System.Directory
 import           Data.Aeson (ToJSON(..), encode)
 import qualified Data.ByteString.Lazy as L
+import           Data.ByteString.Builder
 import           Data.Text.Lazy.Encoding (encodeUtf8)
 import           Network.Wai
 import           Network.HTTP.Types
+import qualified Network.HTTP.Types.Status as Status
+import           Network.HTTP.Media
 import           Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings)
 import           Network.Socket
 
@@ -63,10 +66,17 @@ withThread asyncAction action = do
 
 app :: IO (Trigger.Result, String, [Diagnostic]) -> Application
 app getLastResult request respond = case pathInfo request of
-  ["diagnostics"] -> do
+
+  [] -> requireMethod "GET" $ do
+    getLastResult >>= textPlain
+
+  ["diagnostics"] -> requireMethod "GET" $ do
     (_, _, diagnostics) <- getLastResult
     respond $ json diagnostics
-  _ -> getLastResult >>= textPlain
+
+  _ -> do
+    respond $ genericStatus Status.notFound404 request
+
   where
     color :: Either ByteString Bool
     color = case join $ lookup "color" $ queryString request of
@@ -77,24 +87,57 @@ app getLastResult request respond = case pathInfo request of
 
     textPlain :: (Trigger.Result, FilePath, [Diagnostic]) -> IO ResponseReceived
     textPlain (result, xs, _diagnostics) = case color of
-      Left err -> respond $ responseLBS status400 [(hContentType, "text/plain")] (L.fromStrict err)
+      Left err -> respond $ responseLBS Status.badRequest400 [(hContentType, "text/plain")] (L.fromStrict err)
       Right c -> respond $ responseLBS status [(hContentType, "text/plain")] (encodeUtf8 . fromString $ strip xs)
         where
           strip :: String -> String
           strip
             | c = id
             | otherwise = stripAnsi
 
+          status :: Status
           status = case result of
-            Trigger.HookFailed -> status500
-            Trigger.Failure -> status500
-            Trigger.Success -> status200
-
-json :: ToJSON a => a -> Response
-json value = responseLBS
-  status200
-  [("Content-Type", "application/json")]
-  (encode value)
+            Trigger.HookFailed -> Status.internalServerError500
+            Trigger.Failure -> Status.internalServerError500
+            Trigger.Success -> Status.ok200
+
+    requireMethod :: Method -> IO ResponseReceived -> IO ResponseReceived
+    requireMethod required action = case requestMethod request of
+      method | method == required -> action
+      _ -> respond $ genericRfc7807Response Status.methodNotAllowed405
+
+    json :: ToJSON a => a -> Response
+    json value = responseLBS
+      Status.ok200
+      [(hContentType, "application/json")]
+      (encode value)
+
+genericStatus :: Status -> Request -> Response
+genericStatus status@(Status number message) request = fromMaybe text $ mapAcceptMedia [
+    ("text/plain", text)
+  , ("application/json", json)
+  ] =<< lookup "Accept" request.requestHeaders
+  where
+    text :: Response
+    text = responseBuilder
+      status
+      [("Content-Type", "text/plain")]
+      body
+      where
+        body :: Builder
+        body = "{\"title\":\"" <> byteString message <> "\",\"status\":" <> intDec number <> "}"
+
+    json :: Response
+    json = genericRfc7807Response status
+
+genericRfc7807Response :: Status -> Response
+genericRfc7807Response status@(Status number message) = responseBuilder
+  status
+  [(hContentType, "application/json")]
+  body
+  where
+    body :: Builder
+    body = "{\"title\":\"" <> byteString message <> "\",\"status\":" <> intDec number <> "}"
 
 -- |
 -- Remove terminal sequences.

test/HTTPSpec.hs

@@ -35,7 +35,7 @@ spec = do
             it "removes terminal sequences" $ do
               get "/?color=false" `shouldRespondWith` "success"
 
-          context "with an in invalid value for ?color" $ do
+          context "with an invalid value for ?color" $ do
             it "returns status 400" $ do
               get "/?color=some%20value" `shouldRespondWith` 400 { matchBody = "invalid value for color: some%20value" }
 
@@ -61,6 +61,16 @@ spec = do
       withApp (Trigger.Failure, "", [err]) $ do
         it "returns GHC diagnostics" $ do
           get "/diagnostics" `shouldRespondWith` expected
+
+    context "when querying a non-existing endpoint" $ withApp undefined $ do
+      it "returns status 404" $ do
+        get "/foo" `shouldRespondWith` 404 {matchBody = "404 Not Found"}
+
+      context "with \"Accept: application/json\"" $ do
+        it "returns a JSON error" $ do
+          request "GET" "/foo" [("Accept", "application/json")] "" `shouldRespondWith` 404 {
+            matchBody = "{\"title\":\"Not Found\",\"status\":404}"
+          }
 
   describe "stripAnsi" $ do
     it "removes ANSI color sequences" $ do