Factor out some new libraries

	word64-map:
		Data.Word64Map
	network-addr:
		Network.Address
	tox-crypto:
		Crypto.Tox
	lifted-concurrent:
		Control.Concurrent.Lifted.Instrument
		Control.Concurrent.Async.Lifted.Instrument
	psq-wrap:
		Data.Wrapper.PSQInt
		Data.Wrapper.PSQ
	minmax-psq:
		Data.MinMaxPSQ
        tasks:
                Control.Concurrent.Tasks
	kad:
		Network.Kademlia
		Network.Kademlia.Bootstrap
		Network.Kademlia.Routing
		Network.Kademlia.CommonAPI
		Network.Kademlia.Persistence
		Network.Kademlia.Search

30 files changed, 6681 insertions, 0 deletions

diff --git a/dht/Presence/ByteStringOperators.hs b/dht/Presence/ByteStringOperators.hs
new file mode 100644
index 00000000..e8485134
--- /dev/null
+++ b/dht/Presence/ByteStringOperators.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE CPP #-}
+module ByteStringOperators where
+
+import qualified Data.ByteString as S (ByteString)
+import Data.ByteString.Lazy.Char8 as L 
+import Control.Applicative
+
+#if MIN_VERSION_bytestring(0,10,0)
+#else
+-- These two were imported to provide an NFData instance.
+import qualified Data.ByteString.Lazy.Internal as L (ByteString(..))
+import Control.DeepSeq
+#endif
+
+
+(<++>) :: ByteString -> ByteString -> ByteString
+(<++.>) :: ByteString -> S.ByteString -> ByteString
+(<.++>) :: S.ByteString -> ByteString -> ByteString
+(<.++.>) :: S.ByteString -> S.ByteString -> ByteString
+a <++> b =  L.append a b
+a <++.> b = L.append a (fromChunks [b])
+a <.++> b = L.append (fromChunks [a]) b
+a <.++.> b = fromChunks [a,b]
+infixr 5 <.++.>
+infixr 5 <.++>
+infixr 5 <++>
+infixr 5 <++.>
+
+
+(<++$>) :: Functor f => ByteString -> f ByteString -> f ByteString
+(<$++>) :: Functor f => f ByteString -> ByteString -> f ByteString
+(<$++$>) :: Applicative f => f ByteString -> f ByteString -> f ByteString
+a <++$> b = fmap (a<++>) b
+a <$++> b = fmap (<++>b) a
+a <$++$> b = liftA2 (<++>) a b
+infixr 6 <++$>
+infixr 6 <$++>
+infixr 6 <$++$>
+
+(<?++>) :: Maybe ByteString -> ByteString -> ByteString
+Nothing <?++> b = b
+Just a  <?++> b = a <++> b
+infixr 5 <?++>
+
+(<++?>) :: ByteString -> Maybe ByteString -> ByteString
+a <++?> Nothing = a
+a <++?> Just b  = a <++> b
+infixr 5 <++?>
+
+bshow :: Show a => a -> ByteString
+bshow = L.pack . show
+
+
+#if MIN_VERSION_bytestring(0,10,0)
+#else
+instance NFData L.ByteString where
+    rnf L.Empty       = ()
+    rnf (L.Chunk _ b) = rnf b
+#endif
diff --git a/dht/Presence/Chat.hs b/dht/Presence/Chat.hs
new file mode 100644
index 00000000..03bea44b
--- /dev/null
+++ b/dht/Presence/Chat.hs
@@ -0,0 +1,227 @@
+{-# LANGUAGE LambdaCase #-}
+module Chat where
+
+import Debug.Trace
+import Data.Semigroup
+import Control.Concurrent.STM
+import Control.Monad
+import qualified Data.Map as Map
+         ;import Data.Map (Map)
+import Data.Text (Text)
+import Data.Word
+
+import Util (stripResource)
+
+-- To join a chat room, add a 'ClientRoomLink' to 'roomDesiredLink' with
+-- 'desireStreamEvent' set to 'Nothing'.
+--
+-- To leave a chat room, remove the 'ClientRoomLink' from the map.
+
+data Room k = Room
+    { roomDesiredTransaction :: TVar (Map k (TVar (Maybe ChatTransaction)))
+    , roomChan               :: TChan ChatTransaction
+    , roomFutureSeqNo        :: TVar Word64
+    , roomMembers            :: TVar (Map Text{-nick-} (PerMember k))
+    , roomAffiliations       :: TVar (Map Text{-jid-} Affiliation)
+    , roomReservations       :: TVar (Map Text{-nick-} Text{-jid-})
+    }
+
+newtype PerMember k = PerMember
+    { memberKey :: k
+    }
+
+newtype Affiliation = Affiliation
+    { reservedNick :: Text
+    }
+
+data ChatEvent = Join | Part | Action Text | Talk Text -- | NickChange Text
+ deriving (Eq,Ord,Show)
+
+data Membership = Outside | Inside
+ deriving (Eq,Ord,Read,Show)
+
+data MembershipEffect = MembershipEffect { fromMembership :: Membership
+                                         , toMembership   :: Membership
+                                         }
+                      | NoMembershipEffect
+                      | InvalidMembershipEffect
+ deriving (Eq,Ord,Read,Show)
+
+instance Semigroup MembershipEffect
+
+instance Monoid MembershipEffect where
+    mempty = NoMembershipEffect
+    MembershipEffect a x `mappend` MembershipEffect y b
+        | x == y    = MembershipEffect a b
+        | otherwise = InvalidMembershipEffect
+    NoMembershipEffect `mappend` b                  = b
+    a                  `mappend` NoMembershipEffect = a
+    _                  `mappend` _                  = InvalidMembershipEffect
+
+chatEffect :: ChatEvent -> MembershipEffect
+chatEffect Join = MembershipEffect Outside Inside
+chatEffect Part = MembershipEffect Inside  Outside
+chatEffect _    = MembershipEffect Inside  Inside
+
+membershipEffect :: [ChatEvent] -> MembershipEffect
+membershipEffect xs =  foldMap chatEffect xs
+
+
+data ChatTransaction = ChatTransaction
+    { chatSeqNo     :: Word64
+    , chatSenderJID :: Maybe Text
+    , chatSender    :: Text
+    , chatMessage   :: [ChatEvent]
+    }
+ deriving (Eq,Ord,Show)
+
+newtype RoomHandle = RH (TVar (Maybe ChatTransaction))
+
+data JoinedRoom k = JoinedRoom
+    { joinedRoom :: Room k
+    , joinedNick :: Text
+    , roomHandle :: RoomHandle
+    , roomTransactions :: TChan ChatTransaction
+    }
+
+newRoom :: STM (Room k)
+newRoom = do
+    m <- newTVar Map.empty
+    c <- newTChan -- newBroadcastTChan
+    n <- newTVar 0
+    cs <- newTVar Map.empty
+    as <- newTVar Map.empty
+    rs <- newTVar Map.empty
+    return Room
+        { roomDesiredTransaction = m
+        , roomChan               = c
+        , roomFutureSeqNo        = n
+        , roomMembers            = cs
+        , roomAffiliations       = as
+        , roomReservations       = rs
+        }
+
+
+--- Client interface
+
+joinRoom :: Ord k => k
+                     -> Room k
+                     -> Maybe Text
+                     -> Text
+                     -> STM (JoinedRoom k)
+joinRoom k room jid nick = do
+    no <- readTVar $ roomFutureSeqNo room
+    v <- newTVar (Just $ ChatTransaction no jid nick [Join])
+    modifyTVar' (roomDesiredTransaction room) $ Map.insert k v
+    c <- dupTChan (roomChan room)
+    return $ JoinedRoom room nick (RH v) c
+
+partRoom :: JoinedRoom k -> Maybe Text -> STM ()
+partRoom (JoinedRoom room nick (RH v) c) jid = do
+    writeTVar v Nothing -- Cancel pending chat.
+    sendChat (JoinedRoom room nick (RH v) c) jid [Part]
+    return ()
+
+sendChat :: JoinedRoom k -> Maybe Text -> [ChatEvent] -> STM Bool
+sendChat (JoinedRoom room nick (RH v) _) jid chat = do
+    mpending <- readTVar v
+    no <- readTVar $ roomFutureSeqNo room
+    case mpending of
+        Just (ChatTransaction no' _ _ _) | no' >= no -> return False
+        _ -> do
+            writeTVar v (Just $ ChatTransaction no jid nick chat)
+            return True
+
+-- | Blocks until a transaction occurs.  Optionally, a failed transaction will
+-- be automatically renewed.
+readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction)
+readRoom k (JoinedRoom room _ (RH v) c) = do
+    mpending <- readTVar v
+    final <- readTChan c
+    case mpending of
+        Just pending -> do
+            if pending == final
+                then do
+                    writeTVar v Nothing
+                    when (Part `elem` chatMessage final) $ do
+                        modifyTVar' (roomDesiredTransaction room)
+                            $ Map.delete k
+                    return (True,final)
+                else do
+                    no <- readTVar $ roomFutureSeqNo room
+                    writeTVar v $ Just pending { chatSeqNo = no }
+                    return (False,final)
+        Nothing -> return (False,final)
+
+roomOccupants :: Room k-> STM [(Text{-nick-},Maybe Text{-friendly name-})]
+roomOccupants room = do
+    ns <- Map.keys <$> readTVar (roomMembers room)
+    return $ map (\n -> (n,Just n)) ns
+
+roomReservedNick :: Room k -> Text{-JID-} -> STM (Maybe Text{-nick-})
+roomReservedNick room jid = do
+    a <- Map.lookup jid <$> readTVar (roomAffiliations room)
+    return $ reservedNick <$> a
+
+roomFriendlyName :: Room k -> STM (Maybe Text)
+roomFriendlyName _ = return Nothing
+
+-- Room implementation interface
+
+data Validation = Malformed | Requires Membership | Denied | Valid Membership Membership
+ deriving (Eq,Ord,Show,Read)
+
+validateTransaction :: Ord k => Room k -> k -> ChatTransaction -> STM Validation
+validateTransaction room k t@(ChatTransaction no mjid nick xs)
+    | null xs   = return Malformed
+    | otherwise = case membershipEffect xs of
+        MembershipEffect Inside what ->
+            Map.lookup nick <$> readTVar (roomMembers room) >>= \case
+                Nothing                   -> return (Requires Inside)
+                Just p | memberKey p /= k -> return Denied
+                _                         -> return (Valid Inside what)
+        MembershipEffect Outside what -> do
+            Map.lookup k <$> return Map.empty {- readTVar (roomDesiredTransaction room) -} >>= \case
+                Nothing -> Map.lookup nick <$> readTVar (roomMembers room) >>= \case
+                            Nothing -> Map.lookup nick <$> readTVar (roomReservations room) >>= \case
+                                        Just rjid | Just jid <- mjid
+                                                  , stripResource jid == rjid
+                                                 -> return (Valid Outside what)
+                                        Just _   -> return Denied
+                                        Nothing  -> return (Valid Outside what)
+                            Just _  -> return Denied -- Nick already taken.
+                Just _ -> return (Requires Outside)
+        _ -> return Malformed
+
+
+roomCommit :: Ord k => Room k -> k -> ChatTransaction -> STM ()
+roomCommit room k t = do
+    let fin = do
+            trace "increment seqno!" $ return ()
+            modifyTVar' (roomFutureSeqNo room) succ
+            writeTChan (roomChan room) t
+    v <- validateTransaction room k t
+    trace ("roomCommit " ++ show v ++ " " ++ show t) $ return ()
+    case v of
+        Valid Outside Inside -> do
+            modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember
+                { memberKey = k
+                }
+            fin
+        Valid Inside Outside -> do
+            modifyTVar' (roomMembers room) $ Map.delete (chatSender t)
+            fin
+        Valid _ _ -> fin
+        bad -> trace ("validateTransaction: " ++ show bad) $ return ()
+
+roomPending :: Ord k => Room k -> STM (Map k ChatTransaction)
+roomPending room = do
+    no <- readTVar $ roomFutureSeqNo room
+    m <- Map.mapMaybe (>>= \t -> do guard (chatSeqNo t == no)
+                                    return t)
+          <$> do readTVar (roomDesiredTransaction room)
+                    >>= mapM readTVar
+    fmap (Map.mapMaybe id)
+        $ sequence $ Map.mapWithKey (\k t -> validateTransaction room k t >>= \case
+                        Valid _ _ -> return (Just t)
+                        _         -> return Nothing) m
diff --git a/dht/Presence/ClientState.hs b/dht/Presence/ClientState.hs
new file mode 100644
index 00000000..08cc54ed
--- /dev/null
+++ b/dht/Presence/ClientState.hs
@@ -0,0 +1,41 @@
+module ClientState where
+
+import Control.Concurrent.STM
+import Data.Text ( Text )
+import Data.Int  ( Int8 )
+import Data.Bits ( (.&.) )
+
+import UTmp       ( ProcessID )
+import XMPPServer ( Stanza )
+
+data ClientState = ClientState
+      -- | The unix tty or the jabber resource for this client.
+    { clientResource :: Text
+      -- | Unix user that is running this client.
+    , clientUser     :: Text
+      -- | The specific roster/identity of the user that this client presenting.
+    , clientProfile  :: Text
+      -- | The unix process id of the client if we know it.
+    , clientPid      :: Maybe ProcessID
+      -- | The presence (away/available) stanza this client is indicating.
+    , clientStatus   :: TVar (Maybe Stanza)
+      -- | XMPP client flags (read access via 'clientIsAvailable' and 'clientIsInterested')
+    , clientFlags    :: TVar Int8
+    }
+
+cf_available :: Int8
+cf_available = 0x1
+cf_interested :: Int8
+cf_interested = 0x2
+
+-- | True if the client has sent an initial presence
+clientIsAvailable :: ClientState -> STM Bool
+clientIsAvailable c  = do
+    flgs <- readTVar (clientFlags c)
+    return $ flgs .&. cf_available /= 0
+
+-- | True if the client has requested a roster
+clientIsInterested :: ClientState -> STM Bool
+clientIsInterested c = do
+    flgs <- readTVar (clientFlags c)
+    return $ flgs .&. cf_interested /= 0
diff --git a/dht/Presence/ConfigFiles.hs b/dht/Presence/ConfigFiles.hs
new file mode 100644
index 00000000..d0164e33
--- /dev/null
+++ b/dht/Presence/ConfigFiles.hs
@@ -0,0 +1,170 @@
+{-# LANGUAGE OverloadedStrings #-}
+module ConfigFiles where
+
+import Data.ByteString.Lazy.Char8 as L
+import System.Posix.User
+import System.Posix.Files (fileExist)
+import System.FilePath
+import System.Directory
+import System.IO
+-- import System.IO.Strict
+import System.IO.Error
+import Control.Exception
+import Control.Monad
+import Control.DeepSeq
+import ByteStringOperators () -- For NFData instance
+import Data.List (partition)
+import Data.Maybe (catMaybes,isJust)
+
+import DPut
+import DebugTag
+
+type User = ByteString
+type Profile = String
+
+configDir, buddyFile, subscriberFile,
+  otherFile, pendingFile, solicitedFile,
+  secretsFile :: FilePath
+
+-- A "buddy" is somebody who approved our friend request and will keep
+-- us informed of their presence.
+--
+-- A "subscriber" is somebody who we approved and promised to keep informed
+-- of our own presence.
+
+configDir      = ".presence"
+buddyFile      = "buddies"     -- subscription="to"
+subscriberFile = "subscribers" -- subscription="from"
+pendingFile    = "pending"     -- pending subscriber (we've yet to approve)
+solicitedFile  = "solicited"   -- pending buddy (we sent a friend request)
+otherFile      = "others"
+secretsFile    = "secret"
+
+
+configPath :: User -> Profile -> String -> IO String
+configPath user "." filename = do
+    ue <- getUserEntryForName (unpack user)
+    return $ (++("/"++configDir++"/"++filename)) $ homeDirectory ue
+ `catchIOError` \e -> do
+    dput XJabber $ "configPath " ++ show user ++ "\".\": " ++ show e
+    return $ (++("/"++configDir++"/"++filename)) $ "/tmp"
+configPath user profile filename = do
+    ue <- getUserEntryForName (unpack user)
+    return $ (++("/"++configDir++"/"++profile++"/"++filename)) $ homeDirectory ue
+ `catchIOError` \e -> do
+    dput XJabber $ "configPath " ++ show user ++ " " ++ show profile ++ ": " ++ show e
+    return $ (++("/"++configDir++"/"++filename)) $ "/tmp"
+
+createConfigFile :: ByteString -> FilePath -> IO ()
+createConfigFile tag path = do
+    let dir = dropFileName path
+    doesDirectoryExist dir >>= flip unless (do
+            createDirectory dir
+        )
+    withFile path WriteMode $ \h -> do
+        L.hPutStrLn h tag
+
+addItem :: ByteString -> ByteString -> FilePath -> IO ()
+addItem item tag path =
+    let doit = do
+         handle (\e -> when (isDoesNotExistError e)
+                       (createConfigFile tag path >> doit))
+           $ do exists <- fileExist path
+                if exists
+                  then withFile path AppendMode $ \h ->
+                         L.hPutStrLn h item
+                  else withFile path WriteMode $ \h -> do
+                         L.hPutStrLn h tag
+                         L.hPutStrLn h item
+    in doit
+
+
+-- | Modify a presence configuration file.  This function will iterate over all
+-- items in the file and invoke a test function.  If the function returns
+-- Nothing, that item is removed from the file.  Otherwise, the function may
+-- rename the item by returning the new name.
+--
+-- If the last argument is populated, it is a new item to append to the end of
+-- the file.
+--
+-- Note that the entire file is read in, processed, and then rewritten from
+-- scratch.
+modifyFile ::
+  (ByteString,FilePath)
+  -> User
+  -> Profile
+  -> (ByteString -> IO (Maybe ByteString)) -- ^ Returns Just for each item you want to keep.
+  -> Maybe ByteString                      -- ^ Optionally append this item.
+  -> IO Bool                               -- Returns True if test function ever returned Nothing
+modifyFile (tag,file) user profile test appending = configPath user profile file >>= doit
+    where
+        doit path = do
+         handle (\e -> if (isDoesNotExistError e)
+                        then (createConfigFile tag path >> doit path)
+                        else return False)
+           $ do exists <- fileExist path
+                if exists
+                  then do
+                    xs <- withFile path ReadMode $ \h -> do
+                             contents <- L.hGetContents h
+                             case L.lines contents of
+                              x:xs -> mapM test xs
+                              _    -> return []
+                    let (keepers,deleted) = partition isJust xs
+                    withFile path WriteMode $ \h -> do
+                        L.hPutStrLn h tag
+                        forM_ (catMaybes keepers) (L.hPutStrLn h)
+                        forM_ appending (L.hPutStrLn h)
+                    return . not . Prelude.null $ deleted
+                  else do
+                    withFile path WriteMode $ \h -> do
+                        L.hPutStrLn h tag
+                        forM_ appending (L.hPutStrLn h)
+                    return False
+
+modifySolicited, modifyBuddies, modifyOthers, modifyPending, modifySubscribers
+  :: User -> Profile -> (ByteString -> IO (Maybe ByteString)) -> Maybe ByteString -> IO Bool
+
+modifySolicited   = modifyFile ("<? solicited ?>"   , solicitedFile)
+modifyBuddies     = modifyFile ("<? buddies ?>"     , buddyFile)
+modifyOthers      = modifyFile ("<? others ?>"      , otherFile)
+modifyPending     = modifyFile ("<? pending ?>"     , pendingFile)
+modifySubscribers = modifyFile ("<? subscribers ?>" , subscriberFile)
+
+addBuddy :: User -> Profile -> ByteString -> IO ()
+addBuddy user profile buddy =
+    configPath user profile buddyFile >>= addItem buddy "<? buddies ?>"
+
+addSubscriber :: User -> Profile -> ByteString -> IO ()
+addSubscriber user profile subscriber =
+    configPath user profile subscriberFile >>= addItem subscriber "<? subscribers ?>"
+
+addSolicited :: User -> Profile -> ByteString -> IO ()
+addSolicited user profile solicited =
+    configPath user profile solicitedFile >>= addItem solicited "<? solicited ?>"
+
+getConfigList :: FilePath -> IO [ByteString]
+getConfigList path =
+  handle (\e -> if isDoesNotExistError e then (return []) else throw e)
+    $ withFile path ReadMode $
+        L.hGetContents
+        >=> return . Prelude.tail . L.lines
+        >=> (\a -> seq (rnf a) (return a))
+
+getBuddies :: User -> Profile -> IO [ByteString]
+getBuddies user profile = configPath user profile buddyFile >>= getConfigList
+
+getSubscribers :: User -> Profile -> IO [ByteString]
+getSubscribers user profile = configPath user profile subscriberFile >>= getConfigList
+
+getOthers :: User -> Profile -> IO [ByteString]
+getOthers user profile = configPath user profile otherFile >>= getConfigList
+
+getPending :: User -> Profile -> IO [ByteString]
+getPending user profile = configPath user profile pendingFile >>= getConfigList
+
+getSolicited :: User -> Profile -> IO [ByteString]
+getSolicited user profile = configPath user profile solicitedFile >>= getConfigList
+
+getSecrets :: User -> Profile -> IO [ByteString]
+getSecrets user profile = configPath user profile secretsFile >>= getConfigList
diff --git a/dht/Presence/ConnectionKey.hs b/dht/Presence/ConnectionKey.hs
new file mode 100644
index 00000000..ad4eeab7
--- /dev/null
+++ b/dht/Presence/ConnectionKey.hs
@@ -0,0 +1,8 @@
+module ConnectionKey where
+
+import Network.Socket ( SockAddr(..) )
+import SockAddr ()
+
+newtype ClientAddress = ClientAddress SockAddr
+    deriving (Eq,Ord,Show)
+
diff --git a/dht/Presence/ConsoleWriter.hs b/dht/Presence/ConsoleWriter.hs
new file mode 100644
index 00000000..c6e1871a
--- /dev/null
+++ b/dht/Presence/ConsoleWriter.hs
@@ -0,0 +1,420 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+module ConsoleWriter
+    ( ConsoleWriter(cwPresenceChan)
+    , newConsoleWriter
+    , writeActiveTTY
+    , writeAllPty
+    , cwClients
+    ) where
+
+import Control.Monad
+-- import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.STM
+import Data.Monoid
+import Data.Char
+import Data.Maybe
+import System.Environment hiding (setEnv)
+import System.Exit ( ExitCode(ExitSuccess) )
+import System.Posix.Env     ( setEnv )
+import System.Posix.Process ( forkProcess, exitImmediately, executeFile )
+import System.Posix.User  ( setUserID, getUserEntryForName, userID )
+import System.Posix.Files ( getFileStatus, fileMode )
+import System.INotify ( initINotify, EventVariety(Modify), addWatch )
+import System.IO.Error
+import Data.Word      ( Word8 )
+import Data.Text      ( Text )
+import Data.Map       ( Map )
+import Data.List      ( foldl', groupBy )
+import Data.Bits      ( (.&.) )
+import qualified Data.Map as Map
+import qualified Data.Traversable as Traversable
+import qualified Data.Text as Text
+-- import qualified Data.Text.IO as Text
+import qualified Network.BSD as BSD
+
+import DPut
+import DebugTag
+import UTmp           ( users2, utmp_file, UtmpRecord(..), UT_Type(..) )
+import FGConsole      ( forkTTYMonitor )
+import XMPPServer     ( Stanza, makePresenceStanza, JabberShow(..), stanzaType
+                      , LangSpecificMessage(..), msgLangMap, cloneStanza, stanzaFrom )
+import ControlMaybe
+import ClientState
+
+data ConsoleWriter = ConsoleWriter
+    { cwPresenceChan :: TMVar (ClientState,Stanza)
+    -- ^ tty switches and logins are announced on this mvar
+    , csActiveTTY :: TVar Word8
+    , csUtmp :: TVar (Map Text (TVar (Maybe UtmpRecord)))
+    , cwClients :: TVar (Map Text ClientState)
+    -- ^ This 'TVar' holds a map from resource id (tty name)
+    --   to ClientState for all active TTYs and PTYs.
+    }
+
+tshow :: forall a. Show a => a -> Text
+tshow x = Text.pack . show $ x
+
+retryWhen :: forall b. STM b -> (b -> Bool) -> STM b
+retryWhen var pred = do
+    value <- var
+    if pred value then retry
+                  else return value
+
+
+onLogin ::
+    forall t.
+    ConsoleWriter
+    -> (STM (Word8, Maybe UtmpRecord)
+        -> TVar (Maybe UtmpRecord) -> IO ())
+    -> t
+    -> IO ()
+onLogin cs start = \e -> do
+    us <- UTmp.users2
+    let (m,cruft) =
+            foldl' (\(m,cruft) x ->
+                        case utmpType x of
+                         USER_PROCESS
+                           -> (Map.insert (utmpTty x) x m,cruft)
+                         DEAD_PROCESS | utmpPid x /= 0
+                           -> (m,Map.insert (utmpTty x) x cruft)
+                         _ -> (m,cruft))
+                   (Map.empty,Map.empty)
+                   us
+    forM_ (Map.elems cruft) $ \c -> do
+        putStrLn $ "cruft " ++ show (utmpTty c, utmpPid c,utmpHost c, utmpRemoteAddr c)
+    newborn <- atomically $ do
+        old <- readTVar (csUtmp cs) -- swapTVar (csUtmp cs) m
+        newborn <- flip Traversable.mapM (m Map.\\ old)
+                    $ newTVar . Just
+        updated <- let upd v u = writeTVar v $ Just u
+                   in Traversable.sequence $ Map.intersectionWith upd old m
+        let dead = old Map.\\ m
+        Traversable.mapM (flip writeTVar Nothing) dead
+        writeTVar (csUtmp cs) $ (old `Map.union` newborn) Map.\\ dead
+        return newborn
+    let getActive = do
+            tty <- readTVar $ csActiveTTY cs
+            utmp <- readTVar $ csUtmp cs
+            fromMaybe (return (tty,Nothing))
+               $ Map.lookup ("tty"<>tshow tty) utmp <&> \tuvar -> do
+            tu <- readTVar tuvar
+            return (tty,tu)
+
+    forM_ (Map.elems newborn) $
+        forkIO . start getActive
+    -- forM_ (Map.elems dead   ) $ putStrLn . ("gone: "++) . show
+
+-- | Sets up threads to monitor tty switches and logins that are
+-- written to the system utmp file and returns a 'ConsoleWriter'
+-- object for interacting with that information.
+newConsoleWriter :: IO (Maybe ConsoleWriter)
+newConsoleWriter = do
+    chan <- atomically $ newEmptyTMVar
+    cs <- atomically $ do
+        ttyvar <- newTVar 0
+        utmpvar <- newTVar Map.empty
+        clients <- newTVar Map.empty
+        return $ ConsoleWriter { cwPresenceChan = chan
+                               , csActiveTTY = ttyvar
+                               , csUtmp = utmpvar
+                               , cwClients = clients
+                               }
+    outvar <- atomically $ newTMVar ()
+    let logit outvar s = do
+            {-
+            atomically $ takeTMVar outvar
+            Text.putStrLn s
+            atomically $ putTMVar outvar ()
+            -}
+            return ()
+        onTTY outvar cs vtnum = do
+            logit outvar $ "switch: " <> tshow vtnum
+            atomically $ writeTVar (csActiveTTY cs) vtnum
+
+    inotify <- initINotify
+
+    -- get active tty
+    mtty <- forkTTYMonitor (onTTY outvar cs)
+    forM mtty $ \_ -> do
+    atomically $ retryWhen (readTVar $ csActiveTTY cs) (==0)
+
+    -- read utmp
+    onLogin cs (newCon (logit outvar) cs) Modify
+
+    -- monitor utmp
+    wd <- addWatch
+            inotify
+            [Modify] -- [CloseWrite,Open,Close,Access,Modify,Move]
+            utmp_file
+            (onLogin cs (newCon (logit outvar) cs))
+    return cs
+
+-- Transforms a string of form language[_territory][.codeset][@modifier]
+-- typically used in LC_ locale variables into the BCP 47
+-- language codes used in xml:lang attributes.
+toBCP47 :: [Char] -> [Char]
+toBCP47 lang = map hyphen $ takeWhile (/='.') lang
+ where hyphen '_' = '-'
+       hyphen  c  =  c
+
+#if MIN_VERSION_base(4,6,0)
+#else
+lookupEnv k = fmap (lookup k) getEnvironment
+#endif
+
+getPreferedLang :: IO Text
+getPreferedLang = do
+    lang <- do
+        lc_all <- lookupEnv "LC_ALL"
+        lc_messages <- lookupEnv "LC_MESSAGES"
+        lang <- lookupEnv "LANG"
+        return $ lc_all `mplus` lc_messages `mplus` lang
+    return $ maybe "en" (Text.pack . toBCP47) lang
+
+cimatch :: Text -> Text -> Bool
+cimatch w t = Text.toLower w == Text.toLower t
+
+cimatches :: Text -> [Text] -> [Text]
+cimatches w ts = dropWhile (not . cimatch w) ts
+
+-- rfc4647 lookup of best match language tag
+lookupLang :: [Text] -> [Text] -> Maybe Text
+lookupLang (w:ws) tags
+    | Text.null w = lookupLang ws tags
+    | otherwise   = case cimatches w tags of
+                        (t:_) -> Just t
+                        []    -> lookupLang (reduce w:ws) tags
+ where
+    reduce w = Text.concat $ reverse nopriv
+        where
+            rparts = reverse . init $ Text.groupBy (\_ c -> c/='-') w
+            nopriv = dropWhile ispriv rparts
+            ispriv t = Text.length t == 2 && Text.head t == '-'
+
+lookupLang [] tags | "" `elem` tags = Just ""
+                   | otherwise      = listToMaybe $ tags
+
+
+messageText :: Stanza -> IO Text
+messageText msg = do
+    pref <- getPreferedLang
+    let m = msgLangMap (stanzaType msg)
+        key = lookupLang [pref] (map fst m)
+        mchoice = do
+            k <- key
+            lookup k m
+    return $ fromMaybe "" $ do
+        choice <- mchoice
+        let subj = fmap ("Subject: " <>) $ msgSubject choice
+            ts = catMaybes [subj, msgBody choice]
+        return $ Text.intercalate "\n\n" ts
+
+readEnvFile :: String -> FilePath -> IO (Maybe String)
+readEnvFile var file = fmap parse $ readFile file
+ where
+    parse xs = listToMaybe $ map (drop 1 . concat . drop 1) $ filter ofinterest bs
+     where
+        bs = map (groupBy (\_ x -> x/='=')) $ split (/='\0') xs
+        ofinterest (k:vs) | k==var = True
+        ofinterest _               = False
+
+    split pred xs = take 1 gs ++ map (drop 1) (drop 1 gs)
+     where
+        gs = groupBy (\_ x -> pred x) xs
+
+-- | Delivers an XMPP message stanza to the currently active
+-- tty.  If that is a linux console, it will write to it similar
+-- to the manner of the BSD write command.  If that is an X11
+-- display, it will attempt to notify the user via a libnotify
+-- interface.
+writeActiveTTY :: ConsoleWriter -> Stanza -> IO Bool
+writeActiveTTY cw msg = do
+    putStrLn $ "writeActiveTTY"
+    -- TODO: Do not deliver if the detination user does not own the active tty!
+    (tty, mbu) <- atomically $ do
+                num <- readTVar $ csActiveTTY cw
+                utmp <- readTVar $ csUtmp cw
+                mbu <- maybe (return Nothing) readTVar
+                        $ Map.lookup ("tty"<>tshow num) utmp
+                return ( "/dev/tty" <> tshow num
+                       , mbu )
+    fromMaybe (return False) $ mbu <&> \utmp -> do
+    display <- fmap (fmap Text.pack)
+        $ readEnvFile "DISPLAY" ("/proc/" ++ show (utmpPid utmp) ++ "/environ")
+    case fmap (==utmpHost utmp) display of
+        Just True -> deliverGUIMessage cw tty utmp msg
+        _ -> deliverTerminalMessage cw tty utmp msg
+
+deliverGUIMessage ::
+    forall t t1. t -> t1 -> UtmpRecord -> Stanza -> IO Bool
+deliverGUIMessage cw tty utmp msg = do
+    text <- do
+        t <- messageText msg
+        return $ Text.unpack
+            $ case stanzaFrom msg of
+                Just from -> from <> ": " <> t
+                Nothing -> t
+    putStrLn $ "deliverGUI: " ++ text
+    handleIO_ (return False) $ do
+    muentry <- fmap Just (getUserEntryForName (Text.unpack $ utmpUser utmp))
+                `catchIOError` \e -> do
+                    dput XJabber $ "deliverGUIMessage(getUserEntryForName "++show (utmpUser utmp)++"): "++show e
+                    return Nothing
+    forM_ muentry $ \uentry -> do
+        let display = Text.unpack $ utmpHost utmp
+        pid <- forkProcess $ do
+            setUserID (userID uentry)
+            setEnv "DISPLAY" display True
+            -- rawSystem "/usr/bin/notify-send" [text]
+            executeFile "/usr/bin/notify-send" False [text] (Just [("DISPLAY",display)])
+            exitImmediately ExitSuccess
+        return ()
+    return True
+
+crlf :: Text -> Text
+crlf t = Text.unlines $ map cr (Text.lines t)
+ where
+    cr t | Text.last t == '\r'  = t
+         | otherwise            = t <> "\r"
+
+deliverTerminalMessage ::
+    forall t t1. t -> Text -> t1 -> Stanza -> IO Bool
+deliverTerminalMessage cw tty utmp msg = do
+    mode <- fmap fileMode (getFileStatus $ Text.unpack tty)
+    let mesgy = mode .&. 0o020 /= 0 -- verify mode g+w
+    if not mesgy then return False else do
+    text <- do
+        t <- messageText msg
+        return $ Text.unpack
+            $ case stanzaFrom msg of
+                Just from -> "\r\n" <> from <> " says...\r\n" <> crlf t <> "\r\n"
+                Nothing -> crlf t <> "\r\n"
+    writeFile (Text.unpack tty) text
+    return True -- return True if a message was delivered
+
+-- | Deliver the given message to all a user's PTYs.
+writeAllPty :: ConsoleWriter -> Stanza -> IO Bool
+writeAllPty cw msg = do
+    -- TODO: filter only ptys owned by the destination user.
+    us <- atomically $ readTVar (csUtmp cw)
+    let ptys = Map.filterWithKey ispty us
+        ispty k _ = "pts/" `Text.isPrefixOf` k
+                    && Text.all isDigit (Text.drop 4 k)
+    bs <- forM (Map.toList ptys) $ \(tty,utmp) -> do
+        deliverTerminalMessage cw ("/dev/" <> tty) utmp msg
+    return $ or bs
+
+resource :: UtmpRecord -> Text
+resource u =
+    case utmpTty u of
+        s | Text.take 3 s == "tty" -> s
+        s | Text.take 4 s == "pts/" -> "pty" <> Text.drop 4 s <> ":" <> utmpHost u
+        s -> escapeR s <> ":" <> utmpHost u
+ where
+    escapeR s = s
+
+textHostName :: IO Text
+textHostName = fmap Text.pack BSD.getHostName
+
+ujid :: UtmpRecord -> IO Text
+ujid u = do
+    h <- textHostName
+    return $ utmpUser u <> "@" <> h <> "/" <> resource u
+
+newCon :: (Text -> IO ())
+             -> ConsoleWriter
+             -> STM (Word8,Maybe UtmpRecord)
+             -> TVar (Maybe UtmpRecord)
+             -> IO ()
+newCon log cw activeTTY utmp = do
+    ((tty,tu),u) <- atomically $
+        liftM2 (,) activeTTY
+                   (readTVar utmp)
+    forM_ u $ \u -> do
+    jid <- ujid u
+    log $ status (resource u) tty tu <> " " <> jid <> "  pid=" <> tshow (utmpPid u)
+            <> (if istty (resource u)
+                 then " host=" <> tshow (utmpHost u)
+                 else "")
+            <> " session=" <> tshow (utmpSession u)
+            <> " addr=" <> tshow (utmpRemoteAddr u)
+    let r = resource u
+    stanza <- makePresenceStanza
+                            "jabber:client"
+                            (Just jid)
+                            (jstatus r tty tu)
+    statusv <- atomically $ newTVar (Just stanza)
+    flgs <- atomically $ newTVar 0
+    let client = ClientState { clientResource = r
+                             , clientUser     = utmpUser u
+                             , clientProfile  = "."
+                             , clientPid      = Nothing
+                             , clientStatus   = statusv
+                             , clientFlags    = flgs }
+    atomically $ do
+        modifyTVar (cwClients cw) $ Map.insert r client
+        putTMVar (cwPresenceChan cw) (client,stanza)
+    loop client tty tu (Just u)
+ where
+    bstatus r ttynum mtu
+        =  r == ttystr
+        || match mtu
+        where ttystr = "tty" <> tshow ttynum
+              searchstr mtu = maybe ttystr utmpHost $ do
+                tu <- mtu
+                guard (not $ Text.null $ utmpHost tu)
+                return tu
+              match mtu = searchstr mtu `Text.isInfixOf` Text.dropWhile (/=':') r
+    jstatus r ttynum tu =
+        if bstatus r ttynum tu
+            then Available
+            else Away
+    status r ttynum tu = tshow $ jstatus r ttynum tu
+
+    istty r = fst3 == "tty" && Text.all isDigit rst
+     where
+        (fst3,rst) = Text.splitAt 3 r
+
+    loop client tty tu u = do
+        what <- atomically $ foldr1 orElse
+            [ do (tty',tu') <- retryWhen activeTTY
+                            (\ttyu -> bstatus r tty tu == uncurry (bstatus r) ttyu)
+                 return $ ttyChanged tty' tu'
+            , do u' <- retryWhen (readTVar utmp) (==u)
+                 return $ utmpChanged u'
+            ]
+        what
+      where
+        r = maybe "" resource u
+
+        ttyChanged tty' tu' = do
+            jid <- maybe (return "") ujid u
+            stanza <- makePresenceStanza
+                            "jabber:client"
+                            (Just jid)
+                            (jstatus r tty' tu')
+            dup <- cloneStanza stanza
+            atomically $ do
+                writeTVar (clientStatus client) $ Just dup
+                putTMVar (cwPresenceChan cw) (client,stanza)
+            log $ status r tty' tu' <> " " <> jid
+            loop client tty' tu' u
+
+        utmpChanged u' = maybe dead changed u'
+         where
+            changed u' = do
+                jid0 <- maybe (return "") ujid u
+                jid <- ujid u'
+                log $ "changed: " <> jid0 <> " --> " <> jid
+                loop client tty tu (Just u')
+            dead = do
+                jid <- maybe (return "") ujid u
+                stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
+                atomically $ do
+                    modifyTVar (cwClients cw) $ Map.delete (clientResource client)
+                    putTMVar (cwPresenceChan cw) (client,stanza)
+                log $ "Offline   " <> jid
+
diff --git a/dht/Presence/Control/Concurrent/STM/Util.hs b/dht/Presence/Control/Concurrent/STM/Util.hs
new file mode 100644
index 00000000..4be3cff5
--- /dev/null
+++ b/dht/Presence/Control/Concurrent/STM/Util.hs
@@ -0,0 +1,21 @@
+module Control.Concurrent.STM.Util where
+
+import Control.Monad.IO.Class
+import Control.Concurrent.STM
+
+chanContents :: TChan x -> IO [x]
+chanContents ch = do
+        x  <- atomically $ do
+            bempty <- isEmptyTChan ch
+            if bempty
+                then return Nothing
+                else fmap Just $ readTChan ch
+        maybe (return [])
+              (\x -> do
+                xs <- chanContents ch
+                return (x:xs))
+              x
+
+ioWriteChan :: MonadIO m => TChan a -> a -> m ()
+ioWriteChan c v = liftIO . atomically $ writeTChan c v
+
diff --git a/dht/Presence/ControlMaybe.hs b/dht/Presence/ControlMaybe.hs
new file mode 100644
index 00000000..a101d667
--- /dev/null
+++ b/dht/Presence/ControlMaybe.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module ControlMaybe
+   ( module ControlMaybe
+   , module Data.Functor
+   ) where
+
+-- import GHC.IO.Exception (IOException(..))
+import Control.Monad
+import Data.Functor
+import System.IO.Error
+
+
+-- forM_ with less polymorphism.
+withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
+withJust m f = forM_ m f
+{-# INLINE withJust #-}
+
+whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
+whenJust acn f = acn >>= mapM_ f
+{-# INLINE whenJust #-}
+
+
+catchIO_ :: IO a -> IO a -> IO a
+catchIO_ body catcher = catchIOError body (\_ -> catcher)
+{-# INLINE catchIO_ #-}
+
+handleIO_ :: IO a -> IO a -> IO a
+handleIO_ catcher body = catchIOError body (\_ -> catcher)
+{-# INLINE handleIO_ #-}
+
+
+handleIO :: (IOError -> IO a) -> IO a -> IO a
+handleIO catcher body = catchIOError body catcher
+{-# INLINE handleIO #-}
+
+#if !MIN_VERSION_base(4,11,0)
+-- | Flipped version of '<$>'.
+--
+-- @
+-- ('<&>') = 'flip' 'fmap'
+-- @
+--
+-- @since 4.11.0.0
+--
+-- ==== __Examples__
+-- Apply @(+1)@ to a list, a 'Data.Maybe.Just' and a 'Data.Either.Right':
+--
+-- >>> Just 2 <&> (+1)
+-- Just 3
+--
+-- >>> [1,2,3] <&> (+1)
+-- [2,3,4]
+--
+-- >>> Right 3 <&> (+1)
+-- Right 4
+--
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+as <&> f = f <$> as
+
+infixl 1 <&>
+#endif
+
+
diff --git a/dht/Presence/DNSCache.hs b/dht/Presence/DNSCache.hs
new file mode 100644
index 00000000..e28655c5
--- /dev/null
+++ b/dht/Presence/DNSCache.hs
@@ -0,0 +1,291 @@
+-- | Both 'getAddrInfo' and 'getHostByAddr' have hard-coded timeouts for
+-- waiting upon network queries that can be a little too long for some use
+-- cases. This module wraps both of them so that they block for at most one
+-- second.  It caches late-arriving results so that they can be returned by
+-- repeated timed-out queries.
+--
+-- In order to achieve the shorter timeout, it is likely that the you will need
+-- to build with GHC's -threaded option.  Otherwise, if the wrapped FFI calls
+-- to resolve the address will block Haskell threads.  Note: I didn't verify
+-- this.
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes    #-}
+{-# LANGUAGE CPP           #-}
+module DNSCache
+    ( DNSCache
+    , reverseResolve
+    , forwardResolve
+    , newDNSCache
+    , parseAddress
+    , unsafeParseAddress
+    , strip_brackets
+    , withPort
+    ) where
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+import Control.Arrow
+import Control.Concurrent.STM
+import Data.Text       ( Text )
+import Network.Socket  ( SockAddr(..), AddrInfoFlag(..), defaultHints, getAddrInfo, AddrInfo(..) )
+import Data.Time.Clock ( UTCTime, getCurrentTime, diffUTCTime )
+import System.IO.Error ( isDoesNotExistError )
+import System.Endian   ( fromBE32, toBE32 )
+import Control.Exception ( handle )
+import Data.Map        ( Map )
+import qualified Data.Map    as Map
+import qualified Network.BSD as BSD
+import qualified Data.Text   as Text
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Ord
+import Data.Maybe
+import System.IO.Error
+import System.IO.Unsafe
+
+import SockAddr      ()
+import ControlMaybe  ( handleIO_ )
+import GetHostByAddr ( getHostByAddr )
+import InterruptibleDelay
+import DPut
+import DebugTag
+
+type TimeStamp = UTCTime
+
+data DNSCache =
+    DNSCache
+    { fcache :: TVar (Map Text [(TimeStamp, SockAddr)])
+    , rcache :: TVar (Map SockAddr [(TimeStamp, Text)])
+    }
+
+
+newDNSCache :: IO DNSCache
+newDNSCache = do
+        fcache <- newTVarIO Map.empty
+        rcache <- newTVarIO Map.empty
+        return DNSCache { fcache=fcache, rcache=rcache }
+
+updateCache :: Eq x =>
+    Bool -> TimeStamp -> [x] -> Maybe [(TimeStamp,x)] -> Maybe [(TimeStamp,x)]
+updateCache withScrub utc xs mys = do
+    let ys = maybe [] id mys
+        ys' = filter scrub ys
+        ys'' = map (utc,) xs ++ ys'
+        minute = 60
+        scrub (t,x) | withScrub && diffUTCTime utc t < minute = False
+        scrub (t,x) | x `elem` xs = False
+        scrub _ = True
+    guard $ not (null ys'')
+    return ys''
+
+dnsObserve :: DNSCache -> Bool -> TimeStamp -> [(Text,SockAddr)] -> STM ()
+dnsObserve dns withScrub utc obs = do
+    f <- readTVar $ fcache dns
+    r <- readTVar $ rcache dns
+    let obs' = map (\(n,a)->(n,a `withPort` 0)) obs
+        gs = do
+            g <- groupBy ((==) `on` fst) $ sortBy (comparing fst) obs'
+            (n,_) <- take 1 g
+            return (n,map snd g)
+        f' = foldl' updatef f gs
+        hs = do
+            h <- groupBy ((==) `on` snd) $ sortBy (comparing snd) obs'
+            (_,a) <- take 1 h
+            return (a,map fst h)
+        r' = foldl' updater r hs
+    writeTVar (fcache dns) f'
+    writeTVar (rcache dns) r'
+ where
+    updatef f (n,addrs) = Map.alter (updateCache withScrub utc addrs) n f
+    updater r (a,ns) = Map.alter (updateCache withScrub utc ns) a r
+
+make6mapped4 :: SockAddr -> SockAddr
+make6mapped4 addr@(SockAddrInet6 {}) = addr
+make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
+
+tryForkOS :: IO () -> IO ThreadId
+tryForkOS action = catchIOError (forkOS action) $ \e -> do
+    dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out."
+    forkIO action
+
+
+-- Attempt to resolve the given domain name.  Returns an empty list if the
+-- resolve operation takes longer than the timeout, but the 'DNSCache' will be
+-- updated when the resolve completes.
+--
+-- When the resolve operation does complete, any entries less than a minute old
+-- will be overwritten with the new results.  Older entries are allowed to
+-- persist for reasons I don't understand as of this writing. (See 'updateCache')
+rawForwardResolve ::
+    DNSCache -> (Text -> IO ()) -> Int -> Text -> IO [SockAddr]
+rawForwardResolve dns onFail timeout addrtext = do
+    r <- atomically newEmptyTMVar
+    mvar <- interruptibleDelay
+    rt <- tryForkOS $ do
+        myThreadId >>= flip labelThread ("resolve."++show addrtext)
+        resolver r mvar
+    startDelay mvar timeout
+    did <- atomically $ tryPutTMVar r []
+    when did (onFail addrtext)
+    atomically $ readTMVar r
+ where
+    resolver r mvar = do
+      xs <- handle (\e -> let _ = isDoesNotExistError e in return [])
+            $ do fmap (nub . map (make6mapped4 . addrAddress)) $ 
+                  getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME, AI_V4MAPPED ]})
+                    (Just $ Text.unpack $ strip_brackets addrtext)
+                    (Just "5269")
+      did <- atomically $ tryPutTMVar r xs
+      when did $ do
+      interruptDelay mvar
+      utc <- getCurrentTime
+      atomically $ dnsObserve dns True utc $ map (addrtext,) xs
+      return ()
+
+strip_brackets :: Text -> Text
+strip_brackets s =
+      case Text.uncons s of
+          Just ('[',t) -> Text.takeWhile (/=']') t
+          _            -> s
+
+
+reportTimeout :: forall a. Show a => a -> IO ()
+reportTimeout addrtext = do
+      dput XMisc $ "timeout resolving: "++show addrtext
+      -- killThread rt
+
+unmap6mapped4 :: SockAddr -> SockAddr
+unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) =
+    SockAddrInet port (toBE32 a)
+unmap6mapped4 addr = addr
+
+rawReverseResolve ::
+    DNSCache -> (SockAddr -> IO ()) -> Int -> SockAddr -> IO [Text]
+rawReverseResolve dns onFail timeout addr = do
+    r <- atomically newEmptyTMVar
+    mvar <- interruptibleDelay
+    rt <- forkOS $ resolver r mvar
+    startDelay mvar timeout
+    did <- atomically $ tryPutTMVar r []
+    when did (onFail addr)
+    atomically $ readTMVar r
+ where
+    resolver r mvar = 
+      handleIO_ (return ()) $ do
+        ent <- getHostByAddr (unmap6mapped4 addr) --  AF_UNSPEC addr
+        let names = BSD.hostName ent : BSD.hostAliases ent
+            xs = map Text.pack $ nub names
+        forkIO $ do
+            utc <- getCurrentTime
+            atomically $ dnsObserve dns False utc $ map (,addr) xs
+        atomically $ putTMVar r  xs
+
+-- Returns expired (older than a minute) cached reverse-dns results
+-- and removes them from the cache.
+expiredReverse :: DNSCache -> SockAddr -> IO [Text]
+expiredReverse dns addr = do
+    utc <- getCurrentTime
+    addr <- return $ addr `withPort` 0
+    es <- atomically $ do
+        r <- readTVar $ rcache dns
+        let ns = maybe [] id $ Map.lookup addr r
+            minute = 60 -- seconds
+            -- XXX: Is this right?  flip diffUTCTime utc returns the age of the 
+            -- cache entry?
+            (es0,ns') = partition ( (>=minute) . flip diffUTCTime utc . fst ) ns
+            es = map snd es0
+        modifyTVar' (rcache dns) $ Map.insert addr ns'
+        f <- readTVar $ fcache dns
+        let f' = foldl' (flip $ Map.alter (expire utc)) f es
+            expire utc Nothing   = Nothing
+            expire utc (Just as) = if null as' then Nothing else Just as'
+                where as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
+        writeTVar (fcache dns) f'
+        return es
+    return es
+
+cachedReverse :: DNSCache -> SockAddr -> IO [Text]
+cachedReverse dns addr = do
+    utc <- getCurrentTime
+    addr <- return $ addr `withPort` 0
+    atomically $ do
+        r <- readTVar (rcache dns)
+        let ns = maybe [] id $ Map.lookup addr r
+        {-
+            ns' = filter ( (<minute) . flip diffUTCTime utc . fst) ns
+            minute = 60 -- seconds
+        modifyTVar' (rcache dns) $ Map.insert addr ns'
+        return $ map snd ns'
+        -}
+        return $ map snd ns
+
+-- Returns any dns query results for the given name that were observed less
+-- than a minute ago and updates the forward-cache to remove any results older
+-- than that.
+cachedForward :: DNSCache -> Text -> IO [SockAddr]
+cachedForward dns n = do
+    utc <- getCurrentTime
+    atomically $ do
+        f <- readTVar (fcache dns)
+        let as = maybe [] id $ Map.lookup n f
+            as' = filter ( (<minute) . flip diffUTCTime utc . fst) as
+            minute = 60 -- seconds
+        modifyTVar' (fcache dns) $ Map.insert n as'
+        return $ map snd as'
+
+-- Reverse-resolves an address to a domain name.  Returns both the result of a
+-- new query and any freshly cached results.  Cache entries older than a minute
+-- will not be returned, but will be refreshed in spawned threads so that they
+-- may be available for the next call.
+reverseResolve :: DNSCache -> SockAddr -> IO [Text]
+reverseResolve dns addr = do
+    expired <- expiredReverse dns addr
+    forM_ expired $ \n -> forkIO $ do
+        rawForwardResolve dns (const $ return ()) 1000000 n
+        return ()
+    xs <- rawReverseResolve dns (const $ return ()) 1000000 addr
+    cs <- cachedReverse dns addr
+    return $ xs ++ filter (not . flip elem xs) cs
+
+-- Resolves a name, if there's no result within one second, then any cached
+-- results that are less than a minute old are returned.
+forwardResolve :: DNSCache -> Text -> IO [SockAddr]
+forwardResolve dns n = do
+    as <- rawForwardResolve dns (const $ return ()) 1000000 n
+    if null as
+      then cachedForward dns n
+      else return as
+
+parseAddress :: Text -> IO (Maybe SockAddr)
+parseAddress addr_str = do
+    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] }) 
+                        (Just . Text.unpack $ addr_str) 
+                        (Just "0")
+    return . listToMaybe $ map addrAddress info
+
+
+splitAtPort :: String -> (String,String)
+splitAtPort s = second sanitizePort $ case s of
+    ('[':t) -> break (==']') t
+    _       -> break (==':') s
+ where
+    sanitizePort (']':':':p) = p
+    sanitizePort (':':p)     = p
+    sanitizePort _           = "0"
+
+unsafeParseAddress :: String -> Maybe SockAddr
+unsafeParseAddress addr_str = unsafePerformIO $ do
+    let (ipstr,portstr) = splitAtPort addr_str
+    info <- getAddrInfo (Just $ defaultHints { addrFlags = [ AI_NUMERICHOST ] })
+                        (Just ipstr)
+                        (Just portstr)
+    return . listToMaybe $ map addrAddress info
+
+withPort :: SockAddr -> Int -> SockAddr
+withPort (SockAddrInet _ a)      port = SockAddrInet (toEnum port) a
+withPort (SockAddrInet6 _ a b c) port = SockAddrInet6 (toEnum port) a b c
diff --git a/dht/Presence/EventUtil.hs b/dht/Presence/EventUtil.hs
new file mode 100644
index 00000000..908e09e0
--- /dev/null
+++ b/dht/Presence/EventUtil.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+module EventUtil where
+
+import Control.Monad
+import Data.XML.Types as XML
+import qualified Data.List as List
+import Data.Text (Text)
+
+-- getStreamName (EventBeginElement name _) = name
+
+isEventBeginElement :: Event -> Bool
+isEventBeginElement (EventBeginElement {}) = True
+isEventBeginElement _ = False
+
+isEventEndElement :: Event -> Bool
+isEventEndElement (EventEndElement {}) = True
+isEventEndElement _ = False
+
+-- Note: This function ignores name space qualification
+elementAttrs ::
+  MonadPlus m =>
+  Text -> Event -> m [(Name, [Content])]
+elementAttrs expected (EventBeginElement name attrs)
+    | nameLocalName name==expected 
+    = return attrs
+elementAttrs _ _ = mzero
+
+streamP :: Text -> Name
+streamP name = Name name (Just "http://etherx.jabber.org/streams") (Just "stream")
+
+attr :: Name -> Text -> (Name,[Content])
+attr   name value = (name,[ContentText value])
+
+isServerIQOf :: Event -> Text -> Bool
+isServerIQOf (EventBeginElement name attrs) testType 
+    | name=="{jabber:server}iq" 
+    && matchAttrib "type" testType attrs
+    = True
+isServerIQOf _ _ = False
+
+isClientIQOf :: Event -> Text -> Bool
+isClientIQOf (EventBeginElement name attrs) testType 
+    | name=="{jabber:client}iq" 
+    && matchAttrib "type" testType attrs
+    = True
+isClientIQOf _ _ = False
+
+matchAttrib :: Name -> Text -> [(Name, [Content])] -> Bool
+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 -> [(Name, [Content])] -> Maybe Text
+lookupAttrib name attrs =
+    case List.find ( (==name) . fst) attrs of
+        Just (_,[ContentText x])   -> Just x
+        Just (_,[ContentEntity x]) -> Just x
+        _                          -> Nothing
+
+tagAttrs :: Event -> [(Name, [Content])]
+tagAttrs (EventBeginElement _ xs) = xs
+tagAttrs _                        = []
+
+    
+{-
+iqTypeSet    = "set"
+iqTypeGet    = "get"
+iqTypeResult = "result"
+iqTypeError  = "error"
+-}
+
+
+tagName :: Event -> Name
+tagName (EventBeginElement n _) = n
+tagName _                       = ""
+
+closerFor :: Event -> Event
+closerFor (EventBeginElement n _) = EventEndElement n
+closerFor _ = error "closerFor: unsupported event"
+
+
diff --git a/dht/Presence/FGConsole.hs b/dht/Presence/FGConsole.hs
new file mode 100644
index 00000000..03aaebf2
--- /dev/null
+++ b/dht/Presence/FGConsole.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module FGConsole where
+
+import Data.Word
+import System.Posix.IO
+import System.Posix.Types
+import Control.Concurrent
+-- import GHC.IO.Handle
+import Unsafe.Coerce
+import Control.Exception as E
+-- import Prelude as E
+import Control.Monad
+import Foreign.C
+
+import Logging
+import System.Posix.Signals
+
+-- c_monitorTTY fd = trace "c_monitorTTY" (return ()) -- (trace "WTF" todo)
+
+foreign import ccall "monitorTTY" c_monitorTTY :: Fd -> IO CInt
+foreign import ccall "closeTTY" c_closeTTY :: IO ()
+
+forkTTYMonitor :: (Word8 -> IO ()) -> IO (Maybe (Fd,ThreadId))
+forkTTYMonitor handler =  do
+    (rfd,wfd) <- createPipe
+    retvar <- newEmptyMVar
+    thread <- forkIO $ do
+        let cleanup = do
+                trace "quitting monitorTTY thread." (return ())
+                closeFd wfd `E.catch` \(e::IOException) -> return ()
+                closeFd rfd `E.catch` \(e::IOException) -> return ()
+                c_closeTTY
+        -- rh <- fdToHandle rfd
+        didfork <- c_monitorTTY wfd
+        putMVar retvar didfork
+        when (didfork == 0) $ do
+        let monitor =
+                (do
+                    threadWaitRead rfd
+                    (cs,cnt) <- fdRead rfd 1
+                    forM_ cs (handler . unsafeCoerce {- . trace "read byte" -})
+                    monitor)
+                `E.catch`
+                      \(e :: IOException) -> do
+                        err <- getErrno
+                        case () of
+                         _ | err==eAGAIN -> monitor
+                         _ | otherwise   -> cleanup
+                `E.catch`
+                      \(e ::  AsyncException) -> cleanup
+        monitor
+    didfork <- takeMVar retvar
+    if didfork == 0
+        then return $! Just (rfd,thread)
+        else return $! Nothing
+
+killTTYMonitor :: (Fd, ThreadId) -> IO ()
+killTTYMonitor (rfd,thread) = do
+    closeFd rfd
+    yield
+    killThread thread
+    raiseSignal sigUSR1
+    -- threadDelay 1000000
+
+
+-- vim:ft=haskell:
diff --git a/dht/Presence/GetHostByAddr.hs b/dht/Presence/GetHostByAddr.hs
new file mode 100644
index 00000000..45bca5e9
--- /dev/null
+++ b/dht/Presence/GetHostByAddr.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+module GetHostByAddr where
+
+import Network.BSD
+import Foreign.Ptr
+import Foreign.C.Types
+import Foreign.Storable (Storable(..))
+import Foreign.Marshal.Utils (with)
+import Foreign.Marshal.Alloc
+import Control.Concurrent
+import System.IO.Unsafe
+import System.IO.Error (ioeSetErrorString, mkIOError)
+import Network.Socket
+import GHC.IO.Exception
+
+
+throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a)
+throwNoSuchThingIfNull loc desc act = do
+  ptr <- act
+  if (ptr == nullPtr)
+       then ioError (ioeSetErrorString (mkIOError NoSuchThing loc Nothing Nothing) desc)
+       else return ptr
+
+{-# NOINLINE lock #-}
+lock :: MVar ()
+lock = unsafePerformIO $ newMVar ()
+
+withLock :: IO a -> IO a
+withLock act = withMVar lock (\_ -> act)
+
+trySysCall :: IO a -> IO a
+trySysCall act = act
+
+{-
+-- The locking of gethostbyaddr is similar to gethostbyname.
+-- | Get a 'HostEntry' corresponding to the given address and family.
+-- Note that only IPv4 is currently supported.
+getHostByAddr :: Family -> SockAddr -> IO HostEntry
+getHostByAddr family addr = do
+ withSockAddr addr $ \ ptr_addr len -> withLock $ do
+ throwNoSuchThingIfNull         "getHostByAddr" "no such host entry"
+   $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral len) (packFamily family)
+ >>= peek
+-}
+
+
+-- The locking of gethostbyaddr is similar to gethostbyname.
+-- | Get a 'HostEntry' corresponding to the given address and family.
+-- Note that only IPv4 is currently supported.
+-- getHostByAddr :: Family -> HostAddress -> IO HostEntry
+-- getHostByAddr family addr = do
+getHostByAddr :: SockAddr -> IO HostEntry
+getHostByAddr (SockAddrInet port addr ) = do
+ let family = AF_INET
+ with addr $ \ ptr_addr -> withLock $ do
+ throwNoSuchThingIfNull         "getHostByAddr" "no such host entry"
+   $ trySysCall $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family)
+ >>= peek
+getHostByAddr (SockAddrInet6 port flow (a,b,c,d) scope) = do
+ let family = AF_INET6
+ allocaBytes 16 $ \ ptr_addr -> do
+ pokeElemOff ptr_addr 0 a
+ pokeElemOff ptr_addr 1 b
+ pokeElemOff ptr_addr 2 c
+ pokeElemOff ptr_addr 3 d
+ withLock $ do
+ throwNoSuchThingIfNull         "getHostByAddr" "no such host entry"
+   $ trySysCall $ c_gethostbyaddr ptr_addr 16 (packFamily family)
+ >>= peek
+
+
+foreign import ccall safe "gethostbyaddr"
+   c_gethostbyaddr :: Ptr a -> CInt -> CInt -> IO (Ptr HostEntry)
+
+
+
+-- vim:ft=haskell:
diff --git a/dht/Presence/IDMangler.hs b/dht/Presence/IDMangler.hs
new file mode 100644
index 00000000..664d4f54
--- /dev/null
+++ b/dht/Presence/IDMangler.hs
@@ -0,0 +1,68 @@
+---------------------------------------------------------------------------
+-- |
+-- Module : IDMangler
+--
+-- This library is useful for generating id attributes for use in an XMPP
+-- application.  It conveniently encodes a key value for looking up context and
+-- an original id attribute in case of forwarded messages.
+--
+-- For example, an id attribute with an embedded 'XMPPServer.ConnectionKey'
+-- for a forwarded message with an original id attribute of \"purplecfa6168a\"
+-- might look something like this:
+--
+-- > AAAAAAAAAAIBksnqOQiYmtmupcLxbXakI9zcmUl4:purplecfa6168a
+--
+{-# LANGUAGE OverloadedStrings #-}
+module IDMangler
+    ( IDMangler
+    , newIDMangler
+    , generateUniqueID
+    , unmangleId
+    ) where
+
+import Control.Monad.STM
+import Control.Concurrent.STM
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.ByteString.Lazy as LazyByteString
+import Data.Binary
+import qualified Codec.Binary.Base64 as Base64
+import Control.Monad
+import Data.Monoid ( (<>) )
+
+
+data IDMangler k
+ = IDMangler { idmCounter :: TVar Int }
+
+newIDMangler :: IO (IDMangler k)
+newIDMangler = do
+    nv <- atomically $ newTVar 0
+    return $ IDMangler nv
+
+-- | Use the given state and optional data to generate a unique id attribute
+-- suitable for xml.  To recover the optional encoded data, see 'unmangleId'.
+generateUniqueID :: Binary k =>
+    IDMangler k   -- ^ the state (a counter) for ensuring uniqueness
+    -> Maybe k    -- ^ optional recoverable key for context
+    -> Maybe Text -- ^ optional recoverable auxilary id attribute
+    -> IO Text    -- ^ unique id attribute with encoded data
+generateUniqueID mangler mkey mid = do
+    n <- atomically $ do
+        modifyTVar' (idmCounter mangler) (+1)
+        readTVar (idmCounter mangler)
+    let bs = encode (n,mkey)
+        base64 = Base64.encode (LazyByteString.unpack bs)
+        suf = maybe "" (":" <>) mid
+    return $ Text.pack base64 <> suf
+
+-- | Recover data from an encoded id attribute.
+unmangleId :: Binary k => Text -> (Maybe k, Maybe Text)
+unmangleId encoded = (k,mid)
+ where
+    (e,postcolon) = Text.span (/=':') encoded
+    bytes = Base64.decode (Text.unpack e)
+    decoded = fmap (decode . LazyByteString.pack) bytes
+    k = decoded >>= (\(n,k) -> let _ = n :: Int in k)
+    mid = do guard (not . Text.null $ postcolon)
+             return $ Text.drop 1 postcolon
+
diff --git a/dht/Presence/LocalChat.hs b/dht/Presence/LocalChat.hs
new file mode 100644
index 00000000..eab54a03
--- /dev/null
+++ b/dht/Presence/LocalChat.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE CPP #-}
+module LocalChat
+    ( module Chat
+    , module LocalChat
+    ) where
+
+import Debug.Trace
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Function
+import Data.List
+import qualified Data.Map as Map
+         ;import Data.Map (Map)
+import qualified Data.Text as T
+         ;import Data.Text (Text)
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+import DPut
+import DebugTag
+import Chat
+import MUC
+
+forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
+forkUntilSignaled lbl action = do
+    quitSignal <- newTVarIO False
+    t <- forkIO $ do
+        fix $ \loop -> join $ atomically
+            $ orElse (do readTVar quitSignal >>= check
+                         return $ return ())
+                     (fmap (>> loop) $ action)
+    labelThread t lbl
+    return $ atomically (writeTVar quitSignal True)
+
+
+chatevents rsvar = do
+    rs <- readTVar rsvar
+    if Map.null rs
+      then retry
+      else do
+        ios <- forM rs $ \r -> do
+            ps <- roomPending r
+            trace ("roomPending " ++ show ps) $ return ()
+            case Map.toList ps of
+                (k,t):ts -> do
+                    roomCommit r k t
+                    return $ do
+                        dput XJabber $ "committed " ++ show (length ts,k,t)
+                _ -> retry
+        return $ foldl1 (>>) ios
+
+forkLocalChat :: MUC -> IO (IO ())
+forkLocalChat muc = do
+    (chan, rs) <- atomically $ do
+        c <- dupTChan (mucChan muc)
+        rs <- newTVar Map.empty
+        return (c,rs)
+    forkUntilSignaled "localchat" $ orElse (chatevents rs) $ do
+        e <- readTChan chan
+        case e of
+            MUCCreate room jid nick r -> modifyTVar' rs $ Map.insert room r
+        return $ case e of
+            MUCCreate room jid nick _ ->
+                dput XJabber $ unwords $ map T.unpack
+                    [ "MUCCreate", room, jid, nick ]
+
diff --git a/dht/Presence/LocalPeerCred.hs b/dht/Presence/LocalPeerCred.hs
new file mode 100644
index 00000000..f68557e8
--- /dev/null
+++ b/dht/Presence/LocalPeerCred.hs
@@ -0,0 +1,234 @@
+{-# LANGUAGE ViewPatterns  #-}
+{-# LANGUAGE TupleSections #-}
+module LocalPeerCred where
+
+import System.Endian
+import qualified Data.ByteString.Lazy.Char8 as L
+ -- hiding (map,putStrLn,tail,splitAt,tails,filter)
+ --  import qualified Data.ByteString.Lazy.Char8 as L (splitAt)
+import qualified Data.ByteString.Lazy as W8
+import Data.List as List (tails,groupBy)
+import System.IO ( withFile, IOMode(..))
+import System.Directory
+import Control.Arrow (first)
+import Data.Char
+import Data.Maybe
+import Data.Bits
+import Data.Serialize
+import Data.Word
+import System.Posix.Types
+import System.Posix.Files
+import Logging
+import Network.SocketLike
+import ControlMaybe
+import Data.String
+import System.IO
+
+(??) :: (Num t, Ord t) => [a] -> t -> Maybe a
+xs     ?? n | n < 0 =  Nothing
+[]     ?? _         =  Nothing
+(x:_)  ?? 0         =  Just x
+(_:xs) ?? n         =  xs ?? (n-1)
+
+parseHex :: W8.ByteString -> W8.ByteString
+parseHex bs = L.concat . parseHex' $ bs
+ where
+  parseHex' bs =
+      let (dnib,ts) = L.splitAt 2 bs
+          parseNibble x = W8.pack $ group2 toW8 (W8.unpack $ W8.map hexDigit x)
+          hexDigit d = d - (if d>0x39 then 0x37 else 0x30)
+          group2 f (x:y:ys) = f x y : group2 f ys
+          group2 _ _        = []
+          toW8 a b = shift a 4 .|. b
+      in parseNibble dnib :
+          if L.null ts 
+              then []
+              else parseHex' ts
+
+getLocalPeerCred' :: SockAddr -> IO (Maybe (UserID, W8.ByteString))
+getLocalPeerCred' (unmap6mapped4 -> SockAddrInet portn host) = do
+    let port = fromEnum portn
+    {- trace ("tcp4 "++show(port,host)) $ -} 
+    withFile "/proc/net/tcp"  ReadMode (parseProcNet port host)
+
+getLocalPeerCred' (unmap6mapped4 -> SockAddrInet6 portn flow host scope) = do
+    let port = fromEnum portn
+        (a,b,c,d) = host
+        host' = (toBE32 a, toBE32 b, toBE32 c, toBE32 d)
+    withFile "/proc/net/tcp6" ReadMode (parseProcNet port host')
+
+getLocalPeerCred' (unmap6mapped4 -> addr@(SockAddrUnix _)) =
+    -- TODO:  parse /proc/net/unix
+    -- see also: Network.Socket.getPeerCred
+    return Nothing
+
+getLocalPeerCred :: SocketLike sock => sock -> IO (Maybe UserID)
+getLocalPeerCred sock = do
+    addr <- getPeerName sock
+    muid <- getLocalPeerCred' addr
+    case muid of
+        Just (uid,inode) -> return (Just uid)
+        Nothing  -> trace "proc failed." $ fmap (validate . CUid . fromIntegral . sndOf3) (getPeerCred sock)
+                     where sndOf3 (pid,uid,gid) = uid
+ where
+    validate uid = Just uid -- TODO
+
+from16 :: Word16 -> Int
+from16 = fromEnum
+
+as16 :: Word16 -> Word16
+as16 = id
+
+parseProcNet :: (Serialize t, Num t1, Eq t, Eq t1) =>
+          t1
+          -> t
+          -> Handle
+          -> IO (Maybe (UserID, W8.ByteString))
+parseProcNet port host h = do
+        tcp <- L.hGetContents h -- Failed: tcp <- hFileSize h >>= hGet h . fromIntegral
+        let u = do
+                    ls <- listToMaybe . tail . tails . L.lines $ tcp
+                    let ws = map L.words ls
+                    let rs = ( catMaybes . flip map ws $ \xs -> do
+                          let ys = snd (Prelude.splitAt 1 xs)
+                          localaddr <- listToMaybe ys
+                          let zs = L.splitWith (==':') localaddr
+                          addr <- fmap parseHex $ listToMaybe zs
+                          port <- either (const Nothing) (Just . fromIntegral . as16) . decode . L.toStrict . parseHex
+                                  =<< listToMaybe (snd (Prelude.splitAt 1 zs))
+                          let ys' = snd (Prelude.splitAt 5 (tail ys))
+                              ys'' = snd (Prelude.splitAt 2 ys')
+                          uid <- listToMaybe ys'
+                          inode <- listToMaybe ys''
+                          peer <- either (const Nothing) Just $ do
+                            a <- decode $ L.toStrict addr
+                            return (port,a)
+                          let user = toEnum (read (L.unpack uid) ::Int) ::UserID  -- CUid . fromIntegral $ (read (unpack uid)::Int)
+                          return $ {-trace ("peer:"++show(peer,user,inode))-} (peer,(user,inode))
+                          )
+                    fmap snd . listToMaybe $ filter ((==(port,host)).fst) rs 
+        {- trace ("found: "++show u) -} 
+        u `seq` return u
+ {-
+ where
+    a === b = let r= a==b in  trace ("Comparing "++show (a,b)++"-->"++show r) r
+    -}
+
+
+-- PEER NAME: [::ffff:127.0.0.1]:34307
+unmap6mapped4 :: SockAddr -> SockAddr
+unmap6mapped4 addr@(SockAddrInet6 port _ (0,0,0xFFFF,a) _) = SockAddrInet port (toBE32 a)
+unmap6mapped4 addr = addr
+
+identifyTTY ::
+  [(W8.ByteString, ProcessID)]
+  -> UserID -> W8.ByteString -> IO (Maybe W8.ByteString, Maybe CPid)
+identifyTTY tty_pids uid inode = do
+    pid <- scanProc (show uid) (L.unpack inode)
+    -- putStrLn $ "scanProc --> "++show pid
+    fromMaybe (return (Nothing,Nothing)) $ pid <&> \(pid,ttydev) -> do
+    tty <- ttyOrDisplay pid ttydev
+    -- putStrLn $ "users = " ++ show tty_pids
+    dts <- ttyToXorgs tty_pids
+    -- putStrLn $ "displays = " ++ show dts 
+    -- putStrLn $ "tty = " ++ show tty
+    -- -- displays = [(":5",Chunk "tty7" Empty)]
+    let tty' = if take 3 tty=="tty" 
+                then Just (L.pack tty) 
+                else lookup (parseTty tty) (map (first parseTty) dts)
+    return (tty',Just pid)
+    where
+        parseTty :: String -> Float
+        parseTty = read .  tail . dropWhile (/=':') 
+
+ttyToXorgs :: Show a => [(t, a)] -> IO [([Char], t)]
+ttyToXorgs tty_pids = do
+    dts' <- flip mapM tty_pids $ \(tty,pid) -> do
+        cmd' <- readFile $ "/proc/"++show pid++"/cmdline"
+        case listToMaybe . words . takeWhile (/='\0') $ cmd' of
+          Nothing  -> return Nothing
+          Just cmd -> do
+            if notElem cmd ["gdm-session-worker"]
+                then return Nothing
+                else do
+                  display <- readDisplayVariable pid
+                  return (fmap ( (,tty) . snd ) display)
+    let dts = catMaybes dts'
+    return dts
+
+
+scanProc :: t -> [Char] -> IO (Maybe (CPid, FilePath))
+scanProc uid inode = do
+    contents <- getDirectoryContents "/proc" `catchIO_` return []
+    let pids = reverse $ filter (\n -> not (null n) && isDigit (head n)) contents
+    let searchPids []         = return Nothing
+        searchPids (pid:pids) =  do
+            loginuid <- fmap makeUidStr $ readFile $ "/proc/"++pid++"/loginuid"
+            if False -- (uid/=loginuid) -- this check proved bad when mcabber ran on tty3
+             then searchPids pids
+             else do
+                -- putStrLn $ "pid "++show pid ++ " --> uid "++show loginuid
+                let loop [] = return Nothing
+                    loop ("0":fds) = loop fds
+                    loop (fd:fds) = do
+                      handleIO_ (loop fds) $ do
+                          what <- readSymbolicLink $ "/proc/"++pid++"/fd/"++fd
+                          -- putStrLn $ " what= "++show what
+                          if (what=="socket:["++inode++"]")
+                            then do
+                              tty <- readSymbolicLink $ "/proc/"++pid++"/fd/0"
+                              return (Just (pid,tty))
+                            else loop fds
+                -- requires root (or same user as for pid)...
+                fds <- getDirectoryContents ("/proc/"++pid++"/fd") `catchIO_` return []
+                mb <- loop fds
+                maybe (searchPids pids) (return . Just) mb
+
+    fmap (fmap (first (read :: String -> CPid))) $ searchPids pids
+
+ttyOrDisplay :: Show a => a -> FilePath -> IO [Char]
+ttyOrDisplay pid ttydev = do
+    ptty <- searchParentsForTTY (show pid) ttydev
+    case ptty of
+        Just tty -> return tty
+        Nothing  -> do
+            display <- readDisplayVariable pid
+            -- putStrLn $ "display = " ++ show display
+            case display of
+                Just (_,disp) -> return disp
+                _             -> return ttydev
+
+
+readDisplayVariable :: Show a => a -> IO (Maybe ([Char], [Char]))
+readDisplayVariable pid = do
+            env <- handleIO_ (return "") 
+                    . readFile $ "/proc/"++show pid++"/environ"
+            let vs = unzero $ List.groupBy (\_ c->c/='\0') env
+                unzero []     = []
+                unzero (v:vs) = v:map tail vs
+                keyvalue xs = (key,value) 
+                  where
+                    (key,ys) = break (=='=') xs
+                    value = case ys of { [] -> [];  (_:ys') -> ys' }
+                display = listToMaybe 
+                            . filter ((=="DISPLAY").fst) 
+                            . map keyvalue 
+                            $ vs
+            return display 
+
+
+makeUidStr :: (Data.String.IsString t, Eq t) => t -> t
+makeUidStr "4294967295" = "invalid"
+makeUidStr uid          = uid
+
+
+searchParentsForTTY :: String -> FilePath -> IO (Maybe [Char])
+searchParentsForTTY pid  ttydev | take 8 ttydev == "/dev/tty" = return . Just $ drop 5 ttydev
+searchParentsForTTY "1"  ttydev | otherwise                   = return Nothing
+searchParentsForTTY pid ttydev = do
+    stat <- handleIO_ (return "") . readFile $ "/proc/"++pid++"/stat"
+    case words stat ?? 3 of
+        Nothing   -> return Nothing
+        Just ppid -> do
+          tty <- handleIO_ (return "") $ readSymbolicLink $ "/proc/"++ppid++"/fd/0"
+          searchParentsForTTY ppid tty
diff --git a/dht/Presence/LockedChan.hs b/dht/Presence/LockedChan.hs
new file mode 100644
index 00000000..eac2b5ad
--- /dev/null
+++ b/dht/Presence/LockedChan.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE CPP #-}
+module LockedChan
+  ( LockedChan
+  , cloneLChan
+  , newLockedChan
+  , peekLChan
+  , unlockChan 
+  , writeLChan )
+ where
+
+
+import Control.Monad.STM
+import Control.Concurrent.STM
+
+data LockedChan a = LockedChan
+    { lock :: TVar Bool
+    , chan :: TChan a
+    }
+
+unlockChan :: LockedChan a -> IO (TChan a)
+unlockChan c = do
+    waslocked <- atomically $ swapTVar (lock c) False
+    if waslocked
+        then return (chan c) 
+        else error "Attempt to read unlocked channel"
+
+writeLChan :: LockedChan a -> a -> STM ()
+writeLChan c a = writeTChan (chan c) a
+
+-- This one blocks rather than throwing an exception...
+-- todo: probably this should be changed to conform to the rest
+-- of the api.
+peekLChan :: LockedChan a -> STM a
+peekLChan c = do
+    readTVar (lock c) >>= check
+    peekTChan (chan c)
+
+newLockedChan :: STM (LockedChan a)
+newLockedChan = do
+    lock <- newTVar True
+    chan <- newTChan
+    return $ LockedChan lock chan
+
+cloneLChan :: LockedChan a -> IO (LockedChan a)
+cloneLChan c = do
+    mchan <- atomically $ do
+        locked <- readTVar (lock c)
+        if locked
+            then fmap Just $ do
+                    c2 <- cloneTChan (chan c)
+                    l2 <- newTVar True
+                    return $ LockedChan l2 c2
+            else return Nothing
+    maybe (do putStrLn "LockedChan: Attempt to clone unlocked channel"
+              error "Attempt to clone unlocked channel")
+          return
+          mchan
+
+#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
diff --git a/dht/Presence/Logging.hs b/dht/Presence/Logging.hs
new file mode 100644
index 00000000..b997d341
--- /dev/null
+++ b/dht/Presence/Logging.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE RankNTypes #-}
+module Logging where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.ByteString.Char8 as S
+import qualified Data.Text.IO as Text
+import qualified Data.Text as Text
+import qualified Debug.Trace as Debug
+
+debugL :: L.ByteString -> IO ()
+debugS :: S.ByteString -> IO ()
+debugStr :: String -> IO ()
+debugText :: Text.Text -> IO ()
+trace :: forall a. String -> a -> a
+
+
+debugStr str = putStrLn str
+
+debugL bs = L.putStrLn bs
+
+debugS bs = S.putStrLn bs
+
+debugText text = Text.putStrLn text
+
+trace str a = Debug.trace str a
diff --git a/dht/Presence/MUC.hs b/dht/Presence/MUC.hs
new file mode 100644
index 00000000..639e834b
--- /dev/null
+++ b/dht/Presence/MUC.hs
@@ -0,0 +1,61 @@
+module MUC where
+
+import Control.Monad
+import Control.Concurrent.STM
+
+import qualified Data.Map.Strict as Map
+         ;import Data.Map.Strict (Map)
+
+import Chat
+import ConnectionKey
+import Data.Text (Text)
+
+data MUC = MUC
+    { mucRooms :: TVar (Map Text (Room ClientAddress))
+    , mucChan  :: TChan MUCEvent
+    }
+
+data MUCEvent = MUCCreate Text{-room-} Text{-JID-} Text{-nick-} (Room ClientAddress)
+
+
+newMUC :: STM MUC
+newMUC = MUC <$> newTVar Map.empty <*> newBroadcastTChan
+
+mucRoomList :: MUC -> IO [(Text{-room-},Maybe Text{-friendly room name-})]
+mucRoomList muc = atomically $ do
+    rs <- Map.toList <$> readTVar (mucRooms muc)
+    forM rs $ \(rkey,r) -> do
+        fn <- roomFriendlyName r
+        return (rkey,fn)
+
+mucRoomOccupants :: MUC -> Text{-room-} -> IO [(Text{-nick-},Maybe Text{-friendly name-})]
+mucRoomOccupants muc rkey = atomically $ do
+    mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
+    case mr of
+        Nothing -> return []
+        Just r  -> roomOccupants r
+
+mucReservedNick :: MUC -> Text{-room-} -> IO (Maybe (Text{-JID-} -> IO (Maybe Text)))
+mucReservedNick muc rkey = atomically $ do
+    mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
+    case mr of
+        Nothing -> return Nothing
+        Just r  -> return $ Just $ \jid -> atomically $ roomReservedNick r jid
+
+mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> STM (JoinedRoom ClientAddress)
+mucJoinRoom muc jid nick rkey k = do
+    mr <- Map.lookup rkey <$> readTVar (mucRooms muc)
+    case mr of
+        Nothing -> do
+            -- create room.
+            r <- newRoom
+            v <- joinRoom k r (Just jid) nick
+            modifyTVar' (mucRooms muc) $ Map.insert rkey r
+            writeTChan (mucChan muc) $ MUCCreate rkey jid nick r
+            return v
+        Just r  -> do
+            -- join room.
+            v <- joinRoom k r (Just jid) nick
+            return v
+
+
diff --git a/dht/Presence/Nesting.hs b/dht/Presence/Nesting.hs
new file mode 100644
index 00000000..cf47c9fc
--- /dev/null
+++ b/dht/Presence/Nesting.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Nesting where
+
+import Control.Monad.State.Strict
+import Data.Conduit
+import Data.Conduit.Lift
+import qualified Data.List as List
+import qualified Data.Text as S
+import Data.XML.Types
+
+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
+
+xmlLang :: Monad m => NestingXML o m (Maybe Lang)
+xmlLang = fmap (fmap snd . top . langStack) (lift get)
+  where
+    top ( a :! _as ) = Just a
+    top _           = Nothing
+
+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 :: [(Name, [Content])] -> Maybe S.Text
+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 =
+    fix $ \loop -> do
+        lvl' <- nesting
+        when (lvl' >= lvl) $ do
+        xml <- await
+        maybe (return ()) (const loop) xml
+
+withXML ::
+    Monad m =>
+    (i -> ConduitM i o m ()) -> ConduitM i o m ()
+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 _ _) -> return xml
+            Just _ -> do
+                lvl' <- nesting
+                if (lvl'>=lvl) then loop
+                               else return Nothing
diff --git a/dht/Presence/Paths.hs b/dht/Presence/Paths.hs
new file mode 100644
index 00000000..9d51b66e
--- /dev/null
+++ b/dht/Presence/Paths.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE CPP #-}
+module Paths where
+
+#include <paths.h>
+
+bshell :: String
+console :: String
+cshell :: String
+devdb :: String
+devnull :: String
+drum :: String
+gshadow :: String
+klog :: String
+kmem :: String
+lastlog :: String
+maildir :: String
+man :: String
+mem :: String
+mnttab :: String
+mounted :: String
+nologin :: String
+preserve :: String
+rwhodir :: String
+sendmail :: String
+shadow :: String
+shells :: String
+tty :: String
+unix :: String
+utmp :: String
+vi :: String
+wtmp :: String
+
+
+
+bshell = _PATH_BSHELL
+console = _PATH_CONSOLE
+cshell = _PATH_CSHELL
+devdb = _PATH_DEVDB
+devnull = _PATH_DEVNULL
+drum = _PATH_DRUM
+gshadow = _PATH_GSHADOW
+klog = _PATH_KLOG
+kmem = _PATH_KMEM
+lastlog = _PATH_LASTLOG
+maildir = _PATH_MAILDIR
+man = _PATH_MAN
+mem = _PATH_MEM
+mnttab = _PATH_MNTTAB
+mounted = _PATH_MOUNTED
+nologin = _PATH_NOLOGIN
+preserve = _PATH_PRESERVE
+rwhodir = _PATH_RWHODIR
+sendmail = _PATH_SENDMAIL
+shadow = _PATH_SHADOW
+shells = _PATH_SHELLS
+tty = _PATH_TTY
+unix = _PATH_UNIX
+utmp = _PATH_UTMP
+vi = _PATH_VI
+wtmp = _PATH_WTMP
+
+
diff --git a/dht/Presence/PeerResolve.hs b/dht/Presence/PeerResolve.hs
new file mode 100644
index 00000000..62becfe1
--- /dev/null
+++ b/dht/Presence/PeerResolve.hs
@@ -0,0 +1,27 @@
+module PeerResolve
+    ( peerKeyToResolvedNames
+    , resolvePeer
+    , parseAddress
+    , unsafeParseAddress
+    , strip_brackets
+    , withPort
+    ) where
+
+import Data.Text       ( Text )
+import Network.Socket  ( SockAddr(..) )
+import System.IO.Unsafe
+
+import DNSCache
+import ConnectionKey
+
+{-# NOINLINE global_dns_cache #-}
+global_dns_cache :: DNSCache
+global_dns_cache = unsafePerformIO $ newDNSCache
+
+resolvePeer :: Text -> IO [PeerAddress]
+resolvePeer addrtext = map PeerAddress <$> forwardResolve global_dns_cache addrtext
+
+peerKeyToResolvedNames :: PeerAddress -> IO [Text]
+peerKeyToResolvedNames (PeerAddress addr)
+    = reverseResolve global_dns_cache addr
+
diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs
new file mode 100644
index 00000000..8cdd1cdc
--- /dev/null
+++ b/dht/Presence/Presence.hs
@@ -0,0 +1,1428 @@
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE LambdaCase                #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE TupleSections             #-}
+module Presence where
+
+import System.Directory
+import System.IO.Error
+#ifndef THREAD_DEBUG
+import Control.Concurrent
+#else
+import Control.Concurrent.Lifted.Instrument
+#endif
+
+import Control.Concurrent.STM
+import Control.Monad.Trans
+import Network.Socket ( SockAddr(..) )
+import Data.Char
+import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
+import Data.Ord (comparing )
+import Data.Monoid ((<>))
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Control.Monad
+import Data.Text (Text)
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Control.Exception ({-evaluate,-}handle,SomeException(..))
+import System.Posix.User (getUserEntryForID,userName)
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified ConfigFiles
+import Data.Maybe
+import Data.Bits
+import Data.Int (Int8)
+import Data.XML.Types (Event)
+import System.Posix.Types (UserID,CPid)
+import Control.Applicative
+import Crypto.PubKey.Curve25519 (SecretKey,toPublic)
+
+import ControlMaybe
+import DNSCache (parseAddress, strip_brackets, withPort)
+import LockedChan (LockedChan)
+import Text.Read (readMaybe)
+import UTmp (ProcessID,users)
+import LocalPeerCred
+import XMPPServer
+import ConsoleWriter
+import ClientState
+import Util
+import qualified Connection
+         ;import Connection (PeerAddress (..), resolvePeer, reverseAddress)
+import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgress,ToxContact(..))
+import Crypto.Tox (decodeSecret)
+import DPut
+import DebugTag
+
+{-
+isPeerKey :: ClientAddress -> Bool
+isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
+
+isClientKey :: ClientAddress -> Bool
+isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
+-}
+
+localJID :: Text -> Text -> Text -> IO Text
+localJID user "." resource = do
+    hostname <- textHostName
+    return $ user <> "@" <> hostname <> "/" <> resource
+localJID user profile resource =
+    return $ user <> "@" <> profile <> "/" <> resource
+
+-- | These hooks will be invoked in order to connect to *.tox hosts in the
+-- user's roster.
+--
+-- The parameter k is a lookup key corresponding to an XMPP client.  Each
+-- unique value should be able to hold a reference to the ToxID identity which
+-- should stay online until all interested keys have run 'deactivateAccount'.
+data ToxManager k = ToxManager
+      -- | Put the given ToxID online.
+    { activateAccount        :: k -> Text -> SecretKey -> IO ()
+      -- | Take the given ToxID offline (assuming no other /k/ has a claim).
+    , deactivateAccount      :: k -> Text -> IO ()
+    , toxConnections :: Connection.Manager ToxProgress ToxContact
+      -- | Given a remote Tox key, return the address of a connected peer.
+      --
+      -- The arguments are our public key (in base64 format) followed by
+      -- their public key (in base64 format).
+    , resolveToxPeer         :: Text -> Text -> IO (Maybe PeerAddress)
+    }
+
+type ClientProfile = Text
+
+data PresenceState status = PresenceState
+    { clients         :: TVar (Map ClientAddress ClientState)
+    , clientsByUser   :: TVar (Map Text LocalPresence)
+    , clientsByProfile :: TVar (Map Text LocalPresence)
+    , remotesByPeer   :: TVar (Map PeerAddress
+                                   (Map UserName RemotePresence))
+    , server          :: XMPPServer
+    , manager         :: ClientProfile -> Connection.Manager status Text
+    , ckeyToChan       :: TVar (Map ClientAddress Conn)
+    , pkeyToChan       :: TVar (Map PeerAddress Conn)
+    , consoleWriter   :: Maybe ConsoleWriter
+    , toxManager      :: Maybe (ToxManager ClientAddress)
+    }
+
+
+newPresenceState :: Maybe ConsoleWriter
+                 -> Maybe (PresenceState status -> ToxManager ClientAddress)
+                 -> XMPPServer
+                 -> (ClientProfile -> Connection.Manager status Text)
+                 -> IO (PresenceState status)
+newPresenceState cw toxman sv man = atomically $ do
+        clients          <- newTVar Map.empty
+        clientsByUser    <- newTVar Map.empty
+        clientsByProfile <- newTVar Map.empty
+        remotesByPeer    <- newTVar Map.empty
+        ckeyToChan       <- newTVar Map.empty
+        pkeyToChan       <- newTVar Map.empty
+        let st = PresenceState
+                    { clients          = clients
+                    , clientsByUser    = clientsByUser
+                    , clientsByProfile = clientsByProfile
+                    , remotesByPeer    = remotesByPeer
+                    , ckeyToChan       = ckeyToChan
+                    , pkeyToChan       = pkeyToChan
+                    , server           = sv
+                    , manager          = man
+                    , consoleWriter    = cw
+                    , toxManager       = Nothing
+                    }
+        return $ st { toxManager = fmap ($ st) toxman }
+
+
+nameForClient :: PresenceState stat -> ClientAddress -> IO Text
+nameForClient state k = do
+    mc <- atomically $ do
+        cmap <- readTVar (clients state)
+        return $ Map.lookup k cmap
+    case mc of
+        Nothing -> textHostName
+        Just client -> case clientProfile client of
+            "."     -> textHostName
+            profile -> return profile
+
+presenceHooks :: PresenceState stat -> Map Text MUC
+                                      -> Int
+                                      -> Maybe SockAddr -- ^ client-to-server bind address
+                                      -> Maybe SockAddr -- ^ server-to-server bind address
+                                      -> XMPPServerParameters
+presenceHooks state chats verbosity mclient mpeer = XMPPServerParameters
+    { xmppChooseResourceName        = chooseResourceName state
+    , xmppTellClientHisName         = tellClientHisName state
+    , xmppTellMyNameToClient        = nameForClient state
+    , xmppTellMyNameToPeer          = \(Local addr) -> return $ addrToText addr
+    , xmppTellPeerHisName           = return . peerKeyToText
+    , xmppNewConnection             = newConn state
+    , xmppEOF                       = eofConn state
+    , xmppRosterBuddies             = rosterGetBuddies state
+    , xmppRosterSubscribers         = rosterGetSubscribers state
+    , xmppRosterSolicited           = rosterGetSolicited state
+    , xmppRosterOthers              = rosterGetOthers state
+    , xmppSubscribeToRoster         = informSentRoster state
+    , xmppDeliverMessage            = deliverMessage state
+    , xmppInformClientPresence      = informClientPresence state
+    , xmppInformPeerPresence        = informPeerPresence state
+    , xmppAnswerProbe               = \k stanza chan -> answerProbe state (stanzaTo stanza) k chan
+    , xmppClientSubscriptionRequest = clientSubscriptionRequest state
+    , xmppPeerSubscriptionRequest   = peerSubscriptionRequest state
+    , xmppClientInformSubscription  = clientInformSubscription state
+    , xmppPeerInformSubscription    = peerInformSubscription state
+    , xmppVerbosity                 = return verbosity
+    , xmppGroupChat                 = chats {- Map.singleton "chat" chat
+        { mucRoomList      = return [("testroom",Just "testroom")]
+        , mucRoomOccupants = \case
+            "testroom" -> return [("fakeperson",Nothing)]
+            _          -> return []
+        , mucReservedNick = \case
+            "testroom" -> return $ Just (return . Just)
+            _          -> return Nothing
+        , mucJoinRoom = \room nick caddr stanza -> do
+            who <- tellClientHisName state caddr
+            dput XJabber $ Text.unpack who ++ " joined " ++ Text.unpack room
+                            ++ " with nick: " ++ Text.unpack nick
+            -- TODO: broadcast presence to all participants.
+            -- See 7.2.3 of XEP-0045
+        -}
+    , xmppClientBind                = mclient
+    , xmppPeerBind                  = mpeer
+    }
+
+
+data LocalPresence = LocalPresence
+    { networkClients :: Map ClientAddress ClientState
+    -- TODO: loginClients
+    }
+
+data RemotePresence = RemotePresence
+    { resources :: Map ResourceName Stanza
+    -- , localSubscribers :: Map Text ()
+    -- ^ subset of clientsByUser who should be
+    -- notified about this presence.
+    }
+
+
+
+pcSingletonNetworkClient :: ClientAddress -> ClientState -> LocalPresence
+pcSingletonNetworkClient key client =
+    LocalPresence
+    { networkClients = Map.singleton key client
+    }
+
+pcInsertNetworkClient :: ClientAddress -> ClientState -> LocalPresence -> LocalPresence
+pcInsertNetworkClient key client pc =
+    pc { networkClients = Map.insert key client (networkClients pc) }
+
+pcRemoveNewtworkClient :: ClientAddress
+                        -> LocalPresence -> Maybe LocalPresence
+pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing
+                                                 else Just pc'
+ where
+    pc' = pc { networkClients = Map.delete key (networkClients pc) }
+
+pcIsEmpty :: LocalPresence -> Bool
+pcIsEmpty pc = Map.null (networkClients pc)
+
+
+
+getConsolePids :: PresenceState stat -> IO [(Text,ProcessID)]
+getConsolePids state = do
+    us <- UTmp.users
+    return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
+
+identifyTTY' :: [(Text, ProcessID)]
+              -> System.Posix.Types.UserID
+              -> L.ByteString
+              -> IO (Maybe Text, Maybe System.Posix.Types.CPid)
+identifyTTY' ttypids uid inode = ttypid
+ where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids
+       ttypid = fmap textify $ identifyTTY ttypids' uid inode
+       textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
+
+chooseResourceName :: PresenceState stat
+                    -> ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
+chooseResourceName state k (Remote addr) clientsNameForMe desired = do
+    muid <- getLocalPeerCred' addr
+    (mtty,pid) <- getTTYandPID muid
+    user <- getJabberUserForId muid
+    status <- atomically $ newTVar Nothing
+    flgs <- atomically $ newTVar 0
+    profile <- fmap (fromMaybe ".")
+        $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) ->
+        case Text.splitAt 43 wanted_profile0 of
+            (pub,".tox") -> do
+                cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." ""
+#if !MIN_VERSION_directory(1,2,5)
+                let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path
+#endif
+                cfs  <- map Text.pack <$> listDirectory cdir `catchIOError` (\e -> return [])
+                let profiles = filter (\f -> Text.toLower f == Text.toLower wanted_profile0) cfs
+                -- dput XMisc $ "Toxmpp profile " ++ show (user,wanted_profile0,profiles,cfs)
+                let wanted_profile = head $ profiles ++ [wanted_profile0]
+                secs <- configText ConfigFiles.getSecrets user wanted_profile
+                case secs of
+                    sec:_ | Just s <- decodeSecret (Text.encodeUtf8 sec)
+                          , map toLower (show $ key2id $ toPublic s) == map toLower (Text.unpack pub)
+                          -> do activateAccount toxman k wanted_profile s
+                                dput XMisc $ "loaded tox secret " ++ show sec
+                                return wanted_profile
+                    _     -> do
+                            -- XXX: We should probably fail to connect when an
+                            -- invalid Tox profile is used.  For now, we'll
+                            -- fall back to the Unix account login.
+                            dput XMisc "failed to find tox secret"
+                            return "."
+            ("*.tox","") -> do
+                dput XMisc $ "TODO: Match single tox key profile or generate first."
+                -- TODO: Match single tox key profile or generate first.
+                _todo
+            _ -> return "."
+    let client = ClientState { clientResource = maybe "fallback" id mtty
+                             , clientUser     = user
+                             , clientProfile  = profile
+                             , clientPid      = pid
+                             , clientStatus   = status
+                             , clientFlags    = flgs }
+
+    do -- forward-lookup of the buddies so that it is cached for reversing.
+       buds <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
+       forM_ buds $ \bud -> do
+            let (_,h,_) = splitJID bud
+            forkIO $ void $ resolvePeer (manager state $ clientProfile client) h
+
+    atomically $ do
+        modifyTVar' (clients state) $ Map.insert k client
+        let add mb = Just $ maybe (pcSingletonNetworkClient k client)
+                                  (pcInsertNetworkClient k client)
+                                  mb
+        modifyTVar' (clientsByUser    state) $ Map.alter add (clientUser client)
+        modifyTVar' (clientsByProfile state) $ Map.alter add (clientProfile client)
+
+    localJID (clientUser client) (clientProfile client) (clientResource client)
+
+  where
+    getTTYandPID muid = do
+        -- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state
+        ttypids <- getConsolePids state
+        -- let tailOf3 ((_,a),b) = (a,b)
+        (t,pid) <- case muid of
+                      Just (uid,inode) -> identifyTTY' ttypids uid inode
+                      Nothing          -> return (Nothing,Nothing)
+        let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid
+        return (rsc,pid)
+
+    getJabberUserForId muid =
+             maybe (return "nobody")
+                   (\(uid,_) ->
+                        handle (\(SomeException _) ->
+                                return . (<> "uid.") . Text.pack . show $ uid)
+                          $ do
+                             user <- fmap userName $ getUserEntryForID uid
+                             return (Text.pack user)
+                        )
+                   muid
+
+-- Perform action with 'ClientState' associated with the given 'ClientAddress'.
+-- If there is no associated 'ClientState', then perform the supplied fallback
+-- action.
+forClient :: PresenceState stat -> ClientAddress -> IO b -> (ClientState -> IO b) -> IO b
+forClient state k fallback f = do
+    mclient <- atomically $ do
+        cs <- readTVar (clients state)
+        return $ Map.lookup k cs
+    maybe fallback f mclient
+
+tellClientHisName :: PresenceState stat -> ClientAddress -> IO Text
+tellClientHisName state k = forClient state k fallback go
+ where
+    fallback  = localJID "nobody" "." "fallback"
+    go client = localJID (clientUser client) (clientProfile client) (clientResource client)
+
+toMapUnit :: Ord k => [k] -> Map k ()
+toMapUnit xs = Map.fromList $ map (,()) xs
+
+resolveAllPeers :: Connection.Manager stat Text -> [Text] -> IO (Map PeerAddress ())
+resolveAllPeers man hosts = fmap (toMapUnit . concat) $ Prelude.mapM (fmap (take 1) . resolvePeer man) hosts
+
+
+-- Read a roster file and start trying to connect to all relevent peers.
+rosterGetStuff
+  :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
+     -> PresenceState stat -> ClientAddress -> IO [Text]
+rosterGetStuff what state k = forClient state k (return [])
+    $ \client -> do
+    jids0 <- configText what (clientUser client) (clientProfile client)
+    let jids = map splitJID jids0
+    -- Using case to bring 'status' type variable to Connection.Manager into scope.
+    case state of
+      PresenceState { server = sv } -> do
+        let conns = manager state $ clientProfile client
+        -- Grok peers to associate with from the roster:
+        let isTox = do (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
+                       return me
+            noToxUsers (u,h,r)
+                | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r)
+                | otherwise                = unsplitJID (u,h,r)
+        forM_ jids $ \(_,host,_) -> do
+            -- We need either conns  :: Connection.Manager TCPStatus Text
+            --             or toxman :: ToxManager ClientAddress
+            -- It is decided by checking hostnames for .tox ending.
+            let policySetter = fromMaybe (Connection.setPolicy conns host) $ do
+                    isTox
+                    toxman <- toxManager state
+                    (them, ".tox") <- Just $ Text.splitAt 43 host
+                    meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
+                    themid <- readMaybe $ Text.unpack them
+                    return $ Connection.setPolicy (toxConnections toxman)
+                                                  (ToxContact meid themid)
+            policySetter Connection.TryingToConnect
+        return $ fromMaybe jids0 $ do isTox
+                                      Just $ map noToxUsers jids
+
+rosterGetBuddies :: PresenceState stat -> ClientAddress -> IO [Text]
+rosterGetBuddies state k = rosterGetStuff ConfigFiles.getBuddies state k
+
+rosterGetSolicited :: PresenceState stat -> ClientAddress -> IO [Text]
+rosterGetSolicited = rosterGetStuff ConfigFiles.getSolicited
+
+-- XXX: Should we be connecting to these peers?
+rosterGetOthers :: PresenceState stat -> ClientAddress -> IO [Text]
+rosterGetOthers = rosterGetStuff ConfigFiles.getOthers
+
+rosterGetSubscribers :: PresenceState stat -> ClientAddress -> IO [Text]
+rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
+
+data Conn = Conn { connChan :: TChan Stanza
+                 , auxData  :: ConnectionData }
+
+-- Read config file as Text content rather than UTF8 bytestrings.
+configText :: Functor f =>
+            (ConfigFiles.User -> ConfigFiles.Profile -> f [L.ByteString])
+            -> Text     -- user
+            -> Text     -- profile
+            -> f [Text] -- items
+configText what u p = fmap (map lazyByteStringToText)
+                        $ what (textToLazyByteString u) (Text.unpack p)
+
+getBuddies' :: Text -> Text -> IO [Text]
+getBuddies' = configText ConfigFiles.getBuddies
+getSolicited' :: Text -> Text -> IO [Text]
+getSolicited' = configText ConfigFiles.getSolicited
+
+-- | Obtain from roster all buddies and pending buddies (called solicited
+-- regardless of whether we've yet delivered a friend-request) matching the
+-- supplied side-effecting predicate.
+--
+-- Returned tuple:
+--
+--   * Bool - True if buddy (should send probe).
+--            False if solicited (should send friend-request).
+--
+--   * Maybe Username - Username field of contact.
+--
+--   * Text - Unix user who owns this roster entry.
+--
+--   * Text - Hostname as it appears in roster.
+--
+getBuddiesAndSolicited :: PresenceState stat
+                         -> Text              -- ^ Config profile: "." or tox host.
+                         -> (Text -> IO Bool) -- ^ Return True if you want this hostname.
+                         -> IO [(Bool, Maybe UserName, Text, Text)]
+getBuddiesAndSolicited state profile pred
+    -- XXX: The following O(n²) nub may be a little
+    --      too onerous.
+    = fmap nub $ do
+        cbu <- atomically $ readTVar $ clientsByUser state
+        fmap concat $ sequence $ do
+            (user,LocalPresence cmap) <- Map.toList cbu
+            (isbud, getter) <- [(True ,getBuddies'  )
+                               ,(False,getSolicited')]
+            return $ do
+                buds <- map splitJID <$> getter user profile
+                fmap concat $ forM buds $ \(u,h,r) -> do
+                interested <- pred h
+                if interested
+                    then return [(isbud,u,user,h)]
+                    else return []
+
+sendProbesAndSolicitations :: PresenceState stat -> PeerAddress -> Local SockAddr -> TChan Stanza -> IO ()
+sendProbesAndSolicitations state k (Local laddr) chan = do
+    prof <- atomically $ do
+        pktc <- readTVar (pkeyToChan state)
+        return $ maybe "." (cdProfile . auxData) $  Map.lookup k pktc
+    -- get all buddies & solicited matching k for all users
+    xs <- getBuddiesAndSolicited state prof $ \case
+        h | ".tox" `Text.isSuffixOf` h -> return False -- Tox probes/solicitations are handled in ToxToXMPP module.
+        h -> do
+            addrs <- nub <$> resolvePeer (manager state $ prof) h
+            return $ k `elem` addrs -- Roster item resolves to /k/ peer.
+    forM_ xs $ \(isbud,u,user,h) -> do
+        let make = if isbud then presenceProbe
+                            else presenceSolicitation
+            toh = peerKeyToText k
+            jid = unsplitJID (u,toh,Nothing)
+            me = addrToText laddr -- xmppTellMyNameToPeer
+            from = if isbud then me -- probe from server
+                            else -- solicitation from particular user
+                                 unsplitJID (Just user,me,Nothing)
+        stanza <- make from jid
+        -- send probes for buddies, solicitations for solicited.
+        dput XJabber $ "probing "++show k++" for: " ++ show (isbud,jid)
+        atomically $ writeTChan chan stanza
+    -- reverse xs `seq` return ()
+
+
+newConn :: PresenceState stat -> SockAddr -> ConnectionData -> TChan Stanza -> IO ()
+newConn state saddr cdta outchan =
+    case classifyConnection saddr cdta of
+        Left (pkey,laddr) -> do
+            atomically $ modifyTVar' (pkeyToChan state)
+                $ Map.insert pkey Conn { connChan = outchan
+                                       , auxData  = cdta }
+            sendProbesAndSolicitations state pkey laddr outchan
+        Right (ckey,_) -> do
+            atomically $ modifyTVar' (ckeyToChan state)
+                $ Map.insert ckey Conn { connChan = outchan
+                                       , auxData  = cdta }
+
+delclient :: (Alternative m, Monad m) =>
+           ClientAddress -> m LocalPresence -> m LocalPresence
+delclient k mlp = do
+    lp <- mlp
+    let nc = Map.delete k $ networkClients lp
+    guard $ not (Map.null nc)
+    return $ lp { networkClients = nc }
+
+eofConn :: PresenceState stat -> SockAddr -> ConnectionData -> IO ()
+eofConn state saddr cdta = do
+    case classifyConnection saddr cdta of
+        Left (k,_) -> do
+            h <- case cdType cdta of
+                -- TODO: This should be cached (perhaps by rewriteJIDForClient?) so that we
+                -- guarantee that the OFFLINE message matches the ONLINE message.
+                -- For now, we reverse-resolve the peer key.
+                XMPP -> -- For XMPP peers, informPeerPresence expects a textual
+                        -- representation of the IP address to reverse-resolve.
+                        return $ peerKeyToText k
+                Tox  -> do
+                    -- For Tox peers, informPeerPresence expects the actual hostname
+                    -- so we will use the one that the peer told us at greeting time.
+                    m <- atomically $ swapTVar (cdRemoteName cdta) Nothing
+                    case m of
+                        Nothing -> do
+                            dput XJabber $ "BUG: Tox peer didn't inform us of its name."
+                            -- The following fallback behavior is probably wrong.
+                            return $ peerKeyToText k
+                        Just toxname -> return toxname
+            -- ioToSource terminated.
+            --
+            -- dhtd: Network.Socket.getAddrInfo
+            --   (called with preferred socket type/protocol: AddrInfo
+            --      { addrFlags = [AI_NUMERICHOST], addrFamily = AF_UNSPEC
+            --      , addrSocketType = NoSocketType, addrProtocol = 0
+            --      , addrAddress = <assumed to be undefined>
+            --      , addrCanonName = <assumed to be undefined>}
+            --      , host name: Just "DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
+            --      , service name: Just "0")
+            --      : does not exist (Name or service not known)
+
+            jids <- atomically $ do
+                rbp <- readTVar (remotesByPeer state)
+                return $ do
+                    umap <- maybeToList $ Map.lookup k rbp
+                    (u,rp) <- Map.toList umap
+                    r <- Map.keys (resources rp)
+                    let excludeEmpty "" = Nothing
+                        excludeEmpty x  = Just x
+                    return $ unsplitJID (excludeEmpty u, h, excludeEmpty r)
+            -- EOF PEER PeerAddress [d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]:0:
+            --   ["@[d768:82dd:3e86:a6ba:8fb3:6f9c:6327:75d8%4236342772]/"]
+            -- dput XJabber $ "EOF PEER "++show k++": "++show jids
+            forM_ jids $ \jid -> do
+            stanza <- makePresenceStanza "jabber:client" (Just jid) Offline
+            informPeerPresence state k stanza
+        Right (k,_) -> do
+            forClient state k (return ()) $ \client -> do
+            forM_ (toxManager state) $ \toxman -> do
+                case Text.splitAt 43 (clientProfile client) of
+                    (pub,".tox") -> deactivateAccount toxman k (clientProfile client)
+                    _            -> return ()
+            stanza <- makePresenceStanza "jabber:server" Nothing Offline
+            informClientPresence state k stanza
+            atomically $ do
+                modifyTVar' (clientsByUser    state) $ Map.alter (delclient k) (clientUser    client)
+                modifyTVar' (clientsByProfile state) $ Map.alter (delclient k) (clientProfile client)
+    atomically $ case classifyConnection saddr cdta of
+                    Left  (pkey,_) -> modifyTVar' (pkeyToChan state) $ Map.delete pkey
+                    Right (ckey,_) -> modifyTVar' (ckeyToChan state) $ Map.delete ckey
+
+{-
+parseRemoteAddress :: Text -> IO (Maybe (Remote SockAddr))
+parseRemoteAddress s = fmap Remote <$> parseAddress s
+-}
+
+-- This attempts to reverse resolve a peers address to give the human-friendly
+-- domain name as it appears in the roster.  It prefers host names that occur
+-- in the given list of JIDs, but will fall back to any reverse-resolved name
+-- and if it was unable to reverse the address, it will yield an ip address.
+peerKeyToResolvedName :: Connection.Manager s Text -> [Text] -> PeerAddress -> IO Text
+peerKeyToResolvedName man buds pk = do
+    ns <- reverseAddress man pk
+    let hs = map (\jid -> let (_,h,_)=splitJID jid in h) buds
+        ns' = sortBy (comparing $ not . flip elem hs) ns
+    return $ fromMaybe (peerKeyToText pk) (listToMaybe ns')
+
+
+-- | The given address is taken to be the local address for the socket this JID
+-- came in on.  The returned JID parts are suitable for unsplitJID to create a
+-- valid JID for communicating to a client.  The returned Bool is True when the
+-- host part refers to this local host (i.e. it equals the given SockAddr).
+-- If there are multiple results, it will prefer one which is a member of the
+-- given list in the last argument.
+rewriteJIDForClient :: Connection.Manager s Text -> Local SockAddr -> Text -> [Text] -> IO (Bool,(Maybe Text,Text,Maybe Text))
+rewriteJIDForClient man (Local laddr) jid buds = do
+    let (n,h,r) = splitJID jid
+    -- dput XJabber $ "rewriteJIDForClient parsing " ++ show h
+    maddr <- parseAddress (strip_brackets h)
+    fromMaybe (return (False,(n,ip6literal h,r))) $ maddr <&> \saddr -> do
+    let mine =  sameAddress laddr saddr
+    h' <- if mine then textHostName
+                  else peerKeyToResolvedName man buds (addrToPeerKey $ Remote saddr)
+    return (mine,(n,h',r))
+
+-- Given a local address and an IP-address JID, we return True if the JID is
+-- local, False otherwise.  Additionally, a list of equivalent hostname JIDS
+-- are returned.
+multiplyJIDForClient :: Connection.Manager s Text -> ClientAddress -> Text -> IO (Bool,[(Maybe Text,Text,Maybe Text)])
+multiplyJIDForClient man k jid = do
+    let (n,h,r) = splitJID jid
+    -- dput XJabber $ "multiplyJIDForClient parsing " ++ show h
+    maddr <- parseAddress (strip_brackets h)
+    fromMaybe (return (False,[(n,ip6literal h,r)])) $ maddr <&> \saddr -> do
+    let Local laddr = addrFromClientKey k
+        mine        = sameAddress laddr saddr
+    names <- if mine then fmap (:[]) textHostName
+                     else reverseAddress man (addrToPeerKey $ Remote saddr)
+    return (mine,map (\h' -> (n,h',r)) names)
+
+
+guardPortStrippedAddress :: Text -> Local SockAddr -> IO (Maybe ())
+guardPortStrippedAddress h (Local laddr) = do
+    -- dput XJabber $ "guardPortStrippedAddress parsing " ++ show h
+    maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h)
+    let laddr' = laddr `withPort` 0
+    return $ maddr >>= guard . (==laddr')
+
+
+-- | Accepts a textual representation of a domainname
+-- JID suitable for client connections, and returns the
+-- coresponding ipv6 address JID suitable for peers paired
+-- with a PeerAddress with the address part of that JID in
+-- binary form.  If no suitable address could be resolved
+-- for the given name, Nothing is returned.
+rewriteJIDForPeer :: Connection.Manager s Text -> Text -> IO (Maybe (Text,PeerAddress))
+rewriteJIDForPeer man jid = do
+    let (n,h,r) = splitJID jid
+    maddr <- fmap listToMaybe $ resolvePeer man h
+    return $ flip fmap maddr $ \addr ->
+        let h' = peerKeyToText addr
+            to' = unsplitJID (n,h',r)
+        in (to',addr)
+
+deliverToConsole :: PresenceState stat -> IO () -> Stanza -> IO ()
+deliverToConsole PresenceState{ consoleWriter = Just cw } fail msg = do
+    did1 <- writeActiveTTY cw msg
+    did2 <- writeAllPty cw msg
+    if not (did1 || did2) then fail else return ()
+deliverToConsole _ fail _ = fail
+
+-- | deliver <message/> or error stanza
+deliverMessage :: PresenceState stat
+                -> IO ()
+                -> StanzaWrap (LockedChan Event)
+                -> IO ()
+deliverMessage state fail msg =
+    case stanzaOrigin msg of
+      ClientOrigin senderk _ -> do
+        -- Case 1.  Client -> Peer
+        mto <- join $ atomically $ do
+            mclient <- Map.lookup senderk <$> readTVar (clients state)
+            return $ do
+              dput XJabber $ "deliverMessage: to="++show (stanzaTo msg,fmap clientProfile mclient)
+              fromMaybe -- Resolve XMPP peer.
+                          (fmap join $ mapM (uncurry $ rewriteJIDForPeer . manager state)
+                                     $ (,) <$> (clientProfile <$> mclient) <*> stanzaTo msg)
+                $ do
+                     client <- mclient
+                     to <- stanzaTo msg
+                     let (mu,th,rsc) = splitJID to
+                     (toxman,me,_) <- weAreTox state client th
+                     return $ do
+                         dput XJabber $ "deliverMessage: weAreTox="++show me
+                         -- In case the client sends us a lower-cased version of the base64
+                         -- tox key hostname, we resolve it by comparing it with roster entries.
+                         xs <- getBuddiesAndSolicited state (clientProfile client) $ \case
+                            rh | (_,".tox") <- Text.splitAt 43 rh
+                               , Text.toLower rh == Text.toLower th
+                               -> return True
+                            _ -> return False
+                         fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do
+                             let (them,_) = Text.splitAt 43 h
+                             maddr <- resolveToxPeer toxman me them
+                             let to' = unsplitJID (mu,h,rsc)
+                             return $ fmap (to',) maddr
+        fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg)
+                      fail {- reverse lookup failure -})
+                $ mto <&> \(to',k) -> do
+        chans <- atomically $ readTVar (pkeyToChan state)
+        fromMaybe (do dput XJabber $ "Peer unavailable: "++ show k
+                      fail)
+                $ (Map.lookup k chans) <&> \conn -> do
+        -- original 'from' address is discarded.
+        from' <- forClient state senderk (return Nothing)
+                        $ return . Just . clientJID conn
+        -- dup <- atomically $ cloneStanza (msg { stanzaTo=Just to', stanzaFrom=Just from' })
+        let dup = (msg { stanzaTo=Just to', stanzaFrom=from' })
+        sendModifiedStanzaToPeer dup (connChan conn)
+      PeerOrigin senderk _ -> do
+        (pchans,cchans) <- atomically $ do
+            pc <- readTVar (pkeyToChan state)
+            cc <- readTVar (ckeyToChan state)
+            return (pc,cc)
+        fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk
+                      fail)
+                $ Map.lookup senderk pchans
+            <&> \(Conn { connChan = sender_chan
+                       , auxData  = ConnectionData (Left laddr) ctyp cprof _ }) -> do
+        fromMaybe (do dput XJabber $ "Message missing \"to\" attribute."
+                      fail)
+                $ (stanzaTo msg) <&> \to -> do
+        (mine,(n,h,r)) <- case (ctyp,cprof) of
+            (Tox,prof) -> let (n,h,r) = splitJID to
+                          in return ( h==prof, (n,h,r) )
+            _          -> rewriteJIDForClient (manager state cprof) laddr to []
+        if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to)
+                            fail
+                    else do
+        let to' = unsplitJID (n,h,r)
+        let (cmapVar,ckey) = case ctyp of
+                Tox  -> (clientsByProfile state , Just cprof )
+                XMPP -> (clientsByUser    state , n          )
+        cmap <- atomically . readTVar $ cmapVar
+        chans <- fmap (fromMaybe []) $ do
+            forM (ckey >>= flip Map.lookup cmap) $ \presence_container -> do
+            let ks = Map.keys (networkClients presence_container)
+                chans = do
+                    (k,client) <- Map.toList $ networkClients presence_container
+                    chan <- maybeToList $ Map.lookup k cchans
+                    return (clientProfile client, clientUser client, chan)
+            forM chans $ \(profile,user,chan) -> do
+            buds <- configText ConfigFiles.getBuddies user profile
+            from' <- case ctyp of
+              Tox  -> return $ stanzaFrom msg
+              XMPP -> do
+                forM (stanzaFrom msg) $ \from -> do
+                (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
+                return $ unsplitJID trip
+            to' <- case ctyp of
+                XMPP -> return $ stanzaTo msg
+                Tox  -> return $ Just $ unsplitJID (Just user, profile, Nothing)
+            return (from',chan)
+        dput XJabber $ "chan count: " ++ show (length chans)
+        if null chans then when (ctyp == XMPP) $ do
+            forM_ (stanzaFrom msg) $ \from -> do
+            from' <- do
+                -- Fallback to "." profile when no clients.
+                buds <- maybe (return [])
+                              (\n -> configText ConfigFiles.getBuddies n ".")
+                              n
+                (_,trip) <- rewriteJIDForClient (manager state cprof) laddr from buds
+                return . Just $ unsplitJID trip
+            let msg' = msg { stanzaTo=Just to'
+                           , stanzaFrom=from' }
+            deliverToConsole state fail msg'
+        else do
+            forM_ chans $ \(from',Conn { connChan=chan}) -> do
+            -- TODO: Cloning isn't really necessary unless there are multiple
+            -- destinations and we should probably transition to minimal cloning,
+            -- or else we should distinguish between announcable stanzas and
+            -- consumable stanzas and announcables use write-only broadcast
+            -- channels that must be cloned in order to be consumed.
+            -- For now, we are doing redundant cloning.
+            let msg' = msg { stanzaTo=Just to'
+                           , stanzaFrom=from' }
+            dup <- cloneStanza msg'
+            sendModifiedStanzaToClient dup
+                                      chan
+
+
+setClientFlag :: PresenceState stat -> ClientAddress -> Int8 -> IO ()
+setClientFlag state k flag =
+    atomically $ do
+        cmap <- readTVar (clients state)
+        forM_ (Map.lookup k cmap) $ \client -> do
+        setClientFlag0 client flag
+
+setClientFlag0 :: ClientState -> Int8 -> STM ()
+setClientFlag0 client flag =
+    modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
+
+informSentRoster :: PresenceState stat -> ClientAddress -> IO ()
+informSentRoster state k = do
+    setClientFlag state k cf_interested
+
+
+subscribedPeers :: Connection.Manager s Text -> Text -> Text -> IO [PeerAddress]
+subscribedPeers man user profile = do
+    jids <- configText ConfigFiles.getSubscribers user profile
+    let hosts = map ((\(_,h,_)->h) . splitJID) jids
+    fmap Map.keys $ resolveAllPeers man hosts
+
+-- | this JID is suitable for peers, not clients.
+clientJID :: Conn -> ClientState -> Text
+clientJID con client = unsplitJID ( Just $ clientUser client
+                                  , either (\(Local a) -> addrToText a) -- my host name, for peers
+                                           (error $ unlines [ "clientJID wrongly used for client connection!"
+                                                            , "TODO: my host name for clients? nameForClient? localJID?"])
+                                           $ cdAddr $ auxData con
+                                  , Just $ clientResource client)
+
+-- | Send presence notification to subscribed peers.
+-- Note that a full JID from address will be added to the
+-- stanza if it is not present.
+informClientPresence :: PresenceState stat
+                        -> ClientAddress -> StanzaWrap (LockedChan Event) -> IO ()
+informClientPresence state k stanza = do
+    forClient state k (return ()) $ \client -> do
+    informClientPresence0 state (Just k) client stanza
+
+informClientPresence0 :: PresenceState stat
+                       -> Maybe ClientAddress
+                       -> ClientState
+                       -> StanzaWrap (LockedChan Event)
+                       -> IO ()
+informClientPresence0 state mbk client stanza = do
+    dup <- cloneStanza stanza
+    atomically $ writeTVar (clientStatus client) $ Just dup
+    is_avail <- atomically $ clientIsAvailable client
+    when (not is_avail) $ do
+        atomically $ setClientFlag0 client cf_available
+        maybe (return ()) (sendCachedPresence state) mbk
+    addrs <- subscribedPeers (manager state $ clientProfile client) (clientUser client) (clientProfile client)
+    dput XJabber $ "informClientPresence(subscribedPeers) "++show (clientProfile client,addrs)
+    ktc <- atomically $ readTVar (pkeyToChan state)
+    let connected = mapMaybe (flip Map.lookup ktc) addrs
+    forM_ connected $ \con -> do
+    let from' = clientJID con client
+    mto <- maybe (return Nothing)
+                 (fmap (fmap fst) . rewriteJIDForPeer (manager state $ clientProfile client))
+                 (stanzaTo stanza)
+    dup <- cloneStanza stanza
+    sendModifiedStanzaToPeer dup { stanzaFrom = Just from'
+                                 , stanzaTo = mto }
+                             (connChan con)
+
+informPeerPresence :: PresenceState stat
+                    -> PeerAddress
+                    -> StanzaWrap (LockedChan Event)
+                    -> IO ()
+informPeerPresence state k stanza = do
+    -- Presence must indicate full JID with resource...
+    dput XJabber $ "xmppInformPeerPresence checking from address..."
+    forM_ (stanzaFrom stanza) $ \from -> do
+    let (muser0,h,mresource0) = splitJID from
+        -- We'll allow the case that user and resource are simultaneously
+        -- absent.  They will be stored in the remotesByPeer map using the
+        -- empty string.  This is to accommodate the tox protocol which didn't
+        -- anticipate a single peer would have multiple users or front-ends.
+        (muser,mresource) = case (muser0,mresource0) of
+            (Nothing,Nothing) -> (Just "", Just "")
+            _                 -> (muser0,mresource0)
+    dput XJabber $ "xmppInformPeerPresence from  = " ++ show from
+    -- forM_ mresource       $ \resource -> do
+    forM_ muser           $ \user -> do
+
+    clients <- atomically $ do
+
+        -- Update remotesByPeer...
+        rbp <- readTVar (remotesByPeer state)
+        let umap = maybe Map.empty id $ Map.lookup k rbp
+            rp = case (presenceShow $ stanzaType stanza) of
+                    Offline ->
+                        maybe Map.empty
+                              (\resource ->
+                                  maybe (Map.empty)
+                                     (Map.delete resource . resources)
+                                   $ Map.lookup user umap)
+                              mresource
+
+                    _ ->maybe Map.empty
+                              (\resource ->
+                                  maybe (Map.singleton resource stanza)
+                                     (Map.insert resource stanza . resources )
+                                    $ Map.lookup user umap)
+                              mresource
+            umap' = Map.insert user (RemotePresence rp) umap
+
+        fromMaybe (return []) $ case presenceShow $ stanzaType stanza of
+                                     Offline -> Just ()
+                                     _       -> mresource >> Just ()
+            <&> \_ -> do
+        writeTVar (remotesByPeer state) $ Map.insert k umap' rbp
+        -- TODO: Store or delete the stanza (remotesByPeer)
+
+        -- all clients, we'll filter available/authorized later
+
+        ktc <- readTVar (ckeyToChan state)
+        cmap <- readTVar (clients state)
+        return $ do
+            (ck,client) <- Map.toList cmap
+            con <- maybeToList $ Map.lookup ck ktc
+            return (ck,con,client)
+    dput XJabber $ "xmppInformPeerPresence (length clients="++show (length clients)++")"
+    (ctyp,cprof) <- atomically $ do
+        mconn <- Map.lookup k <$> readTVar (pkeyToChan state)
+        return $ fromMaybe (XMPP,".") $ do
+            ConnectionData _ ctyp cprof _ <- auxData <$> mconn
+            return (ctyp,cprof)
+    forM_ clients $ \(ck,con,client) -> do
+        -- (TODO: appropriately authorized clients only.)
+        -- For now, all "available" clients (available = sent initial presence)
+        is_avail <- atomically $ clientIsAvailable client
+        when is_avail $ do
+        -- reversing for client: ("DdhbLjiwaV0GAiGKgesNPbvj2TbhrBHEWEEc5icfvQN.tox"
+        --                       ,XMPP,"OrjBG.GyWuQhGc1pb0KssgmYAocohFh35Vx8mREC9Nu.tox",".")
+        dput XJabber $ "reversing for client: " ++ show (from,ctyp,clientProfile client,cprof)
+        froms <- case ctyp of
+            Tox | clientProfile client == cprof -> return [from]
+            _ -> do -- flip (maybe $ return [from]) k . const $ do
+                (_,trip) <- multiplyJIDForClient (manager state $ clientProfile client) ck from
+                return (map unsplitJID trip)
+
+        dput XJabber $ "sending to client: " ++ show (stanzaType stanza,froms)
+        forM_ froms $ \from' -> do
+        dup <- cloneStanza stanza
+        sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
+                                   (connChan con)
+
+consoleClients :: PresenceState stat -> STM (Map Text ClientState)
+consoleClients PresenceState{ consoleWriter = Just cw } = readTVar (cwClients cw)
+consoleClients _                                        = return Map.empty
+
+
+answerProbe :: PresenceState stat -> Maybe Text -> PeerAddress -> TChan Stanza -> IO ()
+answerProbe state mto k chan = do
+    -- dput XJabber $ "answerProbe! " ++ show (stanzaType stanza)
+    ktc <- atomically $ readTVar (pkeyToChan state)
+    muser <- fmap join $ sequence $ do
+        to <- mto
+        conn <- Map.lookup k ktc
+        let (mu,h,_)   = splitJID to -- TODO: currently resource-id is ignored on presence
+                                     --  probes.  Is this correct? Check the spec.
+            Left laddr = cdAddr $ auxData conn
+            ch         = addrToText a where Local a = laddr
+        u <- mu
+        Just $ do
+            guardPortStrippedAddress h laddr
+             <&> maybe Nothing (\_ -> Just (u,conn,ch))
+
+    forM_ muser $ \(u,conn,ch) -> do
+
+    profiles <- releventProfiles (cdType $ auxData conn) u
+    forM_ profiles $ \profile -> do
+
+    -- only subscribed peers should get probe replies
+    let man = manager state $ cdProfile $ auxData conn
+    resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers u profile
+    let gaddrs = groupBy sameHost (sort resolved_subs)
+        sameHost a b = (snd a == snd b) -- (==) `on` snd
+        whitelist = do
+            xs <- gaddrs     -- group of subscribed jids on the same host
+            x <- take 1 xs   -- the host from the group
+            guard $ snd x==k -- only hosts matching the key /k/
+            mapMaybe fst xs  -- all users subscribed at the remote peer /k/
+
+    -- TODO: notify remote peer that they are unsubscribed?
+    --   reply <- makeInformSubscription "jabber:server" to from False
+    when (not $ null whitelist) $ do
+
+    replies <- catMaybes <$> do -- runTraversableT $ do
+        cbu <- atomically $ readTVar (clientsByUser state) -- Map Text LocalPresence
+        let lpres = maybeToList $ Map.lookup u cbu
+        cw <- atomically $ consoleClients state -- Map Text ClientState
+        forM ((lpres >>= Map.elems . networkClients) ++ Map.elems cw) $ \clientState -> do
+            -- liftIOMaybe :: IO (Maybe a) -> TraversableT [] IO a
+            mstanza <- atomically $ readTVar (clientStatus clientState)
+            forM mstanza $ \stanza0 -> do
+                stanza <- cloneStanza stanza0
+                let jid = unsplitJID (Just $ clientUser clientState
+                                     , ch
+                                     ,Just $ clientResource clientState)
+                return stanza { stanzaFrom = Just jid
+                              , stanzaType = (stanzaType stanza)
+                                { presenceWhiteList = whitelist }
+                              }
+
+    forM_ replies $ \reply -> do
+        sendModifiedStanzaToPeer reply chan
+
+    -- if no presence, send offline message
+    when (null replies) $ do
+        let jid = unsplitJID (Just u,ch,Nothing)
+        pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline
+        atomically $ writeTChan (connChan conn) pstanza
+
+-- Send friend requests and remote presences stored in remotesByPeer to XMPP
+-- clients.
+sendCachedPresence :: PresenceState stat -> ClientAddress -> IO ()
+sendCachedPresence state k = do
+    forClient state k (return ()) $ \client -> do
+    rbp <- atomically $ readTVar (remotesByPeer state)
+    jids <- configText ConfigFiles.getBuddies (clientUser client) (clientProfile client)
+    let hosts = map ((\(_,h,_)->h) . splitJID) jids
+    addrs <- resolveAllPeers (manager state $ clientProfile client) hosts
+    let onlines = rbp `Map.intersection` addrs
+    mcon <- atomically $ do ktc <- readTVar (ckeyToChan state)
+                            return $ Map.lookup k ktc
+    forM_ mcon $ \con -> do
+    forM_ (Map.toList onlines) $ \(pk, umap) -> do
+        forM_ (Map.toList umap) $ \(user,rp) -> do
+        let h = peerKeyToText pk
+        forM_ (Map.toList $ resources rp) $ \(resource,stanza) -> do
+        let jid = unsplitJID (Just user,h,Just resource)
+        (mine,js) <- multiplyJIDForClient (manager state $ clientProfile client) k jid
+        forM_ js $ \jid -> do
+        let from' = unsplitJID jid
+        dup <- cloneStanza stanza
+        sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
+                                   (connChan con)
+
+    pending <- configText ConfigFiles.getPending (clientUser client) (clientProfile client)
+    hostname <- nameForClient state k
+    forM_ pending $ \pending_jid -> do
+        let cjid = unsplitJID ( Just $ clientUser client
+                              , hostname
+                              , Nothing )
+        ask <- presenceSolicitation pending_jid cjid
+        sendModifiedStanzaToClient ask (connChan con)
+
+    -- Note: relying on self peer connection to send
+    -- send local buddies.
+    return ()
+
+addToRosterFile ::
+                 Connection.Manager s Text
+                 -> (ConfigFiles.User
+                      -> ConfigFiles.Profile
+                      -> (L.ByteString -> IO (Maybe L.ByteString))
+                      -> Maybe L.ByteString
+                      -> t1)
+                 -> Text -- user
+                 -> Text -- profile
+                 -> Text -> [PeerAddress] -> t1
+addToRosterFile man doit whose profile to addrs =
+    modifyRosterFile man doit whose profile to addrs True False
+
+removeFromRosterFile ::
+                      Connection.Manager s Text
+                      -> (ConfigFiles.User
+                           -> ConfigFiles.Profile
+                           -> (L.ByteString -> IO (Maybe L.ByteString))
+                           -> Maybe L.ByteString
+                           -> t1)
+                      -> Text -- user
+                      -> Text -- profile
+                      -> Text -> [PeerAddress] -> t1
+removeFromRosterFile man doit whose profile to addrs =
+    modifyRosterFile man doit whose profile to addrs False False
+
+-- | Sanity-checked roster file manipulation.  Primarily, this function handles
+-- hostname aliases.
+modifyRosterFile ::
+                  Connection.Manager s Text
+                   -> (ConfigFiles.User
+                       -> ConfigFiles.Profile
+                       -> (L.ByteString -> IO (Maybe L.ByteString))
+                       -> Maybe L.ByteString
+                       -> t1)   -- ^ Lower-level modification function
+                                --   indicating which file is being modified.
+                                --   Valid choices from ConfigFiles module:
+                                --
+                                --     * modifySolicited
+                                --
+                                --     * modifyBuddies
+                                --
+                                --     * modifyPending
+                                --
+                                --     * modifySubscribers
+                  -> Text       -- ^ user
+                  -> Text       -- ^ profile
+                  -> Text       -- ^ JID that will be added or removed a hostname
+                  -> [PeerAddress] -- ^ Alias addresses for hostname in the JID.
+                  -> Bool       -- ^ True if adding, otherwise False
+                  -> Bool       -- ^ True to allow deleting all users at a host.
+                  -> t1
+modifyRosterFile man doit whose profile to addrs bAdd bWildCard = do
+    let (mu,_,_) = splitJID to
+        -- For each jid in the file, this function will decide whether to keep
+        -- it (possibly modified) which is indicated by Just _ or to remove the
+        -- item from the file which is indicated by Nothing.
+        cmp :: L.ByteString -> IO (Maybe L.ByteString)
+        cmp jid = do
+            let (msu,stored_h,mr) = splitJID (lazyByteStringToText jid)
+                keep   = return (Just jid) :: IO (Maybe L.ByteString)
+                delete = return Nothing    :: IO (Maybe L.ByteString)
+                iocheck  = do
+                    stored_addrs <- resolvePeer man stored_h -- TODO: don't resolve .tox peers.
+                    case stored_addrs of
+                        []                      -> keep   -- do not delete if failed to resolve
+                        xs | null (xs \\ addrs) -> delete -- hostname alias, delete
+                        _                       -> keep
+            fmap join $ sequence $ do
+                guard $ isNothing mr -- delete if resource specified in file.
+                if mu == msu || bWildCard
+                    then Just iocheck -- do not delete unless hostname alias
+                    else Just keep    -- do not delete if user field doesn't match.
+    doit (textToLazyByteString whose) (Text.unpack profile)
+         cmp
+         (guard bAdd >> Just (textToLazyByteString to))
+
+
+clientSubscriptionRequest :: PresenceState stat -> IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
+clientSubscriptionRequest state fail k stanza chan = do
+    forClient state k fail $ \client -> do
+    fromMaybe fail $ (splitJID <$> stanzaTo stanza) <&> \(mu,h,_) -> do
+    dput XJabber $ "Forwarding solicitation to peer"
+    let to0   = unsplitJID (mu,h,Nothing) -- deleted resource
+        cuser = clientUser client
+        cprof = clientProfile client
+        man = manager state cprof
+        mto = if ".tox" `Text.isSuffixOf` cprof
+          then case parseNoSpamId to0 of
+            Right toxjid@(NoSpamId nspam _)   -> Just ( Text.pack $ '$' : nospam64 nspam
+                                                      , Text.pack $ show toxjid
+                                                      , return [] )
+            Left _ | Text.isSuffixOf ".tox" h -> Nothing
+            Left _ | Text.all isHexDigit h
+                     && Text.length h == 76   -> Nothing
+            Left _ -> fmap (\u -> (u, to0 ,resolvePeer man h)) mu
+          else fmap (\u -> (u, to0 ,resolvePeer man h)) mu
+    fromMaybe fail $ mto <&> \(u,to,resolv) -> do
+    -- add to-address to from's solicited
+    dput XJabber $ unlines [ "to0=" ++ Text.unpack to0
+                           , "to=" ++ show (Text.unpack to) ]
+    addrs <- resolv
+    addToRosterFile      man ConfigFiles.modifySolicited cuser cprof to addrs
+    removeFromRosterFile man ConfigFiles.modifyBuddies   cuser cprof to addrs
+    resolved_subs <- resolvedFromRoster man ConfigFiles.getSubscribers cuser cprof
+    let is_subscribed = not . null $ [ (mu, a) | a <- addrs ]
+                                     `intersect` resolved_subs
+    -- subscribers: "from"
+    -- buddies: "to"
+
+    case state of
+      PresenceState { server = svVar } -> do
+
+        (cktc,pktc,(sv,conns)) <- atomically $ do
+            cktc <- readTVar $ ckeyToChan state
+            pktc <- readTVar $ pkeyToChan state
+            return (cktc,pktc,(server state,man))
+
+        -- Update roster for each client.
+        case stanzaType stanza of
+         PresenceRequestSubscription True -> do
+            hostname <- nameForClient state k
+            let cjid = unsplitJID (Just $ clientUser client, hostname,Nothing)
+            chans <- clientCons state cktc (clientUser client)
+            forM_ chans $ \( Conn { connChan=chan }, client ) -> do
+                -- roster update ask="subscribe"
+                update <- myMakeRosterUpdate (clientProfile client) cjid to
+                    [ ("ask","subscribe")
+                    , if is_subscribed then ("subscription","from")
+                                       else ("subscription","none")
+                    ]
+                sendModifiedStanzaToClient update chan
+                when (to /= to0) $ do
+                    removal <- myMakeRosterUpdate (clientProfile client) cjid to0
+                        [ ("subscription","remove") ]
+                    sendModifiedStanzaToClient removal chan
+         _ -> return ()
+
+        -- Send friend request to peer.
+        let dsts = pktc `Map.intersection` toMapUnit addrs
+        forM_ (Map.toList dsts) $ \(pk,con) -> do
+            -- if already connected, send solicitation ...
+            -- let from = clientJID con client
+            let Left laddr = cdAddr $ auxData con
+                from = unsplitJID ( Just $ clientUser client
+                                  , (\(Local a) -> addrToText a) $ laddr
+                                  , Nothing )
+            mb <- rewriteJIDForPeer (manager state $ cdProfile $ auxData con) to
+            forM_ mb $ \(to',addr) -> do
+            dup <- cloneStanza stanza
+            sendModifiedStanzaToPeer (dup { stanzaTo = Just to'
+                                          , stanzaFrom = Just from })
+                                     (connChan con)
+        let policySetter = fromMaybe (Connection.setPolicy conns h) $ do
+                (toxman,_,_) <- weAreTox state client h
+                meid <- readMaybe $ Text.unpack $ Text.take 43 (clientProfile client)
+                themid <- readMaybe $ Text.unpack h
+                Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid)
+        -- Add peer if we are not already associated ...
+        policySetter Connection.TryingToConnect
+
+weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
+weAreTox state client h = do
+    toxman <- toxManager state
+    (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
+    (them, ".tox") <- Just $ Text.splitAt 43 h
+    return (toxman,me,them)
+
+resolvedFromRoster
+  :: Connection.Manager s Text
+     -> (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
+     -> UserName -> Text -> IO [(Maybe UserName, PeerAddress)]
+resolvedFromRoster man doit u profile = concat <$> do
+    subs <- configText doit u profile
+    forM (splitJID `fmap` subs) $ \(mu,h,_) -> do
+        addrs <- fmap nub $ resolvePeer man h
+        return $ map (mu,) addrs
+
+clientCons :: PresenceState stat
+            -> Map ClientAddress t -> Text -> IO [(t, ClientState)]
+clientCons state ktc u = map snd <$> clientCons' state ktc u
+
+clientCons' :: PresenceState stat
+            -> Map ClientAddress t -> Text -> IO [(ClientAddress,(t, ClientState))]
+clientCons' state ktc u = do
+    mlp <- atomically $ do
+            cmap <- readTVar $ clientsByUser state
+            return $ Map.lookup u cmap
+    let ks = do lp <- maybeToList mlp
+                Map.toList (networkClients lp)
+        doit (k,client) = do
+            con <- Map.lookup k ktc
+            return (k,(con,client))
+    return $ mapMaybe doit ks
+
+releventProfiles :: ConnectionType -> Text -> IO [Text]
+releventProfiles XMPP _    = return ["."]
+releventProfiles ctyp user = do
+    -- TODO: Return all the ".tox" profiles that a user has under his
+    -- .presence/ directory.
+    return []
+
+peerSubscriptionRequest :: PresenceState stat -> IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
+peerSubscriptionRequest state fail k stanza chan = do
+    dput XJabber $ "Handling pending subscription from remote"
+    fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
+    fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
+    let (mto_u,h,_) = splitJID to
+        (mfrom_u,from_h,_) = splitJID from
+    to <- return $ unsplitJID (mto_u,h,Nothing) -- delete resource
+    from <- return $ unsplitJID (mfrom_u,from_h,Nothing) -- delete resource
+    (pktc,cktc,cmap) <- atomically $ do
+        cktc <- readTVar (ckeyToChan state)
+        pktc <- readTVar (pkeyToChan state)
+        cmap <- readTVar (clients state)
+        return (pktc,cktc,cmap)
+    fromMaybe fail $ (Map.lookup k pktc)
+        <&> \Conn { auxData=ConnectionData (Left laddr) ctyp profile _ } -> do
+    (mine,totup) <- case (ctyp,profile) of
+        (Tox,p) -> let (u,h,r) = splitJID to
+                   in return ( h == p, (u,h,r) )
+        _       -> rewriteJIDForClient (manager state profile) laddr to []
+    if not mine then fail else do
+    (_,fromtup) <- rewriteJIDForClient (manager state profile) laddr from []
+    fromMaybe fail $ mto_u <&> \u -> do
+    fromMaybe fail $ mfrom_u <&> \from_u -> do
+    resolved_subs <- resolvedFromRoster (manager state profile) ConfigFiles.getSubscribers u profile
+    let already_subscribed = elem (mfrom_u,k) resolved_subs
+        is_wanted = case stanzaType stanza of
+                      PresenceRequestSubscription b -> b
+                      _ -> False -- Shouldn't happen.
+    --    Section 8 says (for presence of type "subscribe", the server MUST
+    --    adhere to the rules defined under Section 3 and summarized under
+    --    see Appendix A. (pariticularly Appendex A.3.1)
+    if already_subscribed == is_wanted
+     then do
+        -- contact ∈ subscribers --> SHOULD NOT, already handled
+        -- already subscribed, reply and quit
+        -- (note: swapping to and from for reply)
+        reply <- makeInformSubscription "jabber:server" to from is_wanted
+        sendModifiedStanzaToPeer reply chan
+        answerProbe state (Just to) k chan
+     else do
+
+    -- TODO: if peer-connection is to self, then auto-approve local user.
+
+    -- add from-address to to's pending
+    addrs <- resolvePeer (manager state profile) from_h
+
+    -- Catch exception in case the user does not exist
+    if null addrs then fail else do
+
+    let from' = unsplitJID fromtup
+
+    -- Update roster files (subscribe: add to pending, unsubscribe: remove from subscribers).
+    already_pending <-
+      if is_wanted then
+        addToRosterFile (manager state profile) ConfigFiles.modifyPending u profile from' addrs
+      else do
+        removeFromRosterFile (manager state profile) ConfigFiles.modifySubscribers u profile from' addrs
+        reply <- makeInformSubscription "jabber:server" to from is_wanted
+        sendModifiedStanzaToPeer reply chan
+        return False
+
+    -- contact ∉ subscribers & contact ∈ pending --> SHOULD NOT
+    when (not already_pending) $ do
+    -- contact ∉ subscribers & contact ∉ pending --> MUST
+
+    chans <- clientCons state cktc u
+    forM_ chans $ \( Conn { connChan=chan }, client ) -> do
+    -- send to clients
+    -- TODO: interested/available clients only?
+    dup <- cloneStanza stanza
+    sendModifiedStanzaToClient dup { stanzaFrom = Just $ from'
+                                   , stanzaTo = Just $ unsplitJID totup }
+                               chan
+
+myMakeRosterUpdate prf tojid contact as
+    | ".tox" `Text.isSuffixOf` prf
+    , (Just u,h,r) <- splitJID contact
+    , ".tox" `Text.isSuffixOf` u      = XMPPServer.makeRosterUpdate tojid (unsplitJID (Nothing,h,r)) as
+myMakeRosterUpdate _ tojid contact as = XMPPServer.makeRosterUpdate tojid contact as
+
+
+clientInformSubscription :: PresenceState stat
+                          -> IO ()
+                          -> ClientAddress
+                          -> StanzaWrap (LockedChan Event)
+                          -> IO ()
+clientInformSubscription state fail k stanza = do
+    forClient state k fail $ \client -> do
+    fromMaybe fail $ (stanzaTo stanza) <&> \to -> do
+    dput XJabber $ "clientInformSubscription"
+    let (mu,h,mr) = splitJID to
+        man = manager state $ clientProfile client
+    addrs <- resolvePeer man h
+    -- remove from pending
+    buds <- resolvedFromRoster man ConfigFiles.getBuddies (clientUser client) (clientProfile client)
+    let is_buddy = not . null $ map (mu,) addrs `intersect` buds
+    removeFromRosterFile man ConfigFiles.modifyPending (clientUser client) (clientProfile client) to addrs
+    let (relationship,addf,remf) =
+         case stanzaType stanza of
+           PresenceInformSubscription True ->
+                ( ("subscription", if is_buddy then "both"
+                                               else "from" )
+                , ConfigFiles.modifySubscribers
+                , ConfigFiles.modifyOthers )
+           _ -> ( ("subscription", if is_buddy then "to"
+                                               else "none" )
+                , ConfigFiles.modifyOthers
+                , ConfigFiles.modifySubscribers )
+    addToRosterFile      man addf (clientUser client) (clientProfile client) to addrs
+    removeFromRosterFile man remf (clientUser client) (clientProfile client) to addrs
+
+    do
+        cbu <- atomically $ readTVar (clientsByUser state)
+        dput XJabber $ "cbu = " ++ show (fmap (fmap clientPid . networkClients) cbu)
+
+    -- send roster update to clients
+    (clients,ktc,pktc) <- atomically $ do
+        cbu <- readTVar (clientsByUser state)
+        let mlp = Map.lookup (clientUser client) cbu
+        let cs = maybe [] (Map.toList . networkClients) mlp
+        ktc <- readTVar (ckeyToChan state)
+        pktc <- readTVar (pkeyToChan state)
+        return (cs,ktc,pktc)
+    forM_ clients $ \(ck, client) -> do
+        is_intereseted <- atomically $ clientIsInterested client
+        dput XJabber $ "clientIsInterested: "++show is_intereseted
+        is_intereseted <- atomically $ clientIsInterested client
+        when is_intereseted $ do
+        forM_ (Map.lookup ck ktc) $ \con -> do
+        hostname <- nameForClient state ck
+        -- TODO: Should cjid include the resource?
+        let cjid = unsplitJID (mu, hostname, Nothing)
+        update <- myMakeRosterUpdate (clientProfile client) cjid to [relationship]
+        sendModifiedStanzaToClient update (connChan con)
+
+    -- notify peer
+    let dsts = toMapUnit addrs
+        cdsts = pktc `Map.intersection` dsts
+    forM_ (Map.toList cdsts) $ \(pk,con) -> do
+        let from = clientJID con client
+            to' = unsplitJID (mu, peerKeyToText pk, Nothing)
+        dup <- cloneStanza stanza
+        sendModifiedStanzaToPeer (dup { stanzaTo = Just $ to'
+                                      , stanzaFrom = Just from })
+                                 (connChan con)
+        answerProbe state (Just from) pk (connChan con)
+
+peerInformSubscription :: PresenceState stat
+                        -> IO ()
+                        -> PeerAddress
+                        -> StanzaWrap (LockedChan Event)
+                        -> IO ()
+peerInformSubscription state fail k stanza = do
+    dput XJabber $ "TODO: peerInformSubscription"
+    -- remove from solicited
+    fromMaybe fail $ (stanzaFrom stanza) <&> \from -> do
+    (ktc,cktc,cmap) <- atomically $ do
+        pktc <- readTVar (pkeyToChan state)
+        cktc <- readTVar (ckeyToChan state)
+        cmap <- readTVar (clients state)
+        return (pktc,cktc,cmap)
+    fromMaybe fail $ Map.lookup k ktc
+        <&> \(Conn { connChan=sender_chan
+                   , auxData =ConnectionData (Left laddr) ctyp profile _ }) -> do
+    let man = manager state profile
+    (from_u,from_h,_) <- case ctyp of
+        Tox  -> return $ splitJID from
+        XMPP -> snd <$> rewriteJIDForClient man laddr from []
+    let from'' = unsplitJID (from_u,from_h,Nothing)
+        muser = do
+            to <- stanzaTo stanza
+            let (mu,to_h,to_r) = splitJID to
+            mu
+    -- TODO muser = Nothing when wanted=False
+    -- should probably mean unsubscribed for all users.
+    -- This would allow us to answer anonymous probes with 'unsubscribed'.
+    fromMaybe fail $ muser <&> \user -> do
+
+    addrs <- resolvePeer man from_h
+    was_solicited <- removeFromRosterFile man ConfigFiles.modifySolicited user profile from'' addrs
+
+    subs <- resolvedFromRoster man ConfigFiles.getSubscribers user profile
+    let is_sub = not . null $ map (from_u,) addrs `intersect` subs
+    dput XJabber $ "DEBUG peerInformSubscription (is_sub,typ)=" ++ show (is_sub,stanzaType stanza)
+    let (relationship,addf,remf) =
+         case stanzaType stanza of
+           PresenceInformSubscription True ->
+                ( ("subscription", if is_sub then "both"
+                                             else "to" )
+                , ConfigFiles.modifyBuddies
+                , ConfigFiles.modifyOthers )
+           _ -> ( ("subscription", if is_sub then "from"
+                                             else "none")
+                , ConfigFiles.modifyOthers
+                , ConfigFiles.modifyBuddies )
+    addToRosterFile      man addf user profile from'' addrs
+    removeFromRosterFile man remf user profile from'' addrs
+
+    chans <- clientCons' state cktc user
+    forM_ chans $ \(ckey,(Conn { connChan=chan }, client)) -> do
+    hostname <- nameForClient state ckey
+    let to' = unsplitJID (Just user, hostname, Nothing)
+    update <- myMakeRosterUpdate (clientProfile client) to' from'' [relationship]
+    is_intereseted <- atomically $ clientIsInterested client
+    when is_intereseted $ do
+        sendModifiedStanzaToClient update chan
+    -- TODO: interested/availabe clients only?
+    dup <- cloneStanza stanza
+    sendModifiedStanzaToClient dup { stanzaFrom = Just $ from''
+                                   , stanzaTo = Just to' }
+                               chan
diff --git a/dht/Presence/SockAddr.hs b/dht/Presence/SockAddr.hs
new file mode 100644
index 00000000..b5fbf16e
--- /dev/null
+++ b/dht/Presence/SockAddr.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE StandaloneDeriving #-}
+module SockAddr () where
+
+#if MIN_VERSION_network(2,4,0)
+import Network.Socket ()
+#else
+import Network.Socket ( SockAddr(..) )
+
+deriving instance Ord SockAddr
+#endif
+
+
+
diff --git a/dht/Presence/Stanza/Build.hs b/dht/Presence/Stanza/Build.hs
new file mode 100644
index 00000000..16552428
--- /dev/null
+++ b/dht/Presence/Stanza/Build.hs
@@ -0,0 +1,155 @@
+{-# 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 = makeMessageEx namespace from to NormalMsg bod
+
+makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza
+makeMessageEx namespace from to msgtyp bod =
+    stanzaFromList typ
+     $ [ EventBeginElement (mkname namespace "message")
+            $ addMessageType msgtyp
+                [ 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)]
+                  , msgType    = msgtyp
+                  }
+    lsm = LangSpecificMessage
+            { msgBody    = Just bod
+            , msgSubject = Nothing }
+
+addMessageType ChatMsg      attrs = ("type",[ContentText "chat"]) : attrs
+addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs
+addMessageType HeadlineMsg  attrs = ("type",[ContentText "headline"]) : attrs
+addMessageType _            attrs = attrs
+
+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 ns mjid pstat = makePresenceStanzaEx ns mjid pstat []
+
+makePresenceStanzaEx :: Text -> Maybe Text -> JabberShow -> [XML.Event]-> IO Stanza
+makePresenceStanzaEx namespace mjid pstat es = do
+    stanzaFromList PresenceStatus { presenceShow = pstat
+                                  , presencePriority = Nothing
+                                  , presenceStatus = []
+                                  , presenceWhiteList = []
+                                  }
+      $ [ EventBeginElement (mkname namespace "presence")
+            (setFrom $ typ pstat) ]
+        ++ (shw pstat >>= jabberShow) ++ es ++
+        [ 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/dht/Presence/Stanza/Parse.hs b/dht/Presence/Stanza/Parse.hs
new file mode 100644
index 00000000..58bf7c51
--- /dev/null
+++ b/dht/Presence/Stanza/Parse.hs
@@ -0,0 +1,277 @@
+module Stanza.Parse (grokStanza,errorTagLocalName) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Char
+import Data.Function
+import Data.Maybe
+import qualified Data.Text    as Text (pack, unpack, words)
+         ;import Data.Text    (Text)
+
+import Control.Monad.Catch             (MonadThrow)
+import Control.Monad.IO.Class          (MonadIO, liftIO)
+import qualified Data.Map              as Map
+import Data.XML.Types                  as XML
+import qualified Text.XML.Stream.Parse as XML
+
+import Control.Concurrent.STM.Util
+import ControlMaybe                (handleIO_, (<&>))
+import EventUtil
+import Nesting
+import Stanza.Types
+
+-- | Identify an XMPP stanza based on the open-tag.
+grokStanza ::  Text -> XML.Event -> NestingXML o IO (Maybe StanzaType)
+grokStanza "jabber:server" stanzaTag =
+    case () of
+        _ | stanzaTag `isServerIQOf` "get" -> grokStanzaIQGet stanzaTag
+        _ | stanzaTag `isServerIQOf` "result" -> grokStanzaIQResult stanzaTag
+        _ | tagName stanzaTag == "{jabber:server}presence" -> grokPresence "jabber:server" stanzaTag
+        _ | tagName stanzaTag == "{jabber:server}message" -> grokMessage "jabber:server" stanzaTag
+        _ -> return $ Just Unrecognized
+
+grokStanza "jabber:client" stanzaTag =
+    case () of
+        _ | stanzaTag `isClientIQOf` "get" -> grokStanzaIQGet stanzaTag
+        _ | stanzaTag `isClientIQOf` "set" -> grokStanzaIQSet stanzaTag
+        _ | stanzaTag `isClientIQOf` "result" -> grokStanzaIQResult stanzaTag
+        _ | tagName stanzaTag == "{jabber:client}presence" -> grokPresence "jabber:client" stanzaTag
+        _ | tagName stanzaTag == "{jabber:client}message" -> grokMessage "jabber:client" stanzaTag
+        _ -> return $ Just Unrecognized
+
+grokStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
+grokStanzaIQGet stanza = do
+    mtag <- nextElement
+    forM  mtag $ \tag -> do
+    case tagName tag of
+        "{urn:xmpp:ping}ping"     -> return Ping
+        "{jabber:iq:roster}query" -> return RequestRoster
+        "{http://jabber.org/protocol/disco#items}query"
+                                  -> return $ RequestItems $ lookupAttrib "node" $ tagAttrs tag
+        "{http://jabber.org/protocol/disco#info}query"
+                                  -> return $ RequestInfo $ lookupAttrib "node" $ tagAttrs tag
+        name                      -> return $ UnrecognizedQuery name
+
+grokStanzaIQResult :: XML.Event -> NestingXML o IO (Maybe StanzaType)
+grokStanzaIQResult stanza = do
+    mtag <- nextElement
+    fromMaybe (return $ Just Pong) $ mtag <&> \tag -> do
+    case tagName tag of
+        "{jabber:iq:version}query" | nameNamespace (tagName stanza)==Just "jabber:client"
+            -> parseClientVersion
+        "{http://jabber.org/protocol/disco#items}query"
+            -> return $ Just Items
+        "{http://jabber.org/protocol/disco#info}query"
+            -> return $ Just Info
+        _ -> return Nothing
+
+grokStanzaIQSet :: XML.Event -> NestingXML o IO (Maybe StanzaType)
+grokStanzaIQSet stanza = do
+    mtag <- nextElement
+    case tagName <$> mtag of
+        Just "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+            -> do mchild <- nextElement
+                  case tagName <$> mchild of
+                    Just "{urn:ietf:params:xml:ns:xmpp-bind}resource"
+                            -> do rsc <- XML.content -- TODO: MonadThrow???
+                                  return . Just $ RequestResource Nothing (Just rsc)
+                    Just _  -> return Nothing
+                    Nothing -> return . Just $ RequestResource Nothing Nothing
+        Just "{urn:ietf:params:xml:ns:xmpp-session}session"
+            -> return $ Just SessionRequest
+        _   -> return Nothing
+
+grokPresence
+  :: ( MonadThrow m
+     , MonadIO m
+     ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
+grokPresence ns stanzaTag = do
+    let typ = lookupAttrib "type" (tagAttrs stanzaTag)
+    case typ of
+        Nothing -> -- Note: Possibly join-chat stanza.
+                   parsePresenceStatus ns stanzaTag
+        Just "unavailable"  -> fmap (fmap (\p -> p {presenceShow=Offline}))
+                                   $ parsePresenceStatus ns stanzaTag
+        Just "error"        -> return . Just $ PresenceInformError
+        Just "unsubscribed" -> return . Just $ PresenceInformSubscription False
+        Just "subscribed"   -> return . Just $ PresenceInformSubscription True
+        Just "probe"        -> return . Just $ PresenceRequestStatus
+        Just "unsubscribe"  -> return . Just $ PresenceRequestSubscription False
+        Just "subscribe"    -> return . Just $ PresenceRequestSubscription True
+        _                   -> return Nothing
+
+grokMessage
+  :: ( MonadThrow m
+     , MonadIO m
+     ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
+grokMessage ns stanzaTag = do
+    let typ = lookupAttrib "type" (tagAttrs stanzaTag)
+    case typ of
+        Just "error" -> do
+            mb <- findErrorTag ns
+            return $ do
+                e <- mb
+                return $ Error e stanzaTag
+        _ -> do t <- parseMessage ns stanzaTag
+                return $ Just t
+
+parseClientVersion :: NestingXML o IO (Maybe StanzaType)
+parseClientVersion = parseit Nothing Nothing
+ where
+    reportit mname mver = return $ do
+        name <- mname
+        ver <- mver
+        return NotifyClientVersion { versionName=name, versionVersion=ver }
+    parseit :: Maybe Text -> Maybe Text -> NestingXML o IO (Maybe StanzaType)
+    parseit mname mver = do
+        mtag <- nextElement
+        fromMaybe (reportit mname mver) $ mtag <&> \tag -> do
+        case tagName tag of
+            "{jabber:iq:version}name" -> do
+                x <- XML.content
+                parseit (Just x) mver
+            "{jabber:iq:version}version" -> do
+                x <- XML.content
+                parseit mname (Just x)
+            _ -> parseit mname mver
+
+parsePresenceStatus
+  :: ( MonadThrow m
+     , MonadIO m
+     ) => Text -> XML.Event -> NestingXML o m (Maybe StanzaType)
+parsePresenceStatus ns stanzaTag = do
+
+    let toStat "away" = Away
+        toStat "xa"   = ExtendedAway
+        toStat "dnd"  = DoNotDisturb
+        toStat "chat" = Chatty
+
+    showv <- liftIO . atomically $ newTVar Available
+    priov <- liftIO . atomically $ newTVar Nothing
+    statusv <- liftIO . atomically $ newTChan
+    fix $ \loop -> do
+        mtag <- nextElement
+        forM_ mtag $ \tag -> do
+        when (nameNamespace (tagName tag) == Just ns) $ do
+            case nameLocalName (tagName tag) of
+                "show" -> do t <- XML.content
+                             liftIO . atomically $ writeTVar showv (toStat t)
+                "priority" -> do t <- XML.content
+                                 liftIO . handleIO_ (return ()) $ do
+                                 prio <- readIO (Text.unpack t)
+                                 atomically $ writeTVar priov (Just prio)
+                "status" -> do t <- XML.content
+                               lang <- xmlLang
+                               ioWriteChan statusv (maybe "" id lang,t)
+                _ -> return ()
+        loop
+    show <- liftIO . atomically $ readTVar showv
+    prio <- liftIO . atomically $ readTVar priov
+    status <- liftIO $ chanContents statusv -- Could use unsafeInterleaveIO to
+                                            -- avoid multiple passes, but whatever.
+    let wlist = do
+            w <- maybeToList $ lookupAttrib "whitelist" (tagAttrs stanzaTag)
+            Text.words w
+    return . Just $ PresenceStatus { presenceShow = show
+                                   , presencePriority = prio
+                                   , presenceStatus = status
+                                   , presenceWhiteList = wlist
+                                   }
+parseMessage
+  :: ( MonadThrow m
+     , MonadIO m
+     ) => Text -> XML.Event -> NestingXML o m StanzaType
+parseMessage ns stanza = do
+    let bodytag = Name { nameNamespace = Just ns
+                       , nameLocalName = "body"
+                       , namePrefix = Nothing }
+        subjecttag = Name { nameNamespace = Just ns
+                          , nameLocalName = "subject"
+                          , namePrefix = Nothing }
+        threadtag = Name { nameNamespace = Just ns
+                         , nameLocalName = "thread"
+                         , namePrefix = Nothing }
+    let emptyMsg = LangSpecificMessage { msgBody=Nothing, msgSubject=Nothing }
+        parseChildren (th,cmap) = do
+            child <- nextElement
+            lvl <- nesting
+            xmllang <- xmlLang
+            let lang = maybe "" id xmllang
+            let c = maybe emptyMsg id (Map.lookup lang cmap)
+            -- log $ " child: "<> bshow child
+            case child of
+                Just tag | tagName tag==bodytag
+                                    -> do
+                                        txt <- XML.content
+                                        awaitCloser lvl
+                                        parseChildren (th,Map.insert lang (c { msgBody=Just txt }) cmap)
+                Just tag | tagName tag==subjecttag
+                                    -> do
+                                        txt <- XML.content
+                                        awaitCloser lvl
+                                        parseChildren (th,Map.insert lang (c { msgSubject=Just txt }) cmap)
+                Just tag | tagName tag==threadtag
+                                    -> do
+                                        txt <- XML.content
+                                        awaitCloser lvl
+                                        parseChildren (th {msgThreadContent=txt},cmap)
+                Just tag -> do
+                            -- let nm    = tagName tag
+                            --    attrs = tagAttrs tag
+                            --    -- elems = msgElements c
+                            -- txt <- XML.content
+                            awaitCloser lvl
+                            parseChildren (th,Map.insert lang c cmap)
+                Nothing -> return (th,cmap)
+    (th,langmap) <- parseChildren ( MessageThread {msgThreadParent=Nothing, msgThreadContent=""}
+                                  , Map.empty )
+    return Message {
+        msgLangMap = Map.toList langmap,
+        msgThread  = if msgThreadContent th/="" then Just th else Nothing,
+        msgType    = parseMessageType $ lookupAttrib "type" (tagAttrs stanza)
+    }
+
+parseMessageType :: Maybe Text -> MessageType
+parseMessageType (Just "chat")      = ChatMsg
+parseMessageType (Just "groupchat") = GroupChatMsg
+parseMessageType (Just "headline")  = HeadlineMsg
+parseMessageType _                  = NormalMsg
+
+findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError)
+findErrorTag ns = do
+    x <- nextElement
+    fmap join $ forM x $ \x ->
+      case tagName x of
+        n | nameNamespace n==Just ns && nameLocalName n=="error"
+            -> do
+                 mtag <- findConditionTag
+                 return $ do
+                    tag <- {- trace ("mtag = "++show mtag) -} mtag
+                    let t = nameLocalName (tagName tag)
+                    conditionFromText t
+        _ -> findErrorTag ns
+
+findConditionTag :: Monad m => NestingXML o m (Maybe XML.Event)
+findConditionTag = do
+    mx <- nextElement
+    fmap join $ forM mx $ \x -> do
+    case nameNamespace (tagName x) of
+        Just "urn:ietf:params:xml:ns:xmpp-stanzas" -> return (Just x)
+        _                                          -> findConditionTag
+
+conditionFromText :: Text -> Maybe StanzaError
+conditionFromText t = fmap fst $ listToMaybe ss
+ where
+    es = [BadRequest .. UnexpectedRequest]
+    ts = map (\e->(e,errorTagLocalName e)) es
+    ss = dropWhile ((/=t) . snd) ts
+
+-- | Converts a CamelCase constructor to a hyphenated lower-case name for use
+-- as an xml tag.
+errorTagLocalName :: StanzaError -> Text
+errorTagLocalName e = Text.pack . drop 1 $ do
+    c <- show e
+    if 'A' <= c && c <= 'Z'
+    then [ '-', chr( ord c - ord 'A' + ord 'a') ]
+    else return c
+
diff --git a/dht/Presence/Stanza/Types.hs b/dht/Presence/Stanza/Types.hs
new file mode 100644
index 00000000..7275c8ab
--- /dev/null
+++ b/dht/Presence/Stanza/Types.hs
@@ -0,0 +1,257 @@
+{-# 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
+    | RequestItems (Maybe Text)
+    | Items
+    | RequestInfo (Maybe Text)
+    | Info
+    | 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]
+                        -- ^ A custom extension extension we are using.  When a
+                        -- peer answers a presence probe, it also communicates
+                        -- to the remote peer which remote users it believes
+                        -- are subscribed to that presence.
+                        --
+                        -- This is communicated via a space-delimited list in
+                        -- the nonstandard "whitelist" attribute for a
+                        -- <{jabber:server}presence> tag.
+                        --
+                        -- TODO: Use this to update the buddies file so that a
+                        -- client is made aware when a subscription was
+                        -- canceled.
+                     }
+
+    | PresenceInformError
+    | PresenceInformSubscription Bool
+    | PresenceRequestStatus
+    | PresenceRequestSubscription Bool
+    | Message { msgThread :: Maybe MessageThread
+              , msgLangMap :: [(Lang,LangSpecificMessage)]
+              , msgType :: MessageType
+              }
+    | NotifyClientVersion { versionName :: Text
+                          , versionVersion :: Text }
+    | InternalEnableHack ClientHack
+    | InternalCacheId Text
+ deriving (Show,Eq)
+
+data MessageType
+    = NormalMsg  -- ^ The message is a standalone message that is sent outside
+                 -- the context of a one-to-one conversation or groupchat, and
+                 -- to which it is expected that the recipient will reply.
+                 -- Typically a receiving client will present a message of type
+                 -- "normal" in an interface that enables the recipient to
+                 -- reply, but without a conversation history. The default
+                 -- value of the 'type' attribute is "normal".
+
+    | ChatMsg -- ^ The message is sent in the context of a one-to-one chat
+              -- session. Typically an interactive client will present a
+              -- message of type "chat" in an interface that enables one-to-one
+              -- chat between the two parties, including an appropriate
+              -- conversation history. Detailed recommendations regarding
+              -- one-to-one chat sessions are provided under Section 5.1.
+
+    | GroupChatMsg -- ^ The message is sent in the context of a multi-user chat
+                   -- environment (similar to that of [IRC]). Typically a
+                   -- receiving client will present a message of type
+                   -- "groupchat" in an interface that enables many-to-many
+                   -- chat between the parties, including a roster of parties
+                   -- in the chatroom and an appropriate conversation history.
+                   -- For detailed information about XMPP-based groupchat,
+                   -- refer to [XEP‑0045].
+
+    | HeadlineMsg -- ^ The message provides an alert, a notification, or other
+                  -- transient information to which no reply is expected (e.g.,
+                  -- news headlines, sports updates, near-real-time market
+                  -- data, or syndicated content). Because no reply to the
+                  -- message is expected, typically a receiving client will
+                  -- present a message of type "headline" in an interface that
+                  -- appropriately differentiates the message from standalone
+                  -- messages, chat messages, and groupchat messages (e.g., by
+                  -- not providing the recipient with the ability to reply). If
+                  -- the 'to' address is the bare JID, the receiving server
+                  -- SHOULD deliver the message to all of the recipient's
+                  -- available resources with non-negative presence priority
+                  -- and MUST deliver the message to at least one of those
+                  -- resources; if the 'to' address is a full JID and there is
+                  -- a matching resource, the server MUST deliver the message
+                  -- to that resource; otherwise the server MUST either
+                  -- silently ignore the message or return an error (see
+                  -- Section 8).
+
+    -- | ErrorMsg -- The message is generated by an entity that experiences an
+    -- error when processing a message received from another entity (for
+    -- details regarding stanza error syntax, refer to [XMPP‑CORE]). A client
+    -- that receives a message of type "error" SHOULD present an appropriate
+    -- interface informing the original sender regarding the nature of the
+    -- error.
+
+ deriving (Show,Read,Ord,Eq,Enum)
+
+
+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
+    -- Peek at the stanza open tag.
+    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/dht/Presence/UTmp.hs b/dht/Presence/UTmp.hs
new file mode 100644
index 00000000..fcfe529a
--- /dev/null
+++ b/dht/Presence/UTmp.hs
@@ -0,0 +1,259 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RankNTypes #-}
+module UTmp
+    ( users
+    , users2
+    , utmp_file
+    , UserName
+    , Tty
+    , ProcessID
+    , UtmpRecord(..)
+    , UT_Type(..)
+    ) where
+
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.BitSyntax
+import Data.Functor.Identity
+import Data.Maybe
+import Data.String
+import System.Posix.Process
+import System.Posix.Signals
+import System.Posix.Types
+import System.Posix.User
+import Control.Monad
+import Data.Word
+import Data.Int
+import Control.Monad.Error.Class
+import System.IO.Error
+import qualified Paths
+import Data.Text      ( Text )
+import Unsafe.Coerce  ( unsafeCoerce )
+import Network.Socket ( SockAddr(..) )
+import qualified Data.Text.Encoding as Text
+import SockAddr ()
+
+
+utmp_file :: IsString s => s
+utmp_file = fromString $ Paths.utmp -- "/var/run/utmp"
+
+utmp_bs :: IO C.ByteString
+utmp_bs = S.readFile utmp_file
+
+decode_utmp_bytestring ::
+    C.ByteString
+    -> (Word32,
+        Word32,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        Word16,
+        Word16,
+        Word32,
+        C.ByteString,
+        Word32,
+        Word32,
+        Word32,
+        Word32)
+decode_utmp_bytestring = 
+    runIdentity 
+    . $(bitSyn [ UnsignedLE 4 -- type
+               , UnsignedLE 4 -- pid
+               , Fixed 32 -- tty
+               , Fixed 4 -- inittab id
+               , Fixed 32 -- username
+               , Fixed 256 -- remote host
+               , UnsignedLE 2 -- termination status
+               , UnsignedLE 2 -- exit status (int)
+               , UnsignedLE 4 -- session id  (int)
+               , Fixed 8 -- time entry was made
+               , Unsigned 4 -- remote addr v6 addr[0]
+               , Unsigned 4 -- remote addr v6 addr[1]
+               , Unsigned 4 -- remote addr v6 addr[2]
+               , Unsigned 4 -- remote addr v6 addr[3]
+               , Skip 20 -- reserved
+               ])
+
+utmp_size :: Int
+utmp_size = 384 -- 768
+
+
+utmp_records :: C.ByteString -> [C.ByteString]
+utmp_records bs | S.length bs >= utmp_size 
+    =  u:utmp_records us
+ where
+    (u,us) = S.splitAt utmp_size bs
+
+utmp_records bs = [bs]
+
+utmp ::
+    IO
+      [(Word32,
+        Word32,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        C.ByteString,
+        Word16,
+        Word16,
+        Word32,
+        C.ByteString,
+        Word32,
+        Word32,
+        Word32,
+        Word32)]
+utmp = fmap (map decode_utmp_bytestring . utmp_records) utmp_bs
+
+toStr :: C.ByteString -> [Char]
+toStr = takeWhile (/='\0') . C.unpack
+
+interp_utmp_record ::
+    forall t t1 t2 t3 t4 t5 t6 t7 t8 a.
+    Integral a =>
+    (a,
+     Word32,
+     C.ByteString,
+     t,
+     C.ByteString,
+     C.ByteString,
+     t1,
+     t2,
+     t3,
+     t4,
+     t5,
+     t6,
+     t7,
+     t8)
+    -> (UT_Type, [Char], [Char], CPid, [Char])
+interp_utmp_record (typ,pid,tty,inittab,user,hostv4,term,exit,session,time
+                   ,addr0,addr1,addr2,addr3) =
+    ( (toEnum . fromIntegral) typ :: UT_Type
+    , toStr user, toStr tty, processId pid, toStr hostv4 )
+ where
+    processId = CPid . coerceToSigned
+
+coerceToSigned :: Word32 -> Int32
+coerceToSigned = unsafeCoerce
+
+
+data UT_Type
+ = EMPTY           -- No valid user accounting information.  */
+
+ | RUN_LVL         -- The system's runlevel.  */
+ | BOOT_TIME       -- Time of system boot.  */
+ | NEW_TIME        -- Time after system clock changed.  */
+ | OLD_TIME        -- Time when system clock changed.  */
+
+ | INIT_PROCESS    -- Process spawned by the init process.  */
+ | LOGIN_PROCESS   -- Session leader of a logged in user.  */
+ | USER_PROCESS    -- Normal process.  */
+ | DEAD_PROCESS    -- Terminated process.  */
+
+ | ACCOUNTING      
+
+ deriving (Enum,Show,Eq,Ord,Read)
+
+processAlive :: ProcessID -> IO Bool
+processAlive pid = do
+    catchError (do { signalProcess nullSignal pid ; return True })
+      $ \e -> do { return (not ( isDoesNotExistError e)); }
+
+type UserName = L.ByteString
+type Tty      = L.ByteString
+
+users :: IO [(UserName, Tty, ProcessID)]
+users = utmp_users `catchIOError` \_ -> do
+            -- If we can't read utmp file, then return a list with only the current
+            -- user.
+            uname <- getLoginName
+            pid <- getProcessID -- TODO: XXX: Does this make sense as a fallback?
+            return [(L.pack uname,L.empty,pid)]
+ where
+  utmp_users = fmap (map only3) $ do
+    us <- utmp
+    let us' = map interp_utmp_record us
+        us'' = mapMaybe user_proc us'
+        user_proc (USER_PROCESS, u,tty,pid, hostv4)
+                    = Just (L.pack u,L.pack tty,pid,hostv4)
+        user_proc _ = Nothing
+        onThrd f (_,_,pid,_) = f pid
+    us3 <- filterM (onThrd processAlive) us''
+    return us3
+
+only3 :: forall t t1 t2 t3. (t1, t2, t3, t) -> (t1, t2, t3)
+only3 (a,b,c,_) = (a,b,c)
+
+data UtmpRecord = UtmpRecord
+  { utmpType :: UT_Type
+  , utmpUser :: Text
+  , utmpTty :: Text
+  , utmpPid :: CPid
+  , utmpHost :: Text
+  , utmpSession :: Int32
+  , utmpRemoteAddr :: Maybe SockAddr
+  }
+ deriving ( Show, Eq, Ord )
+
+toText :: C.ByteString -> Text
+toText bs = Text.decodeUtf8 $ C.takeWhile (/='\0') bs
+
+interp_utmp_record2 ::
+    forall t t1 t2 t3 a.
+    Integral a =>
+    (a,
+     Word32,
+     C.ByteString,
+     t,
+     C.ByteString,
+     C.ByteString,
+     t1,
+     t2,
+     Word32,
+     t3,
+     Word32,
+     Word32,
+     Word32,
+     Word32)
+    -> UtmpRecord
+interp_utmp_record2 (typ,pid,tty,inittab,user,hostv4
+                    ,term,exit,session,time,addr0,addr1,addr2,addr3) =
+    UtmpRecord
+        { utmpType = toEnum (fromIntegral typ) :: UT_Type
+        , utmpUser = toText user
+        , utmpTty  = toText tty
+        , utmpPid  = processId pid
+        , utmpHost = toText hostv4
+        , utmpSession = coerceToSigned session
+        , utmpRemoteAddr =
+            if all (==0) [addr1,addr2,addr3]
+             then do guard (addr0/=0)
+                     Just $ SockAddrInet6 0 0 (0,0,0xFFFF,addr0) 0
+             else Just $ SockAddrInet6 0 0 (addr0,addr1,addr2,addr3) 0
+        }
+ where
+    processId = CPid . coerceToSigned
+
+users2 :: IO [UtmpRecord]
+users2 = do
+    us <- utmp
+    let us' = map interp_utmp_record2 us
+    us3 <- filterM (processAlive . utmpPid) us'
+    return us3
+
+{- 
+ - This is how the w command reports idle time:
+/* stat the device file to get an idle time */
+static time_t idletime(const char *restrict const tty)
+{
+        struct stat sbuf;
+        if (stat(tty, &sbuf) != 0)
+                return 0;
+        return time(NULL) - sbuf.st_atime;
+}
+ - THis might be useful fo rimplementing
+ - xep-0012 Last Activity
+ - iq get {jabber:iq:last}query
+ - 
+ -}
diff --git a/dht/Presence/Util.hs b/dht/Presence/Util.hs
new file mode 100644
index 00000000..e19b35fd
--- /dev/null
+++ b/dht/Presence/Util.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Util where
+
+import qualified Data.ByteString.Lazy as L
+import Data.Monoid
+import qualified Data.Text            as Text
+         ;import Data.Text            (Text)
+import qualified Data.Text.Encoding   as Text
+import qualified Network.BSD          as BSD
+import Network.Socket
+
+import Network.Address (setPort)
+
+type UserName = Text
+type ResourceName = Text
+
+stripResource :: Text -> Text
+stripResource jid = let (n,h,_) = splitJID jid
+                    in unsplitJID (n,h,Nothing)
+
+unsplitJID :: (Maybe UserName,Text,Maybe ResourceName) -> Text
+unsplitJID (n,h,r) = username <> h <> resource
+ where
+    username = maybe "" (<>"@") n
+    resource = maybe "" ("/"<>) r
+
+splitJID :: Text -> (Maybe UserName,Text,Maybe ResourceName)
+splitJID bjid =
+    let (uATh,slashrsc) = Text.break (=='/') bjid
+        rsrc = if Text.null slashrsc then Nothing
+                                     else Just $ Text.drop 1 slashrsc
+        (u,atserver) = Text.break (=='@') uATh
+        (name,server) = if Text.null atserver then (Nothing,u)
+                                              else (Just u,Text.drop 1 atserver)
+    in (name,server,rsrc)
+
+
+textHostName :: IO Text
+textHostName = fmap Text.pack BSD.getHostName
+
+textToLazyByteString :: Text -> L.ByteString
+textToLazyByteString s = L.fromChunks [Text.encodeUtf8 s]
+
+lazyByteStringToText :: L.ByteString -> Text
+lazyByteStringToText = (foldr (<>) mempty . map Text.decodeUtf8 . L.toChunks)
+
+-- | for example:  2001-db8-85a3-8d3-1319-8a2e-370-7348.ipv6-literal.net
+ip6literal :: Text -> Text
+ip6literal addr = Text.map dash addr <> ".ipv6-literal.net"
+ where
+    dash ':' = '-'
+    dash x   = x
+
+sameAddress :: SockAddr -> SockAddr -> Bool
+sameAddress laddr addr = setPort 0 laddr == setPort 0 addr
+
+
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
new file mode 100644
index 00000000..fe099fb8
--- /dev/null
+++ b/dht/Presence/XMPPServer.hs
@@ -0,0 +1,1812 @@
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE DoAndIfThenElse           #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE LambdaCase                #-}
+{-# LANGUAGE MultiWayIf                #-}
+{-# LANGUAGE OverloadedStrings         #-}
+{-# LANGUAGE RankNTypes                #-}
+{-# LANGUAGE TupleSections             #-}
+module XMPPServer
+    ( xmppServer
+    , forkXmpp
+    , quitXmpp
+    , ClientAddress
+    , PeerAddress
+    , Local(..)
+    , Remote(..)
+    , ConnectionData(..)
+    , ConnectionType(..)
+    , MUC(..)
+    , XMPPServerParameters(..)
+    , XMPPServer
+    , classifyConnection
+    , addrToPeerKey
+    , addrFromClientKey
+    , xmppConnections
+    , xmppEventChannel
+    , StanzaWrap(..)
+    , Stanza(..)
+    , StanzaType(..)
+    , StanzaOrigin(..)
+    , cloneStanza
+    , LangSpecificMessage(..)
+    , peerKeyToText
+    , addrToText
+    , sendModifiedStanzaToPeer
+    , sendModifiedStanzaToClient
+    , presenceProbe
+    , presenceSolicitation
+    , makePresenceStanza
+    , makeInformSubscription
+    , makeRosterUpdate
+    , makeMessage
+    , JabberShow(..)
+    , Server
+    , flushPassThrough
+    , greet'
+    , (<&>)
+    ) where
+
+import ConnectionKey
+import qualified Control.Concurrent.STM.UpdateStream as Slotted
+import Nesting
+import Connection.Tcp
+import EventUtil
+import ControlMaybe
+import LockedChan
+import Connection (PeerAddress(..))
+import qualified Connection
+import Util
+import Network.Address (getBindAddress, sockAddrPort)
+
+import Debug.Trace
+import Control.Monad.Trans (lift)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Fix (fix)
+import Control.Monad
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar)
+#else
+import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId)
+import GHC.Conc                  (labelThread)
+#endif
+import Control.Concurrent.STM
+import Data.List hiding ((\\))
+-- import Control.Concurrent.STM.TChan
+import Network.SocketLike
+import Text.Printf
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as Strict8
+-- import qualified Data.ByteString.Lazy.Char8 as Lazy8
+
+import Data.Conduit
+import qualified Data.Conduit.List as CL
+import qualified Data.Conduit.Binary as CB
+#if MIN_VERSION_conduit_extra(1,1,7)
+import Data.Conduit.ByteString.Builder (builderToByteStringFlush)
+#else
+import Data.Conduit.Blaze (builderToByteStringFlush)
+#endif
+
+import Control.Arrow
+import Control.Concurrent.STM.Util
+import DNSCache (withPort)
+import qualified Text.XML.Stream.Render as XML hiding (content)
+import qualified Text.XML.Stream.Parse as XML
+import Data.XML.Types as XML
+import Data.Maybe
+import Data.Monoid ( (<>) )
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Map as Map
+import Data.Set (Set, (\\) )
+import qualified Data.Set as Set
+import Data.String ( IsString(..) )
+import qualified System.Random
+import Data.Void (Void)
+import DPut
+import DebugTag
+import Stanza.Build
+import Stanza.Parse
+import Stanza.Types
+import MUC
+import Chat
+
+-- peerport :: PortNumber
+-- peerport = 5269
+-- clientport :: PortNumber
+-- clientport = 5222
+
+my_uuid :: Text
+my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
+
+
+newtype Local a = Local a deriving (Eq,Ord,Show)
+newtype Remote a = Remote a deriving (Eq,Ord,Show)
+
+data XMPPServerParameters =
+    XMPPServerParameters
+    { -- | Called when a client requests a resource id.  The first Maybe indicates
+      --   the name the client referred to this server by.  The second Maybe is the
+      --   client's preferred resource name.
+      --
+      -- Note: The returned domain will be discarded and replaced with the result of
+      -- 'xmppTellMyNameToClient'.
+      xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
+    , -- | This should indicate the server's hostname that all client's see.
+      xmppTellMyNameToClient :: ClientAddress -> IO Text
+    , xmppTellMyNameToPeer   :: Local SockAddr -> IO Text
+    , xmppTellClientHisName  :: ClientAddress -> IO Text
+    , xmppTellPeerHisName    :: PeerAddress -> IO Text
+    , xmppNewConnection      :: SockAddr -> ConnectionData -> TChan Stanza -> IO ()
+    , xmppEOF                :: SockAddr -> ConnectionData -> IO ()
+    , xmppRosterBuddies      :: ClientAddress -> IO [Text]
+    , xmppRosterSubscribers  :: ClientAddress -> IO [Text]
+    , xmppRosterSolicited    :: ClientAddress -> IO [Text]
+    , xmppRosterOthers       :: ClientAddress -> IO [Text]
+    , -- | Called when after sending a roster to a client.  Usually this  means
+      -- the client status should change from "available" to "interested".
+      xmppSubscribeToRoster  :: ClientAddress -> IO ()
+    -- , xmppLookupClientJID :: SockAddr -> IO Text
+    , xmppDeliverMessage     :: (IO ()) -> Stanza -> IO ()
+      -- | Called whenever a local client's presence changes.
+    , xmppInformClientPresence :: ClientAddress -> Stanza -> IO ()
+      -- | Called whenever a remote peer's presence changes.
+    , xmppInformPeerPresence :: PeerAddress -> Stanza -> IO ()
+    , -- | Called when a remote peer requests our status.
+      xmppAnswerProbe        :: PeerAddress -> Stanza -> TChan Stanza -> IO ()
+    , xmppClientSubscriptionRequest :: IO () -> ClientAddress -> Stanza -> TChan Stanza -> IO ()
+    , -- | Called when a remote peer sends subscription request.
+      xmppPeerSubscriptionRequest :: IO () -> PeerAddress -> Stanza -> TChan Stanza -> IO ()
+    , xmppClientInformSubscription :: IO () -> ClientAddress -> Stanza -> IO ()
+    , -- | Called when a remote peer informs us of our subscription status.
+      xmppPeerInformSubscription :: IO () -> PeerAddress -> Stanza -> IO ()
+    , xmppGroupChat          :: Map.Map Text MUC -- Key should be lowercase identifier.
+    , xmppVerbosity          :: IO Int
+    , xmppClientBind         :: Maybe SockAddr
+    , xmppPeerBind           :: Maybe SockAddr
+    }
+
+
+enableClientHacks ::
+    forall t a.
+    (Eq a, IsString a) =>
+    a -> t -> TChan Stanza -> IO ()
+enableClientHacks "Pidgin" version replyto = do
+    wlog "Enabling hack SimulatedChatErrors for client Pidgin"
+    donevar <- atomically newEmptyTMVar
+    sendReply donevar
+              (InternalEnableHack SimulatedChatErrors)
+              []
+              replyto
+enableClientHacks "irssi-xmpp" version replyto = do
+    wlog "Enabling hack SimulatedChatErrors for client irssi-xmpp"
+    donevar <- atomically newEmptyTMVar
+    sendReply donevar
+              (InternalEnableHack SimulatedChatErrors)
+              []
+              replyto
+enableClientHacks _ _ _ = return ()
+
+cacheMessageId :: Text -> TChan Stanza -> IO ()
+cacheMessageId id' replyto = do
+    wlog $ "Caching id " ++ Text.unpack id'
+    donevar <- atomically newEmptyTMVar
+    sendReply donevar
+              (InternalCacheId id')
+              []
+              replyto
+
+
+-- TODO: http://xmpp.org/rfcs/rfc6120.html#rules-remote-error
+-- client connection
+-- socat script to send stanza fragment
+-- copyToChannel can keep a stack of closers to append to finish-off a stanza
+-- the TMVar () from forkConnection can be passed and with a stanza to detect interruption
+
+addrToText :: SockAddr -> Text
+addrToText (addr@(SockAddrInet _ _)) = Text.pack $ stripColon (show addr)
+ where stripColon s = pre where (pre,_) = break (==':') s
+addrToText (addr@(SockAddrInet6 _ _ _ _)) = Text.pack $ stripColon (show addr)
+ where stripColon s = if null bracket then pre else pre ++ "]"
+          where
+            (pre,bracket) = break (==']') s
+
+-- Shows (as Text) the IP address associated with the given SockAddr.
+peerKeyToText :: PeerAddress -> Text
+peerKeyToText (PeerAddress addr) = addrToText addr
+
+
+wlog :: String -> IO ()
+wlog = dput XJabber
+
+wlogb :: ByteString -> IO ()
+wlogb = wlog . Strict8.unpack
+
+flushPassThrough :: Monad m => ConduitT a b m () -> ConduitT (Flush a) (Flush b) m ()
+flushPassThrough c = getZipConduit $ ZipConduit (onlyChunks .| mapOutput Chunk c) <* ZipConduit onlyFlushes
+  where
+    onlyChunks  :: Monad m => ConduitT (Flush a) a m ()
+    onlyFlushes :: Monad m => ConduitT (Flush a) (Flush b) m ()
+    onlyChunks           = awaitForever yieldChunk
+    onlyFlushes          = awaitForever yieldFlush
+    yieldFlush Flush     = yield Flush
+    yieldFlush _         = return ()
+    yieldChunk (Chunk x) = yield x
+    yieldChunk _         = return ()
+
+xmlStream :: ReadCommand -> WriteCommand -> ( ConduitT () XML.Event IO ()
+                                            , ConduitT (Flush XML.Event) Void IO () )
+xmlStream conread conwrite = (xsrc,xsnk)
+ where
+    xsrc = src .| XML.parseBytes XML.def
+    xsnk :: ConduitT (Flush Event) Void IO ()
+    xsnk = -- XML.renderBytes XML.def =$ snk
+        flushPassThrough (XML.renderBuilder XML.def)
+        .| builderToByteStringFlush
+        .| discardFlush
+        .| snk
+      where
+        discardFlush :: Monad m => ConduitM (Flush a) a m ()
+        discardFlush = awaitForever yieldChunk
+        yieldChunk (Chunk x) = yield x
+        yieldChunk _ = return ()
+
+    src = do
+        v <- lift conread
+        maybe (return ()) -- lift . wlog $ "conread: Nothing")
+              (yield >=> const src)
+              v
+    snk = awaitForever $ liftIO . conwrite
+
+
+type FlagCommand = STM Bool
+type ReadCommand = IO (Maybe ByteString)
+type WriteCommand = ByteString -> IO Bool
+
+cloneStanza :: StanzaWrap (LockedChan a) -> IO (StanzaWrap (LockedChan a))
+cloneStanza stanza = do
+    dupped <- cloneLChan (stanzaChan stanza)
+    return stanza { stanzaChan = dupped }
+
+copyToChannel
+  :: MonadIO m =>
+     (Event -> a) -> LockedChan a -> TVar (Maybe [Event]) -> ConduitM Event Event m ()
+copyToChannel f chan closer_stack = awaitForever copy
+ where
+    copy x = do
+        liftIO . atomically $ writeLChan chan (f x)
+        case x of
+            EventBeginDocument {} -> do
+                let clsr = closerFor x
+                liftIO . atomically $
+                    modifyTVar' closer_stack (fmap (clsr:))
+            EventEndDocument {} -> do
+                liftIO . atomically $
+                    modifyTVar' closer_stack (fmap (drop 1))
+            _ -> return ()
+        yield x
+
+
+prettyPrint :: ByteString -> ConduitM Event Void IO ()
+prettyPrint prefix =
+        XML.renderBytes (XML.def { XML.rsPretty=True })
+        .| CB.lines
+        .| CL.mapM_ (wlogb . (prefix <>))
+
+swapNamespace :: Monad m => Text -> Text -> ConduitM Event Event m ()
+swapNamespace old new = awaitForever (yield . swapit old new)
+
+swapit :: Text -> Text -> Event -> Event
+swapit old new (EventBeginElement n as) | nameNamespace n==Just old =
+    EventBeginElement (n { nameNamespace = Just new }) as
+swapit old new (EventEndElement n) | nameNamespace n==Just old =
+    EventEndElement (n { nameNamespace = Just new })
+swapit old new x = x
+
+-- | This is invoked by sendModifiedStanzaTo* before swapping the namespace.
+--
+-- Optionally, when the namespace is jabber:server, this will set a "whitelist"
+-- attribute on a presence tag that indicates a list of users deliminated by
+-- spaces.  This is so that a server can communicate to another server which
+-- users are believed to be subscribed.
+fixHeaders :: Monad m => Stanza -> ConduitM Event Event m ()
+fixHeaders Stanza { stanzaType=typ, stanzaTo=mto, stanzaFrom=mfrom } = do
+    x <- await
+    maybe (return ()) f x
+ where
+    f (EventBeginElement n as) = do yield $ EventBeginElement n (update n as)
+                                    awaitForever yield
+    f x = yield x >> awaitForever yield
+    update n as = as3
+     where
+        as' = maybe as (setAttrib "to" as) mto
+        as'' = maybe as' (setAttrib "from" as') mfrom
+        as3 = case typ of
+                PresenceStatus {} | nameNamespace n == Just "jabber:client"
+                  -> delAttrib "whitelist" as'' -- client-to-peer "whitelist" is filtered.
+                PresenceStatus {} | otherwise
+                  -- peer-to-client, we may have set a list of subscribed users
+                  -- to be communicated to the remote end.
+                  -> case presenceWhiteList typ of
+                        [] -> delAttrib "whitelist" as''
+                        ws -> setAttrib "whitelist" as'' (Text.intercalate " " ws)
+                _ -> as''
+
+        setAttrib akey as aval = attr akey aval:filter ((/=akey) . fst) as
+        delAttrib akey as = filter ((/=akey) . fst) as
+
+conduitToChan
+  :: ConduitT () Event IO ()
+     -> IO (LockedChan Event, TVar (Maybe [Event]), TMVar a)
+conduitToChan c = do
+    chan <- atomically newLockedChan
+    clsrs <- atomically $ newTVar (Just [])
+    quitvar <- atomically $ newEmptyTMVar
+    forkIO $ do
+        runConduit $ c .| copyToChannel id chan clsrs .| awaitForever (const $ return ())
+        atomically $ writeTVar clsrs Nothing
+    return (chan,clsrs,quitvar)
+
+conduitToStanza
+  :: StanzaType
+     -> Maybe Text -- ^ id
+     -> Maybe Text -- ^ from
+     -> Maybe Text -- ^ to
+     -> ConduitT () Event IO ()
+     -> IO Stanza
+conduitToStanza stype mid from to c = do
+    (chan,clsrs,quitvar) <- conduitToChan c
+    return
+        Stanza  { stanzaType = stype
+                , stanzaId = mid
+                , stanzaTo = to
+                , stanzaFrom = from
+                , stanzaChan = chan
+                , stanzaClosers = clsrs
+                , stanzaInterrupt = quitvar
+                , stanzaOrigin = LocalPeer
+                }
+
+
+stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
+stanzaToConduit stanza = do
+    let xchan = stanzaChan stanza
+        xfin = stanzaClosers stanza
+        rdone = stanzaInterrupt stanza
+        loop = return ()
+    xchan <- liftIO $ unlockChan xchan
+    fix $ \inner -> do
+        what <- liftIO . atomically $ foldr1 orElse
+            [readTChan xchan >>= \xml -> return $ do
+                yield xml -- atomically $ Slotted.push slots Nothing xml
+                inner
+            ,do mb <- readTVar xfin
+                cempty <- isEmptyTChan xchan
+                if isNothing mb
+                    then if cempty then return loop else retry
+                    else do done <- tryReadTMVar rdone
+                            check (isJust done)
+                            trace "todo: send closers" retry
+            ,do isEmptyTChan xchan >>= check
+                readTMVar rdone
+                return (return ())]
+        what
+
+
+sendModifiedStanzaToPeer :: Stanza -> TChan Stanza -> IO ()
+sendModifiedStanzaToPeer stanza chan = do
+    (echan,clsrs,quitvar) <- conduitToChan c
+    ioWriteChan chan
+        stanza  { stanzaChan = echan
+                , stanzaClosers = clsrs
+                , stanzaInterrupt = quitvar
+                , stanzaType = processedType (stanzaType stanza)
+                -- TODO id? origin?
+                }
+ where
+    old = "jabber:client"
+    new = "jabber:server"
+    c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza
+    processedType (Error cond tag) = Error cond (swapit old new tag)
+    processedType x = x
+
+
+-- Modifies a server-to-server stanza to send it to a client.  This changes the
+-- namespace and also filters some non-supported attributes.  Any other
+-- modifications need to be made by the caller.
+sendModifiedStanzaToClient :: Stanza -> TChan Stanza -> IO ()
+sendModifiedStanzaToClient stanza chan = do
+    (echan,clsrs,quitvar) <- conduitToChan c
+    -- wlog $ "send-to-client " ++ show (stanzaId stanza)
+    ioWriteChan chan
+        stanza  { stanzaChan = echan
+                , stanzaClosers = clsrs
+                , stanzaInterrupt = quitvar
+                , stanzaType = processedType (stanzaType stanza)
+                -- TODO id? origin?
+                }
+ where
+    old = "jabber:server"
+    new = "jabber:client"
+    c = stanzaToConduit stanza .| swapNamespace old new .| fixHeaders stanza
+    processedType (Error cond tag) = Error cond (swapit old new tag)
+    processedType x = x
+
+
+-- id,to, and from are taken as-is from reply list
+-- todo: this should probably be restricted to IO monad
+sendReply :: (Functor m, MonadIO m) => TMVar () -> StanzaType -> [Event] -> TChan Stanza -> m ()
+sendReply donevar stype reply replychan = 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
+    forM_
+         (fmap (const ()) stanzaTag `mplus` guard (isInternal stype))
+         . const $ do
+    replyStanza <- liftIO . atomically $ do
+        replyChan <- newLockedChan
+        replyClsrs <- newTVar (Just [])
+        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
+                      }
+    ioWriteChan replychan replyStanza
+    void . liftIO . forkIO $ do
+        mapM_ (liftIO . atomically . writeLChan (stanzaChan replyStanza)) reply
+        liftIO . atomically $ writeTVar (stanzaClosers replyStanza) Nothing
+        -- liftIO $ wlog "finished reply stanza"
+
+
+
+{-
+C->Unrecognized <iq
+C->Unrecognized   type="set"
+C->Unrecognized   id="purpleae62d88f"
+C->Unrecognized   xmlns="jabber:client">
+C->Unrecognized     <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind"/>
+C->Unrecognized </iq>
+-}
+
+
+-- Sends all stanzas to announce channel except ping, for which it sends a pong
+-- to the output channel.
+xmppInbound :: ConnectionData
+                -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
+                -> FlagCommand  -- ^ action to check whether the connection needs a ping (XXX: unused)
+                -> TChan Stanza -- ^ channel to announce incoming stanzas on
+                -> TChan Stanza -- ^ channel used to send stanzas
+                -> TMVar ()     -- ^ mvar that is filled when the connection quits
+                -> ConduitM Event o IO ()
+xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
+    withXML $ \begindoc -> do
+    when (begindoc==EventBeginDocument) $ do
+    whenJust nextElement $ \xml -> do
+    withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
+    -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
+    let stream_name   = lookupAttrib "to"   stream_attrs
+        stream_remote = lookupAttrib "from" stream_attrs
+     -- xmpp_version = lookupAttrib "version" stream_attrs
+    liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote
+    fix $ \loop -> do
+    -- liftIO . wlog $ "waiting for stanza."
+    (chan,clsrs) <- liftIO . atomically $
+        liftM2 (,) newLockedChan (newTVar (Just []))
+    whenJust nextElement $ \stanzaTag -> do
+        stanza_lvl <- nesting
+        liftIO . atomically $ do
+            writeLChan chan stanzaTag
+            modifyTVar' clsrs (fmap (closerFor stanzaTag:))
+        copyToChannel id chan clsrs .| do
+          let mid   = lookupAttrib "id"   $ tagAttrs stanzaTag
+              mfrom = lookupAttrib "from" $ tagAttrs stanzaTag
+              mto   = lookupAttrib "to"   $ tagAttrs stanzaTag
+          dispatch <- grokStanza namespace stanzaTag
+          let unrecog = do
+                let stype = Unrecognized
+                s <- liftIO . atomically $ do
+                      return Stanza
+                              { stanzaType = stype
+                              , stanzaId = mid
+                              , stanzaTo = mto
+                              , stanzaFrom = mfrom
+                              , stanzaChan = chan
+                              , stanzaClosers = clsrs
+                              , stanzaInterrupt = donevar
+                              , stanzaOrigin = mkorigin output
+                              }
+                ioWriteChan stanzas s
+          you <- liftIO tellyourname
+          me <- liftIO tellmyname
+          fromMaybe unrecog $ dispatch <&> \dispatch ->
+            case dispatch of
+              -- Checking that the to-address matches this server.
+              -- Otherwise it could be a client-to-client ping or a
+              -- client-to-server for some other server.
+              -- For now, assuming its for the immediate connection.
+              Ping | mto==Just me || mto==Nothing -> do
+                let pongto = maybe you id mfrom
+                    pongfrom = maybe me id mto
+                    pong = makePong namespace mid pongto pongfrom
+                sendReply donevar Pong pong output
+                do -- TODO: Remove this, it is only to generate a debug print
+                   ioWriteChan stanzas Stanza
+                            { stanzaType = Ping
+                            , stanzaId = mid
+                            , stanzaTo = mto
+                            , stanzaFrom = mfrom
+                            , stanzaChan = chan
+                            , stanzaClosers = clsrs
+                            , stanzaInterrupt = donevar
+                            , stanzaOrigin = mkorigin output
+                            }
+              stype -> ioWriteChan stanzas Stanza
+                            { stanzaType      = case stype of
+                                RequestResource _ rsc -> RequestResource stream_name rsc
+                                _                     -> stype
+                            , stanzaId        = mid
+                            , stanzaTo        = mto
+                            , stanzaFrom      = mfrom
+                            , stanzaChan      = chan
+                            , stanzaClosers   = clsrs
+                            , stanzaInterrupt = donevar
+                            , stanzaOrigin    = mkorigin output
+                            }
+          awaitCloser stanza_lvl
+        liftIO . atomically $ writeTVar clsrs Nothing
+        loop
+
+
+while :: IO Bool -> IO a -> IO [a]
+while cond body = do
+    b <- cond
+    if b then do x <- body
+                 xs <- while cond body
+                 return (x:xs)
+         else return []
+
+{-
+readUntilNothing :: TChan (Maybe x) -> IO [x]
+readUntilNothing ch = do
+        x  <- atomically $ readTChan ch
+        maybe (return [])
+              (\x -> do
+                xs <- readUntilNothing ch
+                return (x:xs))
+              x
+-}
+
+streamFeatures :: Text -> [XML.Event]
+streamFeatures "jabber:client" =
+    [ EventBeginElement (streamP "features") []
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind" []
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+
+    {-
+    -- , "  <session xmlns='urn:ietf:params:xml:ns:xmpp-session'/>"
+    , " <mechanisms xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"
+    -- , " <mechanism>DIGEST-MD5</mechanism>"
+    , " <mechanism>PLAIN</mechanism>"
+    , " </mechanisms> "
+    -}
+
+    , EventEndElement (streamP "features")
+    ]
+streamFeatures "jabber:server" =
+    []
+
+
+greet' :: Text -> Text -> [XML.Event]
+greet' namespace host = EventBeginDocument : greet'' namespace host
+
+greet'' :: Text -> Text -> [Event]
+greet'' namespace host =
+    [ EventBeginElement (streamP "stream")
+        [("from",[ContentText host])
+        ,("id",[ContentText "someid"])
+        ,("xmlns",[ContentText namespace])
+        ,("xmlns:stream",[ContentText "http://etherx.jabber.org/streams"])
+        ,("version",[ContentText "1.0"])
+        ]
+    ] ++ streamFeatures namespace
+
+consid :: Maybe Text -> [(Name, [Content])] -> [(Name, [Content])]
+consid Nothing = id
+consid (Just sid) = (("id",[ContentText sid]):)
+
+
+data XMPPState
+    = PingSlot
+ deriving (Eq,Ord)
+
+makePing :: Text -> Maybe Text -> Text -> Text -> [XML.Event]
+makePing namespace mid to from =
+       [ EventBeginElement (mkname namespace "iq")
+         $ (case mid of
+            Just c -> (("id",[ContentText c]):)
+            _      -> id               )
+            [ ("type",[ContentText "get"])
+            , attr "to"   to
+            , attr "from" from
+            ]
+       , EventBeginElement "{urn:xmpp:ping}ping" []
+       , EventEndElement "{urn:xmpp:ping}ping"
+       , EventEndElement $ mkname namespace "iq"]
+
+makeInfo :: Maybe Text -> Text -> Maybe Text -> [Event]
+makeInfo mid from mto = concat
+    [ [ EventBeginElement "{jabber:client}iq"
+            $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
+                            [("from", [ContentText from])
+                            ,("type", [ContentText "result"])]
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
+            [("category",[ContentText "server"])
+            ,("type",[ContentText "im"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
+    , [] -- todo
+    , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
+      , EventEndElement "{jabber:client}iq" ]
+    ]
+
+
+makeNodeInfo :: Maybe Text -> Text -> Text -> Maybe Text -> Maybe Text-> [XML.Event]
+makeNodeInfo mid node from mto mname = concat
+    [ [ EventBeginElement "{jabber:client}iq"
+            $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
+                            [("from", [ContentText from])
+                            ,("type", [ContentText "result"])]
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}query"
+            [("node",[ContentText node])]
+      ]
+    , case mname of
+        Nothing -> []
+        Just name -> [ EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
+                        [("category",[ContentText "conference"])
+                        ,("type",[ContentText "text"])
+                        ,("name",[ContentText name])]
+                     , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
+                     ]
+    , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
+      , EventEndElement "{jabber:client}iq" ]
+    ]
+
+features :: [Text] -> [XML.Event]
+features fs = do
+    t <- fs
+    [ EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText t])],
+      EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
+
+makeMUCInfo :: Maybe Text -> Text -> Maybe Text -> [XML.Event] -> [XML.Event]
+makeMUCInfo mid from mto fs = concat
+    [ [ EventBeginElement "{jabber:client}iq"
+            $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
+                            [("from", [ContentText from])
+                            ,("type", [ContentText "result"])]
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}query" []
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}identity"
+            [("category",[ContentText "conference"])
+            ,("type",[ContentText "text"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}identity"
+      {-
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#info"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/disco#items"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature"
+      -}
+      , EventBeginElement "{http://jabber.org/protocol/disco#info}feature"
+            [("var",[ContentText "http://jabber.org/protocol/muc"])]
+      , EventEndElement "{http://jabber.org/protocol/disco#info}feature" ]
+    , fs
+    , [ EventEndElement "{http://jabber.org/protocol/disco#info}query"
+      , EventEndElement "{jabber:client}iq" ]
+    ]
+
+makeItemList :: Maybe Text -> [(Text,Maybe Text)] -> Text -> Maybe Text -> [Event]
+makeItemList mid items from mto = concat
+    [ [ EventBeginElement "{jabber:client}iq"
+            $ consid mid $ maybe id (\to -> (("to", [ContentText to]) :)) mto
+                            [("from", [ContentText from])
+                            ,("type", [ContentText "result"])]
+      , EventBeginElement "{http://jabber.org/protocol/disco#items}query" []]
+    , do (jid,name) <- items
+         [ EventBeginElement "{http://jabber.org/protocol/disco#items}item"
+                $ maybe id (\n -> (("name", [ContentText n]) :)) name [ ("jid", [ContentText jid]) ],
+           EventEndElement "{http://jabber.org/protocol/disco#items}item" ]
+    , [ EventEndElement "{http://jabber.org/protocol/disco#items}query"
+      , EventEndElement "{jabber:client}iq" ]
+    ]
+
+iq_bind_reply :: Maybe Text -> Text -> [XML.Event]
+iq_bind_reply mid jid =
+    [ EventBeginElement "{jabber:client}iq" (consid mid [("type",[ContentText "result"])])
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+        [("xmlns",[ContentText "urn:ietf:params:xml:ns:xmpp-bind"])]
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-bind}jid" []
+    , EventContent (ContentText jid)
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-bind}jid"
+    , EventEndElement  "{urn:ietf:params:xml:ns:xmpp-bind}bind"
+    , EventEndElement "{jabber:client}iq"
+
+    {-
+    -- query for client version
+    , EventBeginElement "{jabber:client}iq"
+                            [ attr "to" jid
+                            , attr "from" hostname
+                            , attr "type" "get"
+                            , attr "id" "version"]
+    , EventBeginElement "{jabber:iq:version}query" []
+    , EventEndElement "{jabber:iq:version}query"
+    , EventEndElement "{jabber:client}iq"
+    -}
+    ]
+
+iq_session_reply :: Maybe Text -> Text -> [XML.Event]
+iq_session_reply mid host =
+    -- Note: similar to Pong
+    [ EventBeginElement "{jabber:client}iq"
+        (consid mid [("from",[ContentText host])
+                    ,("type",[ContentText "result"])
+                    ])
+    , EventEndElement "{jabber:client}iq"
+    ]
+
+iq_service_unavailable :: Maybe Text -> Text -> XML.Name -> [XML.Event]
+iq_service_unavailable mid host {- mjid -} req =
+    [ EventBeginElement "{jabber:client}iq"
+        (consid mid [attr "type" "error"
+                    ,attr "from" host])
+    , EventBeginElement req []
+    , EventEndElement req
+    , EventBeginElement "{jabber:client}error"
+        [ attr "type" "cancel"
+        , attr "code" "503" ]
+    , EventBeginElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable" []
+    , EventEndElement "{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavailable"
+    , EventEndElement "{jabber:client}error"
+    , EventEndElement "{jabber:client}iq"
+    ]
+
+
+wrapStanzaList :: [XML.Event] -> STM [Either (StanzaWrap XML.Event) XML.Event]
+wrapStanzaList xs = do
+    wrap <- do
+        clsrs <- newTVar Nothing
+        donev <- newTMVar ()
+        return $ \ x ->
+            Stanza { stanzaType = Unrecognized
+                   , stanzaId = mid
+                   , stanzaTo = mto
+                   , stanzaFrom = mfrom
+                   , stanzaClosers = clsrs
+                   , stanzaInterrupt = donev
+                   , stanzaOrigin = LocalPeer
+                   , stanzaChan = x
+                   }
+    return $ map (Left . wrap) (take 1 xs) ++ map Right (drop 1 xs)
+  where
+    m = listToMaybe xs
+    mto = m >>= lookupAttrib "to" . tagAttrs
+    mfrom = m >>= lookupAttrib "from" . tagAttrs
+    mid = m >>= lookupAttrib "id" . tagAttrs
+
+wrapStanzaConduit :: Monad m => StanzaWrap a -> ConduitM Event (Either (StanzaWrap Event) Event) m ()
+wrapStanzaConduit stanza = do
+    mfirst <- await
+    forM_ mfirst $ \first -> do
+    yield . Left $ stanza { stanzaChan = first }
+    awaitForever $ yield . Right
+
+
+
+{-
+greet namespace =
+    [ EventBeginDocument
+    , EventBeginElement (streamP "stream")
+        [ attr "xmlns"   namespace
+        , attr "version" "1.0"
+        ]
+    ]
+-}
+
+{-
+goodbye :: [XML.Event]
+goodbye =
+    [ EventEndElement (streamP "stream")
+    , EventEndDocument
+    ]
+-}
+
+simulateChatError :: StanzaError -> Maybe Text -> [Event]
+simulateChatError err mfrom =
+    [ EventBeginElement "{jabber:client}message"
+         ((maybe id (\t->(attr "from" t:)) mfrom)
+           [attr "type" "normal" ])
+    , EventBeginElement "{jabber:client}body" []
+    , EventContent $ ContentText ("/me " <> errorText err)
+    , EventEndElement "{jabber:client}body"
+    , EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
+      , EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
+        , EventBeginElement "{http://www.w3.org/1999/xhtml}p"
+             [ attr "style" "font-weight:bold; color:red"
+             ]
+        , EventContent $ ContentText ("/me " <> errorText err)
+        , EventEndElement "{http://www.w3.org/1999/xhtml}p"
+      , EventEndElement "{http://www.w3.org/1999/xhtml}body"
+    , EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
+    , EventEndElement "{jabber:client}message"
+    ]
+
+
+-- | Create a friend-request stanza.
+presenceSolicitation :: Text -- ^ JID of sender making request.
+                     -> Text -- ^ JID of recipient who needs to approve it.
+                     -> IO Stanza
+presenceSolicitation = presenceStanza (PresenceRequestSubscription True) "subscribe"
+
+presenceProbe :: Text -> Text -> IO Stanza
+presenceProbe = presenceStanza PresenceRequestStatus "probe"
+
+presenceStanza :: StanzaType -> Text -> Text -> Text -> IO Stanza
+presenceStanza stanza_type type_attr me jid =
+    stanzaFromList stanza_type
+        [ EventBeginElement "{jabber:server}presence"
+                [ attr "to" jid
+                , attr "from" me
+                , attr "type" type_attr
+                ]
+        , EventEndElement "{jabber:server}presence" ]
+
+slotsToSource ::
+    Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
+    -> TVar Int
+    -> TVar (Maybe (StanzaWrap XML.Event))
+    -> TVar Bool
+    -> TMVar ()
+    -> ConduitT () (Flush XML.Event) IO ()
+slotsToSource slots nesting lastStanza needsFlush rdone =
+    fix $ \slot_src -> join . lift . atomically $ foldr1 orElse
+                [Slotted.pull slots >>= \x -> do
+                    x <- case x of
+                            Left wrapped -> do
+                                writeTVar nesting 1
+                                writeTVar lastStanza (Just wrapped)
+                                return $ stanzaChan wrapped
+                            Right x      -> do
+                                when (isEventBeginElement x)
+                                    $ modifyTVar' nesting (+1)
+                                when (isEventEndElement x) $ do
+                                    n <- readTVar nesting
+                                    when (n==1) $ writeTVar lastStanza Nothing
+                                    modifyTVar' nesting (subtract 1)
+                                return x
+                    writeTVar needsFlush True
+                    return $ do
+                    -- liftIO $ wlog $ "yielding Chunk: " ++ show x
+                    yield (Chunk x)
+                    slot_src
+                ,do Slotted.isEmpty slots >>= check
+                    readTVar needsFlush >>= check
+                    writeTVar needsFlush False
+                    return $ do
+                    -- liftIO $ wlog "yielding Flush"
+                    yield Flush
+                    slot_src
+                ,readTMVar rdone >> return (return ())
+                ]
+
+forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event
+                -> XMPPServerParameters
+                -> PeerAddress -- SockAddr (XXX(what?): remote for peer, local for client)
+                -> ConnectionData
+                -> FlagCommand
+                -> ConduitT () XML.Event IO ()
+                -> ConduitT (Flush XML.Event) Void IO ()
+                -> TChan Stanza
+                -> MVar ()
+                -> IO (TChan Stanza)
+forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
+    let auxAddr = cdAddr cdta
+        clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
+            Right _    -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr)
+                                          , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr)
+                                          , ClientOrigin (ClientAddress $ peerAddress saddr))
+            Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr
+                                          , xmppTellPeerHisName xmpp saddr
+                                          , PeerOrigin saddr)
+    me <- tellmyname
+    rdone <- atomically newEmptyTMVar
+    let isStarter (Left _) = True
+        isStarter (Right e) | isEventBeginElement e = True
+        isStarter _ = False
+        isStopper (Left _) = False
+        isStopper (Right e) | isEventEndElement e = True
+        isStopper _ = False
+    slots <- atomically $ Slotted.new isStarter isStopper
+    needsFlush <- atomically $ newTVar False
+    lastStanza <- atomically $ newTVar Nothing
+    nesting <- atomically $ newTVar 0
+    let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
+    let greet_src = do
+            CL.sourceList (greet' namespace me) .| CL.map Chunk
+            yield Flush
+        slot_src = slotsToSource slots nesting lastStanza needsFlush rdone
+    -- client.PeerAddress {peerAddress = [::1]:5222}
+    let lbl n = concat [ n
+                       , Text.unpack (Text.drop 7 namespace) -- "client" or "server"
+                       , "."
+                       , case cdProfile cdta of
+                            _ | Right _ <- cdAddr cdta -> show saddr
+                            "."                        -> show saddr
+                            mytoxname                  -> show saddr {- TODO: remote tox peer name? -} ]
+
+    forkIO $ do myThreadId >>= flip labelThread (lbl "xmpp-post.")
+                -- This thread handles messages after they are pulled out of
+                -- the slots-queue.  Hence, xmpp-post, for post- slots-queue.
+
+                -- Read all slots-queued XML events or stanzas and yield them
+                -- upstream.  This should continue until the connection is
+                -- closed.
+                runConduit $ (greet_src >> slot_src) .| snk
+
+                -- Connection is now closed.  Here we handle any unsent stanzas.
+                last <- atomically $ readTVar lastStanza
+                es <- while (atomically . fmap not $ Slotted.isEmpty slots)
+                            (atomically . Slotted.pull $ slots)
+                let es' = mapMaybe metadata es -- We only care about full stanzas.
+                    metadata (Left s) = Just s
+                    metadata _        = Nothing
+                -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
+                --          and protocol violation
+                -- TODO: IDMangler can be used for better targetted error delivery.
+                let fail stanza = do
+                            wlog $ "failed delivery: " ++ show (stanzaId stanza)
+                            quitVar <- atomically newEmptyTMVar
+                            reply <- makeErrorStanza stanza
+                            tag <- stanzaFirstTag stanza
+                            -- sendReply quitVar (Error RecipientUnavailable tag) reply replyto
+                            replystanza <- stanzaFromList (Error RecipientUnavailable tag) reply
+                            xmppDeliverMessage xmpp (wlog $ "discarded error delivery fail") replystanza
+                    notError s = case stanzaType s of
+                                    Error {} -> False
+                                    _        -> True
+                -- TODO: Probably some stanzas should be queued or saved for re-connect.
+                mapM_ fail $ filter notError (maybeToList last ++ es')
+                wlog $ "end xmpp-post fork: " ++ (lbl "")
+
+    output <- atomically newTChan
+    hacks <- atomically $ newTVar Map.empty
+    msgids <- atomically $ newTVar []
+    forkIO $ do
+        -- Here is the pre- slots-queue thread which handles messages as they
+        -- arrive and assigns slots to them if that is appropriate.
+
+        -- mapM_ (atomically . Slotted.push slots Nothing) greetPeer
+        myThreadId >>= flip labelThread (lbl "xmpp-pre.")
+
+        verbosity <- xmppVerbosity xmpp
+        fix $ \loop -> do
+            what <- atomically $ foldr1 orElse
+                [readTChan output >>= \stanza -> return $ do
+                    wantStanzas <- getVerbose XJabber
+                    let notping f
+                            | not wantStanzas = return ()
+                            | (verbosity==1)  = case stanzaType stanza of Pong -> return ()
+                                                                          _ -> f
+                            | (verbosity>=2)  = f
+                            | otherwise       = return ()
+                    -- isempty <- atomically $ isEmptyTChan (stanzaChan stanza)
+                    -- kwlog $ "queuing: "++show (isempty, stanzaId stanza)
+                    notping $ do
+                        dup <- cloneStanza stanza
+                        let typ = Strict8.pack $ c ++ "<-" ++ stanzaTypeString dup ++ " "
+                            c = case auxAddr of
+                                    Right _ -> "C"
+                                    Left  _ -> "P"
+                        wlog ""
+                        liftIO $ takeMVar pp_mvar
+                        runConduit $ stanzaToConduit dup .| prettyPrint typ
+                        liftIO $ putMVar pp_mvar ()
+                    -- wlog $ "hacks: "++show (stanzaId stanza)
+                    case stanzaType stanza of
+                        InternalEnableHack hack -> do
+                            -- wlog $ "enable hack: " ++ show hack
+                            atomically $ modifyTVar' hacks (Map.insert hack ())
+                        InternalCacheId x -> do
+                            -- wlog $ "cache id thread: " ++ show x
+                            atomically $ modifyTVar' msgids (take 3 . (x:))
+                        _ -> return ()
+                    runConduit $ stanzaToConduit stanza .| wrapStanzaConduit stanza
+                        .| awaitForever
+                            -- TODO: PresenceStatus stanzas should be pushed to appropriate slots
+                            (liftIO . atomically . Slotted.push slots Nothing)
+                    case stanzaType stanza of
+                        Error err tag | tagName tag=="{jabber:client}message" -> do
+                            wlog $ "handling Error hacks"
+                            b <- atomically $ do m <- readTVar hacks
+                                                 cached <- readTVar msgids
+                                                 fromMaybe (return False) $ stanzaId stanza <&> \id' -> do
+                                                 return $ Map.member SimulatedChatErrors m
+                                                            && elem id' cached
+                            ids <- atomically $ readTVar msgids
+                            wlog $ "ids = " ++ show (b,stanzaId stanza, ids)
+                            when b $ do
+                            let sim = simulateChatError err (stanzaFrom stanza)
+                            wlog $ "sending simulated chat for error message."
+                            runConduit $ CL.sourceList sim .| wrapStanzaConduit stanza -- not quite right, but whatever
+                                .| awaitForever
+                                    (liftIO . atomically . Slotted.push slots Nothing)
+                        Error e _ -> do
+                            wlog $ "no hacks for error: " ++ show e
+                        _ -> return ()
+                    loop
+                ,do pingflag >>= check
+                    return $ do
+                    to <- telltheirname
+                    let from = me -- Look it up from Server object
+                                  -- or pass it with Connection event.
+                        mid = Just "ping"
+                        ping0 = makePing namespace mid to from
+                    ping <- atomically $ wrapStanzaList ping0
+                    mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
+                          ping
+                    wlog ""
+                    runConduit $ CL.sourceList ping0 .| prettyPrint (case auxAddr of
+                        Right _ -> "C<-Ping"
+                        Left  _ -> "P<-Ping ")
+                    loop
+                ,readTMVar rdone >> return (return ())
+                ]
+            what
+        wlog $ "end xmpp-pre fork: " ++ show (lbl "")
+    forkIO $ do
+        myThreadId >>= flip labelThread (lbl "xmpp-reader.")
+        -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
+        runConduit $ src .| xmppInbound cdta clientOrServer pingflag stanzas output rdone
+        atomically $ putTMVar rdone ()
+        wlog $ "end reader fork: " ++ lbl ""
+    return output
+
+{-
+data Peer = Peer
+    { peerWanted :: TVar Bool -- ^ False when this peer is on a you-call-me basis
+    , peerState :: TVar PeerState
+    }
+data PeerState
+    = PeerPendingConnect UTCTime
+    | PeerPendingAccept UTCTime
+    | PeerConnected (TChan Stanza)
+-}
+
+peerKey :: SocketLike sock => Maybe SockAddr -> sock -> IO (PeerAddress,ConnectionData)
+peerKey bind_addr sock = do
+    laddr <- getSocketName sock
+    raddr <-
+      sIsConnected sock >>= \c ->
+        if c then getPeerName sock -- addr is normally socketName
+             else return laddr     -- Weird hack: addr is would-be peer name
+    -- Assume remote peers are listening on the same port that we do.
+    let peerport = fromIntegral $ fromMaybe 5269 $ do
+                        p <- bind_addr >>= sockAddrPort
+                        guard (p /= 0) -- Make sure we never use port 0 because it is used
+                                       -- to distinguish fake address connection keys.
+                        return p
+    rname <- atomically $ newTVar Nothing
+    -- dput XMan $ "peerKey " ++ show (PeerAddress $ raddr `withPort` peerport,laddr)
+    return $ ( PeerAddress $ raddr `withPort` peerport
+             , ConnectionData { cdAddr       = Left (Local laddr)
+                              , cdType       = XMPP
+                              , cdProfile    = "."
+                              , cdRemoteName = rname } )
+
+clientKey :: SocketLike sock => sock -> IO (PeerAddress,ConnectionData)
+clientKey sock = do
+    laddr <- getSocketName sock -- [::1]:5222  bind address, same for all clients
+    raddr <- getPeerName sock   -- [::1]:????? unique key
+    when (Just 0 == sockAddrPort raddr) $ do
+        dput XMan $ unwords [ "BUG: XMPP Client"
+                            , show (laddr,raddr)
+                            , "is using port zero.  This could interfere"
+                            , "with Tox peer sessions." ]
+    rname <- atomically $ newTVar Nothing
+    -- dput XMan $ "clientKey " ++ show (PeerAddress laddr,raddr)
+    return $ ( PeerAddress raddr -- Actually a ClientAddress, but _xmpp_sv conkey type is PeerAddress.
+             , ConnectionData { cdAddr       = Right (Remote raddr) -- FIXME: This is a bad way to detect client/peer.
+                              , cdType       = XMPP
+                              , cdProfile    = "."
+                              , cdRemoteName = rname } )
+
+
+xmlifyRosterItems :: Monad m => Set Text -> Text -> Set Text -> ConduitM i Event m ()
+xmlifyRosterItems solicited stype set = mapM_ item (Set.toList set)
+ where
+  item jid = do yield $ EventBeginElement "{jabber:iq:roster}item"
+                        ([ attr "jid" jid
+                         , attr "subscription" stype
+                         ]++if Set.member jid solicited
+                             then [attr "ask" "subscribe"]
+                             else [] )
+                yield $ EventEndElement "{jabber:iq:roster}item"
+
+sendRoster ::
+    StanzaWrap a
+    -> XMPPServerParameters
+    -> ClientAddress
+    -> TChan Stanza
+    -> IO ()
+sendRoster query xmpp clientKey replyto = do
+    let maddr = case stanzaOrigin query of
+             ClientOrigin addr _ -> Just addr
+             PeerOrigin {}       -> Nothing -- remote peer requested roster?
+             LocalPeer           -> Nothing -- local peer requested roster?
+    forM_ maddr $ \k -> do
+    hostname <- xmppTellMyNameToClient xmpp clientKey
+    let getlist f = do
+            bs <- f xmpp k
+            return (Set.fromList bs) -- js)
+    buddies     <- getlist xmppRosterBuddies
+    subscribers <- getlist xmppRosterSubscribers
+    solicited   <- getlist xmppRosterSolicited
+    subnone0    <- getlist xmppRosterOthers
+    jid <- xmppTellClientHisName xmpp k -- LookupClientJID xmpp k
+    let subnone = Set.union solicited subnone0 \\ Set.union buddies subscribers
+    let subto = buddies \\ subscribers
+    let subfrom = subscribers \\ buddies
+    let subboth = Set.intersection buddies subscribers
+    let roster = do
+            yield $ EventBeginElement "{jabber:client}iq"
+                        (consid (stanzaId query)
+                            [ attr "to" jid
+                            , attr "type" "result" ])
+            yield $ EventBeginElement "{jabber:iq:roster}query" [] -- todo: ver?
+            xmlifyRosterItems solicited "to" subto
+            xmlifyRosterItems solicited "from" subfrom
+            xmlifyRosterItems solicited "both" subboth
+            xmlifyRosterItems solicited "none" subnone
+            yield $ EventEndElement "{jabber:iq:roster}query"
+            yield $ EventEndElement "{jabber:client}iq"
+
+    conduitToStanza Roster
+                    (stanzaId query)
+                    Nothing
+                    (Just jid)
+                    roster >>= ioWriteChan replyto
+    {-
+    let debugpresence =
+                [ EventBeginElement "{jabber:client}presence"
+                    [ attr "from" "guest@oxio4inifatsetlx.onion"
+                    , attr "to" jid]
+                , EventEndElement "{jabber:client}presence"
+                ]
+    quitvar <- atomically newEmptyTMVar
+    sendReply quitvar Unrecognized debugpresence replyto
+    -}
+
+
+socketFromKey :: Server PeerAddress ConnectionData releaseKey XML.Event -> ClientAddress -> IO (Remote SockAddr)
+socketFromKey sv (ClientAddress addr) = do
+    map <- atomically $ readTVar (conmap sv)
+    let mcd = Map.lookup (PeerAddress addr) map
+        oops = Remote addr -- No connection data, so using incorrect address.
+    case mcd of
+        Nothing -> return oops
+        Just cd -> return $ either (const oops) id $ cdAddr $ cdata cd
+
+eventContent :: Maybe [Content] -> Text
+eventContent cs = maybe "" (foldr1 (<>) . map content1) cs
+            where content1 (ContentText t)   = t
+                  content1 (ContentEntity t) = t
+
+makeErrorStanza :: StanzaFirstTag a => StanzaWrap a -> IO [XML.Event]
+makeErrorStanza stanza = makeErrorStanza' stanza RecipientUnavailable []
+
+makeErrorStanza' :: StanzaFirstTag a =>
+                          StanzaWrap a -> StanzaError -> [(Name, [Content])] -> IO [Event]
+makeErrorStanza' stanza err attrs = do
+    startTag <- stanzaFirstTag stanza
+    let n = tagName startTag
+        endTag = EventEndElement n
+        amap0 = Map.fromList (tagAttrs startTag)
+        mto   = Map.lookup "to" amap0
+        mfrom = Map.lookup "from" amap0
+        mtype = Map.lookup "type" amap0
+        -- mid = Map.lookup "id" amap0
+        amap1 = Map.alter (const mto) "from" amap0
+        -- amap2 = Map.alter (const $ Just $ [ContentText "blackbird"]) {-mfrom)-} "to" amap1
+        amap2 = Map.alter (const mfrom) "to" amap1
+        amap3 = Map.insert "type" [XML.ContentText "error"] amap2
+        startTag' = EventBeginElement
+                        (tagName startTag)
+                        (Map.toList amap3)
+        -- err = Gone -- FeatureNotImplemented -- UndefinedCondition -- RecipientUnavailable
+        errname = n { nameLocalName = "error" }
+        -- errattrs = [attr "type" "wait"] --  "modify"]
+        errorAttribs e xs = ys ++ xs -- todo replace instead of append
+            where (typ,code) = xep0086 e
+                  ys = [attr "type" typ, attr "code" (Text.pack . show $ code)]
+        errorTagName = Name { nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas"
+                            , nameLocalName = errorTagLocalName err
+                            , namePrefix = Nothing }
+        errattrs = errorAttribs err attrs
+    {-
+    let wlogd v s = do
+            wlog $ "error "++show (lookupAttrib "id" $ tagAttrs startTag)++" " ++ v ++ " = " ++ show s
+    wlogd "amap0" amap0
+    wlogd "mto" mto
+    wlogd "mfrom" mfrom
+    wlogd "amap3" amap3
+    -}
+    if eventContent mtype=="error" then return [] else do
+    return [ startTag'
+           , EventBeginElement errname errattrs
+           , EventBeginElement errorTagName []
+           , EventEndElement errorTagName
+           , EventEndElement errname
+            {-
+           , EventBeginElement "{jabber:client}body" []
+           , EventContent (ContentText "what?")
+           , EventEndElement "{jabber:client}body"
+            -}
+           {-
+           , EventBeginElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy" []
+           , EventEndElement "{154ae29f-98f2-4af4-826d-a40c8a188574}dummy"
+           -}
+           , endTag
+           ]
+
+monitor ::
+    Server PeerAddress ConnectionData releaseKey XML.Event
+    -> ConnectionParameters PeerAddress ConnectionData
+    -> XMPPServerParameters
+    -> IO b
+monitor sv params xmpp = do
+    chan <- return $ serverEvent sv
+    stanzas <- atomically newTChan
+    quitVar <- atomically newEmptyTMVar
+    pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log.
+    joined_rooms <- atomically
+        $ newTVar (Map.empty :: Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
+    fix $ \loop -> do
+    action <- atomically $ foldr1 orElse
+      [ readTChan chan >>= \((addr,u),e) -> return $ do
+        case e of
+            Connection pingflag xsrc xsnk
+                -> do wlog $ tomsg addr "Connection"
+                      outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar
+                      -- /addr/ may be a peer or a client.  So we'll strip off
+                      -- the PeerAddress constructor before exposing it.
+                      xmppNewConnection xmpp (peerAddress addr) u outs
+            ConnectFailure addr
+                -> do return () -- wlog $ tomsg k "ConnectFailure"
+            EOF -> do wlog $ tomsg addr "EOF"
+                      -- /addr/ may be a peer or a client.  So we'll strip off
+                      -- the PeerAddress constructor before exposing it.
+                      xmppEOF xmpp (peerAddress addr) u
+            HalfConnection In
+                -> do wlog $ tomsg addr "ReadOnly"
+                      case cdAddr u of
+                        Left (Local _) -> control sv (Connect (peerAddress addr) params)
+                        _              -> return () -- Don't call-back client connections.
+            HalfConnection Out
+                -> do wlog $ tomsg addr "WriteOnly"
+            RequiresPing
+                -> do return () -- wlog $ tomsg k "RequiresPing"
+      , readTChan stanzas >>= \stanza -> return $ do
+        {-
+        dup <- case stanzaType stanza of
+                -- Must dup anything that is going to be delivered...
+                Message {} -> do
+                    dup <- cloneStanza stanza -- dupped so we can make debug print
+                    return dup
+                Error {} -> do
+                    dup <- cloneStanza stanza -- dupped so we can make debug print
+                    return dup
+                _ -> return stanza
+        -}
+        dup <- cloneStanza stanza
+
+        t <- forkIO $ do applyStanza sv joined_rooms quitVar xmpp stanza
+                         forwardStanza quitVar xmpp stanza
+        labelThread t $ "process." ++ stanzaTypeString stanza
+
+        -- We need to clone in the case the stanza is passed on as for Message.
+        wantStanzas <- getVerbose XJabber
+        verbosity <- xmppVerbosity xmpp
+        let notping f | not wantStanzas = return ()
+                      | (verbosity==1)  = case stanzaType stanza of Pong -> return ()
+                                                                    _    -> f
+                      | (verbosity>=2)  = f
+                      | otherwise       = return ()
+        notping $ do
+        let typ = Strict8.pack $ c ++ "->" ++ stanzaTypeString stanza ++ " "
+            c = case stanzaOrigin stanza of
+                    LocalPeer       -> "*"
+                    ClientOrigin {} -> "C"
+                    PeerOrigin {}   -> "P"
+        wlog ""
+        liftIO $ takeMVar pp_mvar
+        runConduit $ stanzaToConduit dup .| prettyPrint typ
+        liftIO $ putMVar pp_mvar ()
+      , do
+            m <- readTVar joined_rooms
+            foldr orElse retry $ (`map` (do (k,rs) <- Map.toList m
+                                            i <- Map.toList rs
+                                            return (k,i)))
+                $ \(k,((rkey,muckey),(replyto,r))) -> do
+                    (mine,ChatTransaction no cjid cnick es) <- readRoom k r
+                    return $ do
+                        me <- xmppTellMyNameToClient xmpp k
+                        dput XJabber $ "CHAT " ++ Text.unpack rkey ++ ": <" ++ Text.unpack cnick ++ "> " ++ show es
+                        forM_ es $ \case
+                            Join | mine -> sendRoomOccupants muckey me cnick rkey r replyto
+                            Join        -> do
+                                stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Available
+                                            [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
+                                            , EventEndElement "{http://jabber.org/protocol/muc#user}x"
+                                            ]
+                                ioWriteChan replyto stanza
+                            Part        -> do
+                                stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Offline
+                                          $ [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] ]
+                                            ++ (do guard mine
+                                                   [ EventBeginElement "{http://jabber.org/protocol/muc#user}status"
+                                                        [ ("code",[ContentText "110"]) -- self-presence code.
+                                                        ]
+                                                    , EventEndElement "{http://jabber.org/protocol/muc#user}status" ])
+                                            ++ [ EventEndElement "{http://jabber.org/protocol/muc#user}x" ]
+                                ioWriteChan replyto stanza
+                                when mine $ atomically $ do
+                                    jrs <- readTVar joined_rooms
+                                    let m = Map.findWithDefault Map.empty k jrs
+                                        m' = Map.delete (rkey,muckey) m
+                                        jrs' = if Map.null m' then Map.delete k jrs
+                                                              else Map.insert k m' jrs
+                                    writeTVar joined_rooms jrs'
+                            Talk talk   -> do
+                                them <- xmppTellClientHisName xmpp k
+                                stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk
+                                ioWriteChan replyto stanza
+                                return ()
+                            _           -> return ()
+      ]
+    action
+    loop
+ where
+    tomsg k str =  printf "%12s %s" str (show k)
+        where
+            _ = str :: String
+
+roomjid :: Text {- ^ service -} -> Text {- ^ hostname -} -> Text {- ^ room -} -> Text {- ^ nick -} -> Text
+roomjid a me room n = room <> "@" <> a <> "." <> me <> "/" <> n
+
+sendRoomOccupants :: Text -> Text -> Text -> Text -> JoinedRoom k -> TChan Stanza -> IO ()
+sendRoomOccupants a me them room r replyto = do
+    xs <- map (\(n,m) -> (roomjid a me room n, m))
+             <$> atomically (roomOccupants $ joinedRoom r)
+    let (ys,xs') = partition (\(jid,_) -> jid == roomjid a me room them) xs
+    forM_ xs $ \(jid,_) -> do
+        stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
+            [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
+            , EventEndElement "{http://jabber.org/protocol/muc#user}x"
+            ]
+        ioWriteChan replyto stanza
+    forM_ ys $ \(jid,_) -> do
+        stanza <- makePresenceStanzaEx "jabber:client" (Just jid) Available
+            [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
+            , EventBeginElement "{http://jabber.org/protocol/muc#user}status"
+                [ ("code",[ContentText "110"]) -- self-presence code.
+                ]
+            , EventEndElement "{http://jabber.org/protocol/muc#user}status"
+            , EventEndElement "{http://jabber.org/protocol/muc#user}x"
+            ]
+        ioWriteChan replyto stanza
+
+
+stanzaTypeString :: StanzaWrap a -> String
+stanzaTypeString stanza = concat . take 1 . words $ show (stanzaType stanza)
+
+data ServiceMatch a
+    = NotMe                       -- ^ Hostname of another server.
+    | UnknownService Text         -- ^ Unknown subdomain of this host.
+    | Service (Maybe Text) Text a -- ^ A known subdomain of this host.  Optionally, a specific room name.
+    | TopLevelService             -- ^ This server's exact hostname.
+
+
+lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a)
+lookupService me mucs to = case Text.toLower to of
+    nm | nm == Text.toLower me
+         -> TopLevelService
+    nm | let (a,hostname) = second (Text.drop 1) $ Text.break (=='@') nm
+             (service,b)  = Text.break (=='.') $ if Text.null hostname then a else hostname
+       , Text.drop 1 b == Text.toLower me
+         -> case Map.lookup service mucs of
+                    Just muc -> Service (if Text.null hostname then Nothing else Just a) service muc
+                    Nothing  -> UnknownService service
+    _ -> NotMe
+
+applyStanza :: Server PeerAddress ConnectionData releaseKey Event
+                     -> TVar (Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
+                     -> TMVar ()
+                     -> XMPPServerParameters
+                     -> StanzaWrap (LockedChan Event)
+                     -> IO ()
+
+applyStanza sv joined_rooms quitVar xmpp stanza = do
+  dput XJabber $ "applyStanza: " ++ show (stanzaType stanza)
+  case stanzaOrigin stanza of
+    ClientOrigin k replyto ->
+        case stanzaType stanza of
+            RequestResource clientsNameForMe wanted -> do
+                sockaddr <- socketFromKey sv k
+                rsc0 <- xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted
+                hostname <- xmppTellMyNameToClient xmpp k
+                let rsc = unsplitJID (n,hostname,r) where (n,_,r) = splitJID rsc0
+                let reply = iq_bind_reply (stanzaId stanza) rsc
+                -- sendReply quitVar SetResource reply replyto
+                let requestVersion :: ConduitT i XML.Event IO ()
+                    requestVersion = do
+                      yield $ EventBeginElement "{jabber:client}iq"
+                                  [ attr "to" rsc
+                                  , attr "from" hostname
+                                  , attr "type" "get"
+                                  , attr "id" "version"]
+                      yield $ EventBeginElement "{jabber:iq:version}query" []
+                      yield $ EventEndElement "{jabber:iq:version}query"
+                      yield $ EventEndElement "{jabber:client}iq"
+                      {-
+                      -- XXX Debug chat:
+                      yield $ EventBeginElement "{jabber:client}message"
+                              [ attr "from" $ eventContent (Just [ContentText rsc])
+                              , attr "type" "normal" ] -- "blackbird" ]
+                      yield $ EventBeginElement "{jabber:client}body" []
+                      yield $ EventContent $ ContentText ("hello?")
+                      yield $ EventEndElement "{jabber:client}body"
+                      yield $ EventEndElement "{jabber:client}message"
+                      -}
+                sendReply quitVar SetResource reply replyto
+                conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
+                      Nothing -- id
+                      (Just hostname) -- from
+                      (Just rsc) -- to
+                      requestVersion
+                  >>= ioWriteChan replyto
+            SessionRequest -> do
+                me <- xmppTellMyNameToClient xmpp k
+                let reply = iq_session_reply (stanzaId stanza) me
+                sendReply quitVar Pong reply replyto
+            RequestRoster -> do
+                sendRoster stanza xmpp k replyto
+                xmppSubscribeToRoster xmpp k
+            PresenceStatus {} -> do
+                let mucs = xmppGroupChat xmpp
+                me <- xmppTellMyNameToClient xmpp k
+                if | Just to <- stanzaTo stanza
+                   , (Just room,h,mnick) <- splitJID to
+                   , let roomjid = unsplitJID ((Just room,h,Nothing))
+                   , Service (Just _) mucname muc <- lookupService me mucs roomjid
+                        -> case mnick of
+                            Nothing -> do
+                                -- Missing nick.
+                                reply <- makeErrorStanza' stanza JidMalformed
+                                    [ ("by", [ContentText roomjid]) ]
+                                sendReply quitVar (Error JidMalformed (head reply)) reply replyto
+                            Just nick -> case presenceShow (stanzaType stanza) of
+                                Offline   -> do
+                                    jid <- xmppTellClientHisName xmpp k
+                                    atomically $ do
+                                        jrs <- readTVar joined_rooms
+                                        let m = Map.findWithDefault Map.empty k jrs
+                                        case Map.lookup (room,mucname) m of
+                                            Just (_,r) -> do
+                                                partRoom r (Just jid)  -- joinedNick r == nick
+                                                {-
+                                                let m' = Map.delete (room,mucname) m
+                                                    jrs' = if Map.null m' then Map.delete k jrs
+                                                                          else Map.insert k m' jrs
+                                                writeTVar joined_rooms jrs'
+                                                -}
+                                            _          -> return ()
+                                -- Anything other than type="unavailable" is treated as a join.
+                                _ -> do
+                                    jid <- xmppTellClientHisName xmpp k
+                                    join $ atomically $ do
+                                    jrs <- readTVar joined_rooms
+                                    let m = Map.findWithDefault Map.empty k jrs
+                                    case Map.lookup (room,mucname) m of
+                                        Nothing -> do r <- mucJoinRoom muc jid nick room k -- stanza
+                                                      jrs <- readTVar joined_rooms
+                                                      let m = Map.findWithDefault Map.empty k jrs
+                                                      writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs
+                                                      return $ return ()
+                                        Just r -> return $ dput XJabber "MUC: already joined."
+                   | otherwise -> do
+                        -- Handle presence stanza that is not a chatroom join.
+                        xmppInformClientPresence xmpp k stanza
+            PresenceRequestSubscription {} -> do
+                let fail = return () -- todo
+                xmppClientSubscriptionRequest xmpp fail k stanza replyto
+            PresenceInformSubscription {} -> do
+                let fail = return () -- todo
+                xmppClientInformSubscription xmpp fail k stanza
+            NotifyClientVersion name version -> do
+                enableClientHacks name version replyto
+            RequestInfo mnode -> do
+                me <- xmppTellMyNameToClient xmpp k
+                let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
+                                  reply = iq_service_unavailable (stanzaId stanza) me query
+                               in return (Error ServiceUnavailable (head reply), reply)
+                    sto = fromMaybe me (stanzaTo stanza)
+                (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of
+                     NotMe              -> unavail
+                     (UnknownService a) -> unavail -- TODO ItemNotFound instead?
+                     (Service Nothing a muc)
+                         -> case mnode of
+                                Just _  -> unavail
+                                Nothing -> let reply = makeMUCInfo (stanzaId stanza) (a <> "." <> me) (stanzaFrom stanza) []
+                                           in return (Info, reply)
+                     (Service (Just room) a muc) | Nothing <- mnode
+                         -> let reply = makeMUCInfo (stanzaId stanza) (room <> "@" <> a <> "." <> me) (stanzaFrom stanza)
+                                        $ features
+                                            [ "http://jabber.org/protocol/muc#stable_id" ]
+                            in return (Info, reply)
+                     (Service (Just room) a muc) | Just "x-roomuser-item" <- mnode
+                         -> do
+                            mgetnick <- mucReservedNick muc room
+                            case mgetnick of
+                                Nothing -> do
+                                    reply <- makeErrorStanza' stanza FeatureNotImplemented
+                                                [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
+                                    return (Error FeatureNotImplemented (head reply), reply)
+                                Just getnick -> do
+                                    who <- xmppTellClientHisName xmpp k
+                                    n <- getnick who
+                                    let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me)
+                                                    (stanzaFrom stanza) n
+                                    return (Info, reply)
+                     (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#traffic" <- mnode
+                        -> do
+                            dput XJabber $ "TODO: 18.1.1 Allowable Traffic"
+                            reply <- makeErrorStanza' stanza FeatureNotImplemented
+                                        [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
+                            return (Error FeatureNotImplemented (head reply), reply)
+                     (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#rooms" <- mnode
+                        -> do
+                            dput XJabber $ "TODO: 6.7 Discovering Client Support for MUC"
+                            reply <- makeErrorStanza' stanza FeatureNotImplemented
+                                        [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
+                            return (Error FeatureNotImplemented (head reply), reply)
+                     (Service (Just room) a muc) | Just nodename <- mnode
+                        -> do
+                            dput XJabber $ "Uknown info node: " ++ Text.unpack nodename
+                            reply <- makeErrorStanza' stanza FeatureNotImplemented
+                                        [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ]
+                            return (Error FeatureNotImplemented (head reply), reply)
+                     TopLevelService
+                         -> case mnode of
+                            Just _  -> unavail
+                            Nothing -> let reply = makeInfo (stanzaId stanza) me (stanzaFrom stanza)
+                                       in return (Info, reply)
+                sendReply quitVar rtyp reply replyto
+            RequestItems mnode -> do
+                -- let query = "{http://jabber.org/protocol/disco#items}query"
+                me <- xmppTellMyNameToClient xmpp k
+                let unavail = let query = "{http://jabber.org/protocol/disco#info}info"
+                                  reply = iq_service_unavailable (stanzaId stanza) me query
+                              in return (Error ServiceUnavailable (head reply), reply)
+                    sto = fromMaybe me (stanzaTo stanza)
+                (rtyp,reply) <- case lookupService me (xmppGroupChat xmpp) sto of
+                     NotMe                   -> unavail
+                     (UnknownService a)      -> unavail -- TODO ItemNotFound instead?
+                     (Service Nothing a muc) -> do
+                        items <- map (\(n,m) -> (n <> "@" <> a <> "." <> me, m))
+                                    <$> mucRoomList muc
+                        let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
+                        return (Items, reply)
+                     (Service (Just room) a muc) -> do
+                        items <- map (\(n,m) -> (room <> "@" <> a <> "." <> me <> "/" <> n, m))
+                                    <$> mucRoomOccupants muc room
+                            -- Note: I'm assuming 'mucRoomOccupants' returns an empty list for
+                            -- private rooms.
+                        let reply = makeItemList (stanzaId stanza) items (a <> "." <> me) (stanzaFrom stanza)
+                        return (Items, reply)
+                     TopLevelService    -> do
+                         let items = do (name,MUC {}) <- Map.toList $ xmppGroupChat xmpp
+                                        return (name <> "." <> me, Nothing)
+                             reply = makeItemList (stanzaId stanza) items me (stanzaFrom stanza)
+                         return (Items, reply)
+                sendReply quitVar rtyp reply replyto
+            UnrecognizedQuery query -> do
+                me <- xmppTellMyNameToClient xmpp k
+                let reply = iq_service_unavailable (stanzaId stanza) me query
+                sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto
+            Message { msgType = GroupChatMsg } -> do
+                let mucs = xmppGroupChat xmpp
+                me <- xmppTellMyNameToClient xmpp k
+                if | Just to <- stanzaTo stanza
+                   , (Just room,h,mnick) <- splitJID to
+                   , let roomjid = unsplitJID ((Just room,h,Nothing))
+                   , Service (Just _) mucname muc <- lookupService me mucs roomjid
+                        -> case mnick of
+                            Nothing -> do
+                                -- Send message.
+                                jid <- xmppTellClientHisName xmpp k -- This should match stanzaFrom
+                                join $ atomically $ do
+                                    jrs <- readTVar joined_rooms
+                                    let m = Map.findWithDefault Map.empty k jrs
+                                    case Map.lookup (room,mucname) m of
+                                        Just (_,r) -> do
+                                            let RH v = roomHandle r
+                                            oldt <- readTVar v
+                                            expected <- readTVar (roomFutureSeqNo $ joinedRoom r)
+                                            b <- sendChat r (Just jid) $ do
+                                                            (_,msg) <- msgLangMap (stanzaType stanza)
+                                                            talk <- maybeToList $ msgBody msg
+                                                            [ Talk talk ]
+                                            return $ dput XJabber $ "sendChat: " ++ show (b,expected,oldt,msgLangMap (stanzaType stanza))
+                                        _          -> return $ dput XJabber $ "uknown room" ++ show (room,mucname)
+                            Just nick -> do
+                                -- Private message. TODO
+                                dput XJabber $ "TODO: Private messasge. " ++ show nick
+
+                   | otherwise -> dput XJabber $ "Failed groupchat parse. to=" ++ show (stanzaTo stanza)
+            Message {} -> do
+                -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza))
+                maybe (return ()) (flip cacheMessageId replyto) $ do
+                    guard . not . null . mapMaybe (msgBody . snd) $ msgLangMap (stanzaType stanza)
+                    stanzaId stanza
+            _ -> return ()
+    PeerOrigin k replyto ->
+        case stanzaType stanza of
+            PresenceRequestStatus {} -> do
+                xmppAnswerProbe xmpp k stanza replyto
+            PresenceStatus {} -> do
+                xmppInformPeerPresence xmpp k stanza
+            PresenceRequestSubscription {} -> do
+                let fail = return () -- todo
+                xmppPeerSubscriptionRequest xmpp fail k stanza replyto
+            PresenceInformSubscription {} -> do
+                let fail = return () -- todo
+                xmppPeerInformSubscription xmpp fail k stanza
+            _ -> return ()
+    _ -> return ()
+
+forwardStanza :: TMVar () -> XMPPServerParameters -> StanzaWrap (LockedChan Event) -> IO ()
+forwardStanza quitVar xmpp stanza = do
+    let deliver replyto = do
+            -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
+            --          and protocol violation
+            let fail = do
+                    wlog $ "Failed delivery id="++show (stanzaId stanza) -- TODO
+                    reply <- makeErrorStanza stanza
+                    tag <- stanzaFirstTag stanza
+                    sendReply quitVar (Error RecipientUnavailable tag) reply replyto
+            xmppDeliverMessage xmpp fail stanza
+            -- -- bad idea:
+            -- let newStream = greet'' "jabber:client" "blackbird"
+            -- sendReply quitVar Error newStream replyto
+    case stanzaType stanza of
+        Message { msgType = GroupChatMsg } -> return () -- Group chat handled elsewhere.
+        Message {} -> do
+          case stanzaOrigin stanza of
+            LocalPeer {} -> return ()
+            ClientOrigin _ replyto -> deliver replyto
+            PeerOrigin   _ replyto -> deliver replyto
+        Error {} -> do
+          case stanzaOrigin stanza of
+            LocalPeer {} -> return ()
+            ClientOrigin _ replyto -> deliver replyto
+            PeerOrigin   _ replyto -> deliver replyto
+        _ -> return ()
+
+data ConnectionType = XMPP | Tox
+    deriving (Eq,Ord,Enum,Show,Read)
+
+data ConnectionData = ConnectionData
+    { cdAddr :: Either (Local SockAddr)  -- Peer connection local address
+                       (Remote SockAddr) -- unused, todo:remove. (was client connection remote address).
+    , cdType    :: ConnectionType
+    , cdProfile :: Text -- Currently ignored for clients.  Instead, see
+                        -- 'clientProfile' field of 'ClientState'.
+                        --
+                        -- For peers: "." for XMPP, otherwise the ".tox" hostname
+                        --  of this local node.
+
+      -- Initially Nothing, when the remote end identifies itself by a given name,
+      -- the result will be stored here.
+    , cdRemoteName :: TVar (Maybe Text)
+    }
+
+addrToPeerKey :: Remote SockAddr -> PeerAddress
+addrToPeerKey (Remote raddr) = PeerAddress raddr
+
+addrFromClientKey :: ClientAddress -> Local SockAddr
+addrFromClientKey (ClientAddress laddr) = Local laddr
+
+classifyConnection :: SockAddr -> ConnectionData -> Either (PeerAddress, Local SockAddr)
+                                                           (ClientAddress, Remote SockAddr)
+classifyConnection saddr dta = case cdAddr dta of
+    Left  laddr -> Left  (PeerAddress saddr, laddr)
+    Right raddr -> Right (ClientAddress saddr, raddr)
+
+data XMPPServer
+    = forall releaseKey.
+      XMPPServer { _xmpp_sv          :: Server PeerAddress ConnectionData releaseKey XML.Event
+                                        -- ^ Internally, we're using PeerAddress for both clients
+                                        -- and peers.  For the external interface, we mark client
+                                        -- addresses as 'ClientAddress' and not 'PeerAddress'.
+                 , _xmpp_man         :: Connection.Manager TCPStatus Text
+                 , _xmpp_peer_params :: ConnectionParameters PeerAddress ConnectionData
+                 , _xmpp_peer_bind   :: SockAddr
+                 }
+
+xmppConnections :: XMPPServer -> IO (Connection.Manager TCPStatus Text)
+xmppConnections xsv@XMPPServer{_xmpp_man = m} = return m
+
+xmppEventChannel :: XMPPServer -> TChan ((PeerAddress, ConnectionData), ConnectionEvent Event)
+xmppEventChannel XMPPServer{_xmpp_sv=sv} = serverEvent sv
+
+quitXmpp :: XMPPServer -> IO ()
+quitXmpp XMPPServer{_xmpp_sv=sv} = control sv Quit
+
+xmppServer :: MonadIO m => Allocate releaseKey m
+                        -> Maybe SockAddr -- ^ Listen address for server-to-server protocol.
+                        -> m XMPPServer
+xmppServer allocate bind_addr = do
+    sv <- server allocate xmlStream
+    liftIO $ do
+        gen <- System.Random.getStdGen
+        peer_bind <- maybe (getBindAddress "5269" True) return bind_addr
+        let (r, _) = System.Random.next gen
+            fuzz = r `mod` 2000 -- maximum 2 seconds of ping fuzz
+            peer_params :: ConnectionParameters PeerAddress ConnectionData
+            peer_params = (connectionDefaults $ peerKey $ Just peer_bind)
+                              { pingInterval = 15000 + fuzz
+                              , timeout      = 2000
+                              , duplex       = False }
+        tcp <- tcpManager (\(PeerAddress addr) -> (addr, peer_params, 10000)) sv
+        return XMPPServer { _xmpp_sv          = sv
+                          , _xmpp_man         = tcp
+                          , _xmpp_peer_params = peer_params
+                          , _xmpp_peer_bind   = peer_bind
+                          }
+
+forkXmpp :: MonadIO m => XMPPServer -> XMPPServerParameters -> m ThreadId
+forkXmpp XMPPServer { _xmpp_sv          = sv
+                    , _xmpp_peer_params = peer_params
+                    , _xmpp_peer_bind   = peer_bind
+                    }
+         xmpp = liftIO $ do
+    let client_params :: ConnectionParameters PeerAddress ConnectionData
+        client_params = (connectionDefaults clientKey)
+                              { pingInterval = 0
+                              , timeout      = 0
+                              }
+    mt <- forkIO $ do myThreadId >>= flip labelThread ("XMPP.monitor")
+                      monitor sv peer_params xmpp
+    dput XMisc $ "Starting peer listen"
+    control sv (Listen peer_bind peer_params)
+    dput XMisc $ "Starting client listen"
+    client_bind <- maybe (getBindAddress "5222" True) return $ xmppClientBind xmpp
+    control sv (Listen client_bind client_params)
+    return mt
+
+
diff --git a/dht/Presence/monitortty.c b/dht/Presence/monitortty.c
new file mode 100644
index 00000000..7582aa56
--- /dev/null
+++ b/dht/Presence/monitortty.c
@@ -0,0 +1,182 @@
+// monitortty.c
+
+#include <unistd.h>
+#include <pthread.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdint.h>
+#include <errno.h>
+#include <linux/vt.h>
+#include <sys/ioctl.h>
+#include <fcntl.h>
+#include <linux/kd.h>
+#include <stdlib.h>
+
+static char *conspath[] = {
+        "/proc/self/fd/0",
+        "/dev/tty",
+        "/dev/tty0",
+        "/dev/vc/0",
+        "/dev/systty",
+        "/dev/console",
+        NULL
+};
+
+static int
+is_a_console(int fd) {
+        char arg;
+
+        arg = 0;
+        return (isatty (fd)
+                && ioctl(fd, KDGKBTYPE, &arg) == 0
+                && ((arg == KB_101) || (arg == KB_84)));
+}
+
+static int
+open_a_console(const char *fnam) {
+        int fd;
+
+        /*
+         * For ioctl purposes we only need some fd and permissions
+         * do not matter. But setfont:activatemap() does a write.
+         */
+        fd = open(fnam, O_RDWR);
+        if (fd < 0)
+                fd = open(fnam, O_WRONLY);
+        if (fd < 0)
+                fd = open(fnam, O_RDONLY);
+        if (fd < 0)
+                return -1;
+        return fd;
+}
+
+int ttyfd() {
+        // We try several things because opening /dev/console will fail
+        // if someone else used X (which does a chown on /dev/console).
+        int i;
+        int fd;
+        for (i = 0; conspath[i]; i++) {
+                if ((fd = open_a_console(conspath[i])) >= 0) {
+                        if (is_a_console(fd)) {
+                                printf("using %s\n",conspath[i]);
+                                return fd;
+                        }
+                        close(fd);
+                }
+        }
+        for (fd = 0; fd < 3; fd++)
+                if (is_a_console(fd))
+                        return fd;
+        printf("failed to find console fd\n");
+        return -1;
+}
+
+void vt_wait(int tty_fd) {
+        struct vt_event vt;
+        memset(&vt,'\0',sizeof(vt));
+        vt.event = VT_EVENT_SWITCH;
+        int res;
+        // printf("started wait\n");
+        res = ioctl (tty_fd, VT_WAITEVENT, &vt);
+        if (res==-1) {
+                printf("vt_wait error fd=%i\n",tty_fd);
+                perror("vt_wait");
+                // printf("vt_wait: %u - %s\n", errno, errmsg(errno));
+                sleep(1);
+        }
+        // printf("finished wait\n");
+}
+
+int8_t get_active(int tty_fd) {
+        struct vt_stat vtstat;
+        memset(&vtstat,'\0',sizeof(vtstat));
+        if (ioctl(tty_fd, VT_GETSTATE, &vtstat)) {
+                perror ("get_active: VT_GETSTATE");
+                return 7;
+        }
+        return vtstat.v_active;
+}
+
+void chvt(int tty_fd, int n) {
+        if (ioctl(tty_fd, VT_ACTIVATE, n)) {
+                perror ("chvt: VT_ACTIVATE");
+        }
+
+}
+
+pthread_mutex_t mu;
+pthread_t mt;
+int tty = -1;
+
+void *write_vtch(void *pfd) {
+        int fd = (int)(intptr_t)pfd;
+        printf("started VT_WAITEVENT loop fd=%i\n",fd);
+        pthread_mutex_lock(&mu);
+        tty = ttyfd();
+        pthread_mutex_unlock(&mu);
+        int8_t active_tty = get_active(tty);
+        int8_t reported_tty;
+        ssize_t e;
+
+        pthread_setcancelstate(PTHREAD_CANCEL_ENABLE, NULL);
+        for (;;) {
+                // ssize_t write(int fd, const void *buf, size_t count);
+                e = write(fd, &active_tty, 1);
+                if (e<0 ) {
+                        if( errno==EAGAIN) continue;
+                        break;
+                }
+                else if(e==1) {
+                        reported_tty = active_tty;
+                }
+                do {
+                        vt_wait(tty);
+                        // printf("vt_wait() finished. tty=%d fd=%d\n",tty,fd);
+                        active_tty = get_active(tty);
+                } while (active_tty==reported_tty);
+        }
+        
+        // TODO:
+        //  use VT_GETSTATE
+        //  use VT_WAITEVENT
+        printf("stopped VT_WAITEVENT loop\n");
+        tty = -1;
+        pthread_mutex_destroy(&mu);
+        return NULL;
+}
+
+
+// Returns 0 on success.
+int monitorTTY(int fd) {
+    int er = -1, dev = -1;
+        pthread_mutex_init(&mu,NULL);
+    // Ensure we can open a device before we bother forking a thread.
+        dev = ttyfd();
+    if( dev != -1 ) {
+        er = pthread_create (&mt, NULL, write_vtch, (void*)(intptr_t)fd);
+        return er;
+    }
+    else {
+        return -1;
+    }
+}
+
+void closeTTY() {
+        int fd = -1;
+        int active = 7;
+        pthread_mutex_lock(&mu);
+        active = get_active(tty);
+        fd = tty;
+        pthread_mutex_unlock(&mu);
+#ifndef VTHACK
+        pthread_cancel(mt);
+#endif
+        char cmd[40]; cmd[39] = '\0';
+        // Hack to wake up from VT_WAITEVENT ioctl
+#ifdef VTHACK
+        snprintf(cmd,39,"chvt %i;chvt %i",active+1,active);
+        system(cmd);
+        pthread_join(mt,NULL);
+#endif
+        close(fd);
+}