From 3e2a0aad66b7567c8ed2d11214724919790462d7 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 4 Nov 2018 23:58:44 -0500 Subject: Factored Stanza.Build out of XMPPServer. --- Presence/Stanza/Build.hs | 142 ++++++++++++++++++++++++++++++++++++ Presence/Stanza/Parse.hs | 2 +- Presence/Stanza/Type.hs | 184 ----------------------------------------------- Presence/Stanza/Types.hs | 184 +++++++++++++++++++++++++++++++++++++++++++++++ Presence/XMPPServer.hs | 143 +----------------------------------- 5 files changed, 329 insertions(+), 326 deletions(-) create mode 100644 Presence/Stanza/Build.hs delete mode 100644 Presence/Stanza/Type.hs create mode 100644 Presence/Stanza/Types.hs (limited to 'Presence') diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs new file mode 100644 index 00000000..5c4d371a --- /dev/null +++ b/Presence/Stanza/Build.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +module Stanza.Build where + +import Control.Monad +import Control.Concurrent.STM +import Data.Maybe +import Data.Text (Text) +import Data.XML.Types as XML + +#ifdef THREAD_DEBUG +import Control.Concurrent.Lifted.Instrument +#else +import Control.Concurrent +import GHC.Conc (labelThread) +#endif + +import EventUtil +import LockedChan +import Stanza.Types + +makeMessage :: Text -> Text -> Text -> Text -> IO Stanza +makeMessage namespace from to bod = + stanzaFromList typ + $ [ EventBeginElement (mkname namespace "message") + [ attr "from" from + , attr "to" to + ] + , EventBeginElement (mkname namespace "body") [] + , EventContent (ContentText bod) + , EventEndElement (mkname namespace "body") + , EventEndElement (mkname namespace "message") ] + where + typ = Message { msgThread = Nothing + , msgLangMap = [("", lsm)] + } + lsm = LangSpecificMessage + { msgBody = Just bod + , msgSubject = Nothing } + +makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza +makeInformSubscription namespace from to approved = + stanzaFromList (PresenceInformSubscription approved) + $ [ EventBeginElement (mkname namespace "presence") + [ attr "from" from + , attr "to" to + , attr "type" $ if approved then "subscribed" + else "unsubscribed" ] + , EventEndElement (mkname namespace "presence")] + +makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza +makePresenceStanza namespace mjid pstat = do + stanzaFromList PresenceStatus { presenceShow = pstat + , presencePriority = Nothing + , presenceStatus = [] + , presenceWhiteList = [] + } + $ [ EventBeginElement (mkname namespace "presence") + (setFrom $ typ pstat) ] + ++ (shw pstat >>= jabberShow) ++ + [ EventEndElement (mkname namespace "presence")] + where + setFrom = maybe id + (\jid -> (attr "from" jid :) ) + mjid + typ Offline = [attr "type" "unavailable"] + typ _ = [] + shw ExtendedAway = ["xa"] + shw Chatty = ["chat"] + shw Away = ["away"] + shw DoNotDisturb = ["dnd"] + shw _ = [] + jabberShow stat = + [ EventBeginElement "{jabber:client}show" [] + , EventContent (ContentText stat) + , EventEndElement "{jabber:client}show" ] + +makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza +makeRosterUpdate tojid contact as = do + let attrs = map (uncurry attr) as + stanzaFromList Unrecognized + [ EventBeginElement "{jabber:client}iq" + [ attr "to" tojid + , attr "id" "someid" + , attr "type" "set" + ] + , EventBeginElement "{jabber:iq:roster}query" [] + , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs) + , EventEndElement "{jabber:iq:roster}item" + , EventEndElement "{jabber:iq:roster}query" + , EventEndElement "{jabber:client}iq" + ] + +makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event] +makePong namespace mid to from = + -- Note: similar to session reply + [ EventBeginElement (mkname namespace "iq") + $(case mid of + Just c -> (("id",[ContentText c]):) + _ -> id) + [ attr "type" "result" + , attr "to" to + , attr "from" from + ] + , EventEndElement (mkname namespace "iq") + ] + + +mkname :: Text -> Text -> XML.Name +mkname namespace name = (Name name (Just namespace) Nothing) + + +stanzaFromList :: StanzaType -> [Event] -> IO Stanza +stanzaFromList stype reply = do + let stanzaTag = listToMaybe reply + mid = stanzaTag >>= lookupAttrib "id" . tagAttrs + mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs + mto = stanzaTag >>= lookupAttrib "to" . tagAttrs + {- + isInternal (InternalEnableHack {}) = True + isInternal (InternalCacheId {}) = True + isInternal _ = False + -} + (donevar,replyChan,replyClsrs) <- atomically $ do + donevar <- newEmptyTMVar -- TMVar () + replyChan <- newLockedChan + replyClsrs <- newTVar (Just []) + return (donevar,replyChan, replyClsrs) + t <- forkIO $ do + forM_ reply $ atomically . writeLChan replyChan + atomically $ do putTMVar donevar () + writeTVar replyClsrs Nothing + labelThread t $ concat $ "stanza." : take 1 (words $ show stype) + return Stanza { stanzaType = stype + , stanzaId = mid + , stanzaTo = mto -- as-is from reply list + , stanzaFrom = mfrom -- as-is from reply list + , stanzaChan = replyChan + , stanzaClosers = replyClsrs + , stanzaInterrupt = donevar + , stanzaOrigin = LocalPeer + } + diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs index 50e1e25b..e2a9efdd 100644 --- a/Presence/Stanza/Parse.hs +++ b/Presence/Stanza/Parse.hs @@ -18,7 +18,7 @@ import Control.Concurrent.STM.Util import ControlMaybe (handleIO_, (<&>)) import EventUtil import Nesting -import Stanza.Type +import Stanza.Types -- | Identify an XMPP stanza based on the open-tag. grokStanza :: Text -> XML.Event -> NestingXML o IO (Maybe StanzaType) diff --git a/Presence/Stanza/Type.hs b/Presence/Stanza/Type.hs deleted file mode 100644 index 1d8041a9..00000000 --- a/Presence/Stanza/Type.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module Stanza.Type where - -import Control.Concurrent.STM -import Data.Int -import Data.Text -import Data.XML.Types as XML - -import Connection (PeerAddress(..)) -import ConnectionKey (ClientAddress(..)) -import LockedChan -import Nesting (Lang) - -type Stanza = StanzaWrap (LockedChan XML.Event) - -data StanzaWrap a = Stanza - { stanzaType :: StanzaType - , stanzaId :: Maybe Text - , stanzaTo :: Maybe Text - , stanzaFrom :: Maybe Text - , stanzaChan :: a - , stanzaClosers :: TVar (Maybe [XML.Event]) - , stanzaInterrupt :: TMVar () - , stanzaOrigin :: StanzaOrigin - } - -data StanzaOrigin = LocalPeer - | PeerOrigin PeerAddress (TChan Stanza) - | ClientOrigin ClientAddress (TChan Stanza) - -data StanzaType - = Unrecognized - | Ping - | Pong - | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id. - | SetResource - | SessionRequest - | UnrecognizedQuery Name - | RequestRoster - | Roster - | RosterEvent { rosterEventType :: RosterEventType - , rosterUser :: Text - , rosterContact :: Text } - | Error StanzaError XML.Event - | PresenceStatus { presenceShow :: JabberShow - , presencePriority :: Maybe Int8 - , presenceStatus :: [(Lang,Text)] - , presenceWhiteList :: [Text] - } - | PresenceInformError - | PresenceInformSubscription Bool - | PresenceRequestStatus - | PresenceRequestSubscription Bool - | Message { msgThread :: Maybe MessageThread - , msgLangMap :: [(Lang,LangSpecificMessage)] - } - | NotifyClientVersion { versionName :: Text - , versionVersion :: Text } - | InternalEnableHack ClientHack - | InternalCacheId Text - deriving (Show,Eq) - -data RosterEventType - = RequestedSubscription - | NewBuddy -- preceded by PresenceInformSubscription True - | RemovedBuddy -- preceded by PresenceInformSubscription False - | PendingSubscriber -- same as PresenceRequestSubscription - | NewSubscriber - | RejectSubscriber - deriving (Show,Read,Ord,Eq,Enum) - -data ClientHack = SimulatedChatErrors - deriving (Show,Read,Ord,Eq,Enum) - - -data LangSpecificMessage = - LangSpecificMessage { msgBody :: Maybe Text - , msgSubject :: Maybe Text - } - deriving (Show,Eq) - -data MessageThread = MessageThread { - msgThreadParent :: Maybe Text, - msgThreadContent :: Text - } - deriving (Show,Eq) - - -data JabberShow = Offline - | ExtendedAway - | Away - | DoNotDisturb - | Available - | Chatty - deriving (Show,Enum,Ord,Eq,Read) - -class StanzaFirstTag a where - stanzaFirstTag :: StanzaWrap a -> IO XML.Event -instance StanzaFirstTag (TChan XML.Event) where - stanzaFirstTag stanza = do - e <-atomically $ peekTChan (stanzaChan stanza) - return e -instance StanzaFirstTag (LockedChan XML.Event) where - stanzaFirstTag stanza = do - e <-atomically $ peekLChan (stanzaChan stanza) - return e -instance StanzaFirstTag XML.Event where - stanzaFirstTag stanza = return (stanzaChan stanza) - -data StanzaError - = BadRequest - | Conflict - | FeatureNotImplemented - | Forbidden - | Gone - | InternalServerError - | ItemNotFound - | JidMalformed - | NotAcceptable - | NotAllowed - | NotAuthorized - | PaymentRequired - | RecipientUnavailable - | Redirect - | RegistrationRequired - | RemoteServerNotFound - | RemoteServerTimeout - | ResourceConstraint - | ServiceUnavailable - | SubscriptionRequired - | UndefinedCondition - | UnexpectedRequest - deriving (Show,Enum,Ord,Eq) - -xep0086 :: StanzaError -> (Text, Int) -xep0086 e = case e of - BadRequest -> ("modify", 400) - Conflict -> ("cancel", 409) - FeatureNotImplemented -> ("cancel", 501) - Forbidden -> ("auth", 403) - Gone -> ("modify", 302) - InternalServerError -> ("wait", 500) - ItemNotFound -> ("cancel", 404) - JidMalformed -> ("modify", 400) - NotAcceptable -> ("modify", 406) - NotAllowed -> ("cancel", 405) - NotAuthorized -> ("auth", 401) - PaymentRequired -> ("auth", 402) - RecipientUnavailable -> ("wait", 404) - Redirect -> ("modify", 302) - RegistrationRequired -> ("auth", 407) - RemoteServerNotFound -> ("cancel", 404) - RemoteServerTimeout -> ("wait", 504) - ResourceConstraint -> ("wait", 500) - ServiceUnavailable -> ("cancel", 503) - SubscriptionRequired -> ("auth", 407) - UndefinedCondition -> ("", 500) - UnexpectedRequest -> ("wait", 400) - -errorText :: StanzaError -> Text -errorText e = case e of - BadRequest -> "Bad request" - Conflict -> "Conflict" - FeatureNotImplemented -> "This feature is not implemented" - Forbidden -> "Forbidden" - Gone -> "Recipient can no longer be contacted" - InternalServerError -> "Internal server error" - ItemNotFound -> "Item not found" - JidMalformed -> "JID Malformed" - NotAcceptable -> "Message was rejected" - NotAllowed -> "Not allowed" - NotAuthorized -> "Not authorized" - PaymentRequired -> "Payment is required" - RecipientUnavailable -> "Recipient is unavailable" - Redirect -> "Redirect" - RegistrationRequired -> "Registration required" - RemoteServerNotFound -> "Recipient's server not found" - RemoteServerTimeout -> "Remote server timeout" - ResourceConstraint -> "The server is low on resources" - ServiceUnavailable -> "The service is unavailable" - SubscriptionRequired -> "A subscription is required" - UndefinedCondition -> "Undefined condition" - UnexpectedRequest -> "Unexpected request" - diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs new file mode 100644 index 00000000..6b402f4d --- /dev/null +++ b/Presence/Stanza/Types.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE FlexibleInstances #-} +module Stanza.Types where + +import Control.Concurrent.STM +import Data.Int +import Data.Text +import Data.XML.Types as XML + +import Connection (PeerAddress(..)) +import ConnectionKey (ClientAddress(..)) +import LockedChan +import Nesting (Lang) + +type Stanza = StanzaWrap (LockedChan XML.Event) + +data StanzaWrap a = Stanza + { stanzaType :: StanzaType + , stanzaId :: Maybe Text + , stanzaTo :: Maybe Text + , stanzaFrom :: Maybe Text + , stanzaChan :: a + , stanzaClosers :: TVar (Maybe [XML.Event]) + , stanzaInterrupt :: TMVar () + , stanzaOrigin :: StanzaOrigin + } + +data StanzaOrigin = LocalPeer + | PeerOrigin PeerAddress (TChan Stanza) + | ClientOrigin ClientAddress (TChan Stanza) + +data StanzaType + = Unrecognized + | Ping + | Pong + | RequestResource (Maybe Text) (Maybe Text) -- ^ Client's name for this host followed by client's requested resource id. + | SetResource + | SessionRequest + | UnrecognizedQuery Name + | RequestRoster + | Roster + | RosterEvent { rosterEventType :: RosterEventType + , rosterUser :: Text + , rosterContact :: Text } + | Error StanzaError XML.Event + | PresenceStatus { presenceShow :: JabberShow + , presencePriority :: Maybe Int8 + , presenceStatus :: [(Lang,Text)] + , presenceWhiteList :: [Text] + } + | PresenceInformError + | PresenceInformSubscription Bool + | PresenceRequestStatus + | PresenceRequestSubscription Bool + | Message { msgThread :: Maybe MessageThread + , msgLangMap :: [(Lang,LangSpecificMessage)] + } + | NotifyClientVersion { versionName :: Text + , versionVersion :: Text } + | InternalEnableHack ClientHack + | InternalCacheId Text + deriving (Show,Eq) + +data RosterEventType + = RequestedSubscription + | NewBuddy -- preceded by PresenceInformSubscription True + | RemovedBuddy -- preceded by PresenceInformSubscription False + | PendingSubscriber -- same as PresenceRequestSubscription + | NewSubscriber + | RejectSubscriber + deriving (Show,Read,Ord,Eq,Enum) + +data ClientHack = SimulatedChatErrors + deriving (Show,Read,Ord,Eq,Enum) + + +data LangSpecificMessage = + LangSpecificMessage { msgBody :: Maybe Text + , msgSubject :: Maybe Text + } + deriving (Show,Eq) + +data MessageThread = MessageThread { + msgThreadParent :: Maybe Text, + msgThreadContent :: Text + } + deriving (Show,Eq) + + +data JabberShow = Offline + | ExtendedAway + | Away + | DoNotDisturb + | Available + | Chatty + deriving (Show,Enum,Ord,Eq,Read) + +class StanzaFirstTag a where + stanzaFirstTag :: StanzaWrap a -> IO XML.Event +instance StanzaFirstTag (TChan XML.Event) where + stanzaFirstTag stanza = do + e <-atomically $ peekTChan (stanzaChan stanza) + return e +instance StanzaFirstTag (LockedChan XML.Event) where + stanzaFirstTag stanza = do + e <-atomically $ peekLChan (stanzaChan stanza) + return e +instance StanzaFirstTag XML.Event where + stanzaFirstTag stanza = return (stanzaChan stanza) + +data StanzaError + = BadRequest + | Conflict + | FeatureNotImplemented + | Forbidden + | Gone + | InternalServerError + | ItemNotFound + | JidMalformed + | NotAcceptable + | NotAllowed + | NotAuthorized + | PaymentRequired + | RecipientUnavailable + | Redirect + | RegistrationRequired + | RemoteServerNotFound + | RemoteServerTimeout + | ResourceConstraint + | ServiceUnavailable + | SubscriptionRequired + | UndefinedCondition + | UnexpectedRequest + deriving (Show,Enum,Ord,Eq) + +xep0086 :: StanzaError -> (Text, Int) +xep0086 e = case e of + BadRequest -> ("modify", 400) + Conflict -> ("cancel", 409) + FeatureNotImplemented -> ("cancel", 501) + Forbidden -> ("auth", 403) + Gone -> ("modify", 302) + InternalServerError -> ("wait", 500) + ItemNotFound -> ("cancel", 404) + JidMalformed -> ("modify", 400) + NotAcceptable -> ("modify", 406) + NotAllowed -> ("cancel", 405) + NotAuthorized -> ("auth", 401) + PaymentRequired -> ("auth", 402) + RecipientUnavailable -> ("wait", 404) + Redirect -> ("modify", 302) + RegistrationRequired -> ("auth", 407) + RemoteServerNotFound -> ("cancel", 404) + RemoteServerTimeout -> ("wait", 504) + ResourceConstraint -> ("wait", 500) + ServiceUnavailable -> ("cancel", 503) + SubscriptionRequired -> ("auth", 407) + UndefinedCondition -> ("", 500) + UnexpectedRequest -> ("wait", 400) + +errorText :: StanzaError -> Text +errorText e = case e of + BadRequest -> "Bad request" + Conflict -> "Conflict" + FeatureNotImplemented -> "This feature is not implemented" + Forbidden -> "Forbidden" + Gone -> "Recipient can no longer be contacted" + InternalServerError -> "Internal server error" + ItemNotFound -> "Item not found" + JidMalformed -> "JID Malformed" + NotAcceptable -> "Message was rejected" + NotAllowed -> "Not allowed" + NotAuthorized -> "Not authorized" + PaymentRequired -> "Payment is required" + RecipientUnavailable -> "Recipient is unavailable" + Redirect -> "Redirect" + RegistrationRequired -> "Registration required" + RemoteServerNotFound -> "Recipient's server not found" + RemoteServerTimeout -> "Remote server timeout" + ResourceConstraint -> "The server is low on resources" + ServiceUnavailable -> "The service is unavailable" + SubscriptionRequired -> "A subscription is required" + UndefinedCondition -> "Undefined condition" + UnexpectedRequest -> "Unexpected request" + diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 11a27660..a102ed5a 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -102,8 +102,9 @@ import qualified System.Random import Data.Void (Void) import DPut import DebugTag -import Stanza.Type +import Stanza.Build import Stanza.Parse +import Stanza.Types -- peerport :: PortNumber -- peerport = 5269 @@ -450,36 +451,6 @@ sendReply donevar stype reply replychan = do liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing -- liftIO $ wlog "finished reply stanza" -stanzaFromList :: StanzaType -> [Event] -> IO Stanza -stanzaFromList stype reply = do - let stanzaTag = listToMaybe reply - mid = stanzaTag >>= lookupAttrib "id" . tagAttrs - mfrom = stanzaTag >>= lookupAttrib "from" . tagAttrs - mto = stanzaTag >>= lookupAttrib "to" . tagAttrs - {- - isInternal (InternalEnableHack {}) = True - isInternal (InternalCacheId {}) = True - isInternal _ = False - -} - (donevar,replyChan,replyClsrs) <- atomically $ do - donevar <- newEmptyTMVar -- TMVar () - replyChan <- newLockedChan - replyClsrs <- newTVar (Just []) - return (donevar,replyChan, replyClsrs) - forkIO $ do - forM_ reply $ atomically . writeLChan replyChan - atomically $ do putTMVar donevar () - writeTVar replyClsrs Nothing - return Stanza { stanzaType = stype - , stanzaId = mid - , stanzaTo = mto -- as-is from reply list - , stanzaFrom = mfrom -- as-is from reply list - , stanzaChan = replyChan - , stanzaClosers = replyClsrs - , stanzaInterrupt = donevar - , stanzaOrigin = LocalPeer - } - {- @@ -492,95 +463,6 @@ C->Unrecognized -} -mkname :: Text -> Text -> XML.Name -mkname namespace name = (Name name (Just namespace) Nothing) - -makeMessage :: Text -> Text -> Text -> Text -> IO Stanza -makeMessage namespace from to bod = - stanzaFromList typ - $ [ EventBeginElement (mkname namespace "message") - [ attr "from" from - , attr "to" to - ] - , EventBeginElement (mkname namespace "body") [] - , EventContent (ContentText bod) - , EventEndElement (mkname namespace "body") - , EventEndElement (mkname namespace "message") ] - where - typ = Message { msgThread = Nothing - , msgLangMap = [("", lsm)] - } - lsm = LangSpecificMessage - { msgBody = Just bod - , msgSubject = Nothing } - -makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza -makeInformSubscription namespace from to approved = - stanzaFromList (PresenceInformSubscription approved) - $ [ EventBeginElement (mkname namespace "presence") - [ attr "from" from - , attr "to" to - , attr "type" $ if approved then "subscribed" - else "unsubscribed" ] - , EventEndElement (mkname namespace "presence")] - -makePresenceStanza :: Text -> Maybe Text -> JabberShow -> IO Stanza -makePresenceStanza namespace mjid pstat = do - stanzaFromList PresenceStatus { presenceShow = pstat - , presencePriority = Nothing - , presenceStatus = [] - , presenceWhiteList = [] - } - $ [ EventBeginElement (mkname namespace "presence") - (setFrom $ typ pstat) ] - ++ (shw pstat >>= jabberShow) ++ - [ EventEndElement (mkname namespace "presence")] - where - setFrom = maybe id - (\jid -> (attr "from" jid :) ) - mjid - typ Offline = [attr "type" "unavailable"] - typ _ = [] - shw ExtendedAway = ["xa"] - shw Chatty = ["chat"] - shw Away = ["away"] - shw DoNotDisturb = ["dnd"] - shw _ = [] - jabberShow stat = - [ EventBeginElement "{jabber:client}show" [] - , EventContent (ContentText stat) - , EventEndElement "{jabber:client}show" ] - -makeRosterUpdate :: Text -> Text -> [(Name, Text)] -> IO Stanza -makeRosterUpdate tojid contact as = do - let attrs = map (uncurry attr) as - stanzaFromList Unrecognized - [ EventBeginElement "{jabber:client}iq" - [ attr "to" tojid - , attr "id" "someid" - , attr "type" "set" - ] - , EventBeginElement "{jabber:iq:roster}query" [] - , EventBeginElement "{jabber:iq:roster}item" (attr "jid" contact : attrs) - , EventEndElement "{jabber:iq:roster}item" - , EventEndElement "{jabber:iq:roster}query" - , EventEndElement "{jabber:client}iq" - ] - -makePong :: Text -> Maybe Text -> Text -> Text -> [XML.Event] -makePong namespace mid to from = - -- Note: similar to session reply - [ EventBeginElement (mkname namespace "iq") - $(case mid of - Just c -> (("id",[ContentText c]):) - _ -> id) - [ attr "type" "result" - , attr "to" to - , attr "from" from - ] - , EventEndElement (mkname namespace "iq") - ] - xmppInbound :: ConnectionData -> XMPPServerParameters -- ^ XXX: unused -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin) @@ -1549,24 +1431,3 @@ forkXmpp XMPPServer { _xmpp_sv = sv return mt -#if MIN_VERSION_stm(2,4,0) -#else --- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the --- same content available as the original channel. --- --- Terrible inefficient implementation provided to build against older libraries. -cloneTChan :: TChan a -> STM (TChan a) -cloneTChan chan = do - contents <- chanContents' chan - chan2 <- dupTChan chan - mapM_ (writeTChan chan) contents - return chan2 - where - chanContents' chan = do - b <- isEmptyTChan chan - if b then return [] else do - x <- readTChan chan - xs <- chanContents' chan - return (x:xs) -#endif - -- cgit v1.2.3