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

1 files changed, 226 insertions, 0 deletions

diff --git a/dht/ToxToXMPP.hs b/dht/ToxToXMPP.hs
new file mode 100644
index 00000000..1420c642
--- /dev/null
+++ b/dht/ToxToXMPP.hs
@@ -0,0 +1,226 @@
+{-# LANGUAGE CPP                      #-}
+{-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE LambdaCase               #-}
+{-# LANGUAGE NamedFieldPuns           #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE ViewPatterns             #-}
+module ToxToXMPP where
+
+import Control.Monad
+import Crypto.Tox
+import Conduit                      as C
+import qualified Data.Conduit.List  as CL
+import Data.Dependent.Sum
+import Data.Function
+import Data.Functor.Identity
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Text          as T
+         ;import Data.Text          (Text)
+import Data.Text.Encoding           as T
+import Data.Tox.Msg                 as Tox
+import Data.Word
+import Data.XML.Types               as XML
+import EventUtil
+import Network.Address
+import Network.Tox.Crypto.Transport as Tox hiding (UserStatus (..))
+import Network.Tox.NodeId
+import Util                         (unsplitJID)
+import XMPPServer                   as XMPP
+
+available :: StanzaType
+available = PresenceStatus { presenceShow      = Available
+                           , presencePriority  = Nothing
+                           , presenceStatus    = []
+                           , presenceWhiteList = []
+                           }
+
+xmppHostname :: PublicKey -> Text
+xmppHostname k = T.pack $ show (key2id k) ++ ".tox"
+
+toxUserStatus :: UserStatus -> JabberShow
+toxUserStatus Online   = Available
+toxUserStatus Tox.Away = XMPP.Away
+toxUserStatus Busy     = DoNotDisturb
+toxUserStatus _        = XMPP.Away -- Default, shouldn't occur.
+
+-- Currently unused, see note in 'toxJID'.
+toJabberResource :: Int -> Maybe Text
+toJabberResource addr = T.pack . show <$> Just (positive addr)
+ where
+    positive addr | addr < 0  = 2 * negate addr + 1
+                  | otherwise = 2 * addr
+
+toxJID :: Text -> Int -> Text
+toxJID theirhost addr =
+    -- unsplitJID (Nothing, theirhost, toJabberResource addr)
+    --
+    -- Not encoding the Tox session ID because Pidgin apparently doesn't
+    -- cope well with resource IDs occuring on bare hostname JIDs.
+    unsplitJID (Nothing, theirhost, Nothing)
+
+toxToXmpp :: Monad m =>
+    (Int -> Maybe Text -> Invite -> m ())
+    -> SockAddr
+    -> PublicKey
+    -> Text
+    -> ConduitM (Int,Tox.CryptoMessage) XML.Event m ()
+toxToXmpp store_invite _ me theirhost = do
+    CL.sourceList $ XMPP.greet' "jabber:server" theirhost
+    let me_u    = Nothing
+        me_h    = xmppHostname me
+        im_to   = (Just $ unsplitJID
+                            ( me_u
+                            -- /to/ should match local address of this node.
+                            , me_h
+                            , Nothing))
+    let
+      statelessMessages addr im_from = \case
+
+        Pkt MESSAGE :=> Identity bs ->
+            xmppInstantMessage "jabber:server" im_from im_to [] bs
+
+        Pkt TYPING :=> Identity st  -> xmppTyping "jabber:server" im_from im_to st
+
+        Pkt NICKNAME :=> Identity bs ->
+            xmppInstantMessage "jabber:server" im_from im_to
+                [ attr "style" "font-weight:bold; color:red" ]
+                ("NICKNAME(todo) " <> bs)
+
+        toxmsg | msgID toxmsg == M PacketRequest -> return ()
+
+        Pkt INVITE_GROUPCHAT :=> Identity ginv -> do
+            xmppInstantMessage "jabber:server" im_from im_to
+                [ attr "style" "font-weight:bold; color:red" ]
+                ("INVITE(todo)" <> (T.pack $ show ginv))
+            case invite ginv of
+                GroupInvite {} -> do C.lift $ store_invite addr im_from ginv
+                                     xmppInvite "jabber:server"  me_h (fromJust im_from) (fromJust im_to) ginv
+                _              -> return ()
+
+        toxmsg -> do
+            xmppInstantMessage "jabber:server" im_from im_to
+                [ attr "style" "font-weight:bold; color:red" ]
+                (T.pack $ "Unhandled message: " ++ show (msgID toxmsg))
+
+    flip fix available $ \loop status -> do
+        m <- await
+        forM_ m $ \(addr,x) -> do
+        let im_from = (Just $ toxJID theirhost addr)
+        case x of
+          Pkt USERSTATUS :=> Identity st -> do
+            let status' = status { presenceShow = toxUserStatus st }
+            xmppPresence "jabber:server" im_from status'
+            loop status'
+
+          Pkt STATUSMESSAGE :=> Identity bs -> do
+            let status' = status { presenceStatus = [("",bs)] }
+            xmppPresence "jabber:server" im_from status'
+            loop status'
+
+          Pkt ONLINE :=> _ -> do
+            xmppPresence "jabber:server" im_from status
+            loop status
+
+          x -> do
+            statelessMessages addr im_from x
+            loop status
+
+xmppPresence :: Monad m => Text -> Maybe Text -> StanzaType -> ConduitM i XML.Event m ()
+xmppPresence namespace mjid p = do
+    let ns n = n { nameNamespace = Just namespace }
+        setFrom = maybe id
+                        (\jid -> (attr "from" jid :) )
+                        mjid
+        typ Offline = [attr "type" "unavailable"]
+        typ _       = []
+        shw ExtendedAway = ["xa"]
+        shw Chatty       = ["chat"]
+        shw XMPP.Away    = ["away"]
+        shw DoNotDisturb = ["dnd"]
+        shw _            = []
+        jabberShow stat =
+          [ EventBeginElement "{jabber:client}show" []
+          , EventContent (ContentText stat)
+          , EventEndElement "{jabber:client}show" ]
+    C.yield       $ EventBeginElement (ns "presence") (setFrom $ typ $ presenceShow p)
+    mapM_ C.yield $ shw (presenceShow p) >>= jabberShow
+    forM_ (presencePriority p) $ \prio -> do
+        C.yield   $ EventBeginElement (ns "priority") []
+        C.yield   $   EventContent $ ContentText (T.pack $ show prio)
+        C.yield   $ EventEndElement (ns "priority")
+    forM_ (presenceStatus p) $ \(lang,txt) -> do
+        let atts | T.null lang = []
+                 | otherwise   = [ ("xml:lang", [ContentText lang]) ]
+        C.yield   $ EventBeginElement (ns "status") atts
+        C.yield   $   EventContent $ ContentText txt
+        C.yield   $ EventEndElement (ns "status")
+    C.yield       $ EventEndElement (ns "presence")
+
+chatRoomJID me cid = T.pack (show cid) <> "@ngc." <> me
+
+xmppInvite :: Monad m => Text -> Text -> Text -> Text -> Invite -> ConduitM i XML.Event m ()
+xmppInvite namespace me them to inv =
+    let ns n = n { nameNamespace = Just namespace }
+    in mapM_ C.yield
+        [ EventBeginElement (ns "message")
+            [ attr "from" (chatRoomJID me $ inviteChatID inv)
+            , attr "to" to
+            ]
+        ,   EventBeginElement "{http://jabber.org/protocol/muc#user}x" []
+        ,     EventBeginElement "{http://jabber.org/protocol/muc#user}invite"
+                [ attr "from" them ]
+        ,       EventBeginElement "{http://jabber.org/protocol/muc#user}reason" []
+        ,         EventContent (ContentText $ groupName $ invite inv)
+        ,       EventEndElement "{http://jabber.org/protocol/muc#user}reason"
+        ,     EventEndElement "{http://jabber.org/protocol/muc#user}invite"
+        ,   EventEndElement "{http://jabber.org/protocol/muc#user}x"
+        , EventEndElement (ns "message")
+        ]
+
+xmppTyping :: Monad m => Text
+                              -> Maybe Text
+                              -> Maybe Text
+                              -> Bool
+                              -> ConduitM i XML.Event m ()
+xmppTyping namespace mfrom mto x =
+    let ns n = n { nameNamespace = Just namespace }
+        st = case x of
+            False -> "{http://jabber.org/protocol/chatstates}active"
+            True  -> "{http://jabber.org/protocol/chatstates}composing"
+            -- tox-core supports only 0 and 1
+            -- _ -> "{http://jabber.org/protocol/chatstates}paused"
+    in mapM_ C.yield
+        [ EventBeginElement (ns "message")
+               (  maybe id (\t->(attr "from" t:)) mfrom
+                $ maybe id (\t->(attr "to" t:)) mto
+                $ [attr "type" "chat" ] )
+        , EventBeginElement st []
+        , EventEndElement st
+        , EventEndElement (ns "message")
+        ]
+
+xmppInstantMessage :: Monad m => Text
+                              -> Maybe Text
+                              -> Maybe Text
+                              -> [(Name, [Content])]
+                              -> Text
+                              -> ConduitM i XML.Event m ()
+xmppInstantMessage namespace mfrom mto style text = do
+    let ns n = n { nameNamespace = Just namespace }
+    C.yield $ EventBeginElement (ns "message")
+               (  maybe id (\t->(attr "from" t:)) mfrom
+                $ maybe id (\t->(attr "to" t:)) mto
+                $ [attr "type" "normal" ] )
+    C.yield $   EventBeginElement (ns "body") []
+    C.yield $     EventContent $ ContentText text
+    C.yield $   EventEndElement (ns "body")
+    C.yield $   EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
+    C.yield $     EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
+    C.yield $        EventBeginElement "{http://www.w3.org/1999/xhtml}p" style
+    C.yield $          EventContent $ ContentText text
+    C.yield $        EventEndElement "{http://www.w3.org/1999/xhtml}p"
+    C.yield $     EventEndElement "{http://www.w3.org/1999/xhtml}body"
+    C.yield $   EventEndElement "{http://jabber.org/protocol/xhtml-im}html"
+    C.yield $ EventEndElement (ns "message")
+