Merge pull request #1156 from wireapp/feature/capture-lenient

Feature/capture lenient

servant-docs/golden/comprehensive.md

@@ -96,6 +96,28 @@
 
 ```
 
+## GET /capture-lenient/:foo
+
+### Captures:
+
+- *foo*: Capture foo Int
+
+### Response:
+
+- Status code 200
+- Headers: []
+
+- Supported content types are:
+
+    - `application/json;charset=utf-8`
+    - `application/json`
+
+- Example (`application/json;charset=utf-8`, `application/json`):
+
+```javascript
+
+```
+
 ## GET /description
 
 ### foo

servant-server/src/Servant/Server/Internal.hs

@@ -87,7 +87,7 @@ import           Servant.API.ResponseHeaders
 import qualified Servant.Types.SourceT                      as S
 import           Web.HttpApiData
                  (FromHttpApiData, parseHeader, parseQueryParam,
-                 parseUrlPieceMaybe, parseUrlPieces)
+                 parseUrlPieceMaybe, parseUrlPieces, parseUrlPiece)
 
 import           Servant.Server.Internal.BasicAuth
 import           Servant.Server.Internal.Context
@@ -166,11 +166,11 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
 -- > server = getBook
 -- >   where getBook :: Text -> Handler Book
 -- >         getBook isbn = ...
-instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods))
       => HasServer (Capture' mods capture a :> api) context where
 
   type ServerT (Capture' mods capture a :> api) m =
-     a -> ServerT api m
+     If (FoldLenient mods) (Either String a) a -> ServerT api m
 
   hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
 
@@ -178,9 +178,11 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
     CaptureRouter $
         route (Proxy :: Proxy api)
               context
-              (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
-                 Nothing -> delayedFail err400
-                 Just v  -> return v
+              (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods)
+                                            , parseUrlPiece txt :: Either T.Text a) of
+                 (SFalse, Left e) -> delayedFail err400 { errBody = cs e }
+                 (SFalse, Right v) -> return v
+                 (STrue, piece) -> return $ (either (Left . cs) Right) piece
               )
 
 -- | If you use 'CaptureAll' in one of the endpoints for your API,

servant-server/test/Servant/ServerSpec.hs

@@ -46,7 +46,7 @@ import           Network.Wai.Test
                  simpleHeaders, simpleStatus)
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
-                 BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete,
+                 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Lenient, Strict, Delete,
                  EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
                  JSON, NoContent (..), NoFraming, OctetStream, Patch,
                  PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
@@ -54,7 +54,7 @@ import           Servant.API
                  addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
-                 emptyServer, err401, err403, err404, serve, serveWithContext)
+                 emptyServer, err400, err401, err403, err404, serve, serveWithContext)
 import           Servant.Test.ComprehensiveAPI
 import qualified Servant.Types.SourceT             as S
 import           Test.Hspec
@@ -204,13 +204,27 @@ verbSpec = describe "Servant.API.Verb" $ do
 ------------------------------------------------------------------------------
 
 type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
+                :<|> "ears" :> Capture' '[Lenient] "ears" Integer :> Get '[JSON] Animal
+                :<|> "eyes" :> Capture' '[Strict] "eyes" Integer :> Get '[JSON] Animal
 captureApi :: Proxy CaptureApi
 captureApi = Proxy
-captureServer :: Integer -> Handler Animal
-captureServer legs = case legs of
-  4 -> return jerry
-  2 -> return tweety
-  _ -> throwError err404
+
+captureServer :: Server CaptureApi
+captureServer = getLegs :<|> getEars :<|> getEyes
+  where getLegs :: Integer -> Handler Animal
+        getLegs legs = case legs of
+          4 -> return jerry
+          2 -> return tweety
+          _ -> throwError err404
+
+        getEars :: Either String Integer -> Handler Animal
+        getEars (Left e) = return chimera -- ignore integer parse error, return weird animal
+        getEars (Right 2) = return jerry
+        getEars (Right _) = throwError err404
+
+        getEyes :: Integer -> Handler Animal
+        getEyes 2 = return jerry
+        getEyes _ = throwError err404
 
 captureSpec :: Spec
 captureSpec = do
@@ -224,6 +238,17 @@ captureSpec = do
       it "returns 400 if the decoding fails" $ do
         get "/notAnInt" `shouldRespondWith` 400
 
+      it "returns an animal if eyes or ears are 2" $ do
+        get "/ears/2" `shouldRespondWith` 200
+        get "/eyes/2" `shouldRespondWith` 200
+
+      it "returns a weird animal on Lenient Capture" $ do
+        response <- get "/ears/bla"
+        liftIO $ decode' (simpleBody response) `shouldBe` Just chimera
+
+      it "returns 400 if parsing integer fails on Strict Capture" $ do
+        get "/eyes/bla" `shouldRespondWith` 400
+
     with (return (serve
         (Proxy :: Proxy (Capture "captured" String :> Raw))
         (\ "captured" -> Tagged $ \request_ respond ->
@@ -780,6 +805,10 @@ jerry = Animal "Mouse" 4
 tweety :: Animal
 tweety = Animal "Bird" 2
 
+-- weird animal with non-integer amount of ears
+chimera :: Animal
+chimera = Animal "Chimera" (-1)
+
 beholder :: Animal
 beholder = Animal "Beholder" 0
 -- }}}

servant/src/Servant/Test/ComprehensiveAPI.hs

@@ -49,6 +49,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint =
     GET
     :<|> "get-int"          :> Get '[JSON] Int
     :<|> "capture"          :> Capture' '[Description "example description"] "foo" Int :> GET
+    :<|> "capture-lenient"  :> Capture' '[Lenient] "foo" Int :> GET
     :<|> "header"           :> Header "foo" Int :> GET
     :<|> "header-lenient"   :> Header' '[Required, Lenient] "bar" Int :> GET
     :<|> "http-version"     :> HttpVersion :> GET