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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
import System.Environment
import System.Posix.Signals
import Control.Concurrent (threadDelay,forkIO,forkOS,killThread,throwTo)
import Control.Concurrent.STM
import Control.Concurrent.STM.TMVar
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Trans
import Control.Monad.IO.Class (MonadIO, liftIO)
import Network.Socket ( SockAddr(..) )
import System.Endian (fromBE32)
import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
import Data.Ord (comparing )
import Data.Monoid ( (<>), Sum(..), getSum )
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Encoding as Text
import Control.Monad
import Control.Monad.Fix
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.IO.Error (isDoesNotExistError)
import System.Posix.User (getUserEntryForID,userName)
import qualified Data.ByteString.Lazy.Char8 as L
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
import XMPPServer
import PeerResolve
import ConsoleWriter
import ClientState
import Presence
main :: IO ()
main = runResourceT $ do
args <- liftIO getArgs
let verbosity = getSum $ flip foldMap args $ \case
('-':xs) -> Sum $ length (filter (=='-') xs)
_ -> mempty
cw <- liftIO newConsoleWriter
state <- liftIO $ newPresenceState cw
sv <- xmppServer (presenceHooks state verbosity)
liftIO $ do
atomically $ putTMVar (server state) sv
quitVar <- newEmptyTMVarIO
installHandler sigTERM (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
installHandler sigINT (CatchOnce (atomically $ putTMVar quitVar True)) Nothing
forkIO $ do
let console = cwPresenceChan $ consoleWriter state
fix $ \loop -> do
what <- atomically
$ orElse (do (client,stanza) <- takeTMVar console
return $ do informClientPresence0 state Nothing client stanza
loop)
(do readTMVar quitVar
return $ return ())
what
quitMessage <- atomically $ takeTMVar quitVar
putStrLn "goodbye."
return ()
|
