Skip to content

Commit 58e931f

Browse files
phadejphadej
committed
Resolve todos
1 parent a61551b commit 58e931f

File tree

5 files changed

+108
-74
lines changed

5 files changed

+108
-74
lines changed

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

Lines changed: 38 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -28,10 +28,11 @@ import Control.Monad.Trans.Resource (runResourceT)
2828
import qualified Data.ByteString as B
2929
import qualified Data.ByteString.Char8 as BC8
3030
import qualified Data.ByteString.Lazy as BL
31+
import Data.Maybe (fromMaybe, mapMaybe)
3132
import Data.Either (partitionEithers)
32-
import Data.Maybe (fromMaybe)
3333
import Data.String (fromString)
3434
import Data.String.Conversions (cs, (<>))
35+
import qualified Data.Text as T
3536
import Data.Typeable
3637
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
3738
symbolVal)
@@ -319,10 +320,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
319320
Just Nothing -> return Nothing -- param present with no value -> Nothing
320321
Just (Just v) ->
321322
case parseQueryParam v of
322-
-- TODO: This should set an error description (including
323-
-- paramname)
324-
Left _e -> delayedFailFatal err400 -- parsing the request
325-
-- paramter failed
323+
Left e -> delayedFailFatal err400
324+
{ errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e
325+
}
326326

327327
Right param -> return $ Just param
328328
delayed = addParameterCheck subserver . withRequest $ \req ->
@@ -356,26 +356,25 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
356356
type ServerT (QueryParams sym a :> api) m =
357357
[a] -> ServerT api m
358358

359-
route Proxy context subserver =
360-
let querytext r = parseQueryText $ rawQueryString r
361-
-- if sym is "foo", we look for query string parameters
362-
-- named "foo" or "foo[]" and call parseQueryParam on the
363-
-- corresponding values
364-
parameters r = filter looksLikeParam (querytext r)
365-
parseParam (paramName, paramTxt) =
366-
case parseQueryParam (fromMaybe "" paramTxt) of
367-
Left _e -> Left paramName -- On error, remember name of parameter
368-
Right paramVal -> Right paramVal
369-
parseParams req =
370-
case partitionEithers $ parseParam <$> parameters req of
371-
([], params) -> return params -- No errors
372-
-- TODO: This should set an error description
373-
(_errors, _) -> delayedFailFatal err400
374-
delayed = addParameterCheck subserver . withRequest $ \req ->
375-
parseParams req
376-
in route (Proxy :: Proxy api) context delayed
377-
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
378-
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
359+
route Proxy context subserver = route (Proxy :: Proxy api) context $
360+
subserver `addParameterCheck` withRequest paramsCheck
361+
where
362+
paramname = cs $ symbolVal (Proxy :: Proxy sym)
363+
paramsCheck req =
364+
case partitionEithers $ fmap parseQueryParam params of
365+
([], parsed) -> return parsed
366+
(errs, _) -> delayedFailFatal err400
367+
{ errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs
368+
}
369+
where
370+
params :: [T.Text]
371+
params = mapMaybe snd
372+
. filter (looksLikeParam . fst)
373+
. parseQueryText
374+
. rawQueryString
375+
$ req
376+
377+
looksLikeParam name = name == paramname || name == (paramname <> "[]")
379378

380379
-- | If you use @'QueryFlag' "published"@ in one of the endpoints for your API,
381380
-- this automatically requires your server-side handler to be a function
@@ -457,22 +456,28 @@ instance ( AllCTUnrender list a, HasServer api context
457456
type ServerT (ReqBody list a :> api) m =
458457
a -> ServerT api m
459458

460-
route Proxy context subserver =
461-
route (Proxy :: Proxy api) context (addBodyCheck subserver bodyCheck)
459+
route Proxy context subserver
460+
= route (Proxy :: Proxy api) context $
461+
addBodyCheck subserver ctCheck bodyCheck
462462
where
463-
bodyCheck = withRequest $ \ request -> do
463+
-- Content-Type check, we only lookup we can try to parse the request body
464+
ctCheck = withRequest $ \ request -> do
464465
-- See HTTP RFC 2616, section 7.2.1
465466
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
466467
-- See also "W3C Internet Media Type registration, consistency of use"
467468
-- http://www.w3.org/2001/tag/2002/0129-mime
468469
let contentTypeH = fromMaybe "application/octet-stream"
469470
$ lookup hContentType $ requestHeaders request
470-
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
471-
<$> liftIO (lazyRequestBody request)
471+
case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
472+
Nothing -> delayedFailFatal err415
473+
Just f -> return f
474+
475+
-- Body check, we get a body parsing functions as the first argument.
476+
bodyCheck f = withRequest $ \ request -> do
477+
mrqbody <- f <$> liftIO (lazyRequestBody request)
472478
case mrqbody of
473-
Nothing -> delayedFailFatal err415
474-
Just (Left e) -> delayedFailFatal err400 { errBody = cs e }
475-
Just (Right v) -> return v
479+
Left e -> delayedFailFatal err400 { errBody = cs e }
480+
Right v -> return v
476481

477482
-- | Make sure the incoming request starts with @"/path"@, strip it and
478483
-- pass the rest of the request path to @api@.

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

Lines changed: 34 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -132,14 +132,14 @@ toApplication ra request respond = ra request routingRespond
132132
-- 405 (bad method)
133133
-- 401 (unauthorized)
134134
-- 415 (unsupported media type)
135-
-- 400 (bad request)
136135
-- 406 (not acceptable)
136+
-- 400 (bad request)
137137
-- @
138138
--
139139
-- Therefore, while routing, we delay most checks so that they
140140
-- will ultimately occur in the right order.
141141
--
142-
-- A 'Delayed' contains four delayed blocks of tests, and
142+
-- A 'Delayed' contains many delayed blocks of tests, and
143143
-- the actual handler:
144144
--
145145
-- 1. Delayed captures. These can actually cause 404, and
@@ -148,24 +148,28 @@ toApplication ra request respond = ra request routingRespond
148148
-- check order from the error reporting, see above). Delayed
149149
-- captures can provide inputs to the actual handler.
150150
--
151-
-- 2. Query parameter checks. They require parsing and can cause 400 if the
152-
-- parsing fails. Query parameter checks provide inputs to the handler
153-
--
154-
-- 3. Method check(s). This can cause a 405. On success,
151+
-- 2. Method check(s). This can cause a 405. On success,
155152
-- it does not provide an input for the handler. Method checks
156153
-- are comparatively cheap.
157154
--
158-
-- 4. Body and accept header checks. The request body check can
159-
-- cause both 400 and 415. This provides an input to the handler.
160-
-- The accept header check can be performed as the final
161-
-- computation in this block. It can cause a 406.
155+
-- 3. Authentication checks. This can cause 401.
156+
--
157+
-- 4. Accept and content type header checks. These checks
158+
-- can cause 415 and 406 errors.
159+
--
160+
-- 5. Query parameter checks. They require parsing and can cause 400 if the
161+
-- parsing fails. Query parameter checks provide inputs to the handler
162+
--
163+
-- 6. Body check. The request body check can cause 400.
162164
--
163165
data Delayed env c where
164166
Delayed :: { capturesD :: env -> DelayedIO captures
165-
, paramsD :: DelayedIO params
166167
, methodD :: DelayedIO ()
167168
, authD :: DelayedIO auth
168-
, bodyD :: DelayedIO body
169+
, acceptD :: DelayedIO ()
170+
, contentD :: DelayedIO contentType
171+
, paramsD :: DelayedIO params
172+
, bodyD :: contentType -> DelayedIO body
169173
, serverD :: captures
170174
-> params
171175
-> auth
@@ -209,7 +213,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'
209213
-- | A 'Delayed' without any stored checks.
210214
emptyDelayed :: RouteResult a -> Delayed env a
211215
emptyDelayed result =
212-
Delayed (const r) r r r r (\ _ _ _ _ _ -> result)
216+
Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result)
213217
where
214218
r = return ()
215219

@@ -270,20 +274,25 @@ addAuthCheck Delayed{..} new =
270274
, ..
271275
} -- Note [Existential Record Update]
272276

273-
-- | Add a body check to the end of the body block.
277+
-- | Add a content type and body checks around parameter checks.
278+
--
279+
-- We'll report failed content type check (415), before trying to parse
280+
-- query parameters (400). Which, in turn, happens before request body parsing.
274281
addBodyCheck :: Delayed env (a -> b)
275-
-> DelayedIO a
282+
-> DelayedIO c -- ^ content type check
283+
-> (c -> DelayedIO a) -- ^ body check
276284
-> Delayed env b
277-
addBodyCheck Delayed{..} new =
285+
addBodyCheck Delayed{..} newContentD newBodyD =
278286
Delayed
279-
{ bodyD = (,) <$> bodyD <*> new
287+
{ contentD = (,) <$> contentD <*> newContentD
288+
, bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
280289
, serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req
281290
, ..
282291
} -- Note [Existential Record Update]
283292

284293

285-
-- | Add an accept header check to the beginning of the body
286-
-- block. There is a tradeoff here. In principle, we'd like
294+
-- | Add an accept header check before handling parameters.
295+
-- In principle, we'd like
287296
-- to take a bad body (400) response take precedence over a
288297
-- failed accept check (406). BUT to allow streaming the body,
289298
-- we cannot run the body check and then still backtrack.
@@ -297,7 +306,7 @@ addAcceptCheck :: Delayed env a
297306
-> Delayed env a
298307
addAcceptCheck Delayed{..} new =
299308
Delayed
300-
{ bodyD = new *> bodyD
309+
{ acceptD = acceptD *> new
301310
, ..
302311
} -- Note [Existential Record Update]
303312

@@ -322,12 +331,14 @@ runDelayed :: Delayed env a
322331
-> Request
323332
-> ResourceT IO (RouteResult a)
324333
runDelayed Delayed{..} env = runDelayedIO $ do
334+
r <- ask
325335
c <- capturesD env
326336
methodD
327337
a <- authD
328-
b <- bodyD
329-
r <- ask
330-
p <- paramsD -- Has to be after body to respect the relative error order
338+
acceptD
339+
content <- contentD
340+
p <- paramsD -- Has to be before body parsing, but after content-type checks
341+
b <- bodyD content
331342
liftRouteResult (serverD c p a b r)
332343

333344
-- | Runs a delayed server and the resulting action.

‎servant-server/test/Servant/Server/ErrorSpec.hs

Lines changed: 14 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
{-# OPTIONS_GHC -fno-warn-orphans #-}
77
module Servant.Server.ErrorSpec (spec) where
88

9+
import Control.Monad (when)
910
import Data.Aeson (encode)
1011
import qualified Data.ByteString.Char8 as BC
1112
import qualified Data.ByteString.Lazy.Char8 as BCL
@@ -114,10 +115,19 @@ errorOrderSpec =
114115
`shouldRespondWith` 415
115116

116117
it "has 400 as its sixth highest priority error" $ do
117-
request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
118-
`shouldRespondWith` 400
119-
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
120-
`shouldRespondWith` 400
118+
badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
119+
badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
120+
121+
-- Both bad body and bad params result in 400
122+
return badParamsRes `shouldRespondWith` 400
123+
return badBodyRes `shouldRespondWith` 400
124+
125+
-- Param check should occur before body checks
126+
both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody
127+
when (both /= badParamsRes) $ liftIO $
128+
expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
129+
when (both == badBodyRes) $ liftIO $
130+
expectationFailure $ "badParams + badBody == badBody: " ++ show both
121131

122132
it "has handler-level errors as last priority" $ do
123133
request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody

‎servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs

Lines changed: 9 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ import Data.Proxy
1919
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
2020
import Servant
2121
import Servant.Server.Internal.RoutingApplication
22+
import Network.Wai (defaultRequest)
2223
import Test.Hspec
2324
import Test.Hspec.Wai (request, shouldRespondWith, with)
2425

@@ -56,12 +57,14 @@ freeTestResource = modifyIORef delayedTestRef $ \r -> case r of
5657

5758
delayed :: DelayedIO () -> RouteResult (Handler ()) -> Delayed () (Handler ())
5859
delayed body srv = Delayed
59-
{ capturesD = \_ -> return ()
60+
{ capturesD = \() -> return ()
6061
, methodD = return ()
6162
, authD = return ()
63+
, acceptD = return ()
64+
, contentD = return ()
6265
, paramsD = return ()
63-
, bodyD = do
64-
liftIO (writeTestResource"hia" >> putStrLn "garbage created")
66+
, bodyD = \() -> do
67+
liftIO (writeTestResource "hia" >> putStrLn "garbage created")
6568
_ <- register (freeTestResource >> putStrLn "garbage collected")
6669
body
6770
, serverD = \() () () _body _req -> srv
@@ -70,7 +73,7 @@ delayed body srv = Delayed
7073
simpleRun :: Delayed () (Handler ())
7174
-> IO ()
7275
simpleRun d = fmap (either ignoreE id) . try $
73-
runAction d () undefined (\_ -> return ()) (\_ -> FailFatal err500)
76+
runAction d () defaultRequest (\_ -> return ()) (\_ -> FailFatal err500)
7477

7578
where ignoreE :: SomeException -> ()
7679
ignoreE = const ()
@@ -85,10 +88,10 @@ data Res (sym :: Symbol)
8588
instance (KnownSymbol sym, HasServer api ctx) => HasServer (Res sym :> api) ctx where
8689
type ServerT (Res sym :> api) m = IORef (TestResource String) -> ServerT api m
8790
route Proxy ctx server = route (Proxy :: Proxy api) ctx $
88-
server `addBodyCheck` check
91+
addBodyCheck server (return ()) check
8992
where
9093
sym = symbolVal (Proxy :: Proxy sym)
91-
check = do
94+
check () = do
9295
liftIO $ writeTestResource sym
9396
_ <- register freeTestResource
9497
return delayedTestRef

‎servant/src/Servant/API/ContentTypes.hs

Lines changed: 13 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -220,14 +220,20 @@ class Accept ctype => MimeUnrender ctype a where
220220
{-# MINIMAL mimeUnrender | mimeUnrenderWithType #-}
221221

222222
class AllCTUnrender (list :: [*]) a where
223+
canHandleCTypeH
224+
:: Proxy list
225+
-> ByteString -- Content-Type header
226+
-> Maybe (ByteString -> Either String a)
227+
223228
handleCTypeH :: Proxy list
224229
-> ByteString -- Content-Type header
225230
-> ByteString -- Request body
226231
-> Maybe (Either String a)
232+
handleCTypeH p ctypeH body = ($ body) `fmap` canHandleCTypeH p ctypeH
227233

228234
instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where
229-
handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH)
230-
where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
235+
canHandleCTypeH p ctypeH =
236+
M.mapContentMedia (allMimeUnrender p) (cs ctypeH)
231237

232238
--------------------------------------------------------------------------
233239
-- * Utils (Internal)
@@ -292,20 +298,19 @@ instance OVERLAPPING_
292298
--------------------------------------------------------------------------
293299
class (AllMime list) => AllMimeUnrender (list :: [*]) a where
294300
allMimeUnrender :: Proxy list
295-
-> ByteString
296-
-> [(M.MediaType, Either String a)]
301+
-> [(M.MediaType, ByteString -> Either String a)]
297302

298303
instance AllMimeUnrender '[] a where
299-
allMimeUnrender _ _ = []
304+
allMimeUnrender _ = []
300305

301306
instance ( MimeUnrender ctyp a
302307
, AllMimeUnrender ctyps a
303308
) => AllMimeUnrender (ctyp ': ctyps) a where
304-
allMimeUnrender _ bs =
309+
allMimeUnrender _ =
305310
(map mk $ NE.toList $ contentTypes pctyp)
306-
++ allMimeUnrender pctyps bs
311+
++ allMimeUnrender pctyps
307312
where
308-
mk ct = (ct, mimeUnrenderWithType pctyp ct bs)
313+
mk ct = (ct, \bs -> mimeUnrenderWithType pctyp ct bs)
309314
pctyp = Proxy :: Proxy ctyp
310315
pctyps = Proxy :: Proxy ctyps
311316

0 commit comments

Comments
 (0)