1 files changed, 88 insertions, 3 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 118a16b2..803b4324 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -32,7 +32,11 @@ import qualified ConfigFiles
 import Data.Maybe (maybeToList,listToMaybe,mapMaybe)
 import Data.Bits
 import Data.Int (Int8)
+import Data.XML.Types (Event)
+import System.Posix.Types (UserID,CPid)
+import Control.Applicative
 
+import LockedChan (LockedChan)
 import TraversableT
 import UTmp (ProcessID,users)
 import LocalPeerCred
@@ -71,8 +75,10 @@ isPeerKey k = case k of { PeerKey {} -> True ; _ -> False }
 isClientKey :: ConnectionKey -> Bool
 isClientKey k = case k of { ClientKey {} -> True ; _ -> False }
 
+textHostName :: IO Text
 textHostName = fmap Text.pack BSD.getHostName
 
+localJID :: Text -> Text -> IO Text
 localJID user resource = do
     hostname <- textHostName
     return $ user <> "@" <> hostname <> "/" <> resource
@@ -92,19 +98,25 @@ data RemotePresence = RemotePresence
 
 
 
+pcSingletonNetworkClient :: ConnectionKey
+                          -> ClientState -> LocalPresence
 pcSingletonNetworkClient key client =
     LocalPresence
     { networkClients = Map.singleton key client
     } 
 
+pcInsertNetworkClient :: ConnectionKey -> ClientState -> LocalPresence -> LocalPresence
 pcInsertNetworkClient key client pc =
     pc { networkClients = Map.insert key client (networkClients pc) }
 
+pcRemoveNewtworkClient :: ConnectionKey
+                        -> LocalPresence -> Maybe LocalPresence
 pcRemoveNewtworkClient key pc = if pcIsEmpty pc' then Nothing
                                                  else Just pc'
  where
     pc' = pc { networkClients = Map.delete key (networkClients pc) }
 
+pcIsEmpty :: LocalPresence -> Bool
 pcIsEmpty pc = Map.null (networkClients pc)
 
 
@@ -127,14 +139,23 @@ getConsolePids state = do
     us <- UTmp.users
     return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
 
+lazyByteStringToText :: L.ByteString -> Text
 lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks)
+
+textToLazyByteString :: Text -> L.ByteString
 textToLazyByteString s = L.fromChunks [Text.encodeUtf8 s]
 
+identifyTTY' :: [(Text, ProcessID)]
+              -> System.Posix.Types.UserID
+              -> L.ByteString
+              -> IO (Maybe Text, Maybe System.Posix.Types.CPid)
 identifyTTY' ttypids uid inode = ttypid
  where ttypids' = map (\(tty,pid)->(L.fromChunks [Text.encodeUtf8 tty], pid)) ttypids
        ttypid = fmap textify $ identifyTTY ttypids' uid inode
        textify (tty,pid) = (fmap lazyByteStringToText tty, pid)
 
+chooseResourceName :: PresenceState
+                    -> ConnectionKey -> SockAddr -> t -> IO Text
 chooseResourceName state k addr desired = do
     muid <- getLocalPeerCred' addr
     (mtty,pid) <- getTTYandPID muid
@@ -184,17 +205,21 @@ chooseResourceName state k addr desired = do
                         )
                    muid
 
+forClient :: PresenceState
+           -> ConnectionKey -> IO b -> (ClientState -> IO b) -> IO b
 forClient state k fallback f = do
     mclient <- atomically $ do
         cs <- readTVar (clients state)
         return $ Map.lookup k cs
     maybe fallback f mclient
 
+tellClientHisName :: PresenceState -> ConnectionKey -> IO Text
 tellClientHisName state k = forClient state k fallback go
  where
     fallback  = localJID "nobody" "fallback"
     go client = localJID (clientUser client) (clientResource client)
 
+toMapUnit :: Ord k => [k] -> Map k ()
 toMapUnit xs = Map.fromList $ map (,()) xs
 
 resolveAllPeers :: [Text] -> IO (Map SockAddr ())
@@ -237,6 +262,8 @@ rosterGetSubscribers = rosterGetStuff ConfigFiles.getSubscribers
 data Conn = Conn { connChan :: TChan Stanza
                  , auxAddr :: SockAddr }
 
+configText :: Functor f =>
+            (L.ByteString -> f [L.ByteString]) -> Text -> f [Text]
 configText what u = fmap (map lazyByteStringToText)
                         $ what (textToLazyByteString u)
 
@@ -245,6 +272,8 @@ getBuddies' = configText ConfigFiles.getBuddies
 getSolicited' :: Text -> IO [Text]
 getSolicited' = configText ConfigFiles.getSolicited
 
+sendProbesAndSolicitations :: PresenceState
+                            -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
 sendProbesAndSolicitations state k laddr chan = do
     -- get all buddies & solicited matching k for all users
     xs <- runTraversableT $ do
@@ -279,6 +308,7 @@ sendProbesAndSolicitations state k laddr chan = do
         atomically $ writeTChan chan stanza
     -- reverse xs `seq` return ()
 
+newConn :: PresenceState -> ConnectionKey -> SockAddr -> TChan Stanza -> IO ()
 newConn state k addr outchan = do
     atomically $ modifyTVar' (keyToChan state)
         $ Map.insert k Conn { connChan = outchan
@@ -286,12 +316,15 @@ newConn state k addr outchan = do
     when (isPeerKey k)
         $ sendProbesAndSolicitations state k addr outchan
 
+delclient :: (Alternative m, Monad m) =>
+           ConnectionKey -> m LocalPresence -> m LocalPresence
 delclient k mlp = do
     lp <- mlp
     let nc = Map.delete k $ networkClients lp
     guard $ not (Map.null nc)
     return $ lp { networkClients = nc }
 
+eofConn :: PresenceState -> ConnectionKey -> IO ()
 eofConn state k = do
     atomically $ modifyTVar' (keyToChan state) $ Map.delete k
     case k of
@@ -325,9 +358,6 @@ rewriteJIDForClient1 jid = do
         return $ Just ((n,h',r), addr)
 -}
 
-todo = error "Unimplemented"
-
-
 -- | for example:  2001-db8-85a3-8d3-1319-8a2e-370-7348.ipv6-literal.net
 ip6literal :: Text -> Text
 ip6literal addr = Text.map dash addr <> ".ipv6-literal.net"
@@ -351,6 +381,7 @@ rewriteJIDForClient laddr jid buds = do
                   else peerKeyToResolvedName buds (PeerKey addr)
     return (mine,(n,h',r))
 
+sameAddress :: SockAddr -> SockAddr -> Bool
 sameAddress laddr addr = laddr `withPort` 0  == addr `withPort` 0
 
 peerKeyToResolvedName :: [Text] -> ConnectionKey -> IO Text
@@ -373,10 +404,12 @@ multiplyJIDForClient laddr jid = do
     return (mine,map (\h' -> (n,h',r)) names)
 
 
+addrTextToKey :: Text -> IO (Maybe ConnectionKey)
 addrTextToKey h = do
     maddr <- parseAddress (strip_brackets h)
     return (fmap PeerKey maddr)
 
+guardPortStrippedAddress :: Text -> SockAddr -> IO (Maybe ())
 guardPortStrippedAddress h laddr = do
     maddr <- fmap (fmap (`withPort` 0)) $ parseAddress (strip_brackets h)
     let laddr' = laddr `withPort` 0
@@ -398,6 +431,7 @@ rewriteJIDForPeer jid = do
             to' = unsplitJID (n,h',r)
         in (to',addr)
 
+deliverToConsole :: PresenceState -> IO () -> Stanza -> IO ()
 deliverToConsole state fail msg = do
     putStrLn $ "TODO: deliver to console"
     did1 <- writeActiveTTY (consoleWriter state) msg
@@ -405,6 +439,10 @@ deliverToConsole state fail msg = do
     if not (did1 || did2) then fail else return ()
 
 -- | deliver <message/> or error stanza
+deliverMessage :: PresenceState
+                -> IO ()
+                -> StanzaWrap (LockedChan Event)
+                -> IO ()
 deliverMessage state fail msg = 
     case stanzaOrigin msg of
       NetworkOrigin senderk@(ClientKey {}) _ -> do
@@ -465,25 +503,30 @@ deliverMessage state fail msg =
                                   chan
 
 
+setClientFlag :: PresenceState -> ConnectionKey -> Int8 -> IO ()
 setClientFlag state k flag = 
     atomically $ do
         cmap <- readTVar (clients state)
         flip (maybe $ return ()) (Map.lookup k cmap) $ \client -> do
         setClientFlag0 client flag
 
+setClientFlag0 :: ClientState -> Int8 -> STM ()
 setClientFlag0 client flag = 
     modifyTVar' (clientFlags client) (\flgs -> flgs .|. flag)
 
+informSentRoster :: PresenceState -> ConnectionKey -> IO ()
 informSentRoster state k = do
     setClientFlag state k cf_interested
 
 
+subscribedPeers :: Text -> IO [SockAddr]
 subscribedPeers user = do
     jids <- configText ConfigFiles.getSubscribers user
     let hosts = map ((\(_,h,_)->h) . splitJID) jids
     fmap Map.keys $ resolveAllPeers hosts 
 
 -- | this JID is suitable for peers, not clients.
+clientJID :: Conn -> ClientState -> Text
 clientJID con client = unsplitJID ( Just $ clientUser client
                                   , addrToText $ auxAddr con
                                   , Just $ clientResource client)
@@ -491,10 +534,17 @@ clientJID con client = unsplitJID ( Just $ clientUser client
 -- | Send presence notification to subscribed peers.
 -- Note that a full JID from address will be added to the
 -- stanza if it is not present.
+informClientPresence :: PresenceState
+                        -> ConnectionKey -> StanzaWrap (LockedChan Event) -> IO ()
 informClientPresence state k stanza = do
     forClient state k (return ()) $ \client -> do
     informClientPresence0 state (Just k) client stanza
 
+informClientPresence0 :: PresenceState
+                       -> Maybe ConnectionKey
+                       -> ClientState
+                       -> StanzaWrap (LockedChan Event)
+                       -> IO ()
 informClientPresence0 state mbk client stanza = do
     dup <- cloneStanza stanza
     atomically $ writeTVar (clientStatus client) $ Just dup
@@ -516,6 +566,10 @@ informClientPresence0 state mbk client stanza = do
                                  , stanzaTo = mto }
                              (connChan con)
 
+informPeerPresence :: PresenceState
+                    -> ConnectionKey
+                    -> StanzaWrap (LockedChan Event)
+                    -> IO ()
 informPeerPresence state k stanza = do
     -- Presence must indicate full JID with resource...
     putStrLn $ "xmppInformPeerPresence checking from address..." 
@@ -579,6 +633,8 @@ informPeerPresence state k stanza = do
         sendModifiedStanzaToClient (dup { stanzaFrom=Just from' })
                                    (connChan con)
 
+answerProbe :: PresenceState
+             -> Maybe Text -> ConnectionKey -> TChan Stanza -> IO ()
 answerProbe state mto k chan = do
     -- putStrLn $ "answerProbe! " ++ show (stanzaType stanza)
     ktc <- atomically $ readTVar (keyToChan state)
@@ -634,6 +690,7 @@ answerProbe state mto k chan = do
         pstanza <- makePresenceStanza "jabber:server" (Just jid) Offline
         atomically $ writeTChan (connChan conn) pstanza
 
+sendCachedPresence :: PresenceState -> ConnectionKey -> IO ()
 sendCachedPresence state k = do
     forClient state k (return ()) $ \client -> do
     rbp <- atomically $ readTVar (remotesByPeer state)
@@ -671,12 +728,27 @@ sendCachedPresence state k = do
     -- send local buddies.
     return ()
 
+addToRosterFile :: (MonadPlus t, Traversable t) =>
+                 (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                  -> Maybe L.ByteString
+                  -> t1)
+                 -> Text -> Text -> [SockAddr] -> t1
 addToRosterFile doit whose to addrs =
     modifyRosterFile doit whose to addrs True
 
+removeFromRosterFile :: (MonadPlus t, Traversable t) =>
+                      (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                       -> Maybe L.ByteString
+                       -> t1)
+                      -> Text -> Text -> [SockAddr] -> t1
 removeFromRosterFile doit whose to addrs =
     modifyRosterFile doit whose to addrs False
 
+modifyRosterFile :: (Traversable t, MonadPlus t) =>
+                  (L.ByteString -> (L.ByteString -> IO (t L.ByteString))
+                   -> Maybe L.ByteString
+                   -> t1)
+                  -> Text -> Text -> [SockAddr] -> Bool -> t1
 modifyRosterFile doit whose to addrs bAdd = do
     let (mu,_,_) = splitJID to
         cmp jid = runTraversableT $ do
@@ -769,6 +841,8 @@ resolvedFromRoster doit u = do
             addr <- liftMT $ fmap nub $ resolvePeer h
             return (mu,PeerKey addr)
 
+clientCons :: PresenceState
+            -> Map ConnectionKey t -> Text -> IO [(t, ClientState)]
 clientCons state ktc u = do
     mlp <- atomically $ do
             cmap <- readTVar $ clientsByUser state
@@ -848,6 +922,11 @@ peerSubscriptionRequest state fail k stanza chan = do
                                chan
 
 
+clientInformSubscription :: PresenceState
+                          -> IO ()
+                          -> ConnectionKey
+                          -> StanzaWrap (LockedChan Event)
+                          -> IO ()
 clientInformSubscription state fail k stanza = do
     forClient state k fail $ \client -> do
     flip (maybe fail) (stanzaTo stanza) $ \to -> do
@@ -907,6 +986,11 @@ clientInformSubscription state fail k stanza = do
                                  (connChan con)
         answerProbe state (Just from) pk (connChan con)
     
+peerInformSubscription :: PresenceState
+                        -> IO ()
+                        -> ConnectionKey
+                        -> StanzaWrap (LockedChan Event)
+                        -> IO ()
 peerInformSubscription state fail k stanza = do
     putStrLn $ "TODO: peerInformSubscription"
     -- remove from solicited
@@ -957,6 +1041,7 @@ peerInformSubscription state fail k stanza = do
                                    , stanzaTo = Just to' }
                                chan
 
+main :: IO ()
 main = runResourceT $ do
     args <- liftIO getArgs
     let verbosity = getSum $ flip foldMap args $ \case