test: add ability to inject faults, e.g. malformed json responses

README.md

@@ -106,17 +106,31 @@ more details about how to use them.
   i Verifying the deployment:    http://localhost:8080
     against the specification:   example/petstore-basic.spex
 
-  i Parsing the specification.
-
-  i Waiting for health check to pass.
-
-  i Starting to run tests.
+  i Checking the specification.
+
+  i Waiting for health check to pass...
+
+  ✓ Health check passed!
+
+  i Starting to run tests...
+
+  ✓ Done testing, here are the results:
+
+  Test failure (3 shrinks):
+
+  1. getPet : GET /pet/-893 -> Pet
+    ↳ 404 Not Found
+  ------------------------------------------------------------------------
+
+  Coverage:
+    2xx:
+      49% addPet (49)
+    404:
+      51% getPet (51)
 
-  i All tests passed, here are the results:
+  Total: 100
 
-    failing tests: []
-    client errors: 53
-    coverage:      fromList [(OpId "addPet",44),(OpId "getPet",56)]
+  Use --seed 4254641856041340251 to reproduce
   $ kill ${PID_PETSTORE}
   [1]+  Terminated              spex-demo-petstore
   ```

example/petstore-modal-faults.spex

@@ -0,0 +1,11 @@
+component PetStore where
+
+addPet : POST /pet !Pet
+getPet : GET /pet/{petId : @Int} -> Pet
+getBadPet : GET /pet/badJson/{petId : @Int} -> Pet
+neverReached : GET /noThere -> Int
+
+type Pet =
+  { petId   : Int
+  , petName : String 
+  }

example/petstore/petstore.cabal

@@ -20,8 +20,10 @@ library
   build-depends:
     , aeson
     , base
+    , bytestring
     , servant
     , servant-server
+    , wai
     , warp
 
   hs-source-dirs:   src

example/petstore/src/Petstore.hs

@@ -8,16 +8,20 @@ module Petstore where
 import Control.Monad
 import Control.Monad.IO.Class
 import Data.Aeson
+import qualified Data.ByteString.Builder as BSB
+import qualified Data.ByteString.Lazy as LBS
 import Data.IORef
 import Data.List
 import GHC.Generics (Generic)
+import Network.Wai
 import Network.Wai.Handler.Warp
 import Servant
 
 ------------------------------------------------------------------------
 
 type PetstoreAPI =
   "pet" :> Capture "petId" Int :> Get '[JSON] Pet
+    :<|> "pet" :> "badJson" :> Capture "petId" Int :> Get '[JSON] Pet
     :<|> "pet" :> ReqBody '[JSON] Pet :> Post '[JSON] ()
     :<|> "health" :> Get '[JSON] ()
     :<|> "_reset" :> Delete '[JSON] ()
@@ -32,7 +36,7 @@ instance ToJSON Pet
 instance FromJSON Pet
 
 server :: IORef [Pet] -> Server PetstoreAPI
-server store = getPet :<|> addPet :<|> health :<|> reset
+server store = getPet :<|> badGetPet :<|> addPet :<|> health :<|> reset
   where
     getPet :: Int -> Handler Pet
     getPet pid = do
@@ -41,6 +45,10 @@ server store = getPet :<|> addPet :<|> health :<|> reset
         Nothing -> throwError err404
         Just pet -> return pet
 
+    -- XXX: We'll make it do bad stuff in the middleware.
+    badGetPet :: Int -> Handler Pet
+    badGetPet = getPet
+
     addPet :: Pet -> Handler ()
     addPet pet = do
       pets <- liftIO (readIORef store)
@@ -58,7 +66,25 @@ petstoreAPI :: Proxy PetstoreAPI
 petstoreAPI = Proxy
 
 app :: IORef [Pet] -> Application
-app store = serve petstoreAPI (server store)
+app store = faultInject (serve petstoreAPI (server store))
+
+faultInject :: Middleware
+faultInject baseApp req respond0
+  | "badJson" `elem` pathInfo req =
+      baseApp req $ \response -> do
+        let status = responseStatus response
+        let headers = responseHeaders response
+        body <- responseBody response
+        respond0 $ responseLBS status headers (LBS.drop 1 body)
+  | otherwise = baseApp req respond0
+
+responseBody :: Response -> IO LBS.LazyByteString
+responseBody resp =
+  let (_status, _headers, body) = responseToStream resp
+  in  body $ \f -> do
+        content <- newIORef mempty
+        f (\chunk -> modifyIORef' content (<> chunk)) (return ())
+        BSB.toLazyByteString <$> readIORef content
 
 libMain :: Port -> IO ()
 libMain port = do

src/Spex/Verifier/Coverage.hs

@@ -83,31 +83,40 @@ prettyCoverage spec cov =
     ]
       ++ ( if not (null notCoveredOps)
             then
-              [ "Not covered"
+              [ "Not covered:"
               , indent 2 (vcat (map prettyBS notCoveredOps))
               ]
             else []
          )
-      ++ [ "Total: " <> pretty total
+      ++ [ ""
+         , "Total operations (ops): " <> pretty total
          ]
   where
     total :: Word
     total = getSum $ foldMap (foldMap Sum) (unCoverage cov)
 
     prettyOpCov :: (OpId, Word) -> Doc x
     prettyOpCov (oid, n) =
-      pretty (round ((fromIntegral n / fromIntegral total) * 100) :: Int)
+      pretty
+        (round ((fromIntegral n / fromIntegral total :: Double) * 100) :: Int)
         <> "%"
         <+> prettyBS oid
         <+> "("
         <> pretty n
-        <> ")"
+        <> " ops)"
 
     prettyOpCovBad :: (HttpStatusCode, [(OpId, Word)]) -> Doc x
-    prettyOpCovBad (code, ops) = vsep [pretty code <> ":", indent 2 (vcat (map prettyOpCov ops))]
+    prettyOpCovBad (code, ops) =
+      vsep [pretty code <> ":", indent 2 (vcat (map prettyOpCov ops))]
 
     coveredOps :: Set OpId
-    coveredOps = Set.fromList $ concatMap Map.keys $ Map.elems $ unCoverage cov
+    coveredOps =
+      Set.fromList
+        . concatMap Map.keys
+        . Map.elems
+        -- Filter out 404s.
+        . Map.filterWithKey (\code _m -> code /= 404)
+        $ unCoverage cov
 
     declaredOps :: Set OpId
     declaredOps =