6 files changed, 156 insertions, 39 deletions

diff --git a/Presence/FGConsole.hs b/Presence/FGConsole.hs
index fc1ece65..93b9a590 100644
--- a/Presence/FGConsole.hs
+++ b/Presence/FGConsole.hs
@@ -14,7 +14,6 @@ import Control.Monad
 import Foreign.C.Error
 import Foreign.C
 
-import Todo
 import Debug.Trace
 import System.Posix.Signals
 
diff --git a/Presence/LocalPeerCred.hs b/Presence/LocalPeerCred.hs
new file mode 100644
index 00000000..c58fe288
--- /dev/null
+++ b/Presence/LocalPeerCred.hs
@@ -0,0 +1,95 @@
+module LocalPeerCred where
+
+import Data.ByteString.Lazy.Char8 as L hiding (map,putStrLn,tail,splitAt,tails,filter)
+import qualified Data.ByteString.Lazy.Char8 as L (splitAt)
+import qualified Data.ByteString.Lazy as W8
+import Data.List (tails)
+import System.IO ( withFile, IOMode(..))
+import Data.Maybe
+import Data.Binary
+import Data.Bits
+import Network.Socket
+import System.Posix.Types
+import Debug.Trace
+-- import System.Environment (getArgs)
+
+xs     ?? n | n < 0 =  Nothing
+[]     ?? _         =  Nothing
+(x:_)  ?? 0         =  Just x
+(_:xs) ?? n         =  xs ?? (n-1)
+
+parseHex bs = L.concat . parseHex' $ bs
+ where
+  parseHex' bs =
+      let (dnib,ts) = L.splitAt 2 bs
+          parseNibble x = W8.pack $ group2 toW8 (W8.unpack $ W8.map hexDigit x)
+          hexDigit d = d - (if d>0x39 then 0x37 else 0x30)
+          group2 f (x:y:ys) = f x y : group2 f ys
+          group2 _ _        = []
+          toW8 a b = shift a 4 .|. b
+      in parseNibble dnib :
+          if L.null ts 
+              then []
+              else parseHex' ts
+
+getLocalPeerCred' (SockAddrInet portn host) = do
+    let port = fromEnum portn
+    trace ("tcp4 "++show(port,host)) $ withFile "/proc/net/tcp"  ReadMode (parseProcNet port host)
+
+getLocalPeerCred' (SockAddrInet6 portn flow host scope) = do
+    let port = fromEnum portn
+    trace "tcp6" $ withFile "/proc/net/tcp6" ReadMode (parseProcNet port host)
+
+getLocalPeerCred' addr@(SockAddrUnix _) =
+    -- TODO:  parse /proc/net/unix
+    -- see also: Network.Socket.getPeerCred
+    return Nothing
+
+getLocalPeerCred sock = do
+    addr <- getPeerName sock
+    muid <- getLocalPeerCred' addr
+    case muid of
+        Just uid -> return uid
+        Nothing  -> return undefined -- trace "proc failed." $ fmap (CUid . fromIntegral . sndOf3) (getPeerCred sock)
+                     where sndOf3 (pid,uid,gid) = uid
+
+from16 :: Word16 -> Int
+from16 = fromEnum
+
+as16 :: Word16 -> Word16
+as16 = id
+
+parseProcNet port host h = do
+        tcp <- hGetContents h
+        let u = do
+                    ls <- listToMaybe . tail . tails . L.lines $ tcp
+                    let ws = map L.words ls
+                    let rs = ( catMaybes . flip map ws $ \xs -> do
+                          let ys = snd (Prelude.splitAt 1 xs)
+                          localaddr <- listToMaybe ys
+                          let zs = L.splitWith (==':') localaddr
+                          addr <- fmap parseHex $ listToMaybe zs
+                          port <- fmap (fromIntegral . as16 . decode . parseHex) $ listToMaybe $ snd (Prelude.splitAt 1 zs)
+                          let ys' = snd (Prelude.splitAt 5 (tail ys))
+                          uid <- listToMaybe ys'
+                          let peer = (port,decode addr)
+                              user = toEnum (read (unpack uid) ::Int) ::UserID  -- CUid . fromIntegral $ (read (unpack uid)::Int)
+                          return $ trace ("peer:"++show(peer,user)) (peer,user)
+                          )
+                    fmap snd . listToMaybe $ filter ((===(port,host)).fst) rs 
+        trace ("found:"++show u) $ u `seq` return u
+ where
+    a === b = let r= a==b in  trace ("Comparing "++show (a,b)++"-->"++show r) r
+
+{-
+main = do
+    args <- getArgs
+    let addr = fromJust $ do
+         port <- args ?? 0
+         host <- args ?? 1
+         return $ SockAddrInet (toEnum . fromIntegral . readInt $ port) (toEnum (read host::Int))
+        readInt x = read x :: Int
+
+    r <- getLocalPeerCred' addr
+    putStrLn $ "r = " ++ show r
+-}
diff --git a/Presence/Server.hs b/Presence/Server.hs
index feefea2b..adc3de84 100644
--- a/Presence/Server.hs
+++ b/Presence/Server.hs
@@ -4,18 +4,14 @@
 module Server where
 
 import Network.Socket
-import qualified Data.ByteString as S (ByteString)
 import Data.ByteString.Lazy.Char8 as L 
-    ( ByteString
-    , hPutStrLn
-    , fromChunks
+    ( fromChunks
     , putStrLn )
 import Data.ByteString.Char8 
     ( hGetNonBlocking
     )
 import System.IO 
-    ( Handle
-    , IOMode(..)
+    ( IOMode(..)
     , hSetBuffering
     , BufferMode(..)
     , hWaitForInput
@@ -23,8 +19,6 @@ import System.IO
     , hIsEOF
     )
 import Control.Monad
-import Control.Monad.Fix (fix)
-import Todo
 import Control.Concurrent (forkIO)
 import Control.Exception (handle,SomeException(..))
 import Data.HList
@@ -54,8 +48,11 @@ doServer port g startCon = runServer2 port (runConn2 g)
     runConn2 g st (sock,_) = do
         h <- socketToHandle sock ReadWriteMode
         hSetBuffering h NoBuffering
-        st'' <- startCon (h .*. st)
+        st'' <- startCon sock (h .*. st)
         let doException (SomeException e) = Prelude.putStrLn ("\n\nexception: " ++ show e ++ "\n\n")
+        handle doException $ do
+            -- PEER CRED: (0,4294967295,4294967295)
+            -- PEER NAME: 127.0.0.1:37253
         handle doException $ fix $ \loop -> do
             let continue () = hIsEOF h >>= flip when loop . not
             packet <- getPacket h
diff --git a/Presence/UTmp.hs b/Presence/UTmp.hs
index c94dcef2..c2549a88 100644
--- a/Presence/UTmp.hs
+++ b/Presence/UTmp.hs
@@ -6,7 +6,6 @@ import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as C
 import Data.BitSyntax
 import Data.Functor.Identity
-import Foreign.C.String
 import Data.Maybe
 import System.Posix.Signals
 import System.Posix.Types
@@ -17,7 +16,6 @@ import Data.Int
 import Control.Monad.Error.Class
 import System.IO.Error
 
-import Todo
 
 utmp_file = "/var/run/utmp"
 
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 591acad6..05b12b73 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ViewPatterns        #-}
+{-# LANGUAGE TupleSections       #-}
 module XMPPServer ( listenForXmppClients ) where
 
 import Data.HList.TypeEqGeneric1()
@@ -9,27 +10,25 @@ import ByteStringOperators
 
 import Server
 import Data.ByteString.Lazy.Char8 as L 
-    ( ByteString
-    , hPutStrLn
+    ( hPutStrLn
     , unlines
     , pack
-    , unpack
-    , init )
+    , unpack )
 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.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
+import Control.Arrow
+import LocalPeerCred
+import Network.Socket
 
 
 
@@ -51,17 +50,21 @@ greet host = L.unlines
     , "</stream:features>"
     ]
 
-startCon st  = do
+startCon sock st  = do
     let h = hOccursFst st :: Handle 
+    cred <- getLocalPeerCred sock
+    Prelude.putStrLn $ "PEER CRED: "++show cred
+    pname <- getPeerName sock
+    Prelude.putStrLn $ "PEER NAME: "++show pname
     return (ConnectionFinalizer (return ()) .*. st)
 
-iq_query_unavailable host id mjid xmlns = L.unlines $
+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 <++> "'>"
-    , "  <query xmlns='" <++> xmlns <++> "'/>"
+    , "  <" <++> kind <++> " xmlns='" <++> xmlns <++> "'/>"
     , "  <error type='cancel'>"
     , "    <service-unavailable"
     , "        xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>"
@@ -71,6 +74,7 @@ iq_query_unavailable host id mjid xmlns = L.unlines $
 
 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
@@ -132,13 +136,37 @@ iqresponse host (Elem _ attrs content) = do
                 Just (iqresult host id Nothing))
                 
       "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)
+        (tag,as) <- lookup (N "xmlns") (anytagattrs content) 
+        xmlns <- 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'/>"
+
+            _ -> Just (iq_query_unavailable host id Nothing xmlns servicekind)
       _ -> 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) 
+    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 
@@ -152,8 +180,13 @@ doCon st elem cont = do
                 hsend (greet host)
             Element e@(Elem (N "iq") _ _) -> 
                 case iqresponse host e of
-                    Nothing -> trace "no respones" $ return ()
+                    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
 
         putStrLn (show elem)
diff --git a/Presence/main.hs b/Presence/main.hs
index b0f73a9e..7df81903 100644
--- a/Presence/main.hs
+++ b/Presence/main.hs
@@ -1,12 +1,9 @@
 {-# LANGUAGE CPP #-}
 
 import System.Directory
-import System.IO
 import Control.Monad
 import System.Posix.Signals
 import System.Posix.Types
-import Control.Monad.Error.Class
-import Control.Exception (throw)
 import System.Posix.Process
 import Data.Maybe
 
@@ -18,8 +15,7 @@ import FGConsole
 import XMPPServer
 import Data.HList
 import Network.Socket (sClose)
-import Control.Concurrent (threadDelay)
-import Control.Exception (handle,SomeException(..))
+import Control.Exception
 
 jid user host rsrc = user ++ "@" ++ host ++ "/" ++ rsrc
 
@@ -81,22 +77,21 @@ sendUSR1 pid = do
 
 getStartupAction []     = throw (userError "pid file?") >> return (Right "")
 getStartupAction (p:ps) = do
-    catch
+    handle onEr $
         ( do
             pid <- fmap CPid (readFile p >>= readIO)
             -- signal pid
             return (Left pid) )
-        onEr
  where
-    onEr e = do
+    onEr (SomeException _) = do
         pid <- getProcessID
         putStrLn $ "starting pid = "++show pid
-        catch (do 
+        handle (\(SomeException _) -> getStartupAction ps)
+            (do 
                 writeFile p (show pid)
                 putStrLn $ "writing "++show p
                 -- start daemon
                 return (Right p) )
-              (\_ -> getStartupAction ps)
 
 runOnce ps run notify = getStartupAction ps >>= doit
  where