hatexmpp3 (empty) → 0
raw patch · 14 files changed
+1128/−0 lines, 14 filesdep +Network-NinePdep +basedep +bytestringsetup-changed
Dependencies added: Network-NineP, base, bytestring, containers, data-default, datetime, gtk3, hslogger, monad-loops, mtl, pontarius-xmpp, pontarius-xmpp-extras, stm, string-class, text, time, tls, transformers, vector, xml-conduit, xml-types
Files
- Config.hs +120/−0
- GTK/Chat.hs +104/−0
- GTK/GTK.hs +11/−0
- GTK/Roster.hs +75/−0
- HateXMPP.hs +403/−0
- LICENSE +14/−0
- Log.hs +127/−0
- MUC.hs +37/−0
- Network/Xmpp/Extras/IQAvatar.hs +15/−0
- Network/Xmpp/Extras/VCardAvatar.hs +16/−0
- Setup.lhs +3/−0
- TByteVector.hs +68/−0
- Types.hs +69/−0
- hatexmpp3.cabal +66/−0
+ Config.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, TypeFamilies, FlexibleContexts, NoMonomorphismRestriction, CPP #-}++module Config where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Reader+import Data.ByteString as B+import Data.ByteString.Lazy.Char8 as BLC+import Data.Map.Strict as MS+import Data.String.Class as S+import Data.Text as Text+import Data.Text.Encoding as E+import Network.NineP+import Network.NineP.File++import Types++class Configable a where+ readcfg :: BLC.ByteString -> a+ showcfg :: a -> BLC.ByteString++instance Configable String where+ readcfg = BLC.unpack+ showcfg = BLC.pack+instance Configable Text where+ readcfg = E.decodeUtf8 . B.concat . toChunks+ showcfg = fromChunks . (:[]) . E.encodeUtf8+instance Configable Bool where+ readcfg = Prelude.read . BLC.unpack -- TODO+ showcfg = BLC.pack . show+instance Configable Integer where+ readcfg = Prelude.read . BLC.unpack+ showcfg = BLC.pack . show++configTVarReadWith c acc = Just (liftM c . liftIO . readTVarIO . acc =<< ask)+configTVarWriteWith c acc x = liftIO . atomically . flip writeTVar (c x) . acc =<< ask+configTVarReadC = configTVarReadWith showcfg+configTVarWriteC = configTVarWriteWith readcfg++rwf n a b = (n, rwFile n a b)+rwfc n a = rwf n (configTVarReadC a) (Just (configTVarWriteC a))++configDir :: NineFile Hate+configDir = boringDir "config" [+ rwfc "server" server,+ rwfc "username" username,+ rwfc "password" password,+ rwfc "resource" resource,+ rwfc "muc_default_nick" muc_default_nick,+ rwfc "muc_history_request" muc_history_request,+ rwfc "status" status,+ rwfc "stream_management" streamManagement,+ rwfc "permit_all_certs" permitUnsafeCerts+ ]++trimLn :: (Stringy s, Eq (StringCellChar s)) => s -> s+trimLn s = maybe "" (\c -> if c == (S.fromChar '\n') then S.init s else s) $ S.safeLast s+readVar :: TVar a -> Hate a+readVar = liftIO . readTVarIO+readVarH :: (GlobalState -> IO a) -> Hate a+readVarH acc = do+ s <- ask+ liftIO $ acc s+readSVar :: (Stringy a, Eq (StringCellChar a)) => TVar a -> Hate a+readSVar = liftM trimLn . readVar+writeVar v = liftIO . atomically . writeTVar v++initState = do+ st <- newTVarIO ""+ ut <- newTVarIO ""+ pt <- newTVarIO ""+ priot <- newTVarIO ""+ portt <- newTVarIO ""+ rt <- newTVarIO ""+ jnt <- newTVarIO "hatexmpp3"+ jot <- newTVarIO ""+ jvt <- newTVarIO ""+ mdnt <- newTVarIO "hatexmpp3"+ showt <- newTVarIO SNone+ statust <- newTVarIO ""+ streamManagementt <- newTVarIO False+ permitUnsafeCertst <- newTVarIO False+ mhrst <- newTVarIO (-1)+ sesst <- newTVarIO undefined+ featureStreamManagement3t <- newTVarIO False+ logst <- newTVarIO MS.empty+ mucst <- newTVarIO MS.empty+ chatst <- newTVarIO MS.empty+#ifdef UI_GTK+ amt <- newTVarIO undefined+ aut <- newTVarIO undefined+#endif++ return $ GlobalState+ { server = st+ , username = ut+ , password = pt+ , priority = priot+ , port = portt+ , resource = rt+ , jiv_name = jnt+ , jiv_os = jot+ , jiv_version = jvt+ , muc_default_nick = mdnt+ , showst = showt+ , status = statust+ , streamManagement = streamManagementt+ , permitUnsafeCerts = permitUnsafeCertst+ , muc_history_request = mhrst+ , sess = sesst+ , featureStreamManagement3 = featureStreamManagement3t+ , logs = logst+ , mucs = mucst+ , chats = chatst+#ifdef UI_GTK+ , addMUCToRosterWindow = amt+ , addUserToRosterWindow = aut+#endif+ }
+ GTK/Chat.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+module GTK.Chat+ ( addChat+ ) where++import Control.Concurrent.STM+import Control.Monad.Loops+import Control.Monad.Reader+import Data.DateTime+import qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.String.Class as S+import Data.Text as T+import Data.Time+import Graphics.UI.Gtk+import Network.Xmpp++import Types++renderMessage :: (UTCTime, Maybe Nickname, Msg) -> Text+renderMessage (t, mn, m) = T.concat+ [ "\n"+ , S.fromString $ formatDateTime "[%T]" t+ , "<"+ , fromMaybe "" mn+ , ">"+ , m+ ]++delChat :: TVar (M.Map Jid ChatHandler) -> Jid -> IO ()+delChat chatv jid = do+ atomically $ modifyTVar' chatv $ M.delete jid++addChat :: Jid -> (Msg -> IO ()) -> Hate ()+addChat jid message_cb = do+ s <- ask+ handler <- liftIO $ postGUISync $ do+ w <- windowNew+ set w [windowTitle := jidToText jid]+ windowSetDefaultSize w 500 500+ on w deleteEvent $ liftIO $ do+ delChat (chats s) jid+ pure False++ logb <- textBufferNew Nothing+ logv <- textViewNewWithBuffer logb+ textViewSetWrapMode logv WrapWordChar+ textViewSetEditable logv False+ textViewSetCursorVisible logv False++ inputb <- textBufferNew Nothing+ inputv <- textViewNewWithBuffer inputb+ textViewSetAcceptsTab inputv True+ inputv `on` keyPressEvent $ inputKeyPressed inputb message_cb++ logScroll <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetPolicy logScroll PolicyNever PolicyAutomatic+ containerAdd logScroll logv++ panels <- vPanedNew+ panedPack1 panels logScroll True False+ panedPack2 panels inputv True False++ set w [ containerChild := panels ]+ widgetShowAll w+ Rectangle _ _ _ height <- widgetGetAllocation panels+ panedSetPosition panels (round (0.9 * fromIntegral height))++ -- wait for the widgets to pop up to catch the upcoming messages+ whileM_ (fmap (> 0) eventsPending) $ mainIterationDo False+ + pure (\entry -> postGUISync $ do+ bufferAdd logb $ renderMessage entry+ -- wait for the buffer to draw // https://stackoverflow.com/a/40917718/4095104+ whileM_ (fmap (> 0) eventsPending) $ mainIterationDo False+ -- scroll the log to the newly received message+ ei <- textBufferGetEndIter logb+ textViewScrollToIter logv ei 0 $ Just (1, 1)+ pure ()+ )+ liftIO $ atomically $ modifyTVar (chats s) $ M.insert jid handler++bufferGet :: TextBuffer -> IO Text+bufferGet tb = do+ si <- textBufferGetStartIter tb+ ei <- textBufferGetEndIter tb+ textBufferGetText tb si ei True++bufferAdd :: TextBuffer -> Text -> IO ()+bufferAdd tb s = do+ ei <- textBufferGetEndIter tb+ textBufferInsert tb ei s++-- Keypress event handler+inputKeyPressed inputb message_cb = do+ key <- eventKeyName+ mods <- eventModifier+ liftIO $ if (key == "Return") && (notElem Shift mods)+ then do+ t <- bufferGet inputb+ message_cb t+ textBufferSetText inputb ("" :: Text)+ return True+ else return False
+ GTK/GTK.hs view
@@ -0,0 +1,11 @@+module GTK.GTK where++import Control.Concurrent+import Graphics.UI.Gtk++initGTK :: IO ()+initGTK = do+ forkIO $ do+ unsafeInitGUIForThreadedRTS+ mainGUI+ return ()
+ GTK/Roster.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+module GTK.Roster+ ( spawnRosterWindow+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Reader+import Data.Text (Text)+import qualified Data.Text as T+import Data.Tree+import Graphics.UI.Gtk hiding (eventKeyName, eventModifier)+import qualified Graphics.UI.Gtk.ModelView as MView+import Network.Xmpp as X++import Types+import GTK.Chat++treeMUCIndex = 0+treeUserIndex = 1++data RosterTreeNode = MUCs | Users | JID X.MessageType Jid deriving (Eq, Show)++defaultTree :: Forest RosterTreeNode+defaultTree = [Node MUCs [], Node Users []]++renderNode :: RosterTreeNode -> Text+renderNode MUCs = "MUCs"+renderNode Users = "Users"+renderNode (JID _ jid) = jidToText jid++spawnRosterWindow :: (X.MessageType -> Jid -> Text -> IO ()) -> Hate ()+spawnRosterWindow sendMessage = do+ s <- ask+ addToRoster <- liftIO $ postGUISync $ do+ w <- windowNew+ set w [windowTitle := ("hatexmpp roster" :: Text)]+ windowSetDefaultSize w 300 800++ view <- MView.treeViewNew+ treeViewSetHeadersVisible view False+ store <- MView.treeStoreNew defaultTree+ MView.treeViewSetModel view $ Just store++ column <- MView.treeViewColumnNew+ MView.treeViewAppendColumn view column+ MView.treeViewColumnSetTitle column T.empty+ cell <- cellRendererTextNew+ MView.treeViewColumnPackStart column cell True+ cellLayoutSetAttributes column cell store (\record -> [MView.cellText := renderNode record])++ on view rowActivated $ \path _ -> do+ val <- treeStoreGetValue store path+ case val of+ JID typ jid -> do+ forkIO $ flip runHate s $ addChat jid (sendMessage typ jid)+ pure ()+ _ -> pure ()++ scroll <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic+ containerAdd scroll view++ containerAdd w scroll+ widgetShowAll w+ pure (\index typ jid -> postGUISync $ do+ let path = [index]+ pathIter <- treeModelGetIter store path+ unusedIndex <- treeModelIterNChildren store pathIter+ treeStoreInsert store path unusedIndex $ JID typ jid)+ let addMUCToRoster = addToRoster treeMUCIndex GroupChat+ let addUserToRoster = addToRoster treeUserIndex Chat+ liftIO $ atomically $ do+ writeTVar (addMUCToRosterWindow s) addMUCToRoster+ writeTVar (addUserToRosterWindow s) addUserToRoster
+ HateXMPP.hs view
@@ -0,0 +1,403 @@+{-# 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
+ LICENSE view
@@ -0,0 +1,14 @@+ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+ Version 2, December 2004++ Copyright (C) 2004 Sam Hocevar+ 22 rue de Plaisance, 75014 Paris, France+ Everyone is permitted to copy and distribute verbatim or modified+ copies of this license document, and changing it is allowed as long+ as the name is changed.++ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. You just DO WHAT THE FUCK YOU WANT TO.+
+ Log.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}++module Log+ ( getLogLazyS+ , initLog+ , putLog+ ) where++import Control.Concurrent.STM+import Control.Monad.Reader+import Data.ByteString as B+import Data.ByteString.Lazy as BL+import Data.Map.Strict as MS+import Data.Maybe+import Data.List as L+import Data.Sequence as Seq+import Data.String.Class as S+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+import Network.Xmpp.Internal hiding (priority, status)++import TByteVector as TBV+import Types++lookupLog :: Jid -> Hate (Maybe Log)+lookupLog jid = do+ s <- ask+ l <- liftIO $ readTVarIO $ logs s+ return $ MS.lookup jid l++-- tabs are banned in JIDs as control characters, so they can be used as JID separators:+-- https://tools.ietf.org/html/rfc6122#appendix-A.5+-- https://tools.ietf.org/html/rfc3454#appendix-C.2.1+-- NUL is banned in XML, so it can be used as a message separator+showLog :: [LogEntry] -> Text+showLog = T.unlines . L.map (\(t, mn, m) -> T.concat+ [S.toText (show t)+ , "\t"+ , fromMaybe "" mn+ , "\t"+ , m+ , "\0"])++fillLogS :: Log -> IO ()+fillLogS (Log tentries tunshown shown) = do+ (newLogEntry, unshown) <- atomically $ do+ entries <- readTVar tentries+ unshown <- readTVar tunshown+ maybe retry (\ent -> return (ent, unshown)) $ Seq.lookup unshown entries+ TBV.append shown $ showLog [newLogEntry]+ atomically $ writeTVar tunshown (unshown + 1)++readLogLazyS :: Log -> Word -> Word -> IO BL.ByteString+readLogLazyS log offset len = do+ cached <- atomically $ TBV.read (shownLog log) offset len+ if B.null cached+ then do+ fillLogS log+ readLogLazyS log offset len+ else return $ BL.fromStrict cached++-- |Read the specific portion of the log, waiting for yet unavailable data+getLogLazyS :: Jid -> Word -> Word -> Hate BL.ByteString+getLogLazyS jid offset len = do+ log <- lookupLog jid+ liftIO $ maybe (return BL.empty) (\l -> readLogLazyS l offset len) log++newLog :: IO Log+newLog = do+ le <- newTVarIO Seq.empty+ idx <- newTVarIO 0+ sl <- newTByteVector+ return $ Log le idx sl++-- |Create a jid-attached log if it doesn't exist yet+initLog :: Jid -> Hate ()+initLog j = do+ s <- ask+ newlog <- liftIO newLog+ liftIO $ atomically $ do+ ls <- readTVar $ logs s+ when (isNothing $ MS.lookup j ls) $ do+ writeTVar (logEntries newlog) $ Seq.empty+ writeTVar (logs s) $ MS.insert j newlog ls+++putLog :: Jid -> Msg -> Maybe Nickname -> UTCTime -> Hate ()+putLog j m mn t = do+ s <- ask+ --liftIO $ print (j, m, t)+ --liftIO $ TIO.putStr $ putTkabberLog $ TkabberLog t j "" m 0+ initLog j+ liftIO $ atomically $ do+ ls <- readTVar $ logs s+ case MS.lookup j ls of+ -- logs are never destroyed so fromJust always succeeds+ Just (Log entries _ _) -> do+ modifyTVar entries $ \seq -> seq |> (t, mn, m)++data TkabberLog = TkabberLog {+ timestamp :: UTCTime,+ jid :: Jid,+ nick :: Text,+ body :: Msg,+ me :: Int+ }++--getTkabberLog :: Text -> TkabberLog++--putTkabberLog :: TkabberLog -> Text+--putTkabberLog (TkabberLog ts jid nick body me) = T.concat [+-- "timestamp ",+-- T.pack $ formatTime defaultTimeLocale "%Y%m%dT%H%M%S" ts,+-- " jid ",+-- escape $ jidToText jid,+-- " nick ",+-- escape nick,+-- " body ",+-- escape body,+-- " me ",+-- T.pack $ show me,+-- "\n"]+-- where+-- --escape t = if T.length t == 0 then "{}" else esc ' ' "\\\\ " $ esc '}' "\\}" $ esc '\n' "\\n" $ esc '\\' "\\\\" t+-- escape t = if T.length t == 0 then "{}" else L.foldl (\it c -> esc c (T.pack $ '\\':'\\':c:[]) it) (esc '\n' "\\\\n" $ esc '\\' "\\\\\\\\" t) ("{}\" $[]" :: String)+-- esc c e t = T.concat $ L.intersperse e $ T.split (== c) t
+ MUC.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module MUC where++import Control.Concurrent.STM+import Control.Exception+import Control.Monad.Reader+import Data.Default+import qualified Data.Map.Strict as MS+import Data.Maybe+import qualified Data.Text as T+import Network.Xmpp.Extras.MUC+import Network.Xmpp.Internal hiding (priority, status)++import Config+import Log+import Types++addMUC :: Jid -> String -> Hate ()+addMUC jid nick = do+ initLog jid+ s <- ask+ liftIO $ atomically $ do+ ms <- readTVar $ mucs s+ writeTVar (mucs s) $ MS.insert jid (MUC nick) ms++rejoinMUCs :: Hate ()+rejoinMUCs = do+ ms <- readVarH (readTVarIO . mucs)+ se <- readVarH (readTVarIO . sess)+ liftIO $ sequence_ $ map (\(barejid, (MUC nick)) -> do+ let (localp, domainp, _) = jidToTexts barejid+ let jid = (\x -> assert (isJust x) (fromJust x)) $ jidFromTexts localp domainp (Just $ T.pack nick)+ joinMUC jid (Just $ def { mhrSeconds = Just 200 }) se+ return ()+ ) $ MS.toList ms+ -- TODO clear idea about how much of the history to request
+ Network/Xmpp/Extras/IQAvatar.hs view
@@ -0,0 +1,15 @@+-- |+-- Stability : Ultra-Violence+-- Portability : I'm too young to die+-- XEP-0008: IQ-Based Avatars++{-# LANGUAGE OverloadedStrings #-}++module Network.Xmpp.Extras.IQAvatar+ ( askIQAvatar+ ) where++import Data.XML.Types as DXT+import Network.Xmpp.Internal hiding (priority, status)++askIQAvatar jid = sendIQ' Nothing (Just jid) Get Nothing (DXT.Element "query" [("xmlns", [DXT.ContentText "jabber:iq:avatar"])] []) []
+ Network/Xmpp/Extras/VCardAvatar.hs view
@@ -0,0 +1,16 @@+-- |+-- Stability : Ultra-Violence+-- Portability : I'm too young to die+-- XEP-0153: vCard-Based Avatars++{-# LANGUAGE OverloadedStrings #-}++module Network.Xmpp.Extras.VCardAvatar+ ( askvCard+ ) where++import Data.XML.Types as DXT+import Network.Xmpp.Internal hiding (priority, status)++--askvCard :: Jid -> Session -> IO (Either XmppFailure IQResponse)+askvCard jid = sendIQ' Nothing (Just jid) Get Nothing (DXT.Element "vCard" [("xmlns", [DXT.ContentText "vcard-temp"])] []) []
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ TByteVector.hs view
@@ -0,0 +1,68 @@+module TByteVector+ ( TByteVector+ , newTByteVector+ , append+ , read+ ) where++import Control.Concurrent.STM+import Control.Monad+import Data.ByteString as B hiding (append)+import Data.Text as T hiding (append)+import Data.Text.Encoding+import Data.Vector.Unboxed.Mutable (IOVector)+import qualified Data.Vector.Unboxed.Mutable as V+import Data.Word+import GHC.Conc+import Prelude hiding (read)++data TByteVector = TByteVector+ { usedLength :: TVar Word+ , uVector :: TVar (IOVector Word8)+ }++newTByteVector :: IO TByteVector+newTByteVector = do+ ic <- newTVarIO 0+ vec <- V.unsafeNew 0+ v <- newTVarIO vec+ return $ TByteVector+ { usedLength = ic+ , uVector = v+ }++writeList :: IOVector Word8 -> Int -> [Word8] -> IO ()+writeList _ _ [] = return ()+writeList vec offset (x:xs) = do+ V.unsafeWrite vec offset x+ writeList vec (offset + 1) xs+ +toList :: IOVector Word8 -> IO [Word8]+toList vec = if V.null vec then return [] else do+ h <- V.unsafeRead vec 0+ l <- toList $ V.tail vec+ return $ h : l++append :: TByteVector -> Text -> IO ()+append (TByteVector _ v) str = do+ vec <- atomically $ readTVar v+ nv <- do+ let veclen = V.length vec+ let bs = encodeUtf8 str+ let len = B.length bs+ nv <- V.unsafeGrow vec len+ let wordlist = B.unpack bs+ writeList nv veclen wordlist+ return nv+ atomically $ writeTVar v nv++read :: TByteVector -> Word -> Word -> STM ByteString+read (TByteVector _ v) offset len = do+ vec <- readTVar v+ let veclen = V.length vec+ let vecoffset = if offset > fromIntegral veclen then fromIntegral veclen else fromIntegral offset+ let slicelen = if vecoffset + fromIntegral len > veclen then veclen - vecoffset else fromIntegral len+ rv <- unsafeIOToSTM $ do+ wordlist <- toList $ V.slice vecoffset slicelen vec+ return $ B.pack wordlist+ return rv
+ Types.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, TypeFamilies, FlexibleContexts, CPP #-}++module Types where++import Control.Concurrent.STM+import Control.Monad.EmbedIO+import Control.Monad.Reader+import Data.Map.Strict as MS+import Data.Sequence+import Data.Text as Text+import Data.Time.Clock+import Network.Xmpp++import TByteVector++type Hate = ReaderT GlobalState IO+type Nickname = Text+type Msg = Text+type LogEntry = (UTCTime, Maybe Nickname, Msg)+type Logs = MS.Map Jid Log+type MUCs = MS.Map Jid MUC+type ChatHandler = LogEntry -> IO ()++data Log = Log+ { logEntries :: TVar (Seq LogEntry)+ , firstUnshownLogIdx :: TVar Int+ , shownLog :: TByteVector+ }++runHate = runReaderT++instance EmbedIO Hate where+ type Content Hate = GlobalState+ embed f = ask >>= liftIO . f+ callback = runHate++data ShowSt = SNone | SAway | SChat | SDND | SXA deriving Show++data MUC = MUC+ { nick :: String+ } deriving Show++data GlobalState = GlobalState+ { server :: TVar String+ , port :: TVar String+ , username :: TVar Text+ , password :: TVar Text+ , resource :: TVar Text+ , priority :: TVar String+ , jiv_name :: TVar String+ , jiv_os :: TVar String+ , jiv_version :: TVar String+ , muc_default_nick :: TVar String+ , showst :: TVar ShowSt+ , status :: TVar String+ , streamManagement :: TVar Bool+ , permitUnsafeCerts :: TVar Bool+ , muc_history_request :: TVar Integer++ , sess :: TVar Session+ , featureStreamManagement3 :: TVar Bool+ , logs :: TVar Logs+ , mucs :: TVar MUCs+ , chats :: TVar (MS.Map Jid ChatHandler)+#ifdef UI_GTK+ , addMUCToRosterWindow :: TVar (Jid -> IO ())+ , addUserToRosterWindow :: TVar (Jid -> IO ())+#endif+ }
+ hatexmpp3.cabal view
@@ -0,0 +1,66 @@+Cabal-Version: 2.0+Name: hatexmpp3+Version: 0+Category: Network+Synopsis: XMPP client with 9P and (optionally) GTK interfaces+author: Sergey Alirzaev+Maintainer: zl29ah@gmail.com+License: OtherLicense+License-file: LICENSE+Build-Type: Simple+Tested-With: GHC == 8.6.5++Source-repository head+ type: git+ location: https://github.com/l29ah/hatexmpp3++Source-repository this+ type: git+ location: https://github.com/l29ah/hatexmpp3+ tag: 0++flag gtk+ default: True+ manual: True++Executable hatexmpp+ Main-is: HateXMPP.hs+ other-modules:+ Types+ Config+ Log+ MUC+ TByteVector+ Network.Xmpp.Extras.IQAvatar+ Network.Xmpp.Extras.VCardAvatar+ ghc-options: -W -fno-warn-tabs -threaded+ default-language: Haskell2010+ Build-depends:+ base >= 4 && < 5,+ pontarius-xmpp >= 0.4.5 && < 0.6,+ pontarius-xmpp-extras ^>= 0.1.0.4,+ Network-NineP >= 0.4 && < 0.5,+ bytestring >= 0.10 && < 0.11,+ hslogger >= 1.2.8 && < 1.4,+ stm >= 2.4.4 && < 2.6,+ mtl >= 2.2.1 && < 2.3,+ text >= 1.2.0.4 && < 1.3,+ string-class >= 0.1.6.4 && < 0.2,+ xml-types >= 0.3.4 && < 0.4,+ tls >= 1.2.18 && < 1.6,+ containers >= 0.5.6.2 && < 0.7,+ time >= 1.5.0.1 && < 1.11,+ transformers >= 0.4.2.0 && < 0.6,+ data-default >= 0.5.3 && < 0.8,+ xml-conduit >= 1.3.1 && < 1.10,+ vector >= 0.12.0.3 && < 0.13+ if flag(gtk)+ cpp-options: -DUI_GTK+ build-depends:+ gtk3 ^>= 0.14,+ datetime ^>= 0.3.1,+ monad-loops ^>= 0.4.3+ other-modules:+ GTK.Chat+ GTK.GTK+ GTK.Roster