Merge pull request #1661 from shlevy/FromSourceIO-IO

fromSourceIO: Run in IO.

Author: ysangkok

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.
+
+}

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

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 ()) #-}

servant-machines/src/Servant/Machines.hs

@@ -35,12 +35,12 @@ 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
         go (S.Error err) = fail err
         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) #-}

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)

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@.

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 =