summaryrefslogtreecommitdiff
path: root/Presence/XMPPServer.hs
blob: 044ed9e4edadb4c48844bb9ac18c763f4b986663 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}
-- {-# LANGUAGE GADTs               #-}
module XMPPServer where -- ( listenForXmppClients ) where

import Data.HList.TypeEqGeneric1()
import Data.HList.TypeCastGeneric1()
import ByteStringOperators

import Server
import Data.ByteString.Lazy.Char8 as L 
    ( hPutStrLn
    , unlines
    , ByteString
    , pack
    , unpack )
import qualified Data.ByteString.Lazy.Char8 as L 
    ( putStrLn )
import System.IO 
    ( Handle
    )
import Data.HList
import AdaptServer
import Text.XML.HaXml.Lex (xmlLex)
import Text.XML.HaXml.Parse  (XParser,xmlParseWith,element,{-doctypedecl,-}processinginstruction,elemOpenTag,elemCloseTag)
import Text.XML.HaXml.Types as Hax hiding (Element) -- (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
import qualified Text.XML.HaXml.Types as Hax (Element(..))
import Text.XML.HaXml.Posn (Posn)
import Text.XML.HaXml.Lex  (TokenT)
import qualified Text.XML.HaXml.Pretty as PP
import Text.PrettyPrint
import Data.Maybe
import Debug.Trace
import Control.Arrow
import LocalPeerCred
import Network.Socket
import Data.String
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class


class XMPPSession session where
    data XMPPClass session
    newSession   :: XMPPClass session -> Socket -> Handle -> IO session
    setResource  :: session -> ByteString -> IO ()
    getJID       :: session -> IO ByteString
    closeSession :: session -> IO ()


greet host = L.unlines 
    [ "<?xml version='1.0'?>"
    , "<stream:stream"
    , "from='" <++> host <++> "'"
    , "id='someid'"
    , "xmlns='jabber:client' xmlns:stream='http://etherx.jabber.org/streams' version='1.0'>"
    , "<stream:features>"
    , "  <bind xmlns='urn:ietf:params:xml:ns:xmpp-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> "
    -}
    , "</stream:features>"
    ]

-- data TaggedXMPPSession s = TaggedXMPPSession s

startCon session_factory sock st  = do
    let h = hOccursFst st :: Handle 
    cred <- getLocalPeerCred sock
    Prelude.putStrLn $ "PEER CRED: "++show cred
    pname <- getPeerName sock
    session <- newSession session_factory sock h
    Prelude.putStrLn $ "PEER NAME: "++show pname
    
    return ( session .*. ConnectionFinalizer (closeSession session) .*. st)

iq_query_unavailable host id mjid xmlns kind = L.unlines $
    [ "<iq type='error'"
    , "    from='" <++> host <++> "'"
    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
                    Nothing  -> ""
    , "    id='" <++> id <++> "'>"
    , "  <" <++> kind <++> " xmlns='" <++> xmlns <++> "'/>"
    , "  <error type='cancel'>"
    , "    <service-unavailable"
    , "        xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
    , "  </error>"
    , "</iq>"
    ]

tagattrs tag content = Prelude.concatMap (\(CElem (Elem _ a _) _)->a) 
                          $ Prelude.filter (bindElem tag) content
anytagattrs content = Prelude.concatMap (\(CElem (Elem n a _) _)->map (second (n,)) a) content

bindElem tag (CElem (Elem (N n) _ _) _) | n==tag = True
bindElem _   _                                   = False

hasElem tag content =
  not . Prelude.null . Prelude.filter (bindElem tag) $ content

unattr (AttValue as) = listToMaybe $ Prelude.concatMap left as
    where left (Left x) = [x]
          left _        = []

astring (AttValue [Left s]) = [s]

tagcontent tag content = Prelude.concatMap (\(CElem (Elem _ _ c) _)->c) 
                              $ Prelude.filter (bindElem tag) content

iq_bind_reply id jid = L.unlines $
    [ "<iq type='result' id='" <++> id <++> "'>"
    , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
    , "<jid>" <++> jid <++> "</jid>"
    , "</bind>"
    , "</iq> "
    ]
iq_session_reply host id = L.unlines $
    [ "<iq type='result'"
    , "    id='" <++> id <++> "'"
    , "    from='" <++> host <++> "'"
    , "    /> "
    ]

iqresult_info host id mjid = L.unlines $
    [ "<iq type='result'"
    , "    from='" <++> host <++> "'"
    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
                    Nothing  -> ""
    , "    id='" <++> id <++> "'>"
    , "  <query xmlns='http://jabber.org/protocol/disco#info'>"
    , "    <identity"
    , "       category='server'"
    , "       type='im'"
    , "       name='" <++> host <++> "'/>"
    , "    <feature var='http://jabber.org/protocol/disco#info'/>"
    , "    <feature var='http://jabber.org/protocol/disco#items'/>"
    , "  </query>"
    , "</iq>"
    ]

iqresponse session host (Elem _ attrs content) = runMaybeT $ do
    id <- MaybeT . return $ fmap pack (lookup (N "id") attrs >>= unattr) 
    typ <- MaybeT . return $ fmap pack (lookup (N "type") attrs >>= unattr)
    case typ of
      "set" -> do
        let string (CString _ s _) = [s]
        mplus (do
                rsrc <- MaybeT . return . fmap pack $ listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
                -- let jid = "TODO" <++> "@" <++> host <++> "/" <++> pack rsrc
                liftIO $ do
                 setResource session rsrc
                 jid <- getJID session
                 return $ iq_bind_reply id jid )
              (do
                guard (hasElem "session" content)
                return (iq_session_reply host id))
                
      "get" -> {- trace ("iq-get "++show (attrs,content)) $ -} do
        (tag,as) <- MaybeT . return $ lookup (N "xmlns") (anytagattrs content) 
        xmlns <- MaybeT . return $ fmap pack $ listToMaybe . astring $ as
        let servicekind = case tag of { (N s) -> pack s ; _ -> "query" }
        case xmlns of
            "urn:xmpp:ping" -> do
                let to = case fmap pack (lookup (N "from") attrs >>= unattr) of
                            Just jid -> "to='" <++> jid <++> "' "
                            Nothing  -> ""
                return $ "<iq from='" <++> host <++> "' " <++> to <++> "id='" <++> id <++> "' type='result'/>"

            _ -> return (iq_query_unavailable host id Nothing xmlns servicekind)
      _ -> MaybeT (return Nothing)
    

presence_response host (Elem _ attrs content) = do
    -- let id = fmap pack (lookup (N "id") attrs >>= unattr) 
    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
    case typ of
        "subscribe" -> do
            -- <presence to='guest@localhost' type='subscribe'/>
            to <- fmap pack (lookup (N "to") attrs >>= unattr)
            Just $ "<presence to='" <++> to <++> "' type='subscribed'/>"
        _ -> Nothing

doCon st elem cont = do
        let h = hOccursFst st :: Handle 
            host = "localhost"
            hsend r = do
                hPutStrLn h r
                L.putStrLn $ "\nOUT:\n" <++> r
            session = hHead st

        putStrLn $ (show $ hang (text "\nIN:") 2 $ pp elem) ++ "\n"

        case elem of
            OpenTag _ -> 
                hsend (greet host)
            Element e@(Elem (N "iq") _ _) -> do
                rpns <- iqresponse session host e
                case rpns of
                    Nothing -> trace "IGNORE: no response to <iq>" $ return ()
                    Just r -> hsend r
            Element e@(Elem (N "presence") _ _) ->
                case presence_response host e of
                    Nothing -> trace "IGNORE: no response to <presence>" $ return ()
                    Just r -> hsend r

            _ -> return () -- putStrLn $ "unhandled: "++show v

        cont ()

instance Show Hax.ElemTag where
    show _ = "elemtag"

data XmppObject
    = Element (Hax.Element Posn)
    | ProcessingInstruction Hax.ProcessingInstruction
    | OpenTag ElemTag
    | CloseTag ()
 deriving Show

pp (Element e) = PP.element e
pp o = fromString (show o)

streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream" 

newtype TryParse p x e = Try (Either e p,[x])

instance Monad (TryParse p x) where
        return v = Try (Left v,[])
        Try (Left m,xs)  >>= k = k m
        Try (Right e,xs) >>= _ = Try (Right e,xs)

runTryParse (Try p) = p
mapRight f (Right x,ls) = (Right (f x),ls)
mapRight f (Left  y,ls) = (Left  y    ,ls)

xmppParse :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
xmppParse ls = runTryParse $ do
    let xml :: (t -> b) -> XParser t -> (Either String b, [(Posn, TokenT)])
        xml tag = mapRight tag . flip xmlParseWith ls
    Try . xml Element               $ element
    Try . xml OpenTag               $ elemOpenTag
    Try . xml CloseTag              $ elemCloseTag streamName
    Try . xml ProcessingInstruction $ processinginstruction
    

listenForXmppClients session_factory port st = do
    let (start,dopkt) = 
            adaptServer ( xmlLex "stream" . unpack
                        , xmppParse)
                        (startCon session_factory,doCon)
    doServer (port .*. st)
             dopkt
             start