From 6a4aebd4be2525de7b58dda5cd6f34582d363785 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 4 Nov 2017 08:35:49 -0400 Subject: Type signatures for main program module. --- xmppServer.hs | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 88 insertions(+), 3 deletions(-) (limited to 'xmppServer.hs') 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 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 -- cgit v1.2.3