1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
{-# LANGUAGE OverloadedStrings #-}
import System.Posix.Signals
import Control.Concurrent.STM
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Network.Socket
( addrAddress
, getAddrInfo
, defaultHints
, addrFlags
, AddrInfoFlag(AI_CANONNAME)
)
import Data.Monoid ( (<>) )
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Encoding as Text
import Control.Monad
import qualified Network.BSD as BSD
import qualified Data.Text as Text
import Data.Text (Text)
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..))
import System.Posix.User (getUserEntryForID,userName)
import qualified Data.ByteString.Lazy.Char8 as L
import UTmp (ProcessID,users)
import LocalPeerCred
import XMPPServer
import Server
textHostName = fmap Text.pack BSD.getHostName
localJID user resource = do
hostname <- textHostName
return $ user <> "@" <> hostname <> "/" <> resource
data ClientState = ClientState
{ clientResource :: Text
, clientUser :: Text
, clientPid :: Maybe ProcessID
}
data PresenceState = PresenceState
{ clients :: TVar (Map ConnectionKey ClientState)
}
getConsolePids :: PresenceState -> IO [(Text,ProcessID)]
getConsolePids state = do -- return [("tty7", 23)] -- todo
us <- UTmp.users
return $ map (\(_,tty,pid)->(lazyByteStringToText tty,pid)) us
lazyByteStringToText = (foldr1 (<>) . map Text.decodeUtf8 . L.toChunks)
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 state k addr desired = do
muid <- getLocalPeerCred' addr
(mtty,pid) <- getTTYandPID muid
user <- getJabberUserForId muid
let client = ClientState { clientResource = maybe "fallback" id mtty
, clientUser = user
, clientPid = pid }
atomically $
modifyTVar' (clients state) $ Map.insert k client
localJID (clientUser client) (clientResource client)
where
getTTYandPID muid = do
-- us <- fmap (map (second fst) . Map.toList) . readTVarIO $ activeUsers state
ttypids <- getConsolePids state
-- let tailOf3 ((_,a),b) = (a,b)
(t,pid) <- case muid of
Just (uid,inode) -> identifyTTY' ttypids uid inode
Nothing -> return (Nothing,Nothing)
let rsc = t `mplus` fmap ( ("pid."<>) . Text.pack . show ) pid
return (rsc,pid)
getJabberUserForId muid =
maybe (return "nobody")
(\(uid,_) ->
handle (\(SomeException _) ->
return . (<> "uid.") . Text.pack . show $ uid)
$ do
user <- fmap userName $ getUserEntryForID uid
return (Text.pack user)
)
muid
forClient state k fallback f = do
mclient <- atomically $ do
cs <- readTVar (clients state)
return $ Map.lookup k cs
maybe (fallback k) (flip f k) mclient
tellClientHisName state k = forClient state k fallback go
where
fallback k = localJID "nobody" "fallback"
go client k = localJID (clientUser client) (clientResource client)
main = runResourceT $ do
-- us <- liftIO UTmp.users
-- liftIO $ putStrLn (show us)
hostname <- liftIO textHostName
state <- do
clients <- liftIO . atomically $ newTVar Map.empty
return PresenceState
{ clients = clients
}
sv <- xmppServer
XMPPServerParameters
{ xmppChooseResourceName = chooseResourceName state
, xmppTellClientHisName = tellClientHisName state
, xmppTellMyNameToClient = textHostName
, xmppTellMyNameToPeer = \addr -> return $ addrToText addr
, xmppTellPeerHisName = return . peerKeyToText
, xmppNewConnection = \k outchan -> return ()
, xmppEOF = \k -> return ()
, xmppRosterBuddies = \k -> return []
, xmppRosterSubscribers = \k -> return []
, xmppRosterSolicited = \k -> return []
, xmppRosterOthers = \k -> return []
, xmppSubscribeToRoster = \k -> return ()
, xmppLookupPeerName = \k -> return "localhost"
-- , xmppLookupClientJID = \k -> return $ "nobody@" <> hostname <> "/tty666"
, xmppDeliverMessage = \fail msg -> do
let msgs = msgLangMap (stanzaType msg)
body = fmap (maybe "" id . msgBody . snd) $ take 1 msgs
when (not $ null body) $ do
Text.putStrLn $ "MESSAGE " <> head body
return ()
, xmppInformClientPresence = \k stanza -> return ()
}
liftIO $ do
let testaddr0 = "fd97:ca88:fa7c:b94b:c8b8:fad4:1021:a54d"
-- testaddr0 = "fdef:9e0b:b502:52c3:c074:28d3:fcd7:bfb7"
testaddr<- fmap (addrAddress . head) $
getAddrInfo (Just $ defaultHints { addrFlags = [ AI_CANONNAME ]})
(Just testaddr0)
(Just "5269")
putStrLn $ "Connecting to "++show testaddr
addPeer sv testaddr
quitVar <- newEmptyTMVarIO
installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
installHandler sigINT (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
quitMessage <- atomically $ takeTMVar quitVar
putStrLn "goodbye."
return ()
|
