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,11 @@ 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           Network.HTTP.Media
 import           Network.Wai.Handler.Warp (runSettingsSocket, defaultSettings)
 import           Network.Socket
 
@@ -63,10 +65,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 $ notFound request
+
   where
     color :: Either ByteString Bool
     color = case join $ lookup "color" $ queryString request of
@@ -85,16 +94,46 @@ app getLastResult request respond = case pathInfo request of
             | 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)
+    requireMethod :: Method -> IO ResponseReceived -> IO ResponseReceived
+    requireMethod required action = case requestMethod request of
+      method | method == required -> action
+      _ -> respond $ genericRfc7807Response methodNotAllowed405
+
+    json :: ToJSON a => a -> Response
+    json value = responseLBS
+      status200
+      [(hContentType, "application/json")]
+      (encode value)
+
+notFound :: Request -> Response
+notFound request = fromMaybe text $ mapAcceptMedia [
+    ("text/plain", text)
+  , ("application/json", json)
+  ] =<< lookup "Accept" request.requestHeaders
+  where
+    text :: Response
+    text = responseLBS
+      status404
+      [("Content-Type", "text/plain")]
+      "404 Not Found"
+
+    json :: Response
+    json = genericRfc7807Response notFound404
+
+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

@@ -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 "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