servant/servant-conduit/src/Servant/Conduit.hs

73 lines
2.8 KiB
Haskell
Raw Normal View History

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | This module exports 'ToSourceIO' and 'FromSourceIO' for 'ConduitT' instances.
module Servant.Conduit (
ConduitToSourceIO (..),
) where
import Control.Monad.IO.Class
(MonadIO (..))
import Control.Monad.IO.Unlift
(MonadUnliftIO (..))
import Control.Monad.Trans.Resource
(ResourceT, runResourceT)
import Data.Conduit.Internal
(ConduitT (..), Pipe (..))
import Servant.API.Stream
import qualified Servant.Types.SourceT as S
-- | Helper class to implement @'ToSourceIO' 'ConduitT'@ instance
-- for various monads.
class ConduitToSourceIO m where
conduitToSourceIO :: ConduitT i o m () -> SourceIO o
instance ConduitToSourceIO IO where
conduitToSourceIO (ConduitT con) = S.SourceT ($ go (con Done)) where
go p0 = case p0 of
Done () -> S.Stop
HaveOutput p o -> S.Yield o (go p)
NeedInput _ip up -> S.Skip (go (up ()))
PipeM m -> S.Effect $ fmap go m
Leftover p _l -> S.Skip (go p)
instance m ~ IO => ConduitToSourceIO (ResourceT m) where
conduitToSourceIO (ConduitT con) =
S.SourceT $ \k ->
runResourceT $ withRunInIO $ \runRes ->
k (go runRes (con Done))
where
go :: (forall x. ResourceT m x -> m x)
-> Pipe i i o () (ResourceT m) ()
-> S.StepT IO o
go _ (Done ()) = S.Stop
go runRes (HaveOutput p o) = S.Yield o (go runRes p)
go runRes (NeedInput _ip up) = S.Skip (go runRes (up ()))
go runRes (PipeM m) = S.Effect $ runRes $ fmap (go runRes) m
go runRes (Leftover p _l) = S.Skip (go runRes p)
instance (ConduitToSourceIO m, r ~ ())
=> ToSourceIO o (ConduitT i o m r)
where
toSourceIO = conduitToSourceIO
instance (MonadIO m, r ~ ()) => FromSourceIO o (ConduitT i o m r) where
fromSourceIO src =
ConduitT $ \con ->
PipeM $ liftIO $ S.unSourceT src $ \step ->
loop con step
where
loop :: MonadIO m => (() -> Pipe i i o () m b) -> S.StepT IO o -> IO (Pipe i i o () m b)
loop con S.Stop = return (con ())
loop _con (S.Error err) = fail err
loop con (S.Skip s) = loop con s
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 () #-}