From 7ccaa169bc2309df7df2db118dd646177867f2b0 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 12 Feb 2014 20:35:52 -0500 Subject: Reply to pings with pongs. --- Data/Conduit/Lift.hs | 526 ++++++++++++++++++++++++++++++++++++++++++++++++++ Presence/EventUtil.hs | 34 ++++ Presence/Nesting.hs | 79 ++++++++ xmppServer.hs | 64 ++++-- 4 files changed, 689 insertions(+), 14 deletions(-) create mode 100644 Data/Conduit/Lift.hs create mode 100644 Presence/Nesting.hs diff --git a/Data/Conduit/Lift.hs b/Data/Conduit/Lift.hs new file mode 100644 index 00000000..341fce53 --- /dev/null +++ b/Data/Conduit/Lift.hs @@ -0,0 +1,526 @@ + + +{-# LANGUAGE RankNTypes #-} +-- | Allow monad transformers to be run/eval/exec in a section of conduit +-- rather then needing to run across the whole conduit. The circumvents many +-- of the problems with breaking the monad transformer laws. For more +-- information, see the announcement blog post: +-- +-- +-- This module was added in conduit 1.0.11. +module Data.Conduit.Lift ( + -- * ErrorT + errorC, + runErrorC, + catchErrorC, +-- liftCatchError, + + -- * MaybeT + maybeC, + runMaybeC, + + -- * ReaderT + readerC, + runReaderC, + + -- * StateT + stateC, + runStateC, + evalStateC, + execStateC, + + -- ** Strict + stateSC, + runStateSC, + evalStateSC, + execStateSC, + + -- * WriterT + writerC, + runWriterC, + execWriterC, + + -- ** Strict + writerSC, + runWriterSC, + execWriterSC, + + -- * RWST + rwsC, + runRWSC, + evalRWSC, + execRWSC, + + -- ** Strict + rwsSC, + runRWSSC, + evalRWSSC, + execRWSSC, + + -- * Utilities + + distribute + ) where + +import Data.Conduit +import Data.Conduit.Internal (ConduitM (..), Pipe (..)) + +import Control.Monad.Morph (hoist, lift, MFunctor(..), ) +import Control.Monad.Trans.Class (MonadTrans(..)) + +import Data.Monoid (Monoid(..)) + + +import qualified Control.Monad.Trans.Error as E +import qualified Control.Monad.Trans.Maybe as M +import qualified Control.Monad.Trans.Reader as R + +import qualified Control.Monad.Trans.State.Strict as SS +import qualified Control.Monad.Trans.Writer.Strict as WS +import qualified Control.Monad.Trans.RWS.Strict as RWSS + +import qualified Control.Monad.Trans.State.Lazy as SL +import qualified Control.Monad.Trans.Writer.Lazy as WL +import qualified Control.Monad.Trans.RWS.Lazy as RWSL + + +catAwaitLifted + :: (Monad (t (ConduitM o1 o m)), Monad m, MonadTrans t) => + ConduitM i o1 (t (ConduitM o1 o m)) () +catAwaitLifted = go + where + go = do + x <- lift . lift $ await + case x of + Nothing -> return () + Just x2 -> do + yield x2 + go + +catYieldLifted + :: (Monad (t (ConduitM i o1 m)), Monad m, MonadTrans t) => + ConduitM o1 o (t (ConduitM i o1 m)) () +catYieldLifted = go + where + go = do + x <- await + case x of + Nothing -> return () + Just x2 -> do + lift . lift $ yield x2 + go + + +distribute + :: (Monad (t (ConduitM b o m)), Monad m, Monad (t m), MonadTrans t, + MFunctor t) => + ConduitM b o (t m) () -> t (ConduitM b o m) () +distribute p = catAwaitLifted =$= hoist (hoist lift) p $$ catYieldLifted + +-- | Run 'E.ErrorT' in the base monad +-- +-- Since 1.0.11 +errorC + :: (Monad m, Monad (t (E.ErrorT e m)), MonadTrans t, E.Error e, + MFunctor t) => + t m (Either e b) -> t (E.ErrorT e m) b +errorC p = do + x <- hoist lift p + lift $ E.ErrorT (return x) + +-- | Run 'E.ErrorT' in the base monad +-- +-- Since 1.0.11 +runErrorC + :: (Monad m, E.Error e) => + ConduitM i o (E.ErrorT e m) r -> ConduitM i o m (Either e r) +runErrorC = + ConduitM . go . unConduitM + where + go (Done r) = Done (Right r) + go (PipeM mp) = PipeM $ do + eres <- E.runErrorT mp + return $ case eres of + Left e -> Done $ Left e + Right p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p f o) = HaveOutput (go p) (E.runErrorT f >> return ()) o + go (NeedInput x y) = NeedInput (go . x) (go . y) +{-# INLINABLE runErrorC #-} + +-- | Catch an error in the base monad +-- +-- Since 1.0.11 +catchErrorC + :: (Monad m, E.Error e) => + ConduitM i o (E.ErrorT e m) r + -> (e -> ConduitM i o (E.ErrorT e m) r) + -> ConduitM i o (E.ErrorT e m) r +catchErrorC c0 h = + ConduitM $ go $ unConduitM c0 + where + go (Done r) = Done r + go (PipeM mp) = PipeM $ do + eres <- lift $ E.runErrorT mp + return $ case eres of + Left e -> unConduitM $ h e + Right p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p f o) = HaveOutput (go p) f o + go (NeedInput x y) = NeedInput (go . x) (go . y) +{-# INLINABLE catchErrorC #-} + +-- | Wrap the base monad in 'M.MaybeT' +-- +-- Since 1.0.11 +maybeC + :: (Monad m, Monad (t (M.MaybeT m)), + MonadTrans t, + MFunctor t) => + t m (Maybe b) -> t (M.MaybeT m) b +maybeC p = do + x <- hoist lift p + lift $ M.MaybeT (return x) +{-# INLINABLE maybeC #-} + +-- | Run 'M.MaybeT' in the base monad +-- +-- Since 1.0.11 +runMaybeC + :: Monad m => + ConduitM i o (M.MaybeT m) r -> ConduitM i o m (Maybe r) +runMaybeC = + ConduitM . go . unConduitM + where + go (Done r) = Done (Just r) + go (PipeM mp) = PipeM $ do + mres <- M.runMaybeT mp + return $ case mres of + Nothing -> Done Nothing + Just p -> go p + go (Leftover p i) = Leftover (go p) i + go (HaveOutput p c o) = HaveOutput (go p) (M.runMaybeT c >> return ()) o + go (NeedInput x y) = NeedInput (go . x) (go . y) +{-# INLINABLE runMaybeC #-} + +-- | Wrap the base monad in 'R.ReaderT' +-- +-- Since 1.0.11 +readerC + :: (Monad m, Monad (t1 (R.ReaderT t m)), + MonadTrans t1, + MFunctor t1) => + (t -> t1 m b) -> t1 (R.ReaderT t m) b +readerC k = do + i <- lift R.ask + hoist lift (k i) +{-# INLINABLE readerC #-} + +-- | Run 'R.ReaderT' in the base monad +-- +-- Since 1.0.11 +runReaderC + :: Monad m => + r -> ConduitM i o (R.ReaderT r m) res -> ConduitM i o m res +runReaderC r = hoist (`R.runReaderT` r) +{-# INLINABLE runReaderC #-} + + +-- | Wrap the base monad in 'SL.StateT' +-- +-- Since 1.0.11 +stateC + :: (Monad m, Monad (t1 (SL.StateT t m)), + MonadTrans t1, + MFunctor t1) => + (t -> t1 m (b, t)) -> t1 (SL.StateT t m) b +stateC k = do + s <- lift SL.get + (r, s') <- hoist lift (k s) + lift (SL.put s') + return r +{-# INLINABLE stateC #-} + +thread :: Monad m + => (r -> s -> res) + -> (forall a. t m a -> s -> m (a, s)) + -> s + -> ConduitM i o (t m) r + -> ConduitM i o m res +thread toRes runM s0 = + ConduitM . go s0 . unConduitM + where + go s (Done r) = Done (toRes r s) + go s (PipeM mp) = PipeM $ do + (p, s') <- runM mp s + return $ go s' p + go s (Leftover p i) = Leftover (go s p) i + go s (NeedInput x y) = NeedInput (go s . x) (go s . y) + go s (HaveOutput p f o) = HaveOutput (go s p) (runM f s >> return ()) o +{-# INLINABLE thread #-} + +-- | Run 'SL.StateT' in the base monad +-- +-- Since 1.0.11 +runStateC + :: Monad m => + s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m (r, s) +runStateC = thread (,) SL.runStateT +{-# INLINABLE runStateC #-} + +-- | Evaluate 'SL.StateT' in the base monad +-- +-- Since 1.0.11 +evalStateC + :: Monad m => + s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m r +evalStateC s p = fmap fst $ runStateC s p +{-# INLINABLE evalStateC #-} + +-- | Execute 'SL.StateT' in the base monad +-- +-- Since 1.0.11 +execStateC + :: Monad m => + s -> ConduitM i o (SL.StateT s m) r -> ConduitM i o m s +execStateC s p = fmap snd $ runStateC s p +{-# INLINABLE execStateC #-} + + +-- | Wrap the base monad in 'SS.StateT' +-- +-- Since 1.0.11 +stateSC + :: (Monad m, Monad (t1 (SS.StateT t m)), + MonadTrans t1, + MFunctor t1) => + (t -> t1 m (b, t)) -> t1 (SS.StateT t m) b +stateSC k = do + s <- lift SS.get + (r, s') <- hoist lift (k s) + lift (SS.put s') + return r +{-# INLINABLE stateSC #-} + +-- | Run 'SS.StateT' in the base monad +-- +-- Since 1.0.11 +runStateSC + :: Monad m => + s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m (r, s) +runStateSC = thread (,) SS.runStateT +{-# INLINABLE runStateSC #-} + +-- | Evaluate 'SS.StateT' in the base monad +-- +-- Since 1.0.11 +evalStateSC + :: Monad m => + s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m r +evalStateSC s p = fmap fst $ runStateSC s p +{-# INLINABLE evalStateSC #-} + +-- | Execute 'SS.StateT' in the base monad +-- +-- Since 1.0.11 +execStateSC + :: Monad m => + s -> ConduitM i o (SS.StateT s m) r -> ConduitM i o m s +execStateSC s p = fmap snd $ runStateSC s p +{-# INLINABLE execStateSC #-} + + +-- | Wrap the base monad in 'WL.WriterT' +-- +-- Since 1.0.11 +writerC + :: (Monad m, Monad (t (WL.WriterT w m)), MonadTrans t, Monoid w, + MFunctor t) => + t m (b, w) -> t (WL.WriterT w m) b +writerC p = do + (r, w) <- hoist lift p + lift $ WL.tell w + return r +{-# INLINABLE writerC #-} + +-- | Run 'WL.WriterT' in the base monad +-- +-- Since 1.0.11 +runWriterC + :: (Monad m, Monoid w) => + ConduitM i o (WL.WriterT w m) r -> ConduitM i o m (r, w) +runWriterC = thread (,) run mempty + where + run m w = do + (a, w') <- WL.runWriterT m + return (a, w `mappend` w') +{-# INLINABLE runWriterC #-} + +-- | Execute 'WL.WriterT' in the base monad +-- +-- Since 1.0.11 +execWriterC + :: (Monad m, Monoid w) => + ConduitM i o (WL.WriterT w m) r -> ConduitM i o m w +execWriterC p = fmap snd $ runWriterC p +{-# INLINABLE execWriterC #-} + + +-- | Wrap the base monad in 'WS.WriterT' +-- +-- Since 1.0.11 +writerSC + :: (Monad m, Monad (t (WS.WriterT w m)), MonadTrans t, Monoid w, + MFunctor t) => + t m (b, w) -> t (WS.WriterT w m) b +writerSC p = do + (r, w) <- hoist lift p + lift $ WS.tell w + return r +{-# INLINABLE writerSC #-} + +-- | Run 'WS.WriterT' in the base monad +-- +-- Since 1.0.11 +runWriterSC + :: (Monad m, Monoid w) => + ConduitM i o (WS.WriterT w m) r -> ConduitM i o m (r, w) +runWriterSC = thread (,) run mempty + where + run m w = do + (a, w') <- WS.runWriterT m + return (a, w `mappend` w') +{-# INLINABLE runWriterSC #-} + +-- | Execute 'WS.WriterT' in the base monad +-- +-- Since 1.0.11 +execWriterSC + :: (Monad m, Monoid w) => + ConduitM i o (WS.WriterT w m) r -> ConduitM i o m w +execWriterSC p = fmap snd $ runWriterSC p +{-# INLINABLE execWriterSC #-} + + +-- | Wrap the base monad in 'RWSL.RWST' +-- +-- Since 1.0.11 +rwsC + :: (Monad m, Monad (t1 (RWSL.RWST t w t2 m)), MonadTrans t1, + Monoid w, MFunctor t1) => + (t -> t2 -> t1 m (b, t2, w)) -> t1 (RWSL.RWST t w t2 m) b +rwsC k = do + i <- lift RWSL.ask + s <- lift RWSL.get + (r, s', w) <- hoist lift (k i s) + lift $ do + RWSL.put s' + RWSL.tell w + return r +{-# INLINABLE rwsC #-} + +-- | Run 'RWSL.RWST' in the base monad +-- +-- Since 1.0.11 +runRWSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitM i o (RWSL.RWST r w s m) res + -> ConduitM i o m (res, s, w) +runRWSC r s0 = thread toRes run (s0, mempty) + where + toRes a (s, w) = (a, s, w) + run m (s, w) = do + (res, s', w') <- RWSL.runRWST m r s + return (res, (s', w `mappend` w')) +{-# INLINABLE runRWSC #-} + +-- | Evaluate 'RWSL.RWST' in the base monad +-- +-- Since 1.0.11 +evalRWSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitM i o (RWSL.RWST r w s m) res + -> ConduitM i o m (res, w) +evalRWSC i s p = fmap f $ runRWSC i s p + where f x = let (r, _, w) = x in (r, w) +{-# INLINABLE evalRWSC #-} + +-- | Execute 'RWSL.RWST' in the base monad +-- +-- Since 1.0.11 +execRWSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitM i o (RWSL.RWST r w s m) res + -> ConduitM i o m (s, w) +execRWSC i s p = fmap f $ runRWSC i s p + where f x = let (_, s2, w2) = x in (s2, w2) +{-# INLINABLE execRWSC #-} + + +-- | Wrap the base monad in 'RWSS.RWST' +-- +-- Since 1.0.11 +rwsSC + :: (Monad m, Monad (t1 (RWSS.RWST t w t2 m)), MonadTrans t1, + Monoid w, MFunctor t1) => + (t -> t2 -> t1 m (b, t2, w)) -> t1 (RWSS.RWST t w t2 m) b +rwsSC k = do + i <- lift RWSS.ask + s <- lift RWSS.get + (r, s', w) <- hoist lift (k i s) + lift $ do + RWSS.put s' + RWSS.tell w + return r +{-# INLINABLE rwsSC #-} + +-- | Run 'RWSS.RWST' in the base monad +-- +-- Since 1.0.11 +runRWSSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitM i o (RWSS.RWST r w s m) res + -> ConduitM i o m (res, s, w) +runRWSSC r s0 = thread toRes run (s0, mempty) + where + toRes a (s, w) = (a, s, w) + run m (s, w) = do + (res, s', w') <- RWSS.runRWST m r s + return (res, (s', w `mappend` w')) +{-# INLINABLE runRWSSC #-} + +-- | Evaluate 'RWSS.RWST' in the base monad +-- +-- Since 1.0.11 +evalRWSSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitM i o (RWSS.RWST r w s m) res + -> ConduitM i o m (res, w) +evalRWSSC i s p = fmap f $ runRWSSC i s p + where f x = let (r, _, w) = x in (r, w) +{-# INLINABLE evalRWSSC #-} + +-- | Execute 'RWSS.RWST' in the base monad +-- +-- Since 1.0.11 +execRWSSC + :: (Monad m, Monoid w) => + r + -> s + -> ConduitM i o (RWSS.RWST r w s m) res + -> ConduitM i o m (s, w) +execRWSSC i s p = fmap f $ runRWSSC i s p + where f x = let (_, s2, w2) = x in (s2, w2) +{-# INLINABLE execRWSSC #-} + + diff --git a/Presence/EventUtil.hs b/Presence/EventUtil.hs index e62f8afc..bdea9fa2 100644 --- a/Presence/EventUtil.hs +++ b/Presence/EventUtil.hs @@ -3,6 +3,7 @@ module EventUtil where import Control.Monad import Data.XML.Types as XML +import qualified Data.List as List getStreamName (EventBeginElement name _) = name @@ -21,3 +22,36 @@ elementAttrs _ _ = mzero streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream") attr name value = (name,[ContentText value]) + +isServerIQOf (EventBeginElement name attrs) testType + | name=="{jabber:server}iq" + && matchAttrib "type" testType attrs + = True +isServerIQOf _ _ = False + +matchAttrib name value attrs = + case List.find ( (==name) . fst) attrs of + Just (_,[ContentText x]) | x==value -> True + Just (_,[ContentEntity x]) | x==value -> True + _ -> False + +lookupAttrib name attrs = + case List.find ( (==name) . fst) attrs of + Just (_,[ContentText x]) -> Just x + Just (_,[ContentEntity x]) -> Just x + _ -> Nothing + +tagAttrs (EventBeginElement _ xs) = xs +tagAttrs _ = [] + + +{- +iqTypeSet = "set" +iqTypeGet = "get" +iqTypeResult = "result" +iqTypeError = "error" +-} + + +tagName (EventBeginElement n _) = n +tagName _ = "" diff --git a/Presence/Nesting.hs b/Presence/Nesting.hs new file mode 100644 index 00000000..24f9baad --- /dev/null +++ b/Presence/Nesting.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Nesting where + +import Data.Conduit +import Data.Conduit.Lift +import Data.XML.Types +import qualified Data.Text as S +import Control.Monad.State +import qualified Data.List as List + +type Lang = S.Text + +data StrictList a = a :! !(StrictList a) | StrictNil + +data XMLState = XMLState { + nestingLevel :: Int, + langStack :: StrictList (Int,Lang) +} + +type NestingXML o m a = ConduitM Event o (StateT XMLState m) a + +doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r +doNestingXML m = + evalStateC (XMLState 0 StrictNil) (trackNesting =$= m) + +nesting :: Monad m => NestingXML o m Int +nesting = lift $ (return . nestingLevel) =<< get + + +trackNesting :: Monad m => ConduitM Event Event (StateT XMLState m) () +trackNesting = awaitForever doit + where + doit xml = do + XMLState lvl langs <- lift get + lift . put $ case xml of + EventBeginElement _ attrs -> + case lookupLang attrs of + Nothing -> XMLState (lvl+1) langs + Just lang -> XMLState (lvl+1) ( (lvl+1,lang) :! langs) + EventEndElement _ -> + case langs of + (llvl,_) :! ls | llvl==lvl -> XMLState (lvl-1) ls + _ | otherwise -> XMLState (lvl-1) langs + _ -> XMLState lvl langs + yield xml + + +lookupLang attrs = + case List.find ( (=="xml:lang") . fst) attrs of + Just (_,[ContentText x]) -> Just x + Just (_,[ContentEntity x]) -> Just x + _ -> Nothing + + +awaitCloser :: Monad m => Int -> NestingXML o m () +awaitCloser lvl = do + fix $ \loop -> do + lvl' <- nesting + when (lvl' >= lvl) $ do + xml <- await + maybe (return ()) (const loop) xml + +withXML f = await >>= maybe (return ()) f + +nextElement :: Monad m => NestingXML o m (Maybe Event) +nextElement = do + lvl <- nesting + fix $ \loop -> do + xml <- await + case xml of + Nothing -> return Nothing + Just (EventBeginElement _ _) -> do + return xml + Just _ -> do + lvl' <- nesting + if (lvl'>=lvl) then loop + else return Nothing + diff --git a/xmppServer.hs b/xmppServer.hs index 85e0cb5c..f91c20ce 100644 --- a/xmppServer.hs +++ b/xmppServer.hs @@ -23,14 +23,14 @@ import Data.Conduit.Blaze (builderToByteStringFlush) import qualified Text.XML.Stream.Render as XML import qualified Text.XML.Stream.Parse as XML import Data.XML.Types as XML -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes,fromJust) import Data.Monoid ( (<>) ) import Data.Text (Text) import qualified Data.Text as Text (pack) import qualified Control.Concurrent.STM.UpdateStream as Slotted import ControlMaybe -import NestingXML +import Nesting import EventUtil import Server @@ -80,6 +80,17 @@ type WriteCommand = ByteString -> IO Bool data Stanza = UnrecognizedStanza { stanzaChan :: TChan (Maybe XML.Event) } + | PingStanza { stanzaId :: Maybe Text + , stanzaChan :: TChan (Maybe XML.Event) } + | PongStanza { -- stanzaId :: Maybe Text + stanzaChan :: TChan (Maybe XML.Event) } + +copyToChannel f chan = awaitForever copy + where + copy x = do + liftIO . atomically $ writeTChan chan (f x) + yield x + prettyPrint prefix xs = liftIO $ @@ -88,6 +99,19 @@ prettyPrint prefix xs = =$= CB.lines $$ CL.mapM_ (wlogb . (prefix <>)) +grockStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe (TChan (Maybe Event) -> Stanza)) +grockStanzaIQGet stanza = do + let mid = lookupAttrib "id" (tagAttrs stanza) + -- mfrom = lookupAttrib "from" (tagAttrs stanza) + mtag <- nextElement + flip (maybe $ return Nothing) mtag $ \tag -> do + case tagName tag of + "{urn:xmpp:ping}ping" -> do + return $ Just (PingStanza mid) + _ -> return Nothing + +ioWriteChan c v = liftIO . atomically $ writeTChan c v + xmppInbound :: ConnectionKey -> FlagCommand -> Source IO XML.Event -> TChan Stanza @@ -99,18 +123,30 @@ xmppInbound k pingflag src stanzas output = doNestingXML $ do whenJust nextElement $ \xml -> do withJust (elementAttrs "stream" xml) $ \stream_attrs -> do fix $ \loop -> do - -- liftIO . wlog $ "waiting for stanza." - chan <- liftIO $ atomically newTChan - whenJust nextElement $ \stanza -> do - stanza_lvl <- nesting - liftIO . atomically $ writeTChan chan (Just stanza) - - liftIO . atomically $ writeTChan stanzas $ - UnrecognizedStanza chan - doUntilCloser stanza_lvl $ \xml -> do - liftIO . atomically $ writeTChan chan (Just xml) - liftIO . atomically $ writeTChan chan Nothing - loop + -- liftIO . wlog $ "waiting for stanza." + chan <- liftIO $ atomically newTChan + whenJust nextElement $ \stanza -> do + stanza_lvl <- nesting + ioWriteChan chan (Just stanza) + copyToChannel Just chan =$= do + dispatch <- + case () of + _ | stanza `isServerIQOf` "get" -> grockStanzaIQGet stanza + _ -> return $ Just UnrecognizedStanza + flip (maybe $ return ()) dispatch $ \dispatch -> + case dispatch chan of + d@(PingStanza {}) -> do + let to = "todo" + from = "todo" + let pong = peerPong (stanzaId d) to from + pongChan <- liftIO $ atomically newTChan + ioWriteChan output (PongStanza pongChan) + mapM_ (ioWriteChan pongChan . Just) pong + ioWriteChan pongChan Nothing + disp -> ioWriteChan stanzas disp + awaitCloser stanza_lvl + ioWriteChan chan Nothing + loop chanContents :: TChan x -> IO [x] -- cgit v1.2.3