progress on sessions

2 files changed, 29 insertions, 49 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 87745e96..044ed9e4 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE ViewPatterns        #-}
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeFamilies        #-}
+-- {-# LANGUAGE GADTs               #-}
 module XMPPServer where -- ( listenForXmppClients ) where
 
 import Data.HList.TypeEqGeneric1()
@@ -37,6 +38,8 @@ 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
@@ -65,7 +68,7 @@ greet host = L.unlines
     , "</stream:features>"
     ]
 
-newtype TaggedXMPPSession s = TaggedXMPPSession s
+-- data TaggedXMPPSession s = TaggedXMPPSession s
 
 startCon session_factory sock st  = do
     let h = hOccursFst st :: Handle 
@@ -75,9 +78,7 @@ startCon session_factory sock st  = do
     session <- newSession session_factory sock h
     Prelude.putStrLn $ "PEER NAME: "++show pname
     
-    return ( ConnectionFinalizer (return ()) 
-           .*. TaggedXMPPSession session
-           .*. st)
+    return ( session .*. ConnectionFinalizer (closeSession session) .*. st)
 
 iq_query_unavailable host id mjid xmlns kind = L.unlines $
     [ "<iq type='error'"
@@ -143,42 +144,37 @@ iqresult_info host id mjid = L.unlines $
     , "</iq>"
     ]
 
-iqresponse host (Elem _ attrs content) = do
-    id <- fmap pack (lookup (N "id") attrs >>= unattr) 
-    typ <- fmap pack (lookup (N "type") attrs >>= unattr)
+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 <- listToMaybe . Prelude.concatMap string . tagcontent "resource" . tagcontent "bind" $ content
-                let jid = "TODO" <++> "@" <++> host <++> "/" <++> pack rsrc
-                Just $ iq_bind_reply id jid )
+                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)
-                Just (iq_session_reply host id))
+                return (iq_session_reply host id))
                 
       "get" -> {- trace ("iq-get "++show (attrs,content)) $ -} do
-        (tag,as) <- lookup (N "xmlns") (anytagattrs content) 
-        xmlns <- fmap pack $ listToMaybe . astring $ as
+        (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  -> ""
-                Just $ "<iq from='" <++> host <++> "' " <++> to <++> "id='" <++> id <++> "' type='result'/>"
+                return $ "<iq from='" <++> host <++> "' " <++> to <++> "id='" <++> id <++> "' type='result'/>"
 
-            _ -> Just (iq_query_unavailable host id Nothing xmlns servicekind)
-      _ -> Nothing
+            _ -> return (iq_query_unavailable host id Nothing xmlns servicekind)
+      _ -> MaybeT (return Nothing)
     
--- <presence>
--- <priority>1</priority>
--- <c xmlns='http://jabber.org/protocol/caps' 
---     node='http://pidgin.im/' 
---     hash='sha-1' ver='lV6i//bt2U8Rm0REcX8h4F3Nk3M=' 
---     ext='voice-v1 camera-v1 video-v1'/>
--- <x xmlns='vcard-temp:x:update'/>
--- </presence>
 
 presence_response host (Elem _ attrs content) = do
     -- let id = fmap pack (lookup (N "id") attrs >>= unattr) 
@@ -196,14 +192,16 @@ doCon st elem cont = do
             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") _ _) -> 
-                case iqresponse host e of
+            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") _ _) ->
@@ -249,26 +247,8 @@ xmppParse ls = runTryParse $ do
     Try . xml OpenTag               $ elemOpenTag
     Try . xml CloseTag              $ elemCloseTag streamName
     Try . xml ProcessingInstruction $ processinginstruction
-
-{-
-xmppParseOld :: [(Posn, TokenT)] -> (Either String XmppObject, [(Posn, TokenT)])
-xmppParseOld 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 (),rs) -> (Right (CloseTag ()),rs)
-                (Left _,_) ->
-                  case xmlParseWith processinginstruction ls of
-                    (Right e,rs) -> (Right (ProcessingInstruction e),rs)
-                    (Left err,rs) -> (Left err,rs)
--}
     
 
-
 listenForXmppClients session_factory port st = do
     let (start,dopkt) = 
             adaptServer ( xmlLex "stream" . unpack
diff --git a/Presence/main.hs b/Presence/main.hs
index 63ebf817..7a5939ff 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -41,10 +41,10 @@ data UnixSession = UnixSession
 
 instance XMPPSession UnixSession where
     data XMPPClass UnixSession = UnixSessions
-    newSession   _ sock handle = return UnixSession
-    setResource  _ resource    = return ()
-    getJID       _             = return "nobody@fake.bad"
-    closeSession _             = return ()
+    newSession   _ sock handle = putStrLn "SESSION: open" >> return UnixSession
+    setResource  _ resource    = putStrLn "SESSION: resource"
+    getJID       _             = putStrLn "SESSION: jid" >> return "nobody@fake.bad"
+    closeSession _             = putStrLn "SESSION: close" >> return ()
 
 on_chvt vtnum = do
     putStrLn $ "changed vt to "++ show vtnum