Check for parse errors in HasServer Header instance
This commit is contained in:
parent
86ad89b15c
commit
08786aadbe
4 changed files with 55 additions and 17 deletions
|
@ -46,7 +46,7 @@ import Network.Wai (Application, Request, Response,
|
||||||
responseLBS, vault)
|
responseLBS, vault)
|
||||||
import Prelude ()
|
import Prelude ()
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
import Web.HttpApiData (FromHttpApiData, parseHeaderMaybe,
|
import Web.HttpApiData (FromHttpApiData, parseHeader,
|
||||||
parseQueryParam,
|
parseQueryParam,
|
||||||
parseUrlPieceMaybe,
|
parseUrlPieceMaybe,
|
||||||
parseUrlPieces)
|
parseUrlPieces)
|
||||||
|
@ -280,10 +280,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
||||||
type ServerT (Header sym a :> api) m =
|
type ServerT (Header sym a :> api) m =
|
||||||
Maybe a -> ServerT api m
|
Maybe a -> ServerT api m
|
||||||
|
|
||||||
route Proxy context subserver =
|
route Proxy context subserver = route (Proxy :: Proxy api) context $
|
||||||
let mheader req = parseHeaderMaybe =<< lookup str (requestHeaders req)
|
subserver `addHeaderCheck` withRequest headerCheck
|
||||||
in route (Proxy :: Proxy api) context (passToServer subserver mheader)
|
where
|
||||||
where str = fromString $ symbolVal (Proxy :: Proxy sym)
|
headerName = symbolVal (Proxy :: Proxy sym)
|
||||||
|
headerCheck req =
|
||||||
|
case lookup (fromString headerName) (requestHeaders req) of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just txt ->
|
||||||
|
case parseHeader txt of
|
||||||
|
Left e -> delayedFailFatal err400
|
||||||
|
{ errBody = cs $ "Error parsing header "
|
||||||
|
<> fromString headerName
|
||||||
|
<> " failed: " <> e
|
||||||
|
}
|
||||||
|
Right header -> return $ Just header
|
||||||
|
|
||||||
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
|
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
|
||||||
-- this automatically requires your server-side handler to be a function
|
-- this automatically requires your server-side handler to be a function
|
||||||
|
@ -321,7 +332,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
||||||
Just (Just v) ->
|
Just (Just v) ->
|
||||||
case parseQueryParam v of
|
case parseQueryParam v of
|
||||||
Left e -> delayedFailFatal err400
|
Left e -> delayedFailFatal err400
|
||||||
{ errBody = cs $ "Error parsing query parameter " <> paramname <> " failed: " <> e
|
{ errBody = cs $ "Error parsing query parameter "
|
||||||
|
<> paramname <> " failed: " <> e
|
||||||
}
|
}
|
||||||
|
|
||||||
Right param -> return $ Just param
|
Right param -> return $ Just param
|
||||||
|
@ -364,7 +376,9 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
||||||
case partitionEithers $ fmap parseQueryParam params of
|
case partitionEithers $ fmap parseQueryParam params of
|
||||||
([], parsed) -> return parsed
|
([], parsed) -> return parsed
|
||||||
(errs, _) -> delayedFailFatal err400
|
(errs, _) -> delayedFailFatal err400
|
||||||
{ errBody = cs $ "Error parsing query parameter(s) " <> paramname <> " failed: " <> T.intercalate ", " errs
|
{ errBody = cs $ "Error parsing query parameter(s) "
|
||||||
|
<> paramname <> " failed: "
|
||||||
|
<> T.intercalate ", " errs
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
params :: [T.Text]
|
params :: [T.Text]
|
||||||
|
|
|
@ -160,7 +160,9 @@ toApplication ra request respond = ra request routingRespond
|
||||||
-- 5. Query parameter checks. They require parsing and can cause 400 if the
|
-- 5. Query parameter checks. They require parsing and can cause 400 if the
|
||||||
-- parsing fails. Query parameter checks provide inputs to the handler
|
-- parsing fails. Query parameter checks provide inputs to the handler
|
||||||
--
|
--
|
||||||
-- 6. Body check. The request body check can cause 400.
|
-- 6. Header Checks. They also require parsing and can cause 400 if parsing fails.
|
||||||
|
--
|
||||||
|
-- 7. Body check. The request body check can cause 400.
|
||||||
--
|
--
|
||||||
data Delayed env c where
|
data Delayed env c where
|
||||||
Delayed :: { capturesD :: env -> DelayedIO captures
|
Delayed :: { capturesD :: env -> DelayedIO captures
|
||||||
|
@ -169,9 +171,11 @@ data Delayed env c where
|
||||||
, acceptD :: DelayedIO ()
|
, acceptD :: DelayedIO ()
|
||||||
, contentD :: DelayedIO contentType
|
, contentD :: DelayedIO contentType
|
||||||
, paramsD :: DelayedIO params
|
, paramsD :: DelayedIO params
|
||||||
|
, headersD :: DelayedIO headers
|
||||||
, bodyD :: contentType -> DelayedIO body
|
, bodyD :: contentType -> DelayedIO body
|
||||||
, serverD :: captures
|
, serverD :: captures
|
||||||
-> params
|
-> params
|
||||||
|
-> headers
|
||||||
-> auth
|
-> auth
|
||||||
-> body
|
-> body
|
||||||
-> Request
|
-> Request
|
||||||
|
@ -181,7 +185,7 @@ data Delayed env c where
|
||||||
instance Functor (Delayed env) where
|
instance Functor (Delayed env) where
|
||||||
fmap f Delayed{..} =
|
fmap f Delayed{..} =
|
||||||
Delayed
|
Delayed
|
||||||
{ serverD = \ c p a b req -> f <$> serverD c p a b req
|
{ serverD = \ c p h a b req -> f <$> serverD c p h a b req
|
||||||
, ..
|
, ..
|
||||||
} -- Note [Existential Record Update]
|
} -- Note [Existential Record Update]
|
||||||
|
|
||||||
|
@ -213,7 +217,7 @@ runDelayedIO m req = transResourceT runRouteResultT $ runReaderT (runDelayedIO'
|
||||||
-- | A 'Delayed' without any stored checks.
|
-- | A 'Delayed' without any stored checks.
|
||||||
emptyDelayed :: RouteResult a -> Delayed env a
|
emptyDelayed :: RouteResult a -> Delayed env a
|
||||||
emptyDelayed result =
|
emptyDelayed result =
|
||||||
Delayed (const r) r r r r r (const r) (\ _ _ _ _ _ -> result)
|
Delayed (const r) r r r r r r (const r) (\ _ _ _ _ _ _ -> result)
|
||||||
where
|
where
|
||||||
r = return ()
|
r = return ()
|
||||||
|
|
||||||
|
@ -238,7 +242,7 @@ addCapture :: Delayed env (a -> b)
|
||||||
addCapture Delayed{..} new =
|
addCapture Delayed{..} new =
|
||||||
Delayed
|
Delayed
|
||||||
{ capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
|
{ capturesD = \ (txt, env) -> (,) <$> capturesD env <*> new txt
|
||||||
, serverD = \ (x, v) p a b req -> ($ v) <$> serverD x p a b req
|
, serverD = \ (x, v) p h a b req -> ($ v) <$> serverD x p h a b req
|
||||||
, ..
|
, ..
|
||||||
} -- Note [Existential Record Update]
|
} -- Note [Existential Record Update]
|
||||||
|
|
||||||
|
@ -249,7 +253,18 @@ addParameterCheck :: Delayed env (a -> b)
|
||||||
addParameterCheck Delayed {..} new =
|
addParameterCheck Delayed {..} new =
|
||||||
Delayed
|
Delayed
|
||||||
{ paramsD = (,) <$> paramsD <*> new
|
{ paramsD = (,) <$> paramsD <*> new
|
||||||
, serverD = \c (p, pNew) a b req -> ($ pNew) <$> serverD c p a b req
|
, serverD = \c (p, pNew) h a b req -> ($ pNew) <$> serverD c p h a b req
|
||||||
|
, ..
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Add a parameter check to the end of the params block
|
||||||
|
addHeaderCheck :: Delayed env (a -> b)
|
||||||
|
-> DelayedIO a
|
||||||
|
-> Delayed env b
|
||||||
|
addHeaderCheck Delayed {..} new =
|
||||||
|
Delayed
|
||||||
|
{ headersD = (,) <$> headersD <*> new
|
||||||
|
, serverD = \c p (h, hNew) a b req -> ($ hNew) <$> serverD c p h a b req
|
||||||
, ..
|
, ..
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -270,7 +285,7 @@ addAuthCheck :: Delayed env (a -> b)
|
||||||
addAuthCheck Delayed{..} new =
|
addAuthCheck Delayed{..} new =
|
||||||
Delayed
|
Delayed
|
||||||
{ authD = (,) <$> authD <*> new
|
{ authD = (,) <$> authD <*> new
|
||||||
, serverD = \ c p (y, v) b req -> ($ v) <$> serverD c p y b req
|
, serverD = \ c p h (y, v) b req -> ($ v) <$> serverD c p h y b req
|
||||||
, ..
|
, ..
|
||||||
} -- Note [Existential Record Update]
|
} -- Note [Existential Record Update]
|
||||||
|
|
||||||
|
@ -286,7 +301,7 @@ addBodyCheck Delayed{..} newContentD newBodyD =
|
||||||
Delayed
|
Delayed
|
||||||
{ contentD = (,) <$> contentD <*> newContentD
|
{ contentD = (,) <$> contentD <*> newContentD
|
||||||
, bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
|
, bodyD = \(content, c) -> (,) <$> bodyD content <*> newBodyD c
|
||||||
, serverD = \ c p a (z, v) req -> ($ v) <$> serverD c p a z req
|
, serverD = \ c p h a (z, v) req -> ($ v) <$> serverD c p h a z req
|
||||||
, ..
|
, ..
|
||||||
} -- Note [Existential Record Update]
|
} -- Note [Existential Record Update]
|
||||||
|
|
||||||
|
@ -316,7 +331,7 @@ addAcceptCheck Delayed{..} new =
|
||||||
passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
|
passToServer :: Delayed env (a -> b) -> (Request -> a) -> Delayed env b
|
||||||
passToServer Delayed{..} x =
|
passToServer Delayed{..} x =
|
||||||
Delayed
|
Delayed
|
||||||
{ serverD = \ c p a b req -> ($ x req) <$> serverD c p a b req
|
{ serverD = \ c p h a b req -> ($ x req) <$> serverD c p h a b req
|
||||||
, ..
|
, ..
|
||||||
} -- Note [Existential Record Update]
|
} -- Note [Existential Record Update]
|
||||||
|
|
||||||
|
@ -338,8 +353,9 @@ runDelayed Delayed{..} env = runDelayedIO $ do
|
||||||
acceptD
|
acceptD
|
||||||
content <- contentD
|
content <- contentD
|
||||||
p <- paramsD -- Has to be before body parsing, but after content-type checks
|
p <- paramsD -- Has to be before body parsing, but after content-type checks
|
||||||
|
h <- headersD
|
||||||
b <- bodyD content
|
b <- bodyD content
|
||||||
liftRouteResult (serverD c p a b r)
|
liftRouteResult (serverD c p h a b r)
|
||||||
|
|
||||||
-- | Runs a delayed server and the resulting action.
|
-- | Runs a delayed server and the resulting action.
|
||||||
-- Takes a continuation that lets us send a response.
|
-- Takes a continuation that lets us send a response.
|
||||||
|
|
|
@ -63,11 +63,12 @@ delayed body srv = Delayed
|
||||||
, acceptD = return ()
|
, acceptD = return ()
|
||||||
, contentD = return ()
|
, contentD = return ()
|
||||||
, paramsD = return ()
|
, paramsD = return ()
|
||||||
|
, headersD = return ()
|
||||||
, bodyD = \() -> do
|
, bodyD = \() -> do
|
||||||
liftIO (writeTestResource "hia" >> putStrLn "garbage created")
|
liftIO (writeTestResource "hia" >> putStrLn "garbage created")
|
||||||
_ <- register (freeTestResource >> putStrLn "garbage collected")
|
_ <- register (freeTestResource >> putStrLn "garbage collected")
|
||||||
body
|
body
|
||||||
, serverD = \() () () _body _req -> srv
|
, serverD = \() () () () _body _req -> srv
|
||||||
}
|
}
|
||||||
|
|
||||||
simpleRun :: Delayed () (Handler ())
|
simpleRun :: Delayed () (Handler ())
|
||||||
|
|
|
@ -477,6 +477,13 @@ headerSpec = describe "Servant.API.Header" $ do
|
||||||
it "passes the header to the handler (String)" $
|
it "passes the header to the handler (String)" $
|
||||||
delete' "/" "" `shouldRespondWith` 200
|
delete' "/" "" `shouldRespondWith` 200
|
||||||
|
|
||||||
|
with (return (serve headerApi expectsInt)) $ do
|
||||||
|
let delete' x = THW.request methodDelete x [("MyHeader", "not a number")]
|
||||||
|
|
||||||
|
it "checks for parse errors" $
|
||||||
|
delete' "/" "" `shouldRespondWith` 400
|
||||||
|
|
||||||
|
|
||||||
-- }}}
|
-- }}}
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- * rawSpec {{{
|
-- * rawSpec {{{
|
||||||
|
|
Loading…
Reference in a new issue