2 files changed, 206 insertions, 1 deletions

diff --git a/Presence/Server.hs b/Presence/Server.hs
index c41f047f..5dce323c 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -54,7 +54,8 @@ doServer port g startCon = runServer2 port (runConn2 g)
         h <- socketToHandle sock ReadWriteMode
         hSetBuffering h NoBuffering
         st'' <- startCon (h .*. st)
-        handle (\(SomeException _) -> return ()) $ fix $ \loop -> do
+        let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
+        handle doException $ fix $ \loop -> do
             let continue () = hIsEOF h >>= flip when loop . not
             packet <- getPacket h
             g st'' packet continue
diff --git a/xmppserver.hs b/xmppserver.hs
new file mode 100644
index 00000000..26e9c12e
--- /dev/null
+++ b/xmppserver.hs
@@ -0,0 +1,204 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns        #-}
+
+import Data.HList.TypeEqGeneric1()
+import Data.HList.TypeCastGeneric1()
+import ByteStringOperators
+
+import Server
+import Data.ByteString.Lazy.Char8 as L 
+    ( ByteString
+    , hPutStrLn
+    , unlines
+    , pack
+    , unpack
+    , init )
+import qualified Data.ByteString.Lazy.Char8 as L 
+    ( putStrLn )
+import System.IO 
+    ( Handle
+    )
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan
+import Data.HList
+import AdaptServer
+import Text.XML.HaXml.Lex (xmlLex)
+import Text.XML.HaXml.Parse  (xmlParseWith,element,doctypedecl,processinginstruction,elemOpenTag,elemCloseTag)
+import Text.XML.HaXml.Types as Hax (ElemTag,QName(..),Namespace(..),Element(..),Content(..),AttValue(..))
+import qualified Text.XML.HaXml.Types as Hax (Element)
+import Data.Maybe
+import Debug.Trace
+
+
+
+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>"
+    ]
+
+startCon st  = do
+    let h = hOccursFst st :: Handle 
+    return (ConnectionFinalizer (return ()) .*. st)
+
+iq_query_unavailable host id mjid xmlns = L.unlines $
+    [ "<iq type='error'"
+    , "    from='" <++> host <++> "'"
+    , case mjid of  Just jid -> "    to='" <++> jid <++> "'"
+                    Nothing  -> ""
+    , "    id='" <++> id <++> "'>"
+    , "  <query 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
+
+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
+
+iqresult host id (Just rsrc) = L.unlines $
+    [ "<iq type='result' id='" <++> id <++> "'>"
+    , "<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>"
+    , "<jid>" <++> id <++> "@" <++> host <++> "/" <++> rsrc <++> "</jid>"
+    , "</bind>"
+    , "</iq> "
+    ]
+iqresult host id Nothing = 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 host (Elem _ attrs content) = do
+    id <- fmap pack (lookup (N "id") attrs >>= unattr) 
+    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
+    case typ of
+      "set" -> do
+        let string (CString _ s _) = [s]
+        mplus (do
+                rsrc <- listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
+                Just $ iqresult host id (Just (pack rsrc)) )
+              (do
+                guard (hasElem "session" content)
+                Just (iqresult host id Nothing))
+{-
+ - packet: Chunk "<iq type='get' id='purple5da6e3ed' to='localhost'><query xmlns='http://jabber.org/protocol/disco#items'/></iq>" Empty
+ - parsed-packet: Chunk "<iq type='get' id='purple5da6e3ed' to='localhost'><query xmlns='http://jabber.org/protocol/disco#items'/></iq>" Empty
+ - iq-get ([(N "type",get),(N "id",purple5da6e3ed),(N "to",localhost)],[CElem (Elem (N "query") [(N "xmlns",http://jabber.org/protocol/disco#items)] []) file stream  at line 1 col 51])
+ - no respones
+ -}
+                
+      "get" -> trace ("iq-get "++show (attrs,content)) $ do
+        xmlns <- fmap pack $
+                  lookup (N "xmlns") (tagattrs "query" content) 
+                    >>= listToMaybe . astring
+        Just (iq_query_unavailable host id Nothing xmlns)
+      _ -> Nothing
+    
+    
+
+doCon st elem cont = do
+        let h = hOccursFst st :: Handle 
+            host = "localhost"
+            hsend r = do
+                hPutStrLn h r
+                L.putStrLn $ "SENT:\n" <++> r
+ 
+        case elem of
+            OpenTag _ -> 
+                hsend (greet host)
+            Element e@(Elem (N "iq") _ _) -> 
+                case iqresponse host e of
+                    Nothing -> trace "no respones" $ return ()
+                    Just r -> hsend r
+            _ -> return () -- putStrLn $ "unhandled: "++show v
+
+        putStrLn (show elem)
+        cont ()
+
+instance Show Hax.ElemTag where
+    show _ = "elemtag"
+
+data XmppObject e i t c
+    = Element e
+    | ProcessingInstruction i
+    | OpenTag t
+    | CloseTag c
+ deriving Show
+
+streamName = QN (Namespace {nsPrefix= "stream" , nsURI="http://etherx.jabber.org/streams" }) "stream" 
+
+xmppParse ls =
+    case xmlParseWith element ls of
+        (Right e,rs) -> (Right (Element e), rs)
+        (Left _,_) -> 
+          case xmlParseWith elemOpenTag ls of
+            (Right e,rs) -> (Right (OpenTag e),rs)
+            (Left _,_) -> 
+              case xmlParseWith (elemCloseTag streamName) ls of
+                (Right e,rs) -> (Right (CloseTag e),rs)
+                (Left _,_) -> 
+                  case xmlParseWith processinginstruction ls of
+                    (Right e,rs) -> (Right (ProcessingInstruction e),rs)
+                    (Left err,rs) -> (Left err,rs)
+    
+
+
+main = do
+    let (start,dopkt) = 
+            adaptServer ( xmlLex "stream" . unpack
+                        , xmppParse)
+                        (startCon,doCon)
+    doServer (5222 .*. HNil)
+             dopkt
+             start
+
+