{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, TypeFamilies, FlexibleContexts, CPP #-}
module Main where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Default
import Data.IORef
import Data.List as L
import qualified Data.Map as M
import Data.Map.Strict (keys)
import qualified Data.Map.Strict as MS
import Data.Maybe
import Data.String.Class (toText)
import qualified Data.Text as T
import Data.Time
import Data.Word
import Data.XML.Types as DXT
import Network.NineP as NP
import Network.NineP.Error
import Network.NineP.File
import Network.TLS
import Network.Xmpp
import Network.Xmpp.Extras.DateTime
import Network.Xmpp.Extras.IQAvatar
import Network.Xmpp.Extras.MUC
import Network.Xmpp.Extras.VCardAvatar
import Network.Xmpp.Internal hiding (priority, status)
import qualified Network.Xmpp.IM.Presence as IMP
import System.Console.GetOpt
import System.Environment
import System.Log.Logger
import qualified Text.XML as TX
import Config
import Log
import MUC
import Types
#ifdef UI_GTK
import GTK.GTK
import GTK.Chat
import qualified GTK.Roster as GR
#endif
import Debug.Trace
data Options = Options
{ oXMPPLogPrio :: Priority
, o9PLogPrio :: Priority
} deriving (Eq, Show)
defaultOptions = Options
{ oXMPPLogPrio = WARNING
, o9PLogPrio = WARNING
}
options :: [OptDescr (Options -> Options)]
options =
[ Option ['d'] ["debug-9p"] (NoArg (\o -> o { o9PLogPrio = DEBUG })) "Debug 9P messages"
, Option ['v'] ["verbose"] (NoArg (\o -> o { oXMPPLogPrio = DEBUG })) "Be verbose on what's happening on the XMPP wire"
]
getOpts :: IO (Options, [String])
getOpts = do
args <- getArgs
pn <- getProgName
case getOpt Permute options args of
(o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)
(_,_,errs) -> ioError (userError (concat errs ++ usageInfo ("Usage: " ++ pn ++ " [options]") options))
dbg = debugM "HateXMPP"
catchXmpp :: Either XmppFailure Session -> IO Session
catchXmpp = either throw return
chatFileRead :: MessageType -> Jid -> Word64 -> Word32 -> Hate BLC.ByteString
chatFileRead _ jid offset len = getLogLazyS jid (fromIntegral offset) (fromIntegral len)
chatFileWrite :: MessageType -> Jid -> BL.ByteString -> Hate ()
chatFileWrite typ jid text = do
s <- ask
se <- readVar $ sess s
liftIO $ do
result <- sendMsg se typ jid $ toText text
return $ either (throw . OtherError . show) (id) result
chatFile jid = --simpleFile (T.unpack $ jidToText jid)
(rwFile (T.unpack $ jidToText jid) Nothing (Just $ chatFileWrite Chat jid)) { NP.read = chatFileRead Chat jid }
vcAvatarRead jid = do
s <- ask
se <- readVar $ sess s
result <- liftIO $ askvCard jid se
liftIO $ traceIO $ show result
undefined
vcAvatarWrite jid = undefined
vcAvatarFile jid = rwFile "avatar" (Just $ vcAvatarRead jid) (Just $ vcAvatarWrite jid)
vcardDir jid = (boringDir "vcard" []) {
getFiles = do
return [avatarFile jid],
descend = \name -> do
--maybe (throw $ ENoFile name) (return . chatFile) $
--jidFromText $ T.pack name
return $ vcAvatarFile jid
}
avatarRead jid = do
s <- ask
se <- readVar $ sess s
result <- liftIO $ askIQAvatar jid se
liftIO $ traceIO $ show result
undefined
avatarWrite jid = undefined
avatarFile jid = rwFile "avatar" (Just $ avatarRead jid) (Just $ avatarWrite jid)
rosterItem jid = (boringDir (T.unpack $ jidToText jid) []) {
getFiles = do
return [chatFile jid, vcardDir jid, avatarFile jid],
descend = \name -> do
case name of
"avatar" -> return $ avatarFile jid
"vcard" -> return $ vcardDir jid
_ -> maybe (throw $ ENoFile name) (return . chatFile) $
jidFromText $ T.pack name
}
rosterDir :: NineFile Hate
rosterDir = (boringDir "roster" []) {
getFiles = do
s <- ask
se <- readVar $ sess s
roster <- liftIO $ getRoster se
return $ fmap (rosterItem) $ keys $ items roster,
descend = \name -> do
s <- ask
se <- readVar $ sess s
maybe (throw $ ENoFile name) (return . rosterItem) $ do
jid <- jidFromText $ T.pack name
return jid
}
readMUCChat jid = chatFileRead GroupChat jid
writeMUCChat jid = chatFileWrite GroupChat jid
mucChat jid = (rwFile "__chat" Nothing (Just $ writeMUCChat jid)) { NP.read = chatFileRead Chat jid }
muc jid = boringDir (T.unpack $ jidToText jid) [("__chat", mucChat jid)]
mucsmkdir name = do
s <- ask
se <- readVarH (readTVarIO . sess)
nick <- readVarH (readTVarIO . muc_default_nick)
let barejid = fromMaybe (throw EInval) $ jidFromText $ T.pack name
let (localp, domainp, _) = jidToTexts barejid
let jid = fromMaybe (throw EInval) $ jidFromTexts localp domainp (Just $ T.pack nick)
#ifdef UI_GTK
-- TODO error reporting
let send text = sendMsg se GroupChat barejid text >> pure ()
addChat barejid send
add <- liftIO $ readTVarIO $ addMUCToRosterWindow s
liftIO $ add barejid
#endif
historyRequestSeconds <- readVarH (readTVarIO . muc_history_request)
let historyRequest = if historyRequestSeconds < 0 then Nothing else Just $ def { mhrSeconds = Just historyRequestSeconds }
liftIO $ joinMUC jid historyRequest se
addMUC barejid nick
return $ muc barejid
mucsDir :: NineFile Hate
mucsDir = (boringDir "mucs" []) {
getFiles = do
s <- ask
ms <- readVar $ mucs s
return $ fmap (muc) $ keys ms,
descend = \name -> do
s <- ask
ms <- readVar $ mucs s
maybe (throw $ ENoFile name) (return . muc) $ do
jid <- jidFromText $ T.pack name
M.lookup jid ms
return jid,
create = \name perms -> if isDir perms then mucsmkdir name else throw EInval
}
sendMsg se typ jid text = sendMessage ((simpleIM jid text) { messageType = typ }) se
-- TODO error handling
sendMsg_ se typ jid text = sendMsg se typ jid text >> pure ()
sendRaw :: B.ByteString -> Session -> IO (Either XmppFailure ())
sendRaw d s = semWrite (writeSemaphore s) d
processOtherFeatures :: Session -> DXT.Element -> Hate ()
processOtherFeatures _ e = do
s <- ask
forM_ (TX.nameNamespace $ DXT.elementName e) $ \ns -> do
case ns of
"urn:xmpp:sm:3" -> do
-- For client-to-server connections, the client MUST NOT attempt to enable stream management until after it has completed Resource Binding unless it is resuming a previous session (see Resumption).
writeVar (featureStreamManagement3 s) True
_ -> return ()
handleReceivedMessage se from msg nick timestamp = do
s <- ask
let entry = (timestamp, nick, msg)
#ifdef UI_GTK
chatHandlers <- liftIO $ readTVarIO $ chats s
let maybeChatWindow = MS.lookup from $ chatHandlers
let send text = sendMsg se Chat from text >> pure ()
when (isNothing maybeChatWindow) $ addChat from send
chatHandlers <- liftIO $ readTVarIO $ chats s
maybe (pure ()) (\handler -> liftIO $ handler entry) $ MS.lookup from $ chatHandlers
#endif
putLog from msg nick timestamp
receiver :: GlobalState -> Session -> IO ()
receiver s se = flip runHate s $ forever $ do
(stanza, _) <- liftIO $ getStanza se
case stanza of
MessageS (Message id from to lang typ pld attr) -> void $ runMaybeT $ do
f <- MaybeT $ pure from
body <- MaybeT $ pure $ L.find (\DXT.Element { DXT.elementName = TX.Name n ns pre } -> n == "body") pld
let l = DXT.elementNodes body
content <- MaybeT $ pure $ L.find (const True) l
text <- case content of
DXT.NodeContent (ContentText t) -> pure t
_ -> mzero
now <- liftIO $ getCurrentTime
let delayed_ts = do
delaye <- L.find (\DXT.Element { DXT.elementName = TX.Name n ns pre } -> n == "delay") pld
stampa <- L.find (\(DXT.Name n ns pre, _) -> n == "stamp") $ DXT.elementAttributes delaye
content <- L.find (const True) $ snd stampa
t <- case content of
ContentText t -> pure t
_ -> mzero
fromDateTime $ T.unpack t :: Maybe UTCTime
let timestamp = fromMaybe now delayed_ts
let nick = if (typ == GroupChat)
then resourcepart f
else maybe (Just $ domainpart f) Just $ localpart f -- TODO use nickname from roster
let saneFrom = if (typ == GroupChat)
then toBare f
else f
lift $ handleReceivedMessage se saneFrom text nick timestamp
PresenceS p@(Presence id from to lang typ pld attr) -> do
if L.null pld
then liftIO $ dbg $ show ("simple presence", from, typ)
else forM_ pld $ \e -> do
let en = DXT.elementName e
if TX.nameLocalName en == "x" && TX.nameNamespace en == Just "http://jabber.org/protocol/muc#user"
then liftIO $ dbg $ show ("a muc guy has changed presence", from, typ)
else liftIO $ dbg $ show ("unknown presence", from, typ, pld)
_ -> liftIO $ dbg $ show stanza
connectS tsess = do
s <- ask
features <- liftIO $ getFeatures tsess
mapM_ (processOtherFeatures tsess) $ streamFeaturesOther features
-- Enable SM
sme <- readVar $ streamManagement s
when sme $ do
smf <- readVar $ featureStreamManagement3 s
when smf $ do
liftIO $ sendRaw "<enable xmlns='urn:xmpp:sm:3'/>" tsess
return ()
liftIO $ initRoster tsess
liftIO $ forkIO $ updateStatus tsess (status s) (mucs s)
writeVar (sess s) tsess
liftIO $ forkIO $ receiver s tsess
updateStatus :: Session -> TVar String -> TVar MUCs -> IO ()
updateStatus tsess statusVar mucsVar = do
initialStatus <- readTVarIO statusVar
let sendStatus s = do
let sendPresenceTo mjid = sendPresence (withIMPresence (def { IMP.status = Just $ toText s }) def { presenceTo = mjid }) tsess
sendPresenceTo Nothing
-- also send the presence update to all the MUCs we participate in
currentMUCs <- readTVarIO mucsVar
mapM_ (sendPresenceTo . Just) $ keys currentMUCs
void $ sendStatus initialStatus
fix (\again previousStatus -> do
changedStatus <- atomically $ do
newStatus <- readTVar statusVar
check (newStatus /= previousStatus)
pure newStatus
void $ sendStatus changedStatus
again changedStatus) initialStatus
streamManagementPlugin :: IO Plugin
streamManagementPlugin = do
stanzaReceivedCount <- newIORef 0 :: IO (IORef Word32)
return $ (\out -> return $ Plugin'
{ inHandler = \sta as -> do
modifyIORef' stanzaReceivedCount succ
case sta of
XmppNonza e -> do
case TX.nameLocalName $ DXT.elementName e of
"enabled" -> writeIORef stanzaReceivedCount 0
"r" -> do
h <- readIORef stanzaReceivedCount
out $ XmppNonza $ DXT.Element "a" [
("xmlns", [DXT.ContentText "urn:xmpp:sm:3"]),
("h", [DXT.ContentText $ T.pack $ show h])
] []
return ()
_ -> return ()
_ -> return ()
return [(sta, as)]
, outHandler = out
, onSessionUp = const $ return ()
})
rosterHandler :: Roster -> RosterUpdate -> IO ()
rosterHandler roster update = do
print "got roster"
print roster
print update
rootmkdir "roster" = do
s <- ask
serv <- readSVar $ server s
user <- readSVar $ username s
pass <- readSVar $ password s
res <- readSVar $ resource s
unsafeCerts <- readVar $ permitUnsafeCerts s
sMP <- liftIO $ streamManagementPlugin
tsess <- liftIO (catchXmpp =<< session serv
(Just (\_ -> ([scramSha1 user Nothing pass]), if res == "" then Nothing else Just res))
(def {
sessionStreamConfiguration = def {
tlsBehaviour = RequireTls,
tlsParams = if unsafeCerts
then xmppDefaultParams { clientHooks = def { onServerCertificate = \_ _ _ _ -> pure [] } }
else xmppDefaultParams
},
plugins = [sMP],
onRosterPush = Just rosterHandler,
onConnectionClosed = \sess why -> do
noticeM "HateXMPP" $ "Disconnected (" ++ show why ++ "). Reconnecting..."
_ <- reconnect' sess
flip runHate s $ do
connectS sess
rejoinMUCs
return ()
}))
#ifdef UI_GTK
GR.spawnRosterWindow $ sendMsg_ tsess
#endif
connectS tsess
#ifdef UI_GTK
-- submit the initial roster data to GUI
add <- liftIO $ readTVarIO $ addUserToRosterWindow s
roster <- liftIO $ getRoster tsess
liftIO $ mapM_ add $ M.keys $ items roster
#endif
return rosterDir
rootmkdir "test" = do
s <- ask
se <- readVar $ sess s
liftIO $ Prelude.print =<< getRoster se
liftIO $ Prelude.print "loh"
throw $ ENotImplemented "test"
rootmkdir _ = throw $ EInval
initMain = do
(opts, _) <- getOpts
updateGlobalLogger "Pontarius.Xmpp" $ setLevel $ oXMPPLogPrio opts
updateGlobalLogger "Network.NineP" $ setLevel $ o9PLogPrio opts
updateGlobalLogger "HateXMPP" $ setLevel $ oXMPPLogPrio opts
a <- getEnv "HATEXMPP_ADDRESS"
state <- initState
#ifdef UI_GTK
initGTK
#endif
(rootdir, rootref) <- simpleDirectory "/" (throw $ EInval) rootmkdir
writeIORef rootref [("config", configDir), ("mucs", mucsDir)]
let ncfg = Config {
root = rootdir,
addr = a,
monadState = state
}
return (state, run9PServer ncfg)
ghciMain = do
(state, runServer) <- initMain
forkIO $ runServer
return state
main = do
(_, runServer) <- initMain
runServer