Create new tox key automatically + disable non-tox operation.

1 files changed, 31 insertions, 34 deletions

diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
index 2f2a1b4b..65d882bd 100644
--- a/dht/Presence/XMPPServer.hs
+++ b/dht/Presence/XMPPServer.hs
@@ -124,9 +124,11 @@ data XMPPServerParameters =
       --   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
+      -- The returned domain will be discarded and replaced with the result of
       -- 'xmppTellMyNameToClient'.
-      xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO Text
+      --
+      -- A Left result causes an error stanza to be sent instead.
+      xmppChooseResourceName :: ClientAddress -> Remote SockAddr -> Maybe Text -> Maybe Text -> IO (Either Text Text)
     , -- | This should indicate the server's hostname that all client's see.
       xmppTellMyNameToClient :: ClientAddress -> IO Text
     , xmppTellMyNameToPeer   :: Local SockAddr -> IO Text
@@ -1436,6 +1438,17 @@ lookupService me mucs to = case Text.toLower to of
                     Nothing  -> UnknownService service
     _ -> NotMe
 
+requestVersion :: Text -> Text -> ConduitT i XML.Event IO ()
+requestVersion rsc hostname = 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"
+
 applyStanza :: Server PeerAddress ConnectionData releaseKey Event
                      -> TVar (Map.Map ClientAddress (Map.Map (Text,Text) (TChan Stanza,JoinedRoom ClientAddress)))
                      -> TMVar ()
@@ -1450,38 +1463,22 @@ applyStanza sv joined_rooms quitVar xmpp stanza = do
         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
+                xmppChooseResourceName xmpp k sockaddr clientsNameForMe wanted >>= \case
+                    Right rsc0 -> do
+                        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
+                        conduitToStanza (UnrecognizedQuery "{jabber:iq:version}query")
+                              Nothing -- id
+                              (Just hostname) -- from
+                              (Just rsc) -- to
+                              (requestVersion rsc hostname)
+                          >>= ioWriteChan replyto
+                    Left err -> do
+                        hostname <- xmppTellMyNameToClient xmpp k
+                        reply <- makeErrorStanza' stanza NotAllowed []
+                        sendReply quitVar (Error NotAuthorized (head reply)) reply replyto
             SessionRequest -> do
                 me <- xmppTellMyNameToClient xmpp k
                 let reply = iq_session_reply (stanzaId stanza) me