remove redundant function

This commit is contained in:
Sönke Hahn 2016-10-24 21:08:27 -04:00
parent e27ea01049
commit 775b239f7f
2 changed files with 5 additions and 23 deletions

View file

@ -6,6 +6,7 @@
-- fixme: document phases -- fixme: document phases
-- fixme: document that the req body can only be consumed once -- fixme: document that the req body can only be consumed once
-- fixme: document that you can write request body streaming combinators
-- fixme: document dependency problem -- fixme: document dependency problem
module Servant.Server.Utils.CustomCombinators ( module Servant.Server.Utils.CustomCombinators (
@ -20,7 +21,6 @@ module Servant.Server.Utils.CustomCombinators (
makeCaptureCombinator, makeCaptureCombinator,
makeRequestCheckCombinator, makeRequestCheckCombinator,
makeAuthCombinator, makeAuthCombinator,
makeReqBodyCombinator,
makeCombinator, makeCombinator,
-- * Re-exports -- * Re-exports
@ -30,12 +30,9 @@ module Servant.Server.Utils.CustomCombinators (
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Exception (throwIO, ErrorCall(..)) import Control.Exception (throwIO, ErrorCall(..))
import Data.ByteString
import Data.Proxy import Data.Proxy
import Data.String.Conversions
import Data.Text import Data.Text
import Network.Wai import Network.Wai
import Text.Read
import Servant.API import Servant.API
import Servant.Server import Servant.Server
@ -59,6 +56,7 @@ runServerCombinator (CI i) = i
-- | -- |
-- >>> :set -XTypeFamilies -- >>> :set -XTypeFamilies
-- >>> :{ -- >>> :{
-- import Text.Read
-- data MyCaptureCombinator -- data MyCaptureCombinator
-- instance HasServer api context => HasServer (MyCaptureCombinator :> api) context where -- instance HasServer api context => HasServer (MyCaptureCombinator :> api) context where
-- type ServerT (MyCaptureCombinator :> api) m = Int -> ServerT api m -- type ServerT (MyCaptureCombinator :> api) m = Int -> ServerT api m
@ -127,23 +125,6 @@ makeAuthCombinator = inner
withRequest $ \ request -> withRequest $ \ request ->
liftRouteResult =<< liftIO (authCheck context (protectBody "makeAuthCombinator" request)) liftRouteResult =<< liftIO (authCheck context (protectBody "makeAuthCombinator" request))
makeReqBodyCombinator ::
(HasServer api context) =>
(Context context -> IO ByteString -> arg)
-> ServerCombinator combinator (arg -> ServerT api Handler) api context
makeReqBodyCombinator = inner
where
inner ::
forall api combinator arg context .
(HasServer api context) =>
(Context context -> IO ByteString -> arg)
-> ServerCombinator combinator (arg -> ServerT api Handler) api context
inner getArg = CI $ \ Proxy context delayed ->
route (Proxy :: Proxy api) context $ addBodyCheck delayed
(return ())
(\ () -> withRequest $ \ request ->
liftRouteResult $ Route $ getArg context $ requestBody request)
makeCombinator :: makeCombinator ::
(HasServer api context) => (HasServer api context) =>
(Context context -> Request -> IO (RouteResult arg)) (Context context -> Request -> IO (RouteResult arg))
@ -159,7 +140,7 @@ makeCombinator = inner
route (Proxy :: Proxy api) context $ addBodyCheck delayed route (Proxy :: Proxy api) context $ addBodyCheck delayed
(return ()) (return ())
(\ () -> withRequest $ \ request -> (\ () -> withRequest $ \ request ->
liftRouteResult =<< liftIO (getArg context (protectBody "makeCombinator" request))) liftRouteResult =<< liftIO (getArg context request))
protectBody :: String -> Request -> Request protectBody :: String -> Request -> Request
protectBody name request = request{ protectBody name request = request{

View file

@ -284,7 +284,8 @@ data Source = Source (IO SBS.ByteString)
instance HasServer api context => HasServer (StreamRequest :> api) context where instance HasServer api context => HasServer (StreamRequest :> api) context where
type ServerT (StreamRequest :> api) m = Source -> ServerT api m type ServerT (StreamRequest :> api) m = Source -> ServerT api m
route = runServerCombinator $ makeReqBodyCombinator (const getSource) route = runServerCombinator $ makeCombinator $
\ context request -> return $ Route $ getSource $ requestBody request
getSource :: IO SBS.ByteString -> Source getSource :: IO SBS.ByteString -> Source
getSource = Source getSource = Source