Export non-ResourceT interface to xmppServer.

1 files changed, 17 insertions, 12 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 774fe886..a1221b6c 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -3,8 +3,10 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleInstances #-} -- instance for TChan Event
 {-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE ExistentialQuantification #-}
 module XMPPServer
     ( xmppServer
+    , quitXmpp
     , ConnectionKey(..)
     , XMPPServerParameters(..)
     , XMPPServer
@@ -47,7 +49,6 @@ import Blaze.ByteString.Builder (Builder)
 
 import Debug.Trace
 import System.IO (hFlush,stdout)
-import Control.Monad.Trans.Resource
 import Control.Monad.Trans (lift)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Fix (fix)
@@ -72,6 +73,7 @@ import Data.Conduit
 import qualified Data.Conduit.List as CL
 import qualified Data.Conduit.Binary as CB
 import Data.Conduit.Blaze (builderToByteStringFlush)
+import Control.Monad.Catch (MonadThrow)
 
 import qualified Text.XML.Stream.Render as XML hiding (content)
 import qualified Text.XML.Stream.Parse as XML
@@ -895,7 +897,7 @@ makePong namespace mid to from =
        ]
 
 
-xmppInbound :: Server ConnectionKey SockAddr ReleaseKey XML.Event
+xmppInbound :: Server ConnectionKey SockAddr releaseKey XML.Event
                 -> XMPPServerParameters
                 -> ConnectionKey
                 -> SockAddr
@@ -1243,7 +1245,7 @@ slotsToSource slots nesting lastStanza needsFlush rdone =
                 ,readTMVar rdone >> return (return ())
                 ]
 
-forkConnection :: Server ConnectionKey SockAddr ReleaseKey XML.Event
+forkConnection :: Server ConnectionKey SockAddr releaseKey XML.Event
                 -> XMPPServerParameters
                 -> ConnectionKey
                 -> SockAddr
@@ -1481,7 +1483,7 @@ sendRoster query xmpp clientKey replyto = do
     -}
 
 
-socketFromKey :: Server ConnectionKey SockAddr ReleaseKey XML.Event -> ConnectionKey -> IO SockAddr
+socketFromKey :: Server ConnectionKey SockAddr releaseKey XML.Event -> ConnectionKey -> IO SockAddr
 socketFromKey sv k = do
     map <- atomically $ readTVar (conmap sv)
     let mcd = Map.lookup k map
@@ -1651,7 +1653,7 @@ makeErrorStanza stanza = do
            ]
 
 monitor ::
-    Server ConnectionKey SockAddr ReleaseKey XML.Event
+    Server ConnectionKey SockAddr releaseKey XML.Event
     -> ConnectionParameters ConnectionKey SockAddr
     -> XMPPServerParameters
     -> IO b
@@ -1817,7 +1819,8 @@ monitor sv params xmpp = do
             _ = str :: String
 
 data XMPPServer
-    = XMPPServer { _xmpp_sv :: Server ConnectionKey SockAddr ReleaseKey XML.Event
+    = forall releaseKey.
+      XMPPServer { _xmpp_sv :: Server ConnectionKey SockAddr releaseKey XML.Event
                  , _xmpp_peer_params :: ConnectionParameters ConnectionKey SockAddr
                  }
 
@@ -1825,18 +1828,20 @@ grokPeer :: XMPPServer -> ConnectionKey -> (SockAddr, ConnectionParameters Conne
 grokPeer sv (PeerKey addr) = (addr, _xmpp_peer_params sv, 10000)
 
 xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text)
-xmppConnections sv = tcpManager (grokPeer sv) (Just . Text.pack) resolvPeer (_xmpp_sv sv)
+xmppConnections xsv@XMPPServer{_xmpp_sv=sv} = tcpManager (grokPeer xsv) (Just . Text.pack) resolvPeer sv
  where
     resolvPeer :: Text -> IO (Maybe ConnectionKey)
     resolvPeer str = fmap PeerKey <$> listToMaybe <$> resolvePeer str
 
 xmppEventChannel :: XMPPServer -> TChan ((ConnectionKey, SockAddr), ConnectionEvent Event)
-xmppEventChannel sv = serverEvent $ _xmpp_sv sv
+xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
 
-xmppServer :: ( MonadResource m
-              , MonadIO m
-              ) => XMPPServerParameters -> m XMPPServer
-xmppServer xmpp = do
+quitXmpp :: XMPPServer -> IO ()
+quitXmpp XMPPServer{_xmpp_sv=sv} = control sv Quit
+
+xmppServer :: MonadIO m =>
+              Allocate releaseKey m -> XMPPServerParameters -> m XMPPServer
+xmppServer allocate xmpp = do
     sv <- server allocate xmlStream
     -- some fuzz helps avoid simultaneity
     pingfuzz <- liftIO $ do