From 162712d7d5894d514954d5278859a85bee3d1acb Mon Sep 17 00:00:00 2001 From: Shea Levy Date: Fri, 17 Mar 2023 11:19:54 -0400 Subject: [PATCH] fromSourceIO: Run in IO. Needed for stateful initialization like io-streams. --- changelog.d/1661 | 15 +++++++++++++++ .../src/Servant/Client/Core/HasClient.hs | 4 ++-- servant-conduit/src/Servant/Conduit.hs | 4 ++-- servant-machines/src/Servant/Machines.hs | 4 ++-- servant-pipes/src/Servant/Pipes.hs | 6 +++--- servant-server/src/Servant/Server/Internal.hs | 7 +++---- servant/src/Servant/API/Stream.hs | 4 ++-- 7 files changed, 29 insertions(+), 15 deletions(-) create mode 100644 changelog.d/1661 diff --git a/changelog.d/1661 b/changelog.d/1661 new file mode 100644 index 000000000..1e12827db --- /dev/null +++ b/changelog.d/1661 @@ -0,0 +1,15 @@ +synopsis: Make fromSourceIO run in IO +prs: #1661 + +description: { + +Some streaming abstractions, like io-streams, require stateful +initialization. Since all actual call sites of `fromSourceIO` +are in a context where `IO` actions can be executed, these +streaming sources can be accomodated by having letting +`fromSourceIO` run in `IO`. + +To migrate your existing `FromSourceIO` instance, simply put +a `pure`/`return` in front of it. + +} diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index 1003f8ff4..eb76b253c 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -428,7 +428,7 @@ instance {-# OVERLAPPABLE #-} clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' - return $ fromSourceIO $ framingUnrender' $ responseBody gres + fromSourceIO $ framingUnrender' $ responseBody gres where req' = req { requestAccept = fromList [contentType (Proxy :: Proxy ct)] @@ -448,7 +448,7 @@ instance {-# OVERLAPPING #-} clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' - val = fromSourceIO $ framingUnrender' $ responseBody gres + val <- fromSourceIO $ framingUnrender' $ responseBody gres return $ Headers { getResponse = val , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres diff --git a/servant-conduit/src/Servant/Conduit.hs b/servant-conduit/src/Servant/Conduit.hs index b3fdc4e1a..7a348d769 100644 --- a/servant-conduit/src/Servant/Conduit.hs +++ b/servant-conduit/src/Servant/Conduit.hs @@ -57,7 +57,7 @@ instance (ConduitToSourceIO m, r ~ ()) toSourceIO = conduitToSourceIO instance (MonadIO m, r ~ ()) => FromSourceIO o (ConduitT i o m r) where - fromSourceIO src = + fromSourceIO src = return $ ConduitT $ \con -> PipeM $ liftIO $ S.unSourceT src $ \step -> loop con step @@ -69,4 +69,4 @@ instance (MonadIO m, r ~ ()) => FromSourceIO o (ConduitT i o m r) where loop con (S.Effect ms) = ms >>= loop con loop con (S.Yield x s) = return (HaveOutput (PipeM (liftIO $ loop con s)) x) - {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> ConduitT i o IO () #-} + {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> IO (ConduitT i o IO ()) #-} diff --git a/servant-machines/src/Servant/Machines.hs b/servant-machines/src/Servant/Machines.hs index a0d6d8b9d..3f3a94398 100644 --- a/servant-machines/src/Servant/Machines.hs +++ b/servant-machines/src/Servant/Machines.hs @@ -35,7 +35,7 @@ instance MachineToSourceIO m => ToSourceIO o (MachineT m k o) where toSourceIO = machineToSourceIO instance MonadIO m => FromSourceIO o (MachineT m k o) where - fromSourceIO src = MachineT $ liftIO $ S.unSourceT src go + fromSourceIO src = return $ MachineT $ liftIO $ S.unSourceT src go where go :: S.StepT IO o -> IO (Step k o (MachineT m k o)) go S.Stop = return Stop @@ -43,4 +43,4 @@ instance MonadIO m => FromSourceIO o (MachineT m k o) where go (S.Skip s) = go s go (S.Effect ms) = ms >>= go go (S.Yield x s) = return (Yield x (MachineT (liftIO (go s)))) - {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> MachineT IO k o #-} + {-# SPECIALIZE INLINE fromSourceIO :: SourceIO o -> IO (MachineT IO k o) #-} diff --git a/servant-pipes/src/Servant/Pipes.hs b/servant-pipes/src/Servant/Pipes.hs index d3dad4476..3ee499e34 100644 --- a/servant-pipes/src/Servant/Pipes.hs +++ b/servant-pipes/src/Servant/Pipes.hs @@ -62,14 +62,14 @@ instance PipesToSourceIO m => ToSourceIO a (ListT m a) where instance (MonadIO m, a' ~ X, a ~ (), b' ~ (), r ~ ()) => FromSourceIO b (Proxy a' a b' b m r) where - fromSourceIO src = M $ liftIO $ S.unSourceT src (return . go) where + fromSourceIO src = pure $ M $ liftIO $ S.unSourceT src (return . go) where go :: S.StepT IO b -> Proxy X () () b m () go S.Stop = Pure () go (S.Error err) = M (liftIO (fail err)) go (S.Skip s) = go s -- drives go (S.Effect ms) = M (liftIO (fmap go ms)) go (S.Yield x s) = Respond x (const (go s)) - {-# SPECIALIZE INLINE fromSourceIO :: SourceIO x -> Proxy X () () x IO () #-} + {-# SPECIALIZE INLINE fromSourceIO :: SourceIO x -> IO (Proxy X () () x IO ()) #-} instance MonadIO m => FromSourceIO a (ListT m a) where - fromSourceIO = Select . fromSourceIO + fromSourceIO src = Select <$> liftIO (fromSourceIO src) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 8a9e511b9..c3a7a2c32 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -752,18 +752,17 @@ instance route Proxy context subserver = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where - ctCheck :: DelayedIO (SourceIO chunk -> a) + ctCheck :: DelayedIO (SourceIO chunk -> IO a) -- TODO: do content-type check ctCheck = return fromSourceIO - bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a + bodyCheck :: (SourceIO chunk -> IO a) -> DelayedIO a bodyCheck fromRS = withRequest $ \req -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk let body = getRequestBodyChunk req let rs = S.fromAction B.null body - let rs' = fromRS $ framingUnrender' rs - return rs' + liftIO $ fromRS $ framingUnrender' rs -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @api@. diff --git a/servant/src/Servant/API/Stream.hs b/servant/src/Servant/API/Stream.hs index 6f6a59cfb..f9642a508 100644 --- a/servant/src/Servant/API/Stream.hs +++ b/servant/src/Servant/API/Stream.hs @@ -113,10 +113,10 @@ instance ToSourceIO a [a] where -- Pipe, etc. By implementing this class, all such streaming abstractions can -- be used directly on the client side for talking to streaming endpoints. class FromSourceIO chunk a | a -> chunk where - fromSourceIO :: SourceIO chunk -> a + fromSourceIO :: SourceIO chunk -> IO a instance MonadIO m => FromSourceIO a (SourceT m a) where - fromSourceIO = sourceFromSourceIO + fromSourceIO = return . sourceFromSourceIO sourceFromSourceIO :: forall m a. MonadIO m => SourceT IO a -> SourceT m a sourceFromSourceIO src =