haskell-xmpp 1.0.2 → 2.0.0
raw patch · 31 files changed
+2061/−933 lines, 31 filesdep +aesondep +blaze-markupdep +bytestringdep ~HaXmldep ~basedep ~mtlnew-component:exe:haskell-xmpp-io-testnew-uploader
Dependencies added: aeson, blaze-markup, bytestring, haskell-xmpp, hspec, http-client, http-conduit, network-bsd, singlethongs, text, time, unliftio, uuid, xml-conduit, xml-hamlet
Dependency ranges changed: HaXml, base, mtl
Files
- Changelog.md +20/−0
- README +0/−14
- README.md +33/−0
- examples/Test.hs +36/−24
- haskell-xmpp.cabal +75/−31
- src/Network/XMPP.hs +4/−4
- src/Network/XMPP/Base64.hs +29/−23
- src/Network/XMPP/Concurrent.hs +77/−64
- src/Network/XMPP/Core.hs +63/−50
- src/Network/XMPP/Ejabberd.hs +118/−0
- src/Network/XMPP/Helpers.hs +39/−22
- src/Network/XMPP/IM/Presence.hs +35/−26
- src/Network/XMPP/IQ.hs +27/−17
- src/Network/XMPP/JID.hs +0/−54
- src/Network/XMPP/MD5.hs +38/−39
- src/Network/XMPP/Print.hs +55/−43
- src/Network/XMPP/Sasl.hs +76/−59
- src/Network/XMPP/Stanza.hs +133/−108
- src/Network/XMPP/Stream.hs +174/−110
- src/Network/XMPP/Types.hs +287/−124
- src/Network/XMPP/UTF8.hs +4/−0
- src/Network/XMPP/Utils.hs +6/−73
- src/Network/XMPP/XEP/Delayed.hs +11/−3
- src/Network/XMPP/XEP/Form.hs +120/−0
- src/Network/XMPP/XEP/MAM.hs +113/−0
- src/Network/XMPP/XEP/MUC.hs +266/−30
- src/Network/XMPP/XEP/Version.hs +19/−15
- src/Network/XMPP/XML.hs +106/−0
- test/Main.hs +2/−0
- test/RoomSpec.hs +87/−0
- test/TestSuiteSpec.hs +8/−0
+ Changelog.md view
@@ -0,0 +1,20 @@+# Changelog for haskell-xmpp++## Version 2.0.0 - 15.10.2020+Riskbook took over maintainership+++ Use HaXML++ Add Missing FlexibleContexts++ Fix Duplicate show instances++ Add integration tests++ Add basic Ejabberd api support+ This is to allow basic integration tests.++ Add simple integration tests++ Add show instance for SomeStanza++ More flexible show instance for Stanza++## Version 1.0.2 - 13.12.2019++Intial release++
− README
@@ -1,14 +0,0 @@-Attempt to write an XMPP bindings for haskell--Alpha-version/work in progress--To build, obtain and install latest HaXml -(darcs get http://www.cs.york.ac.uk/fp/darcs/HaXml)-, then use supplied rebuild.sh--Questions or proposals?-Contact dastapov at gmail.com (via mail),-adept at jabber.kiev.ua (via XMPP :)-or adept at #haskell (via IRC)--Patches? "darcs send" them to dastapov@gmail.com
+ README.md view
@@ -0,0 +1,33 @@+[](https://riskbook.com/)++++Fully functional haskell-xmpp bindings used in production+at riskbook.+This integrates well with ejabbered for example.++Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library.+Unlike package network-protocol-xmpp, which uses libxml-sax, this library uses HaXml and supports MUC.+However, MUC support of the moment is worse than that in package XMPP.+This library make extensive use of STM and threads to simplify writing message-handling code.++As of version 2 riskbook maintains this.+We patched the orignal work by dmitry with these fixes:+- [x] Duplicate Show instances+- [x] Missing FlexibleContexts+- [x] GADTs for Stanzas++## Contributing+Feel free to submit any PR or issue.++Questions can be send to: support@riskbook.com++## License+BSD3++## Special thanks+A special thanks to Dmitry Astapov for making the original release.++### Logo sources++ https://commons.wikimedia.org/wiki/File:XMPP_logo.svg++ https://commons.wikimedia.org/wiki/File:Haskell-Logo.svg
examples/Test.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE GADTs #-}++-- |+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+ module Main where import Control.Monad.Trans (liftIO)@@ -9,45 +15,51 @@ import Network.XMPP.Concurrent import Control.Monad -- import qualified Text.XML.HaXml.Pretty as P (content)-import Text.XML.HaXml.Xtract.Parse (xtract)+-- import Text.XML.HaXml.Xtract.Parse (xtract) iqVersionT1 :: XmppThreadT () iqVersionT1 = do- st <- readChanS - liftIO $ putStrLn ("thread1 got next message.")- when (isVersionReq st) $ do - writeChanS $ presAway "thread1"- liftIO $ putStrLn ("thread1: it was version request. We sent away presence \"thread1\"")+ st <- readChanS+ liftIO $ putStrLn "thread1 got next message."+ case st of+ SomeStanza iq@MkIQ {} ->+ when (isVersionReq iq) $ do+ writeChanS $ SomeStanza $ presAway "thread1"+ liftIO $ putStrLn "thread1: it was version request. We sent away presence \"thread1\""+ _ -> pure () iqVersionT1 iqVersionT2 :: XmppThreadT () iqVersionT2 = do- st <- readChanS - liftIO $ putStrLn ("thread2 got next message.")- when (isVersionReq st) $ do - writeChanS $ presAway "thread2"- liftIO $ putStrLn ("thread1: it was version request. We sent away presence \"thread2\"")- iqVersionT2 + st <- readChanS+ liftIO $ putStrLn "thread2 got next message."+ case st of+ SomeStanza iq@MkIQ {} ->+ when (isVersionReq iq) $ do+ writeChanS $ SomeStanza $ presAway "thread2"+ liftIO $ putStrLn "thread1: it was version request. We sent away presence \"thread2\""+ _ -> pure ()+ iqVersionT2 iqVersion :: XmppThreadT () iqVersion =- loop $ iqReplyTo isVersionReq (versionAnswer "Network.XMPP test" version "Linux")- -main = + loop $ iqReplyTo isVersionReq $ versionAnswer "Network.XMPP test" version "Linux"++main :: IO ()+main = do let user = "testbot" let pass = "testing" let server = "xmpp.org.ru" let resource = "haskell-xmpp-devel"- let room = "testing@conference.jabber.ru" - withNewStream $ + let _room = "testing@conference.jabber.ru"+ void $ runXmppMonad $ do h <- liftIO $ connectViaTcp server 5222- (jid,_) <- initiateStream h server user pass resource+ jid <- initiateStream h server user pass resource liftIO $ putStrLn $ "My jid is " ++ show jid outStanza $ presAvailable "Hello, world!" runThreaded $ do- withNewThread $ iqVersion- withNewThread $ iqVersionT2- return ()+ void $ withNewThread iqVersion+ void $ withNewThread iqVersionT2 {- -- Query and dump roster --out $ iq ! [ id_ "roster-get", type_ "get" ] << query_ "jabber:iq:roster"@@ -59,9 +71,9 @@ liftIO $ putStrLn $ show roster -} -- Set presence to default - - mucJoin (read "testing@conference.jabber.ru/testbot")- mucLeave (read "testing@conference.jabber.ru/testbot")++ outStanza $ enterRoom (read "testing@conference.jabber.ru/testbot") undefined+ outStanza $ leaveRoom (read "testing@conference.jabber.ru/testbot") undefined {- -- Sit in MUC room, echoing all messages -- We echo all messages sent to MUC room or private chat,
haskell-xmpp.cabal view
@@ -1,18 +1,18 @@+cabal-version: 2.0 Name: haskell-xmpp-Version: 1.0.2+Version: 2.0.0 License: BSD3 License-File: LICENSE-Author: Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>-Maintainer: Dmitry Astapov <dastapov@gmail.com>-Homepage: http://patch-tag.com/r/adept/haskell-xmpp/home+Author: Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com>, riskbook <support@riskbook.com>+Maintainer: riskbook <support@riskbook.com>+Homepage: https://github.com/riskbook/haskell-xmpp Category: Network Copyright: (c) 2005-2011 Dmitry Astapov, k.pierre Stability: Stable-Cabal-version: >=1.6-Tested-with: GHC==6.10.4, GHC==6.12.1-Build-type: Simple -Bug-reports: mailto: dastapov@gmail.com-Extra-source-files: README examples/Test.hs+Tested-with: GHC==8.8.3+Build-type: Simple+Bug-reports: https://github.com/riskbook/haskell-xmpp/issues+Extra-source-files: README.md examples/Test.hs Changelog.md Synopsis: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library Description: Haskell XMPP (eXtensible Message Passing Protocol, a.k.a. Jabber) library@@ -23,8 +23,8 @@ This library make extensive use of STM and threads to simplify writing message-handling code. source-repository head- type: darcs- location: adept@patch-tag.com:/r/adept/haskell-xmpp+ type: git+ location: git@github.com:riskbook/haskell-xmpp.git flag examples description: Build examples@@ -35,32 +35,62 @@ default: False library+ default-language: Haskell2010 Hs-Source-Dirs: ./src- Build-Depends: base > 3 && <=5, random, pretty, array, HaXml >= 1.23.3, mtl >= 1.0, network, html, polyparse, regex-compat, stm, utf8-string+ Build-Depends: base > 4.11.0.0 && <= 4.14.0.0+ , random+ , pretty+ , array+ , mtl+ , HaXml+ , network+ , network-bsd+ , html+ , polyparse+ , regex-compat+ , stm+ , utf8-string+ , uuid+ , xml-hamlet+ , xml-conduit+ , text+ , blaze-markup+ , singlethongs+ , time+ , unliftio+ , aeson+ , http-conduit < 2.3.8.0+ , bytestring+ , http-client+ Exposed-modules: Network.XMPP- , Network.XMPP.Sasl- , Network.XMPP.Core- , Network.XMPP.Types- , Network.XMPP.Print- , Network.XMPP.Helpers- , Network.XMPP.Stream- , Network.XMPP.Stanza- , Network.XMPP.Utils- , Network.XMPP.IM.Presence- , Network.XMPP.JID- , Network.XMPP.IQ- , Network.XMPP.UTF8- , Network.XMPP.MD5- , Network.XMPP.Base64- , Network.XMPP.XEP.MUC- , Network.XMPP.XEP.Delayed- , Network.XMPP.XEP.Version- , Network.XMPP.Concurrent- GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans+ , Network.XMPP.Sasl+ , Network.XMPP.Core+ , Network.XMPP.Types+ , Network.XMPP.Print+ , Network.XMPP.Helpers+ , Network.XMPP.Stream+ , Network.XMPP.Stanza+ , Network.XMPP.Utils+ , Network.XMPP.IM.Presence+ , Network.XMPP.IQ+ , Network.XMPP.UTF8+ , Network.XMPP.XML+ , Network.XMPP.MD5+ , Network.XMPP.Base64+ , Network.XMPP.Ejabberd+ , Network.XMPP.XEP.MUC+ , Network.XMPP.XEP.MAM+ , Network.XMPP.XEP.Form+ , Network.XMPP.XEP.Delayed+ , Network.XMPP.XEP.Version+ , Network.XMPP.Concurrent+ GHC-Options: -Wall -Wincomplete-patterns -fno-warn-name-shadowing -fno-warn-orphans if flag(debug) CPP-Options: -DDEBUG Executable haskell-xmpp-test+ default-language: Haskell2010 Hs-Source-Dirs: ./src ./examples if flag(examples) build-depends: base > 3 && <=5@@ -70,3 +100,17 @@ CPP-Options: -DDEBUG Main-Is: Test.hs GHC-Options: -Wall -fno-warn-name-shadowing -fno-warn-orphans++Executable haskell-xmpp-io-test+ default-language: Haskell2010+ hs-source-dirs: ./test+ main-is: Main.hs+ build-tool-depends: hspec-discover:hspec-discover -any+ build-depends:+ base >=4.9.1.0 && <5+ , hspec+ , haskell-xmpp+ , text+ other-modules:+ TestSuiteSpec+ RoomSpec
src/Network/XMPP.hs view
@@ -3,6 +3,8 @@ -- Module : Network.XMPP -- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007 -- License : BSD-style (see the file LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com> -- Stability : experimental@@ -12,9 +14,8 @@ -- ----------------------------------------------------------------------------- -module Network.XMPP - ( module Network.XMPP.JID- , module Network.XMPP.Sasl+module Network.XMPP+ ( module Network.XMPP.Sasl , module Network.XMPP.Core , module Network.XMPP.Helpers , module Network.XMPP.Print@@ -25,7 +26,6 @@ , version ) where -import Network.XMPP.JID import Network.XMPP.Sasl import Network.XMPP.Core import Network.XMPP.Helpers
src/Network/XMPP/Base64.hs view
@@ -3,6 +3,8 @@ -- Module : Network.XMPP.Base64 -- Copyright : (c) Dmitry Astapov 2006, Dominic Steinitz 2005, Warrick Gray 2002 -- License : BSD-style (see the file ReadMe.tex)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : dastapov@gmail.com -- Stability : experimental@@ -161,13 +163,12 @@ import Data.Array import Data.Bits-import Data.Int-import Data.Char (chr,ord)+import Data.Char (chr, ord) encodeArray :: Array Int Char-encodeArray = array (0,64) - [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') - , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') +encodeArray = array (0,64)+ [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F')+ , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')@@ -184,46 +185,49 @@ -- Hack Alert: In the last entry of the answer, the upper 8 bits encode -- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. -- 0 represents a 4 :(-int4_char3 :: [Int] -> [Char]+int4_char3 :: [Int] -> String int4_char3 (a:b:c:d:t) = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)- in (chr (n `shiftR` 16 .&. 0xff))- : (chr (n `shiftR` 8 .&. 0xff))- : (chr (n .&. 0xff)) : int4_char3 t+ in chr (n `shiftR` 16 .&. 0xff)+ : chr (n `shiftR` 8 .&. 0xff)+ : chr (n .&. 0xff) : int4_char3 t int4_char3 [a,b,c] = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)- in [ (chr (n `shiftR` 16 .&. 0xff))- , (chr (n `shiftR` 8 .&. 0xff)) ]+ in [ chr (n `shiftR` 16 .&. 0xff)+ , chr (n `shiftR` 8 .&. 0xff) ] int4_char3 [a,b] = let n = (a `shiftL` 18 .|. b `shiftL` 12)- in [ (chr (n `shiftR` 16 .&. 0xff)) ]+ in [ chr (n `shiftR` 16 .&. 0xff) ] -int4_char3 [] = [] +int4_char3 [_] = [] +int4_char3 [] = [] + -- Convert triplets of characters to -- 4 base64 integers. The last entries -- in the list may not produce 4 integers, -- a trailing 2 character group gives 3 integers, -- while a trailing single character gives 2 integers.-char3_int4 :: [Char] -> [Int]+char3_int4 :: String -> [Int] char3_int4 (a:b:c:t) = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t char3_int4 [a,b] = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)- in [ (n `shiftR` 18 .&. 0x3f)- , (n `shiftR` 12 .&. 0x3f)- , (n `shiftR` 6 .&. 0x3f) ]+ in [ n `shiftR` 18 .&. 0x3f+ , n `shiftR` 12 .&. 0x3f+ , n `shiftR` 6 .&. 0x3f ] char3_int4 [a] = let n = (ord a `shiftL` 16)- in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]+ in [ n `shiftR` 18 .&. 0x3f+ , n `shiftR` 12 .&. 0x3f ] char3_int4 [] = [] @@ -242,21 +246,23 @@ -- Pads a base64 code to a multiple of 4 characters, using the special -- '=' character.+quadruplets :: String -> String quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit+quadruplets [_] = [] quadruplets [] = [] -- 24bit tail unit -enc :: [Int] -> [Char]+enc :: [Int] -> String enc = quadruplets . map enc1 -+dcd :: String -> [Int] dcd [] = [] dcd (h:t)- | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t- | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t- | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t+ | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t+ | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t+ | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t | h == '+' = 62 : dcd t | h == '/' = 63 : dcd t | h == '=' = [] -- terminate data stream
src/Network/XMPP/Concurrent.hs view
@@ -1,8 +1,16 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.Concurrent -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : k.pierre.k@gmail.com -- Stability : experimental@@ -22,87 +30,92 @@ , waitFor ) where +import Control.Concurrent+import Control.Monad.State+import Control.Monad.Reader+ import Network.XMPP.Stream-import Network.XMPP.Stanza import Network.XMPP.Types-import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad.State -import Control.Monad.Reader import Network.XMPP.Utils+import Network.XMPP.XML+import UnliftIO.Async (Async, async)+import UnliftIO (TChan, MonadUnliftIO, atomically, newTChan,+ writeTChan, readTChan, dupTChan) import System.IO- -data Thread = Thread { inCh :: TChan Stanza- , outCh :: TChan Stanza- } -type XmppThreadT a = ReaderT Thread IO a- +data Thread e = Thread+ { tInCh :: TChan (Either XmppError (SomeStanza e))+ , tOutCh :: TChan (SomeStanza ())+ }++type XmppThreadT m a e = ReaderT (Thread e) m a++instance MonadIO m => XmppSendable (ReaderT (Thread e) m) (Stanza t 'Outgoing ()) where+ xmppSend = writeChanS . SomeStanza+ -- Two streams: input and output. Threads read from input stream and write to output stream. -- | Runs thread in XmppState monad-runThreaded :: XmppThreadT () -> XmppStateT ()-runThreaded a = do- in' <- liftIO $ atomically $ newTChan- out' <- liftIO $ atomically $ newTChan- liftIO $ forkIO $ runReaderT a (Thread in' out')- s <- get- liftIO $ forkIO $ loopWrite s out'- liftIO $ forkIO $ connPersist (handle s)- loopRead in' - where - loopRead in' = loop $ - do - st <- parseM- liftIO $ atomically $ writeTChan in' st- loopWrite s out' =- do- withNewStream $ do- put s- loop $ do- st <- liftIO $ atomically $ readTChan out'- outStanza st- return () - loop = sequence_ . repeat- -readChanS :: XmppThreadT Stanza-readChanS = do- c <- asks inCh - st <- liftIO $ atomically $ readTChan c- return st +-- blocks forever.+runThreaded+ :: (FromXML e, MonadIO m, MonadUnliftIO m)+ => XmppThreadT m () e+ -> XmppMonad m ()+runThreaded action = do+ (in', out') <- atomically $ (,) <$> newTChan <*> newTChan+ s@Stream{..} <- get+ void $ lift $+ async (runReaderT action $ Thread in' out') >>+ async (void $ async $ runXmppMonad' s $ loopWrite out') >>+ async (connPersist handle)+ loopRead in'+ where+ loopRead in' = do+ msg <- parseM+ atomically $ writeTChan in' msg+ case msg of+ Left StreamClosedError -> pure ()+ Left RanOutOfInput -> pure ()+ _ -> loopRead in'+ loopWrite :: MonadIO m => TChan (SomeStanza e) -> XmppMonad m ()+ loopWrite out'= do+ liftIO (atomically $ readTChan out') >>= \case+ SomeStanza stnz@MkMessage { mPurpose = SOutgoing } -> xmppSend stnz+ SomeStanza stnz@MkPresence { pPurpose = SOutgoing } -> xmppSend stnz+ SomeStanza stnz@MkIQ { iqPurpose = SOutgoing } -> xmppSend stnz+ _ -> pure () -- Won't happen, but we gotta make compiler happy+ loopWrite out' -writeChanS :: Stanza -> XmppThreadT ()-writeChanS a = do- c <- asks outCh- st <- liftIO $ atomically $ writeTChan c a - return ()+readChanS :: MonadIO m => XmppThreadT m (Either XmppError (SomeStanza e)) e+readChanS = asks tInCh >>= liftIO . atomically . readTChan +writeChanS :: MonadIO m => SomeStanza () -> XmppThreadT m () e+writeChanS a = void $ asks tOutCh >>= liftIO . atomically . flip writeTChan a+ -- | Runs specified action in parallel-withNewThread :: XmppThreadT () -> XmppThreadT ThreadId+withNewThread+ :: (MonadIO m, MonadUnliftIO m)+ => XmppThreadT m () e+ -> XmppThreadT m (Async ()) e withNewThread a = do- in' <- asks inCh- out' <- asks outCh- newin <- liftIO $ atomically $ dupTChan in'- liftIO $ forkIO $ runReaderT a (Thread newin out')+ newin <- asks tInCh >>= liftIO . atomically . dupTChan+ asks tOutCh >>= lift . async . runReaderT a . Thread newin -- | Turns action into infinite loop-loop :: XmppThreadT () -> XmppThreadT ()-loop a = do- a- loop a+loop :: MonadIO m => XmppThreadT m () e -> XmppThreadT m () e+loop a = a >> loop a -waitFor :: (Stanza -> Bool) -> XmppThreadT Stanza+waitFor+ :: MonadIO m+ => (Either XmppError (SomeStanza e) -> Bool)+ -> XmppThreadT m (Either XmppError (SomeStanza e)) e waitFor f = do s <- readChanS- if (f s) then - return s- else do- waitFor f+ if f s then return s else waitFor f -connPersist :: Handle -> IO ()+connPersist :: MonadIO m => Handle -> m () connPersist h = do- hPutStr h " "- debugIO "<space added>"- threadDelay 30000000+ liftIO $ hPutStr h " "+ liftIO $ debugIO "<space added>"+ liftIO $ threadDelay 30000000 connPersist h-
src/Network/XMPP/Core.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.Core -- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007 -- License : BSD-style (see the file LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com> -- Stability : experimental@@ -13,71 +19,78 @@ ----------------------------------------------------------------------------- module Network.XMPP.Core- ( initiateStream+ ( initStream+ , closeStream ) where -import Control.Monad.State-import System.IO+import Control.Monad (void)+import System.IO (Handle, hSetBuffering, BufferMode(..))+import Control.Monad.Except (throwError, runExceptT, lift)+import Control.Monad.IO.Class (liftIO, MonadIO) -import Network.XMPP.Sasl (saslAuth)-import Network.XMPP.Print-import Network.XMPP.Stream-import Network.XMPP.Types-import Network.XMPP.JID-import Network.XMPP.IQ-import Network.XMPP.Utils+import Data.Text (unpack, pack)+import Text.Hamlet.XML (xml) +import Network.XMPP.Utils (debug)+import Network.XMPP.Sasl (saslAuth)+import Network.XMPP.IQ (iqSend)+import Network.XMPP.Print (stream, streamEnd)+import Network.XMPP.XML (noelem, lookupAttr, getText)+import Network.XMPP.Types (Server, Username, Password, Resource, XmppMonad,+ JID(..), JIDQualification(..), StreamType(..),+ IQType(..))+import Network.XMPP.Stream (resetStreamHandle, XmppSendable(..), XmppError(..),+ xtractM, textractM, startM)+ -- | Open connection to specified server and return `Stream' coming from it-initiateStream :: Handle- -> String -- ^ Server (hostname) we are connecting to- -> String -- ^ Username to use- -> String -- ^ Password to use- -> String -- ^ Resource to use- -> XmppStateT (JID, Stream) -- ^ Return (jid, stream)-initiateStream h server username password resrc =+initStream :: MonadIO m => Handle+ -> Server -- ^ Server (hostname) we are connecting to+ -> Username -- ^ Username to use+ -> Password -- ^ Password to use+ -> Resource -- ^ Resource to use+ -> XmppMonad m (Either XmppError (JID 'NodeResource))+initStream h server username password resrc = runExceptT $ do liftIO $ hSetBuffering h NoBuffering resetStreamHandle h- out $ toContent $- stream Client server- attrs <- startM- case (lookupAttr "version" attrs) of- Just "1.0" -> return ()- Nothing ->- -- TODO: JEP 0078- -- in case of absent of version we wont process stream:features- error "No version"- _ -> error "unknown version"+ lift $ xmppSend $ head $ stream Client server noelem+ attrs <- lift startM >>= either throwError pure++ case lookupAttr "version" attrs of+ Just "1.0" -> return ()+ -- TODO: JEP 0078 in case of absent of version we wont process stream:features+ Just ver -> throwError $ UnknownVersion $ pack ver+ Nothing -> throwError $ UnknownVersion "" - debug "Stream started"+ lift $ debug "Stream started" --debug $ "Observing: " ++ render (P.content m)- m <- xtractM "/stream:features/mechanisms/mechanism/-"- let mechs = map getText m- debug $ "Mechanisms: " ++ show mechs+ m <- lift $ xtractM "/stream:features/mechanisms/mechanism/-"+ let mechs = getText <$> m+ lift $ debug $ "Mechanisms: " ++ show mechs -- Handle the authentication- saslAuth mechs server username password+ lift (saslAuth mechs server username password) >>= either throwError pure - out $ toContent $- stream Client server- - startM- + lift $ xmppSend $ head $ stream Client server noelem++ void $ lift startM >>= either throwError pure+ -- Bind this session to resource- xtractM "/stream:features/bind" -- `catch` (fail "Binding is not proposed") + lift $ void $ xtractM "/stream:features/bind" -- `catch` (fail "Binding is not proposed") - iqSend "bind1" Set - [ ptag "bind" [ xmlns "urn:ietf:params:xml:ns:xmpp-bind" ]- [ ptag "resource" []- [ literal $ resrc ]- ]- ]+ lift $ iqSend "bind1" Set + [xml|+ <bind xmlns="urn:ietf:params:xml:ns:xmpp-bind">+ <resource>#{resrc}+ |] - my_jid <- textractM "/iq[@type='result' & @id='bind1']/bind/jid/-"+ my_jid <- lift $ textractM "/iq[@type='result' & @id='bind1']/bind/jid/-" - iqSend "session1" Set - [ itag "session" [xmlns "urn:ietf:params:xml:ns:xmpp-session" ] ]+ lift $ iqSend "session1" Set + [xml| <session xmlns="urn:ietf:params:xml:ns:xmpp-session"> |] - xtractM "/iq[@type='result' & @id='session1']" -- (error "Session binding failed")+ lift $ void $ xtractM "/iq[@type='result' & @id='session1']" -- (error "Session binding failed") - stream <- get - return (read $ my_jid, stream)+ return $ read $ unpack my_jid++closeStream :: MonadIO m => XmppMonad m ()+closeStream = xmppSend $ head $ streamEnd noelem
+ src/Network/XMPP/Ejabberd.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Ejabberd api support+module Network.XMPP.Ejabberd+ ( EjabberdHost(..)+ , EUser(..)+ , VHost(..)+ , EResult(..)+ , RegisterUserReq(..)+ , localEjabberdHost+ , getRegisteredUsers+ , registerNewUser+ ) where++import GHC.Generics (Generic)+import qualified Data.Aeson as J+import qualified Data.ByteString.Lazy as BSL+import Network.HTTP.Client (RequestBody(..), Response)+import Network.HTTP.Simple+ (getResponseBody, httpLBS, parseRequest_, setRequestBody)+import Control.Exception+import Data.Text(Text)+import qualified Data.Text as Text+import Text.Printf+import Data.Char (isLower)+import Control.Applicative++data EUser =+ EUser+ { euName :: Text+ , euPassword :: Text+ } deriving (Eq, Show, Generic)++newtype VHost =+ VHost { vhHost :: Text }+ deriving (Eq, Show, Generic)++data EResult a+ = ESuccess a+ | EError+ { eStatus :: Text+ , eCode :: Int+ , eMessage :: Text+ }+ deriving (Eq, Show)++data RegisterUserReq = RegisterUserReq+ { rurUser :: Text+ , rurPassword :: Text+ , rurHost :: Text+ } deriving (Eq, Show, Generic)++instance J.FromJSON a => J.FromJSON (EResult a) where+ parseJSON raw =+ let failed = flip (J.withObject "EjabberdResponse") raw $ \o -> do+ status <- o J..: "status"+ code <- o J..: "code"+ msg <- o J..: "message"+ pure $ EError status code msg+ success = ESuccess <$> J.parseJSON raw+ in success <|> failed++instance J.ToJSON VHost where+ toJSON = J.genericToJSON snakeLabel++instance J.ToJSON RegisterUserReq where+ toJSON = J.genericToJSON snakeLabel++-- | Make sure to get the port right+-- https://docs.ejabberd.im/admin/guide/security/+-- an example is available in 'localEjabberdHost',+-- which is used for the integration tests.+newtype EjabberdHost = EjabberdHost String++snakeConstructor :: J.Options+snakeConstructor = J.defaultOptions { J.constructorTagModifier = J.camelTo2 '_' }++snakeLabel :: J.Options+snakeLabel = snakeConstructor { J.fieldLabelModifier = J.camelTo2 '_' . dropWhile isLower }++localEjabberdHost :: EjabberdHost+localEjabberdHost = EjabberdHost "http://localhost:5443"++toPath :: EjabberdHost -> String -> String+toPath (EjabberdHost d) = printf "POST %s/%s" d++-- | https://docs.ejabberd.im/developer/ejabberd-api/admin-api/#registered-users+--+-- @since 2.0.0+getRegisteredUsers :: EjabberdHost -> VHost -> IO (EResult [Text])+getRegisteredUsers ejabberd vhost = do -- TODO: monad reader with api host and manager+ let body = RequestBodyLBS $ J.encode vhost+ path = toPath ejabberd "api/registered_users"+ req = setRequestBody body $ parseRequest_ path++ resp :: Either SomeException (Response BSL.ByteString) <-+ try $ httpLBS req+ let eiResult = returnable . J.eitherDecode . getResponseBody <$> resp+ pure $ either (EError "exception" (-1) . Text.pack . show) id eiResult+ where returnable = either (EError "error" (-1) . Text.pack) id++-- | https://docs.ejabberd.im/developer/ejabberd-api/admin-api/#register+--+-- @since 2.0.0+registerNewUser :: EjabberdHost -> EUser -> VHost -> IO (EResult Text)+registerNewUser ejabberd newUser h = do+ let body = RegisterUserReq (euName newUser) (euPassword newUser) $ vhHost h+ encodedBody = RequestBodyLBS $ J.encode body+ path = toPath ejabberd "api/register"+ req = setRequestBody encodedBody $ parseRequest_ path++ resp :: Either SomeException (Response BSL.ByteString) <-+ try $ httpLBS req+ let eiResult = returnable . J.eitherDecode . getResponseBody <$> resp+ pure $ either (EError "exception" (-1) . Text.pack . show) id eiResult+ where returnable = either (EError "error" (-1) . Text.pack) id
src/Network/XMPP/Helpers.hs view
@@ -3,7 +3,9 @@ -- Module : Network.XMPP.Helpers -- Copyright : (c) Dmitry Astapov, 2006 -- License : BSD-style (see the file LICENSE)--- +-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+-- -- Maintainer : Dmitry Astapov <dastapov@gmail.com> -- Stability : experimental -- Portability : portable@@ -12,45 +14,60 @@ -- ----------------------------------------------------------------------------- -module Network.XMPP.Helpers +module Network.XMPP.Helpers ( connectViaHttpProxy , connectViaTcp , openStreamFile ) where import System.IO (Handle, hPutStrLn, hPutStr, hGetLine, openFile, IOMode(..))-import Network (connectTo, PortID(..) )+import Control.Monad (void, when)++import Network.BSD (getHostByName, hostAddresses)+import qualified Data.Text as T+ import Network.Socket-import Network.BSD import Control.Concurrent (threadDelay, forkIO) import Control.Monad.Trans (liftIO) import Network.XMPP.Utils -- | Connect to XMPP server on specified host \/ port-connectViaTcp :: String -- ^ Server (hostname) to connect to- -> Int -- ^ Port to connect to- -> IO Handle+connectViaTcp :: T.Text -- ^ Server (hostname) to connect to+ -> Int -- ^ Port to connect to+ -> IO Handle connectViaTcp server port = do- host <- getHostByName server+ host <- getHostByName $ T.unpack server sock <- socket AF_INET Stream 0 setSocketOption sock KeepAlive 1- connect sock (SockAddrInet (fromIntegral port) (head $ hostAddresses host))- socketToHandle sock ReadWriteMode + let sockAddress = SockAddrInet (fromIntegral port) $ head $ hostAddresses host+ connect sock sockAddress+ socketToHandle sock ReadWriteMode -- | Connect to XMPP server on specified host \/ port -- via HTTP 1.0 proxy-connectViaHttpProxy proxy_server proxy_port server port =- do h <- connectTo proxy_server (PortNumber (fromIntegral proxy_port))- hPutStrLn h $ unlines [ concat ["CONNECT ",server,":",show port," HTTP/1.0"]- , "Connection: Keep-Alive" ]- dropHeaders h- liftIO $ forkIO $ pinger h- return h- where dropHeaders h = do l <- hGetLine h- debugIO $ "Got: " ++ l- if words l /= [] then dropHeaders h- else return ()- pinger h = hPutStr h " " >> threadDelay (30 * 10^6) >> pinger h+connectViaHttpProxy :: Show a => HostName -> Integer -> T.Text -> a -> IO Handle+connectViaHttpProxy proxyServer proxyPort server port = do+ let hints = defaultHints+ { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV]+ , addrSocketType = Stream+ }+ addr:_ <- getAddrInfo (Just hints) (Just proxyServer) (Just $ show proxyPort)+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ h <- socketToHandle sock ReadWriteMode+ hPutStrLn h $ unlines+ [ concat ["CONNECT ", T.unpack server, ":", show port, " HTTP/1.0"]+ , "Connection: Keep-Alive"+ ]+ dropHeaders h+ void $ liftIO $ forkIO $ pinger h+ return h+ where+ dropHeaders h = do+ l <- hGetLine h+ debugIO $ "Got: " ++ l+ when (words l /= []) $ dropHeaders h+ pinger h = hPutStr h " " >> threadDelay (30 * (10 ^ (6 :: Int))) >> pinger h -- | Open file with pre-captured server-to-client XMPP stream. For debugging+openStreamFile :: FilePath -> IO Handle openStreamFile fname = openFile fname ReadMode
src/Network/XMPP/IM/Presence.hs view
@@ -1,8 +1,13 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.IM.Presence -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : k.pierre.k@gmail.com -- Stability : experimental@@ -22,42 +27,46 @@ ) where import Network.XMPP.Types+import Data.Text (Text) -- | Default presence, should be sent at first-presAvailable :: String -- ^ Status message- -> Stanza-presAvailable status = Presence Nothing Nothing "" Default Available status (Just 0) []+presAvailable :: Text -- ^ Status message+ -> Stanza 'Presence 'Outgoing ()+presAvailable status = MkPresence Nothing Nothing "" Default Available status (Just 0) [] SOutgoing -- | Should be sent at last-presUnavailable :: String -> Stanza-presUnavailable status = mkPresenceU Available status+presUnavailable :: Text -> Stanza 'Presence 'Outgoing ()+presUnavailable = mkPresenceU Available -presAway :: String -> Stanza-presAway status = mkPresenceD Away status- -presXa :: String -> Stanza-presXa status = mkPresenceD XAway status+presAway :: Text -> Stanza 'Presence 'Outgoing ()+presAway = mkPresenceD Away -presChat :: String -> Stanza-presChat status = mkPresenceD FreeChat status+presXa :: Text -> Stanza 'Presence 'Outgoing ()+presXa = mkPresenceD XAway -presDND :: String -> Stanza-presDND status = mkPresenceD DND status+presChat :: Text -> Stanza 'Presence 'Outgoing ()+presChat = mkPresenceD FreeChat --- | Helper to contruct presence Stanza with required attrs-mkPresence :: PresenceType -> ShowType -> String -> Stanza+presDND :: Text -> Stanza 'Presence 'Outgoing ()+presDND = mkPresenceD DND++-- | Helper to construct presence Stanza with required attrs+mkPresence :: PresenceType -> ShowType -> Text -> Stanza 'Presence 'Outgoing () mkPresence typ showType status = - Presence Nothing -- pFrom- Nothing -- PTo- "" -- pId- typ- showType- status- (Just 0) -- pPriority :: Maybe Integer- [] -- pExt :: [Content Posn]+ MkPresence + { pFrom = Nothing+ , pTo = Nothing+ , pId = ""+ , pType = typ+ , pShowType = showType+ , pStatus = status+ , pPriority = Just 0+ , pExt = []+ , pPurpose = SOutgoing+ } -mkPresenceD :: ShowType -> String -> Stanza+mkPresenceD :: ShowType -> Text -> Stanza 'Presence 'Outgoing () mkPresenceD = mkPresence Default -mkPresenceU :: ShowType -> String -> Stanza+mkPresenceU :: ShowType -> Text -> Stanza 'Presence 'Outgoing () mkPresenceU = mkPresence Unavailable
src/Network/XMPP/IQ.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.IQ -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : k.pierre.k@gmail.com -- Stability : experimental@@ -18,28 +24,32 @@ ) where import Network.XMPP.Types-import Network.XMPP.Stanza-import Network.XMPP.Utils+import Network.XMPP.Stream import Network.XMPP.Concurrent- -import Text.XML.HaXml-import Text.XML.HaXml.Posn +import Text.XML (Node)+import qualified Data.Text as T+import Control.Monad.IO.Class -- | Send IQ of specified type with supplied data-iqSend :: String -- ^ ID to use+iqSend :: MonadIO m+ => T.Text -- ^ ID to use -> IQType -- ^ IQ type- -> [CFilter Posn] -- ^ request contents - -> XmppStateT ()-iqSend id t d = do- outStanza $ IQ Nothing Nothing id t (map toContent d) + -> [Node] -- ^ request contents+ -> XmppMonad m ()+iqSend id t body = xmppSend $ MkIQ Nothing Nothing id t body SOutgoing -- Extract IQ reply that matches the supplied predicate from the event stream and send it (transformed) -iqReplyTo :: (Stanza -> Bool) -- ^ Predicate used to match required IQ reply- -> (Stanza -> [CFilter Posn]) -- ^ transformer function- -> XmppThreadT ()+iqReplyTo :: (Stanza 'IQ 'Incoming e -> Bool) -- ^ Predicate used to match required IQ reply+ -> (Stanza 'IQ 'Incoming e -> [Node]) -- ^ transformer function+ -> XmppThreadT IO () e iqReplyTo p t = do- s <- waitFor (\x -> p x && isIQ x)- writeChanS (transform t s)+ s <- waitFor (\case+ Right (SomeStanza xiq@MkIQ{ iqPurpose = SIncoming }) -> p xiq+ _ -> False)+ case s of+ Right (SomeStanza stnz@MkIQ{ iqPurpose = SIncoming }) -> writeChanS $ SomeStanza $ transform t stnz+ _ -> pure () where- transform t s@(IQ from' to' id' type' body') =- IQ to' from' id' Result (map toContent $ t s)+ transform :: (Stanza 'IQ 'Incoming e -> [Node]) -> Stanza 'IQ 'Incoming e -> Stanza 'IQ 'Outgoing ()+ transform t s@(MkIQ from' to' id' _type' _body' SIncoming) =+ MkIQ to' from' id' Result (t s) SOutgoing
− src/Network/XMPP/JID.hs
@@ -1,54 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Network.XMPP.JID--- Copyright : (c) pierre, 2006--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : pierre <k.pierre.k@gmail.com>--- Stability : experimental--- Portability : portable------ JID datatype and functions-------------------------------------------------------------------------------------- jid components and functions--- probably import Stringprep--module Network.XMPP.JID- ( JID(..)- ) where--import Text.Regex---- | Jabber ID (JID) datatype-data JID = JID { name :: Maybe String- -- ^ Account name- , server :: String- -- ^ Server adress- , resource :: Maybe String- -- ^ Resource name- }--instance Read JID where- -- Reads JID from string (name@server\/resource)- readsPrec _ str = case matchRegexAll regex str of - Just (_,_,after,(_:name:_:server:_:_:resource:_:[])) -> [((JID (toMaybe name) server (toMaybe resource)), after)]- Just _ -> []- Nothing -> []- where- toMaybe "" = Nothing- toMaybe s = Just s- regex = mkRegex $ - "((([^@])+)@)?" ++- "(([^/])+)" ++- "(/((.)+))?"--instance Show JID where- -- Shows JID- show jid = concat [name', server jid, resource']- where name' = maybe "" (++"@") (name jid)- resource' = maybe "" ("/"++) (resource jid)- -
src/Network/XMPP/MD5.hs view
@@ -3,6 +3,8 @@ -- Module : Network.XMPP.MD5 -- Copyright : (c) Dmitry Astapov 20006, Ian Lynagh 2001 -- License : BSD-style (see the file ReadMe.tex)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : dastapov@gmail.com -- Stability : experimental@@ -41,7 +43,8 @@ #endif -} -rotL x = rotateL x+rotL :: Word32 -> Int -> Word32+rotL = rotateL type Zord64 = Word64 -- ===================== TYPES AND CLASS DEFINTIONS ========================@@ -54,6 +57,9 @@ newtype BoolList = BoolList [Bool] newtype WordList = WordList ([Word32], Zord64) +addABCD :: ABCD -> ABCD -> ABCD+addABCD (ABCD (a1, b1, c1, d1)) (ABCD (a2, b2, c2, d2)) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)+ -- Anything we want to work out the MD5 of must be an instance of class MD5 class MD5 a where@@ -74,12 +80,13 @@ len_pad l (BoolList bs) = BoolList (bs ++ [True] ++ replicate (fromIntegral $ (447 - l) .&. 511) False- ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])]+ ++ [l .&. shiftL 1 x > 0 | x <- mangle [0..63]] ) where mangle [] = []- mangle xs = reverse ys ++ mangle zs- where (ys, zs) = splitAt 8 xs- finished (BoolList s) = s == []+ mangle xs =+ let (ys, zs) = splitAt 8 xs+ in reverse ys ++ mangle zs+ finished (BoolList s) = null s -- The string instance is fairly straightforward@@ -90,7 +97,7 @@ len_pad c64 (Str s) = Str (s ++ padding ++ l) where padding = '\128':replicate (fromIntegral zeros) '\000' zeros = shiftR ((440 - c64) .&. 511) 3- l = length_to_chars 8 c64+ l = lengthToChars 8 c64 finished (Str s) = s == "" @@ -101,52 +108,45 @@ where (xs, ys) = splitAt 16 ws taken = if l > 511 then 512 else l .&. 511 len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen)- where beginning = if length ws > 0 then start ++ lastone' else []+ where beginning = if not $ null ws then start ++ lastone' else [] start = init ws lastone = last ws offset = c64 .&. 31 lastone' = [if offset > 0 then lastone + theone else lastone] theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) (fromIntegral $ offset .&. (31 - 7))- nextish = if offset == 0 then [128] else []+ nextish = [128 | offset == 0] c64' = c64 + (32 - offset)- num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5)+ num_blanks = fromIntegral $ shiftR ((448 - c64') .&. 511) 5 blanks = replicate num_blanks 0 lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) topsize = fromIntegral $ shiftR c64 32 size = [lowsize, topsize]- newlen = l .&. (complement 511)+ newlen = l .&. complement 511 + if c64 .&. 511 >= 448 then 1024 else 512 finished (WordList (_, z)) = z == 0 -instance Num ABCD where- ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)- ABCD (a1, b1, c1, d1) * ABCD (a2, b2, c2, d2) = undefined- abs (x) = x- signum _ = undefined- fromInteger _ = undefined- -- ===================== EXPORTED FUNCTIONS ======================== -- The simplest function, gives you the MD5 of a string as 4-tuple of -- 32bit words. -md5 :: (MD5 a) => a -> ABCD-md5 m = md5_main False 0 magic_numbers m+md5 :: MD5 a => a -> ABCD+md5 = md5_main False 0 magicNumbers -- Returns a hex number ala the md5sum program md5s :: (MD5 a) => a -> String-md5s = abcd_to_string . md5+md5s = abcdToString . md5 -- Returns an integer equivalent to the above hex number md5i :: (MD5 a) => a -> Integer-md5i = abcd_to_integer . md5+md5i = abcdToInteger . md5 -- ===================== THE CORE ALGORITHM ========================@@ -165,7 +165,7 @@ md5_main padded ilen abcd m = if finished m && padded then abcd- else md5_main padded' (ilen + 512) (abcd + abcd') m''+ else md5_main padded' (ilen + 512) (abcd `addABCD` abcd') m'' where (m16, l, m') = get_next m len' = ilen + fromIntegral l ((m16', _, m''), padded') = if not padded && l < 512@@ -251,11 +251,10 @@ md5_i :: XYZ -> Word32 md5_i (x, y, z) = y `xor` (x .|. (complement z)) - -- The magic numbers from the RFC. -magic_numbers :: ABCD-magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476)+magicNumbers :: ABCD+magicNumbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) -- The 4 lists of (rotation, additive constant) tuples, one for each round@@ -313,8 +312,8 @@ -- Turn the 4 32 bit words into a string representing the hex number they -- represent. -abcd_to_string :: ABCD -> String-abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d]+abcdToString :: ABCD -> String+abcdToString (ABCD (a,b,c,d)) = concatMap display_32bits_as_hex [a,b,c,d] -- Split the 32 bit word up, swap the chunks over and convert the numbers@@ -322,21 +321,21 @@ display_32bits_as_hex :: Word32 -> String display_32bits_as_hex w = swap_pairs cs- where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7]- getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n)+ where cs = map (\x -> getc $ shiftR w (4 * x) .&. 15) [0..7]+ getc n = (['0'..'9'] ++ ['a'..'f']) !! fromIntegral n swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs swap_pairs _ = [] -- Convert to an integer, performing endianness magic as we go -abcd_to_integer :: ABCD -> Integer-abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int)- + rev_num b * 2^(64 :: Int)- + rev_num c * 2^(32 :: Int)- + rev_num d+abcdToInteger :: ABCD -> Integer+abcdToInteger (ABCD (a,b,c,d)) = revNum a * 2^(96 :: Int)+ + revNum b * 2^(64 :: Int)+ + revNum c * 2^(32 :: Int)+ + revNum d -rev_num :: Word32 -> Integer-rev_num i = toInteger j `mod` (2^(32 :: Int))+revNum :: Word32 -> Integer+revNum i = toInteger j `mod` (2^(32 :: Int)) -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) 0 [0,8,16,24]@@ -367,8 +366,8 @@ -- Convert the size into a list of characters used by the len_pad function -- for strings -length_to_chars :: Int -> Zord64 -> String-length_to_chars 0 _ = []-length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8)+lengthToChars :: Int -> Zord64 -> String+lengthToChars 0 _ = []+lengthToChars p n = this:lengthToChars (p-1) (shiftR n 8) where this = chr $ fromIntegral $ n .&. 255
src/Network/XMPP/Print.hs view
@@ -3,6 +3,8 @@ -- Module : Network.XMPP.Print -- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007 -- License : BSD-style (see the file LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental@@ -12,84 +14,94 @@ -- Ported from Text.HTML to HaXML combinatiors -- -----------------------------------------------------------------------------+ module Network.XMPP.Print ( -- Top-level rendering functions renderXmpp , putXmppLn , hPutXmpp+ , hPutNode -- XMPP primitives: tags , stream , streamEnd -- XMPP primitives: attributes , to- , xmlns- , xmllang- , language- , stream_version- , mechanism- , type_- , id_- , from ) where -import System.IO-import Text.XML.HaXml hiding (tag)-import qualified Text.XML.HaXml.Pretty as P- -import Network.XMPP.UTF8-import Network.XMPP.Types-import Network.XMPP.Utils+import System.IO+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Text.XML (Node)+import Text.XML.HaXml hiding (tag)+import Text.XML.HaXml.Posn (Posn)+import qualified Text.XML.HaXml.Pretty as P+import Text.Blaze.Renderer.Text (renderMarkup)+import Text.Blaze (toMarkup) +import Network.XMPP.UTF8+import Network.XMPP.Utils+import Network.XMPP.XML+ -- | Convert the internal representation (built using HaXml combinators) into string, -- and print it out-putXmppLn :: XmppMessage -> IO ()+putXmppLn :: Content Posn -> IO () putXmppLn = putStrLn . renderXmpp -- | Convert the internal representation (built using HaXml combinators) into string, -- and print it to the specified Handle, without trailing newline-hPutXmpp :: Handle -> XmppMessage -> IO ()+hPutXmpp :: Handle -> Content Posn -> IO () hPutXmpp h msg = do let str = renderXmpp msg debugIO $ "Sending: " ++ str hPutStr h $ toUTF8 str +hPutNode :: Handle -> Node -> IO ()+hPutNode h n = do+ let str = T.unpack . TL.toStrict . renderMarkup . toMarkup $ n+ debugIO $ "Sending: " ++ str+ hPutStr h $ toUTF8 str+ -- | Render HaXML combinators into string, hacked for XMPP-renderXmpp :: XmppMessage -> String-renderXmpp theXml =- case theXml of- -- stupid hack for <stream:stream> and </stream:stream>- xml@(CElem (Elem (N "stream:stream") _ _) _) ->- (:) '<' $ takeWhile (/= '<') $ tail $ render $ P.content xml- xml ->- render $ P.content xml+renderXmpp :: Content Posn -> String+renderXmpp theXml = case theXml of+ -- stupid hack for <stream:stream> and </stream:stream>+ xml@(CElem (Elem (N "stream:stream") _ _) _) ->+ (:) '<' $ takeWhile (/= '<') $ tail $ render $ P.content xml+ xml -> render $ P.content xml + --- --- XMPP construction combinators, based on the Text.Html --- +stream :: Show a => a -> T.Text -> CFilter i stream typ server =- ptag "stream:stream"- [ strAttr "xmlns:stream" "http://etherx.jabber.org/streams"- , strAttr "xml:language" "en"- , strAttr "version" "1.0"- , strAttr "to" server- , xmlns (show typ)- ]- [ itag "" [] ] + mkElemAttr "stream:stream"+ [ strAttr "xmlns:stream" "http://etherx.jabber.org/streams"+ , strAttr "xml:language" "en"+ , strAttr "version" "1.0"+ , strAttr "to" $ T.unpack server+ , strAttr "xmlns" (show typ)+ ]+ [ mkElemAttr "" [] [] ]+-- TODO: to use hamlet here, we shoud be able to render non-closing tag like `<stream ...>`+-- but hamlet autho close tags and i see no ways to control it+-- head [xml|+-- <stream:stream+-- xmlns:stream="http://etherx.jabber.org/streams"+-- xml:language="en"+-- version="1.0"+-- to=#{T.pack server}+-- xmlns=#{T.pack (show typ)}+-- />+-- -streamEnd =- ptag "/stream:stream" [] [ itag "" [] ]+streamEnd :: CFilter i+streamEnd = mkElemAttr "/stream:stream" [] [mkElemAttr "" [] []] --- --- Predefined XMPP attributes ---+to :: String -> (String, CFilter i) to = strAttr "to"-xmlns = strAttr "xmlns"-language = strAttr "xml:language" -xmllang = strAttr "xml:lang" -stream_version = strAttr "version"-mechanism = strAttr "mechanism"-type_ = strAttr "type"-id_ = strAttr "id"-from = strAttr "from"
src/Network/XMPP/Sasl.hs view
@@ -1,8 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.Sasl -- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007 -- License : BSD-style (see the file LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental@@ -16,70 +21,80 @@ ( saslAuth ) where -import Control.Monad (when,unless)-import Control.Monad.State (liftIO)-import Data.Char (chr,ord)-import Data.List-import Numeric (showHex)-import System.Random (newStdGen, randoms)-import Text.XML.HaXml.Combinators hiding (when)+import Control.Monad (unless, join)+import Control.Monad.IO.Class+import Control.Monad.Except (throwError, runExceptT,+ lift, ExceptT(..))+import Data.Char (chr, ord)+import Data.List (intercalate)+import qualified Data.Text as T+import Numeric (showHex)+import System.Random (newStdGen, randoms)+import Text.XML.HaXml.Combinators hiding (when)+import Text.Hamlet.XML -import Network.XMPP.Base64 as B64-import Network.XMPP.MD5 -import Network.XMPP.Print-import Network.XMPP.Stream-import Network.XMPP.Types-import Network.XMPP.Utils+import qualified Network.XMPP.Base64 as B64+import qualified Network.XMPP.MD5 as MD5+import Network.XMPP.Stream+import Network.XMPP.Types -- | Perform authentication over already-open channel-saslAuth :: [String] -- ^ List of auth mechanism available from server, currently only "DIGEST-MD5" is supported- -> String -- ^ Server we are connectint to (hostname)- -> String -- ^ Username to connect as- -> String -- ^ Password- -> XmppStateT ()+saslAuth :: MonadIO m+ => [T.Text] -- ^ List of auth mechanism available from server, currently only "DIGEST-MD5" is supported+ -> T.Text -- ^ Server we are connectint to (hostname)+ -> T.Text -- ^ Username to connect as+ -> T.Text -- ^ Password+ -> XmppMonad m (Either XmppError ()) saslAuth mechanisms server username password- | "DIGEST-MD5" `elem` mechanisms = saslDigest server username password- | otherwise = error $ "Dont know how to do auth! Available mechanisms are: " ++ show mechanisms+ | "DIGEST-MD5" `elem` mechanisms+ = saslDigest server username password+ | otherwise+ = let mechs = T.pack . show <$> mechanisms+ in pure $ Left $ NonSupportedAuthMechanisms mechs "DIGEST-MD5" -saslDigest server username password = - do out $ toContent $- ptag "auth"- [ xmlns "urn:ietf:params:xml:ns:xmpp-sasl",- mechanism "DIGEST-MD5" ] []- ch_text <- withNextM getChallenge- resp <- liftIO $ saslDigestResponse ch_text username server password- out $ toContent $- ptag "response"- [ xmlns "urn:ietf:params:xml:ns:xmpp-sasl" ]- [ literal $ resp ]- m <- nextM- when (not $ null $ tag "failure" $ m) (error "Auth failure")- let chl_text = getChallenge m- saslDigestRspAuth chl_text- out $ toContent $- ptag "response"- [ xmlns "urn:ietf:params:xml:ns:xmpp-sasl" ] [] - m <- nextM- unless (not $ null $ tag "success" m) (error "Auth failed")++saslDigest :: MonadIO m => T.Text -> T.Text -> T.Text -> XmppMonad m (Either XmppError ())+saslDigest server username password = runExceptT $ do+ lift $ xmppSend $ head auth+ ch_text <- (join <$> lift (withNextM getChallenge)) >>= either throwError pure+ resp <- liftIO $ saslDigestResponse ch_text username server password+ lift $ xmppSend $ head $ response $ T.pack resp+ m <- lift nextM >>= either throwError pure++ unless (null $ tag "failure" m) $ throwError $ AuthError $ T.pack $ show m++ chl_text <- ExceptT . pure $ getChallenge m+ lift (saslDigestRspAuth chl_text) >>= either throwError pure+ lift $ xmppSend $ head sndResponse+ m <- lift nextM >>= either throwError pure+ unless (not $ null $ tag "success" m) $ throwError $ AuthError $ T.pack $ show m+ where- getChallenge c = - case (tag "challenge" /> txt) c of- [] -> error "Wheres challenge?"- x -> getText_ x+ auth = [xml|<auth xmlns="urn:ietf:params:xml:ns:xmpp-sasl" mechanism="DIGEST-MD5">|]+ response resp = [xml|+ <response xmlns="urn:ietf:params:xml:ns:xmpp-sasl">+ #{resp}+ |]+ sndResponse = [xml|<response xmlns="urn:ietf:params:xml:ns:xmpp-sasl">|]+ getChallenge c =+ case (tag "challenge" /> txt) c of+ [] -> Left $ AuthError "Where is challenge?"+ x -> Right $ getText_ x +saslDigestResponse :: T.Text -> T.Text -> T.Text -> T.Text -> IO String saslDigestResponse chl username server password =- let pairs = get_pairs $ B64.decode chl+ let pairs = getPairs $ B64.decode $ T.unpack chl Just qop = lookup "qop" pairs Just nonce = lookup "nonce" pairs nc = "00000001"- digest_uri ="xmpp/" ++ server+ digest_uri = "xmpp/" ++ T.unpack server realm = server in do cnonce <- make_cnonce- let a1 = semi_sep [ md5raw (Str (semi_sep [username,realm,password])), nonce, cnonce]- let a2 = "AUTHENTICATE:" ++ digest_uri- let t = semi_sep [ md5s (Str a1), nonce, nc, cnonce, qop, md5s (Str a2) ]- let response = md5s (Str t)- let resp = concat [ "username=", show username+ let a1 = semi_sep [ md5raw (MD5.Str (semi_sep $ map T.unpack [username, realm, password])), nonce, cnonce]+ a2 = "AUTHENTICATE:" ++ digest_uri+ t = semi_sep [ MD5.md5s (MD5.Str a1), nonce, nc, cnonce, qop, MD5.md5s (MD5.Str a2) ]+ response = MD5.md5s (MD5.Str t)+ resp = concat [ "username=", show username , ",realm=", show realm , ",nonce=", show nonce , ",cnonce=", show cnonce@@ -90,14 +105,15 @@ ] return $ B64.encode resp where- md5raw = map (chr . read . ("0x"++ ) . take 2) . takeWhile (not.null) . iterate (drop 2) . md5s- hexa str = foldr showHex "" $ map ord str- semi_sep = concat . intersperse ":"+ md5raw = map (chr . read . ("0x"++ ) . take 2) . takeWhile (not.null) . iterate (drop 2) . MD5.md5s+ hexa = foldr (showHex . ord) ""+ semi_sep = intercalate ":" make_cnonce = do g <- newStdGen return $ hexa $ map (chr.(`mod` 256)) $ take 8 $ randoms g -- | Split aaa=bbb,foo="bar" into [("aaa","bbb"),("foo","bar")]-get_pairs str = +getPairs :: String -> [(String, String)]+getPairs str = let chunks = map (takeWhile (/=',')) $ takeWhile (not.null) $ iterate (drop 1 . dropWhile (/=',')) str (keys, values) = unzip $ map (break (=='=')) chunks in zip keys $ map trim values@@ -107,8 +123,9 @@ x@('\"':_) -> read x x -> x +saslDigestRspAuth :: MonadIO m => T.Text -> XmppMonad m (Either XmppError ()) saslDigestRspAuth chl =- let pairs = get_pairs $ B64.decode chl- in case lookup "rspauth" pairs of- Just _ -> return ()- Nothing -> error "NO rspauth in SASL digest rspauth!"+ let pairs = getPairs $ B64.decode $ T.unpack chl+ in case lookup "rspauth" pairs of+ Just _ -> pure $ Right ()+ Nothing -> pure $ Left $ AuthError "No rspauth in SASL digest rspauth!"
src/Network/XMPP/Stanza.hs view
@@ -1,135 +1,160 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+--These can disappear once we remove Content Posn versions+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+++ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.Stanza -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)--- +-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+-- -- Maintainer : k.pierre.k@gmail.com -- Stability : experimental -- Portability : portable ----- XMPP stanzas parsing +-- XMPP stanzas parsing -- ----------------------------------------------------------------------------- module Network.XMPP.Stanza- (- parse- , parseM- , outStanza- ) where + ( StanzaEncoder(..)+ , StanzaDecoder(..)+ ) where -import Text.XML.HaXml.Xtract.Parse (xtract)+import Control.Applicative (Alternative, empty)+import Data.Maybe (mapMaybe, listToMaybe)+import qualified Data.Text as T+import Text.Hamlet.XML (xml)+import Text.XML (Node)+import Text.XML.HaXml (Content)+import Text.XML.HaXml.Posn (Posn)+import Text.XML.HaXml.Xtract.Parse (xtract)+import Network.XMPP.Types+import Network.XMPP.XML -import Network.XMPP.Types-import Network.XMPP.Print-import Network.XMPP.Stream-import Network.XMPP.Utils+-------------------------------------------------------------------------------- -import Data.Maybe+class StanzaEncoder t p e a where+ encodeStanza :: Stanza t p e -> a --- | Parses XML element producing Stanza-parse :: XmppMessage -> Stanza-parse m | xtractp id "/message" m = parseMessage m- | xtractp id "/presence" m = parsePresence m- | xtractp id "/iq" m = parseIQ m- | otherwise = error "Can't read stanza"- where- xtractp f p m = not . null $ xtract f p m+class StanzaDecoder t p e a where+ decodeStanza :: a -> Maybe (Stanza t p e) --- | Gets next message from stream and parses it-parseM :: XmppStateT Stanza-parseM = do- m <- nextM- let pm = parse m in do- debug $ "parseM: Got element: " ++ show pm- return pm+-------------------------------------------------------------------------------- -parseMessage :: XmppMessage -> Stanza-parseMessage m = Message from to id' messageType subject body thread x- where- from = mread $ txt "/message/@from" m- to = read $ getText_ $ xtract id "/message/@to" m- id' = getText_ $ xtract id "/message/@id" m- messageType = read $ getText_ $ xtract id "/message/@type" m- subject = getText_ $ xtract id "/message/subject/-" m- body = getText_ $ xtract id "/message/body/-" m- thread = getText_ $ xtract id "/message/thread/-" m- x = xtract id "/message/*" m+condToAlt :: Alternative m => (x -> Bool) -> x -> m x+condToAlt f x = if f x then pure x else empty -parsePresence :: XmppMessage -> Stanza-parsePresence m = Presence from to id' presenceType showType status priority x- where- from = mread $ txt "/presence/@from" m- to = mread $ txt "/presence/@to" m- id' = txt "/presence/@id" m- presenceType = read $ txt "/presence/@type" m - showType = read $ txt "/presence/show/-" m- status = txt "/presence/status/-" m- priority = mread $ txt "/presence/priority/-" m- x = xtract id "/presence/*" m+toAttrList :: [(String, Maybe a)] -> [(String, a)]+toAttrList = mapMaybe sequence -parseIQ :: XmppMessage -> Stanza-parseIQ m = IQ from to id' iqType body- where- from = mread $ txt "/iq/@from" m- to = mread $ txt "/iq/@to" m- id' = txt "/iq/@id" m- iqType = read $ txt "/iq/@type" m- body = [m]+instance {-# OVERLAPPING #-} StanzaEncoder 'Message 'Outgoing e Node where+ encodeStanza MkMessage{..} = head [xml|+ <message *{messageAttrs} xml:lang=en>+ <body *{bodyAttrs}>+ #{mBody}+ |]+ where+ messageAttrs = toAttrList+ [ ("from", show <$> mFrom)+ , ("to", show <$> mTo)+ , ("id", Just $ T.unpack mId)+ , ("type", Just $ show mType)+ ]+ bodyAttrs = toAttrList+ [ ("subject", T.unpack <$> condToAlt (not . T.null) mSubject)+ , ("thread", T.unpack <$> condToAlt (not . T.null) mThread)+ ] --- | Extract text from `XmppMessage' with supplied pattern-txt :: String -- ^ xtract-like pattern to match- -> XmppMessage -- ^ message being processed- -> String -- ^ result of extraction-txt p m = getText_ $ xtract id p m+instance {-# OVERLAPPING #-} StanzaEncoder 'Presence 'Outgoing e Node where+ encodeStanza MkPresence{ pPurpose = SOutgoing, ..} = head [xml|+ <presence *{attrs} xml:lang="en">+ ^{pExt}+ |]+ where+ attrs = toAttrList+ [ ("from", show <$> pFrom)+ , ("to", show <$> pTo)+ , ("id", T.unpack <$> condToAlt (not . T.null) pId)+ , ("type", show <$> condToAlt (/= Default) pType)+ , ("show", show <$> condToAlt (/= Available) pShowType)+ , ("status", T.unpack <$> condToAlt (not . T.null) pStatus)+ , ("priority", show <$> pPriority)+ ] --- | Converts stanza to XML and outputs it -outStanza :: Stanza -> XmppStateT ()-outStanza s = case s of- a@(Message{}) -> outMessage a- a@(Presence{}) -> outPresence a- a@(IQ{}) -> outIQ a+instance {-# OVERLAPPING #-} StanzaEncoder 'IQ 'Outgoing e Node where+ encodeStanza MkIQ{ iqPurpose = SOutgoing, ..} = head [xml|+ <iq *{attrs} xml:lang="en">+ ^{iqBody}+ |]+ where+ attrs = toAttrList+ [ ("from", show <$> iqFrom)+ , ("to", show <$> iqTo)+ , ("id", Just $ T.unpack iqId)+ , ("type", Just $ show iqType)+ ] -outMessage :: Stanza -> XmppStateT ()-outMessage (Message from' to' id' mtype' subject' body' thread' x') =- out $ toContent $ - ptag "message"- ( (mattr "from" from') ++ - [ strAttr "to" (show to'),- strAttr "id" id',- strAttr "type" (show mtype'),- xmllang "en" ] )- ([ ptag "body" [] [literal body'] ] ++- (if subject' /= "" then [ ptag "subject" [] [literal subject'] ] else []) ++ - (if thread' /= "" then [ ptag "thread" [] [literal thread'] ] else []) ++- (map toFilter x'))-outMessage _ = error "Stanza isn't message"+instance StanzaEncoder t 'Outgoing e Node where+ encodeStanza s@MkPresence{} = encodeStanza s+ encodeStanza s@MkMessage{} = encodeStanza s+ encodeStanza s@MkIQ{} = encodeStanza s -outPresence :: Stanza -> XmppStateT ()-outPresence (Presence from' to' id' ptype' stype' status' priority' x') =- out $ toContent $- ptag "presence"- ((mattr "from" from') ++- (mattr "to" to') ++- (if id' /= "" then [strAttr "id" id'] else []) ++- (if ptype' /= Default then [strAttr "type" (show ptype')] else []) ++- [xmllang "en" ]) - ((if stype' /= Available then [ ptag "show" [] [literal $ show stype'] ] else []) ++- (if status' /= "" then [ ptag "status" [] [ literal status' ] ] else []) ++- (if isJust priority' then [ ptag "priority" [] [ literal $ show (fromJust priority') ] ] else []) ++- (map toFilter x'))-outPresence _ = error "Stanza isn't presence"+instance FromXML e => StanzaDecoder 'Message 'Incoming e (Content Posn) where+ decodeStanza m =+ let content = xtract id "/message/*" m+ in+ Just $ MkMessage+ { mFrom = mread $ txtpat "/message/@from" m+ , mTo = mread $ txtpat "/message/@to" m+ , mId = getText_ $ xtract id "/message/@id" m+ , mType = read $ T.unpack $ getText_ $ xtract id "/message/@type" m+ , mSubject = getText_ $ xtract id "/message/subject/-" m+ , mBody = getText_ $ xtract id "/message/body/-" m+ , mThread = getText_ $ xtract id "/message/thread/-" m+ , mExt = maybe (Left content) Right $ listToMaybe $ mapMaybe decodeXml+ content+ , mPurpose = SIncoming+ } -outIQ :: Stanza -> XmppStateT ()-outIQ (IQ from' to' id' itype' body') =- out $ toContent $- ptag "iq"- ((mattr "from" from') ++- (mattr "to" to') ++ - [ strAttr "id" id',- sattr "type" (show itype'),- xmllang "en" ])- (map toFilter body') -outIQ _ = error "Stanza isn't IQ"+instance FromXML e => StanzaDecoder 'Presence 'Incoming e (Content Posn) where+ decodeStanza m =+ let content = xtract id "/presence/*" m+ in+ Just $ MkPresence+ { pFrom = mread $ txtpat "/presence/@from" m+ , pTo = mread $ txtpat "/presence/@to" m+ , pId = txtpat "/presence/@id" m+ , pType = read $ T.unpack $ txtpat "/presence/@type" m+ , pShowType = read $ T.unpack $ txtpat "/presence/show/-" m+ , pStatus = txtpat "/presence/status/-" m+ , pPriority = mread $ txtpat "/presence/priority/-" m+ , pPurpose = SIncoming+ , pExt = maybe (Left content) Right $ listToMaybe $ mapMaybe decodeXml content+ } +instance FromXML e => StanzaDecoder 'IQ 'Incoming e (Content Posn) where+ decodeStanza m =+ let content = xtract id "/iq/*" m+ in+ Just MkIQ+ { iqFrom = mread $ txtpat "/iq/@from" m+ , iqTo = mread $ txtpat "/iq/@to" m+ , iqId = txtpat "/iq/@id" m+ , iqType = read $ T.unpack $ txtpat "/iq/@type" m+ , iqBody = maybe (Left content) Right $ listToMaybe $ mapMaybe decodeXml+ content+ , iqPurpose = SIncoming+ }
src/Network/XMPP/Stream.hs view
@@ -1,8 +1,18 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.Stream -- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007 -- License : BSD-style (see the file LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental@@ -12,142 +22,196 @@ -- ----------------------------------------------------------------------------- module Network.XMPP.Stream- ( - out- , startM- , nextM - , withNextM- , selectM- , xtractM- , textractM- , withSelectM- , withNewStream- , withStream- , resetStreamHandle- , getText- , getText_- , loopWithPlugins+ ( XmppSendable(..) , Plugin(..)+ , XmppError(..)+ , startM, nextM, withNextM, selectM, xtractM, textractM, withSelectM+ , resetStreamHandle, getText, getText_+ , loopWithPlugins , getNextId- , lookupAttr- , newStream+ , parse, parseM, waitAndProcess+ , withUUID ) where -import Control.Monad.State-import System.IO-import Text.ParserCombinators.Poly.State (onFail)-import Text.XML.HaXml.Lex (xmlLex)-import Text.XML.HaXml.Parse-import Text.XML.HaXml.Posn (noPos)-import Text.XML.HaXml.Types-import qualified Text.XML.HaXml.Pretty as P (content)-import Text.XML.HaXml.Xtract.Parse (xtract)--import Network.XMPP.Print-import Network.XMPP.Utils-import Network.XMPP.Types-import Network.XMPP.UTF8+import Control.Monad (void)+import Control.Monad.State (MonadState(..), gets, modify)+import Control.Monad.Except (runExceptT, throwError, lift)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Applicative (Alternative, empty)+import System.IO (Handle, hGetContents)+import Data.Text (Text, unpack, pack)+import qualified Data.UUID.V4 as UUID+import qualified Data.UUID as UUID+import Data.Functor (($>)) --- For a definition of 'Stream' see Network.XMPP.Types.+import Text.XML (Node)+import Text.XML.HaXml.Lex (xmlLex)+import Text.XML.HaXml.Parse+import Text.XML.HaXml.Posn (Posn, noPos)+import Text.XML.HaXml.Types+import qualified Text.XML.HaXml.Pretty as P (content)+import Text.XML.HaXml.Xtract.Parse (xtract)+import Text.ParserCombinators.Poly.State (onFail) --- In the beginning, all Stream buffers are empty, and by default it is bound to stdin.--- Functions like 'openStreamTo' or 'openStreamViaProxyTo' could override this.-newStream :: Stream -newStream = Stream { handle=stdin, idx=0, lexemes=[] }+import Network.XMPP.Print (hPutNode, hPutXmpp)+import Network.XMPP.Utils+import Network.XMPP.Types+import Network.XMPP.UTF8+import Network.XMPP.XML+import Network.XMPP.Stanza --- Main 'workhorses' for Stream are 'out', 'nextM', 'peekM' and 'selectM':+-- Main 'workhorses' for Stream are 'xmppSend', 'nextM', 'peekM' and 'selectM': -- | Sends message into Stream-out :: XmppMessage -> XmppStateT ()-out xmpp = do h <- gets handle- liftIO $ hPutXmpp h xmpp+class XmppSendable t a where+ xmppSend :: Monad t => a -> t () +instance MonadIO m => XmppSendable (XmppMonad m) Node where+ xmppSend node = do+ h <- gets handle+ liftIO $ hPutNode h node++instance MonadIO m => XmppSendable (XmppMonad m) (Content Posn) where+ xmppSend content = do+ h <- gets handle+ liftIO $ hPutXmpp h content++instance MonadIO m => XmppSendable (XmppMonad m) (Stanza t 'Outgoing e) where+ xmppSend s = xmppSend (encodeStanza s :: Node)++data XmppError =+ StreamClosedError+ | MessageParseError Text Text+ | NonSupportedAuthMechanisms [Text] Text+ | AuthError Text+ | RanOutOfInput+ | UnknownVersion Text+ | UnknownError Text+ deriving (Eq, Show)++-- | Parses XML element producing Stanza+parse :: forall l e. (Alternative l, FromXML e) => Content Posn -> l (SomeStanza e)+parse m | xtractp id "/message" m = mSucceed (decodeStanza m :: Maybe (Stanza 'Message 'Incoming e))+ | xtractp id "/presence" m = mSucceed (decodeStanza m :: Maybe (Stanza 'Presence 'Incoming e))+ | xtractp id "/iq" m = mSucceed (decodeStanza m :: Maybe (Stanza 'IQ 'Incoming e))+ | otherwise = empty+ where xtractp f p m = not . null $ xtract f p m+ mSucceed :: (Alternative l, FromXML e) => Maybe (Stanza t p e) -> l (SomeStanza e)+ mSucceed = maybe empty (pure . SomeStanza)++-- | Gets next message from stream and parses it+-- | We shall skip over unknown messages, rather than crashing+parseM :: (FromXML e, MonadIO m) => XmppMonad m (Either XmppError (SomeStanza e))+parseM = (fmap parse <$> nextM) >>= \case+ Right m -> maybe parseM (pure . Right) m+ Left e -> pure $ Left e++-- | Skips all messages, that will return result `Nothing` from computation+-- | In other words - waits for appropriate message, defined by predicate+waitAndProcess+ :: (FromXML e, MonadIO m)+ => (SomeStanza e -> Maybe a)+ -> XmppMonad m (Either XmppError a)+waitAndProcess compute = parseM >>= \case+ Right m -> maybe (waitAndProcess compute) (pure . Right) $ compute m+ Left err -> pure $ Left err++withUUID :: MonadIO m => (UUID.UUID -> Stanza t p e) -> m (Stanza t p e)+withUUID setUUID = setUUID <$> liftIO UUID.nextRandom+ -- | Selects next messages from stream-nextM :: XmppStateT XmppMessage-nextM = - do ls <- gets lexemes- let (elem, rest) = xmlParseWith element ls- case elem of - (Left err) -> error $ "Failed to parse next element: " ++ show err- (Right e) -> do let msg = CElem e noPos- debug $ "nextM: Got element: " ++ show (P.content msg)- modify (\stream -> stream { lexemes = rest } )- return msg+nextM :: MonadIO m => XmppMonad m (Either XmppError (Content Posn))+nextM = runExceptT $ do+ ls <- lift $ gets lexemes + if null ls then throwError RanOutOfInput else pure ()++ case xmlParseWith (elemCloseTag $ N "stream:stream") ls of+ (Right (), rest) -> do+ modify (\stream -> stream { lexemes = rest })+ throwError StreamClosedError -- all subsequent queries will end by EOF exception+ _ -> case xmlParseWith element ls of+ (Right e, rest) -> do+ let msg = CElem e noPos+ lift $ debug $ "nextM: Got element: " ++ show (P.content msg)+ modify (\stream -> stream { lexemes = rest }) $> msg+ (Left err, _) ->+ throwError $ MessageParseError (pack $ show ls) $ pack $ show err+ -- | Selects next message matching predicate-selectM :: (XmppMessage -> Bool) -> XmppStateT XmppMessage-selectM p =- do m <- nextM- if p m then return m- else error "Failed to select message"+selectM+ :: MonadIO m+ => (Content Posn -> Bool)+ -> XmppMonad m (Either XmppError (Content Posn))+selectM p = runExceptT $ do+ m <- lift nextM >>= either throwError pure+ if p m then pure m else throwError $ UnknownError "Failed to select message" -- | Pass in xtract query, return query result from the first message where it returns non-empty results-xtractM :: String -> XmppStateT [XmppMessage]-xtractM q = - do m <- selectM (not . null . (xtract id q))- return $ xtract id q m+xtractM :: MonadIO m => Text -> XmppMonad m [Content Posn]+xtractM q =do+ eim <- selectM (not . null . xtract id (unpack q))+ case eim of+ Right m -> pure $ xtract id (unpack q) m+ Left _e -> pure [] -- TODO -textractM :: String -> XmppStateT String-textractM q = do res <- xtractM q- return $ case res of- [] -> ""- x -> getText_ x+textractM :: MonadIO m => Text -> XmppMonad m Text+textractM q = do+ res <- xtractM q+ pure $ case res of+ [] -> ""+ x -> getText_ x --- All accessor functions have a convenience wrappers:-withM acc f = do m <- acc; return (f m)-withNextM = withM nextM-withSelectM p = withM (selectM p)+withNextM :: MonadIO m => (Content Posn -> b) -> XmppMonad m (Either XmppError b)+withNextM compute = fmap compute <$> nextM +withSelectM+ :: MonadIO m+ => (Content Posn -> Bool)+ -> (Content Posn -> b)+ -> XmppMonad m (Either XmppError b)+withSelectM predicate compute =+ selectM predicate >>= either (pure . Left) (pure . Right . compute)++ -- | startM is a special accessor case, since it has to retrieve only opening tag of the '<stream>' message, -- which encloses the whole XMPP stream. That's why it does it's own parsing, and does not rely on 'nextM'-startM :: XmppStateT [Attribute]-startM =- do ls <- gets lexemes- let (starter, rest) = xmlParseWith streamStart ls- case starter of- Left e -> error e- Right (ElemTag (N "stream:stream") attrs) -> do modify (\stream -> stream { lexemes=rest })- return attrs- Right _ -> error $ "Unexpected element at the beginning of XMPP stream!"- where- streamStart = do ( processinginstruction >> return () ) `onFail` return ()- elemOpenTag---- | Convenience wrappers which allow for nicer code like:--- withNewStream $ do ...-withNewStream :: XmppStateT a -> IO (a, Stream)-withNewStream f = - do let stream = newStream- f `runStateT` stream-withStream :: Stream -> XmppStateT a -> IO (a, Stream)-withStream s f = f `runStateT` s+startM :: MonadIO m => XmppMonad m (Either XmppError [Attribute])+startM = do+ (starter, rest) <- xmlParseWith streamStart <$> gets lexemes+ case starter of+ Left e -> pure $ Left $ UnknownError $ pack e+ Right (ElemTag (N "stream:stream") attrs) ->+ modify (\stream -> stream { lexemes = rest }) $> Right attrs+ Right _ ->+ pure $ Left $ UnknownError "Unexpected element at the beginning of XMPP stream!"+ where+ streamStart = void processinginstruction `onFail` return () >> elemOpenTag --- | Replaces contents of the Stream with the contents--- coming from given handle.+-- | Replaces contents of the Stream with the contents coming from given handle.+resetStreamHandle :: (MonadIO m, MonadState Stream m) => Handle -> m () resetStreamHandle h = do c <- liftIO $ hGetContents h modify (\stream -> stream { handle=h , lexemes = xmlLex "stream" (fromUTF8 c) }) ------------------------------- -- Basic plugin support-data Plugin = Plugin { trigger::String, body::(XmppMessage -> XmppStateT ()) }+data Plugin+ = Plugin+ { trigger :: String+ , body :: Content Posn -> XmppMonad IO ()+ } -loopWithPlugins :: [Plugin] -> XmppStateT ()+loopWithPlugins :: [Plugin] -> XmppMonad IO (Either Text ()) loopWithPlugins ps =- let loop = do m <- nextM- sequence_ [ (body p) m | p <- ps, not (null (xtract id (trigger p) m)) ]- loop- in loop--getNextId :: XmppStateT Int-getNextId =- do i <- gets idx- modify (\stream -> stream { idx = i+1 })- return i--lookupAttr :: String -> [Attribute] -> Maybe String-lookupAttr k lst =- do x <- lookup (N k) lst- case x of- AttValue [Left str] -> Just str- AttValue _ -> Nothing+ let loop = nextM >>= \case+ Right m -> do+ let notEmpty p = not $ null $ xtract id (trigger p) m+ sequence_ [ body p m | p <- ps, notEmpty p ] >> loop+ Left _e -> loop+ in loop +getNextId :: MonadIO m => XmppMonad m Int+getNextId = do+ i <- gets idx+ modify (\stream -> stream { idx = i + 1 })+ return i
src/Network/XMPP/Types.hs view
@@ -1,58 +1,183 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.Types -- Copyright : (c) Dmitry Astapov, 2006 ; pierre, 2007 -- License : BSD-style (see the file LICENSE)--- +-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+-- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental -- Portability : portable -- ------------------------------------------------------------------------------module Network.XMPP.Types- ( XmppMessage- , XmppStateT- , Stream(..)- , StreamType(..)- , Stanza(..)- , MessageType(..), PresenceType(..), IQType(..), ShowType(..)- , RosterItem(..)- , defaultStreamBlockSize- , isMessage, isPresence, isIQ- ) where+module Network.XMPP.Types where -import System.IO (Handle)-import Control.Monad.State (StateT)+import System.IO (Handle, stdin)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans (MonadTrans)+import Control.Monad.State (MonadState, StateT, runStateT)+import Data.Maybe (maybeToList)+import qualified Data.Text as T -import Text.XML.HaXml.Types (Content)-import Text.XML.HaXml.Posn (Posn)-import Text.XML.HaXml.Lex (Token)- -import Text.PrettyPrint.HughesPJ (render)-import qualified Text.XML.HaXml.Pretty as P (content)+import Text.Blaze (ToMarkup (toMarkup))+import Text.Regex+import Text.XML.HaXml.Types (Content)+import Text.XML.HaXml.Posn (Posn)+import Text.XML.HaXml.Lex (Token)+import Text.XML (Node)+import Singlethongs+-------------------------------------------------------------------------------- -import Network.XMPP.JID+type Server = T.Text+type Username = T.Text+type Password = T.Text+type Resource = T.Text --- | XMPP message in the parsed form-type XmppMessage = Content Posn +-------------------------------------------------------------------------------- --- | XMPP stream, used as a state in XmppStateT state transformer-data Stream = Stream { handle::Handle - -- ^ IO handle to the underlying file or socket- , idx :: !Int- -- ^ id of the next message (if needed)- , lexemes :: [Token]- -- ^ Stream of the lexemes coming from server- }+-- | XMPP stream, used as a state in XmppMonad state transformer+data Stream+ = Stream+ { handle::Handle -- ^ IO handle to the underlying file or socket+ , idx :: !Int -- ^ id of the next message (if needed)+ , lexemes :: [Token] -- ^ Stream of the lexemes coming from server+ } --- | Since XMPP is network-oriented, block size is equal to maximal MTU-defaultStreamBlockSize :: Int-defaultStreamBlockSize = 1500+newtype XmppMonad m a+ = XmppMonad { unXmppMonad :: StateT Stream m a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadState Stream, MonadTrans) --- | XmppStateT is a state transformer over IO monad, using Stream as a "state holder".--- For API, look into 'Network.XMPP.Stream'-type XmppStateT a = StateT Stream IO a+runXmppMonad :: MonadIO m => XmppMonad m a -> m (a, Stream)+runXmppMonad = flip runStateT newStream . unXmppMonad+ where newStream = Stream { handle = stdin, idx = 0, lexemes = [] } +runXmppMonad' :: MonadIO m => Stream -> XmppMonad m a -> m (a, Stream)+runXmppMonad' s = flip runStateT s . unXmppMonad++--------------------------------------------------------------------------------+-- | Jabber ID (JID) datatype+--+-- https://xmpp.org/extensions/xep-0029.html#sect-idm45723967532368+-- <JID> - [<node>"@"]<domain>["/"<resource>]+-- <node> - <conforming-char>[<conforming-char>]* - The node identifier (optional)+-- <domain> - <hname>["."<hname>]* - The domain identifier (required)+-- <resource> - <any-char>[<any-char>]* - The resource identifier (optional)++newtype DomainID = DomainID { unDomainID :: T.Text } deriving (Eq, Show)++newtype NodeID = NodeID { unNodeID :: T.Text } deriving (Eq, Show)++newtype ResourceID = ResourceID { unResourceID :: T.Text } deriving (Eq, Show)++data JIDQualification+ = Resource+ | NodeResource+ | Node+ | Domain++data SomeJID = forall (a :: JIDQualification). SomeJID (JID a)++data JID :: JIDQualification -> * where+ ResourceJID :: { jrDomain :: DomainID+ , jrResource :: ResourceID+ } -> JID 'Resource++ NodeResourceJID :: { jnrNode :: NodeID -- ^ Account name+ , jnrDomain :: DomainID -- ^ Server adress+ , jnrResource :: ResourceID -- ^ Resource name+ } -> JID 'NodeResource+ NodeJID :: { nNode :: NodeID+ , nDomain :: DomainID+ } -> JID 'Node+ DomainJID :: { jdDomain :: DomainID } -> JID 'Domain++toBareJID :: JID 'NodeResource -> JID 'Node+toBareJID (NodeResourceJID node domain _) = NodeJID node domain++instance Read (JID 'NodeResource) where+ readsPrec prev str =+ case readsPrec prev str of+ [(SomeJID j@NodeResourceJID{}, after)] -> [(j, after)]+ _ -> []++instance Read (JID 'Resource) where+ readsPrec prev str =+ case readsPrec prev str of+ [(SomeJID j@ResourceJID{}, after)] -> [(j, after)]+ _ -> []++instance Read (JID 'Domain) where+ readsPrec prev str =+ case readsPrec prev str of+ [(SomeJID j@DomainJID{}, after)] -> [(j, after)]+ _ -> []++instance Read (JID 'Node) where+ readsPrec prev str =+ case readsPrec prev str of+ [(SomeJID j@NodeJID{}, after)] -> [(j, after)]+ _ -> []++instance Read SomeJID where+ -- Reads JID from string (name@server\/resource)+ readsPrec _ str = case matchRegexAll regex str of+ Just (_, _, after, [_, name, _, server, _, _, resource, _]) ->+ fmap (, after) . maybeToList $ case (toMaybe name, server, toMaybe resource) of+ (Just node, domain, Just resource) ->+ let nodeId = NodeID $ T.pack node+ domainId = DomainID $ T.pack domain+ resourceId = ResourceID $ T.pack resource+ in Just $ SomeJID $ NodeResourceJID nodeId domainId resourceId+ (Just node, domain, Nothing) ->+ let nodeId = NodeID $ T.pack node+ domainId = DomainID $ T.pack domain+ in Just $ SomeJID $ NodeJID nodeId domainId+ (Nothing, domain, Nothing) ->+ Just $ SomeJID $ DomainJID $ DomainID $ T.pack domain+ (Nothing, domain, Just resource) ->+ let domainId = DomainID $ T.pack domain+ resourceId = ResourceID $ T.pack resource+ in Just $ SomeJID $ ResourceJID domainId resourceId+ _ -> []+ where+ toMaybe "" = Nothing+ toMaybe s = Just s+ regex = mkRegex $ "((([^@])+)@)?" ++ "(([^/])+)" ++ "(/((.)+))?"++instance Show SomeJID where+ show (SomeJID j) = show j++instance Show (JID a) where+ show (NodeResourceJID (NodeID node) (DomainID domain) (ResourceID resource)) =+ T.unpack $ node <> "@" <> domain <> "/" <> resource+ show (ResourceJID (DomainID domain) (ResourceID resource)) =+ T.unpack $ domain <> "/" <> resource+ show (DomainJID (DomainID domain)) = T.unpack domain+ show (NodeJID (NodeID node) (DomainID domain)) =+ T.unpack $ node <> "@" <> domain++deriving instance Eq (JID a)++instance ToMarkup (JID a) where+ toMarkup = toMarkup . show++--------------------------------------------------------------------------------+ -- | XMPP Stream type, used in 'stream' pretty-printing combinator and the likes data StreamType = Client -- ^ Client-to-server | ComponentAccept -- ^ FIXME@@ -64,10 +189,10 @@ show ComponentConnect = "jabber:component:connect" -- | Roster item type (7.1)-data RosterItem = RosterItem { jid :: JID+data RosterItem = RosterItem { jid :: JID 'NodeResource -- ^ Entry's JID , subscribtion :: SubscribtionType- -- ^ Subscribtion type + -- ^ Subscribtion type , nickname :: Maybe String -- ^ Entry's nickname , groups :: [String]@@ -87,60 +212,19 @@ readsPrec _ "to" = [(To, "")] readsPrec _ "from" = [(From, "")] readsPrec _ "both" = [(Both, "")]- readsPrec _ "" = [(None, "")] + readsPrec _ "" = [(None, "")] readsPrec _ _ = error "incorrect subscribtion type" --- | Generic XMPP stream atom-data Stanza = Message { mFrom :: Maybe JID- , mTo :: JID- , mId :: String- -- ^ Message 'from', 'to', 'id' attributes - , mType :: MessageType- -- ^ Message type (2.1.1)- , mSubject :: String- -- ^ Subject element (2.1.2.1)- , mBody :: String- -- ^ Body element (2.1.2.2)- , mThread :: String- -- ^ Thread element (2.1.2.3)- , mExt :: [Content Posn]- -- ^ Additional contents, used for extensions- }- | Presence { pFrom :: Maybe JID- , pTo :: Maybe JID- , pId :: String- -- ^ Presence 'from', 'to', 'id' attributes- , pType :: PresenceType- -- ^ Presence type (2.2.1)- , pShowType :: ShowType- -- ^ Show element (2.2.2.1)- , pStatus :: String- -- ^ Status element (2.2.2.2)- , pPriority :: Maybe Integer- -- ^ Presence priority (2.2.2.3)- , pExt :: [Content Posn]- -- ^ Additional contents, used for extensions- }- | IQ { iqFrom :: Maybe JID- , iqTo :: Maybe JID- , iqId :: String- -- ^ IQ id (Core-9.2.3)- , iqType :: IQType- -- ^ IQ type (Core-9.2.3)- , iqBody :: [Content Posn]- -- ^ Child element (Core-9.2.3)- } deriving Show- -data MessageType = Chat | GroupChat | Headline | Normal | MessageError deriving Eq- -data PresenceType = Default | Unavailable | Subscribe | Subscribed | Unsubscribe | Unsubscribed | Probe | PresenceError deriving Eq -data IQType = Get | Result | Set | IQError deriving Eq--data ShowType = Available | Away | FreeChat | DND | XAway deriving Eq+-------------------------------------------------------------------------------- -instance Show (Content a) where- show = render . P.content+data MessageType+ = Chat+ | GroupChat+ | Headline+ | Normal+ | MessageError+ deriving (Eq) instance Show MessageType where show Chat = "chat"@@ -148,7 +232,26 @@ show Headline = "headline" show Normal = "normal" show MessageError = "error"+instance Read MessageType where+ readsPrec _ "chat" = [(Chat, "")]+ readsPrec _ "groupchat" = [(GroupChat, "")]+ readsPrec _ "headline" = [(Headline, "")]+ readsPrec _ "normal" = [(Normal, "")]+ readsPrec _ "error" = [(MessageError, "")]+ readsPrec _ "" = [(Chat, "")]+ readsPrec _ _ = error "incorrect message type" +data PresenceType+ = Default+ | Unavailable+ | Subscribe+ | Subscribed+ | Unsubscribe+ | Unsubscribed+ | Probe+ | PresenceError+ deriving (Eq)+ instance Show PresenceType where show Default = "" show Unavailable = "unavailable"@@ -158,29 +261,6 @@ show Unsubscribed = "unsubscribed" show Probe = "probe" show PresenceError = "error"--instance Show IQType where- show Get = "get"- show Result = "result"- show Set = "set"- show IQError = "error"--instance Show ShowType where- show Available = ""- show Away = "away"- show FreeChat = "chat"- show DND = "dnd"- show XAway = "xa"--instance Read MessageType where- readsPrec _ "chat" = [(Chat, "")]- readsPrec _ "groupchat" = [(GroupChat, "")]- readsPrec _ "headline" = [(Headline, "")]- readsPrec _ "normal" = [(Normal, "")]- readsPrec _ "error" = [(MessageError, "")]- readsPrec _ "" = [(Chat, "")] - readsPrec _ _ = error "incorrect message type"- instance Read PresenceType where readsPrec _ "" = [(Default, "")] readsPrec _ "available" = [(Default, "")]@@ -192,7 +272,19 @@ readsPrec _ "probe" = [(Probe, "")] readsPrec _ "error" = [(PresenceError, "")] readsPrec _ _ = error "incorrect presence type"- ++data IQType+ = Get+ | Result+ | Set+ | IQError+ deriving (Eq)++instance Show IQType where+ show Get = "get"+ show Result = "result"+ show Set = "set"+ show IQError = "error" instance Read IQType where readsPrec _ "get" = [(Get, "")] readsPrec _ "result" = [(Result, "")]@@ -201,25 +293,96 @@ readsPrec _ "" = [(Get, "")] readsPrec _ _ = error "incorrect iq type" +data ShowType = Available+ | Away+ | FreeChat+ | DND+ | XAway+ deriving (Eq)++instance Show ShowType where+ show Available = ""+ show Away = "away"+ show FreeChat = "chat"+ show DND = "dnd"+ show XAway = "xa" instance Read ShowType where readsPrec _ "" = [(Available, "")] readsPrec _ "available" = [(Available, "")] readsPrec _ "away" = [(Away, "")] readsPrec _ "chat" = [(FreeChat, "")] readsPrec _ "dnd" = [(DND, "")]- readsPrec _ "xa" = [(XAway, "")] + readsPrec _ "xa" = [(XAway, "")] readsPrec _ "invisible" = [(Available, "")] readsPrec _ _ = error "incorrect <show> value" --- | Utility functions -isMessage :: Stanza -> Bool-isMessage Message{} = True-isMessage _ = False+--------------------------------------------------------------------------------+-- | Generic XMPP stream atom -isPresence :: Stanza -> Bool-isPresence Presence{} = True-isPresence _ = False+data StanzaPurpose = Incoming | Outgoing+ deriving (Eq, Show) -isIQ :: Stanza -> Bool-isIQ IQ{} = True-isIQ _ = False+singlethongs ''StanzaPurpose++data SomeStanza e+ = forall (a :: StanzaType) (p :: StanzaPurpose)+ . SomeStanza (Stanza a p e)++instance Show e => Show (SomeStanza e) where+ show (SomeStanza (s@MkMessage {mPurpose = SIncoming})) = "(SomeStanza $ " <> show s <> ")"+ show (SomeStanza (s@MkMessage {mPurpose = SOutgoing})) = "(SomeStanza $ " <> show s <> ")"+ show (SomeStanza (s@MkPresence {pPurpose = SIncoming})) = "(SomeStanza $ " <> show s <> ")"+ show (SomeStanza (s@MkPresence {pPurpose = SOutgoing})) = "(SomeStanza $ " <> show s <> ")"+ show (SomeStanza (s@MkIQ {iqPurpose = SIncoming})) = "(SomeStanza $ " <> show s <> ")"+ show (SomeStanza (s@MkIQ {iqPurpose = SOutgoing})) = "(SomeStanza $ " <> show s <> ")"++data StanzaType+ = Message+ | Presence+ | IQ++type family DataByPurpose (p :: StanzaPurpose) body where+ DataByPurpose 'Incoming body = Either [Content Posn] body+ DataByPurpose 'Outgoing body = [Node]++data Stanza :: StanzaType -> StanzaPurpose -> * -> * where+ MkMessage ::+ { mFrom :: Maybe SomeJID+ , mTo :: Maybe SomeJID+ , mId :: T.Text -- ^ Message 'from', 'to', 'id' attributes+ , mType :: MessageType -- ^ Message type (2.1.1)+ , mSubject :: T.Text -- ^ Subject element (2.1.2.1)+ , mBody :: T.Text -- ^ Body element (2.1.2.2)+ , mThread :: T.Text -- ^ Thread element (2.1.2.3)+ , mExt :: DataByPurpose p ext -- ^ Additional contents, used for extensions+ , mPurpose :: Sing p+ }+ -> Stanza 'Message p ext+ MkPresence ::+ { pFrom :: Maybe SomeJID+ , pTo :: Maybe SomeJID+ , pId :: T.Text -- ^ Presence 'from', 'to', 'id' attributes+ , pType :: PresenceType -- ^ Presence type (2.2.1)+ , pShowType :: ShowType -- ^ Show element (2.2.2.1)+ , pStatus :: T.Text -- ^ Status element (2.2.2.2)+ , pPriority :: Maybe Integer -- ^ Presence priority (2.2.2.3)+ , pExt :: DataByPurpose p ext -- ^ Additional contents, used for extensions+ , pPurpose :: Sing p+ }+ -> Stanza 'Presence p ext+ MkIQ ::+ { iqFrom :: Maybe SomeJID+ , iqTo :: Maybe SomeJID+ , iqId :: T.Text -- ^ IQ id (Core-9.2.3)+ , iqType :: IQType -- ^ IQ type (Core-9.2.3)+ , iqBody :: DataByPurpose p ext -- ^ Child element (Core-9.2.3)+ , iqPurpose :: Sing p+ }+ -> Stanza 'IQ p ext++instance Show (Sing 'Incoming) where+ show _ = "incoming"+instance Show (Sing 'Outgoing) where+ show _ = "outgoing"++deriving instance Show (Sing (dir :: StanzaPurpose)) => Show (DataByPurpose dir ext) => Show ext => Show (Stanza t dir ext)
src/Network/XMPP/UTF8.hs view
@@ -43,6 +43,10 @@ -} +-- |+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+ module Network.XMPP.UTF8 ( fromUTF8, toUTF8 ) where
src/Network/XMPP/Utils.hs view
@@ -4,6 +4,8 @@ -- Module : Network.XMPP.Utils -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental@@ -13,81 +15,12 @@ -- ----------------------------------------------------------------------------- -module Network.XMPP.Utils- (- toContent- , toFilter- , noelem- , sattr- , strAttr- , ptag- , itag- , getVals- , isVal- , getText- , getText_- , mread- , mattr- , mattr'- , debug- , debugIO- , literal -- from HaXML- ) where--import Control.Monad.State-import Text.XML.HaXml hiding (tag)-import Text.XML.HaXml.Posn -import qualified Text.XML.HaXml.Pretty as P-import Text.PrettyPrint.HughesPJ (hcat)-import Text.XML.HaXml.Xtract.Parse (xtract)- -import Network.XMPP.Types---- | Conversion from\/to HaXML's Content and CFilter -toContent :: CFilter Posn -> Content Posn-toContent filter =- head $ filter (CElem noelem noPos) --toFilter :: Content Posn -> CFilter Posn-toFilter x = (\_ -> [x])--noelem = - Elem (N "root") [] []--strAttr s d = (s, literal d)-sattr = strAttr--ptag = mkElemAttr-itag s att = mkElemAttr s att []---- | Returns strings extracted by xtract query -getVals :: String ->- [Content Posn] ->- [String]-getVals q ext = map (\x -> getText_ $ xtract id q x) ext---- | Queries xml for specific value--- @isVal str = any (== str) . getVals@-isVal :: String -> String -> [Content Posn] -> Bool-isVal str cont = any (== str) . (getVals cont)---- -getText cs@(CString{}) = render . P.content $ cs-getText cs@(CRef{}) = render . P.content $ cs-getText x = error $ "Attempt to extract text from content that is not a string: " ++ render ( P.content x )--getText_ = render . hcat . map P.content- -mread "" = Nothing-mread a = Just $ read a--mattr s (Just a) = [ strAttr s (show a) ]-mattr _ Nothing = []+module Network.XMPP.Utils ( debug, debugIO ) where -mattr' s (Just a) = [ strAttr s a ]-mattr' _ Nothing = []+import Control.Monad.IO.Class (MonadIO)+import Network.XMPP.Types -debug :: String -> XmppStateT ()+debug :: MonadIO m => String -> XmppMonad m () debugIO :: String -> IO () #ifdef DEBUG debug = liftIO . putStrLn
src/Network/XMPP/XEP/Delayed.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.XEP.Delayed -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental@@ -22,7 +28,9 @@ import Text.XML.HaXml.Xtract.Parse (xtract) -- | True, if stanza is delivered delayed-isDelayed :: Stanza -> Bool-isDelayed (Message _ _ _ _ _ _ _ ext) =- any (== "jabber:x:delay") $ map (\x -> getText_ $ xtract id "/x/@xmlns" x) ext+isDelayed :: Stanza a 'Incoming () -> Bool+isDelayed (MkMessage _ _ _ _ _ _ _ ext _) =+ case ext of+ Right () -> False+ Left c -> any (== "jabber:x:delay") $ map (getText_ . xtract id "/x/@xmlns") c isDelayed _ = False
+ src/Network/XMPP/XEP/Form.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+--+-----------------------------------------------------------------------------+module Network.XMPP.XEP.Form where++import Text.Hamlet.XML (xml)+import Text.XML.HaXml.Xtract.Parse (xtract)++import Data.Maybe+import Data.List (find)+import qualified Data.Text as T++import Network.XMPP.XML++-- Specification:+-- https://xmpp.org/extensions/xep-0004.html#table-2+--++-- https://xmpp.org/extensions/xep-0004.html#table-2+instance FromXML XmppField where+ decodeXml m =+ let _label = txtpat "/field/@label" m+ typ = txtpat "/field/@type" m+ variable = txtpat "/field/@var" m+ in case typ of+ "boolean" -> BooleanField variable <$> boolVal+ "text-single" -> Just $ SingleTextField variable txtSingleVal+ "list-single" ->+ Just $ ListSingleField variable listOptions txtSingleVal+ "list-multi" -> Just $ ListMultiField variable listOptions listValues+ "hidden" -> Just $ HiddenField variable txtSingleVal+ _ -> Nothing+ where+ listValues = txtpat "/value/-" <$> xtract id "/field/value/" m+ listOptions = txtpat "/value/-" <$> xtract id "/field/option/value" m+ txtSingleVal = txtpat "/field/value/-" m+ boolVal = case txtpat "/field/value/-" m of+ "0" -> Just False+ "1" -> Just True+ _ -> Nothing+++newtype XmppForm = XmppForm [XmppField] deriving (Eq, Show)++type FieldName = T.Text++data XmppField =+ SingleTextField+ { xfName :: FieldName+ , stfValue :: T.Text+ }+ | ListSingleField+ { xfName :: FieldName+ , lsfOptions :: [T.Text]+ , lsfValue :: T.Text+ }+ | BooleanField+ { xfName :: FieldName+ , bfValue :: Bool+ }+ | ListMultiField+ { xfName ::FieldName+ , lmfOptions :: [T.Text]+ , lmfValue :: [T.Text]+ }+ | HiddenField { xfName :: T.Text, hfValue :: T.Text }+ deriving (Eq, Show)++updateFormField :: FieldName -> (XmppField -> XmppField) -> XmppForm -> XmppForm+updateFormField fname update (XmppForm fields) =+ let mField = update <$> find ((== fname) . xfName) fields+ nextFields =+ (<> maybeToList mField) . filter ((/= fname) . xfName) $ fields+ in XmppForm nextFields++setBoolValue :: Bool -> XmppField -> XmppField+setBoolValue val (BooleanField name _) = BooleanField name val+setBoolValue _ field = field++instance FromXML XmppForm where+ decodeXml = Just . XmppForm . mapMaybe decodeXml . xtract id "/x/field"++instance ToXML XmppForm where+ encodeXml (XmppForm fields) =+ [xml|+ <x xmlns="jabber:x:data" type="submit">+ $forall field <- fields+ $case field+ $of HiddenField name value+ <field var=#{name}>+ <value>#{value}++ $of SingleTextField name value+ <field var=#{name}>+ <value>#{value}++ $of BooleanField name value+ <field var=#{name}>+ <value>+ $if value+ 1+ $else+ 0++ $of ListSingleField name _opts value+ <field var=#{name}>+ <value>#{value}++ $of ListMultiField name _opts values+ <field var=#{name}>+ $forall value <- values+ <value>#{value}+ |]
+ src/Network/XMPP/XEP/MAM.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+--+-----------------------------------------------------------------------------+module Network.XMPP.XEP.MAM+ ( messageArchiveQueryStanza+ , defMamQuery+ , MAMQuery(..)+ , MAMPayload(..)+ ) where++import qualified Data.UUID as UUID+import Data.Time (UTCTime)+import Data.Text (Text, pack)+import Data.Maybe (catMaybes)++import Text.Hamlet.XML (xml)++import Network.XMPP.Types+import Network.XMPP.XML (ToXML(..), FromXML(..), matchPatterns,+ txtpat, mread)+import Network.XMPP.XEP.Form (XmppForm(..), XmppField(..))++--+-- Messaging archives management extenstion+-- https://xmpp.org/extensions/xep-0313.html#query+--++messageArchiveQueryStanza :: MAMQuery -> UUID.UUID -> Stanza 'IQ 'Outgoing ()+messageArchiveQueryStanza MAMQuery {..} uuid =+ let form = XmppForm $ catMaybes+ [ Just $ HiddenField "FORM_TYPE" "urn:xmpp:mam:2"+ , SingleTextField "with" . pack . show <$> mqWith+ , SingleTextField "start" . pack . show <$> mqStart+ , SingleTextField "end" . pack . show <$> mqEnd+ ]+ in MkIQ { iqFrom = Nothing+ , iqTo = SomeJID <$> mqRoom+ , iqId = UUID.toText uuid+ , iqType = Set+ , iqPurpose = SOutgoing+ , iqBody = [xml| + <query xmlns="urn:xmpp:mam:2">+ ^{encodeXml form}++ <set xmlns="http://jabber.org/protocol/rsm">+ <max>#{pack $ show mqLimit}+ $maybe afterId <- mqAfter+ <after>#{afterId}++ $if mqFromLatest+ <before>+ $maybe beforeId <- mqBefore+ #{beforeId}+ $else+ $maybe beforeId <- mqBefore+ <before>#{beforeId}+ |]+ }++data MAMQuery = MAMQuery+ { mqStart :: Maybe UTCTime+ , mqEnd :: Maybe UTCTime+ , mqWith :: Maybe (JID 'Node)+ , mqRoom :: Maybe (JID 'Node)+ , mqLimit :: Int+ , mqAfter :: Maybe Text+ , mqBefore :: Maybe Text+ , mqFromLatest :: Bool+ } deriving (Show)++defMamQuery :: MAMQuery+defMamQuery = MAMQuery+ { mqStart = Nothing+ , mqEnd = Nothing+ , mqWith = Nothing+ , mqRoom = Nothing+ , mqLimit = 10+ , mqAfter = Nothing+ , mqBefore = Nothing+ , mqFromLatest = False+ }++data MAMPayload = MAMFinalPayload+ { mComplete :: Bool+ , mLast :: Text+ , mFirst :: Text+ , mFirstIdx :: Text+ , mCount :: Int+ } deriving (Show)++instance FromXML MAMPayload where+ decodeXml m+ | matchPatterns m ["/fin/@complete", "/fin/set/count"]+ = MAMFinalPayload+ <$> decodeBool (txtpat "/fin/@complete" m)+ <*> Just (txtpat "/fin/set/last/-" m)+ <*> Just (txtpat "/fin/set/first/-" m)+ <*> Just (txtpat "/fin/set/first@index" m)+ <*> mread (txtpat "/fin/set/count/-" m)+ | otherwise+ = Nothing+ where+ decodeBool "true" = Just True+ decodeBool "false" = Just False+ decodeBool _ = Nothing
src/Network/XMPP/XEP/MUC.hs view
@@ -1,8 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.XEP.MUC -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental@@ -12,38 +19,267 @@ -- ----------------------------------------------------------------------------- module Network.XMPP.XEP.MUC- (- mucJoin- , mucLeave- , mucJoinStanza- , mucLeaveStanza- ) where+( createRoomStanza, leaveRoomStanza, destroyRoomStanza+, roomMessageStanza, privateMessageStanza, queryInstantRoomConfigStanza+, queryForAssociatedServicesStanza, submitInstantRoomConfigStanza+, setRoomMembersListStanza, queryForRoomInfoStanza+, UserJID, RoomJID, RoomMemberJID, FromXML(..), MUCPayload(..), RoomMembersList(..)+, Affiliation(..), Role(..)+)+where -import Network.XMPP.Stanza-import Network.XMPP.Types-import Network.XMPP.Print -import Network.XMPP.JID-import Network.XMPP.Utils+import qualified Data.UUID as UUID+import qualified Data.Text as T+import Data.Maybe (listToMaybe)+import Data.Time (UTCTime)+import Text.Hamlet.XML (xml)+import Text.XML.HaXml.Xtract.Parse (xtract) --- | Joins MUC room named by JID (conference\@server\/nick)-mucJoin :: JID -> XmppStateT ()-mucJoin jid = do- outStanza $ mucJoinStanza jid+import Network.XMPP.Types+import Network.XMPP.XML+import Network.XMPP.Stanza+import Network.XMPP.XEP.Form --- | Leaves MUC room named by JID (conference\@server\/nick)-mucLeave :: JID -> XmppStateT ()-mucLeave jid = do- outStanza $ mucLeaveStanza jid+type UserJID = JID 'NodeResource -- fully qualified user JID in Jabber: for example - JohnWick@localhost/riskbook-web+type RoomJID = JID 'Node -- for example - programmers@localhost+type RoomMemberJID = JID 'NodeResource -- for example - programmers@localhost/NikitaRzm --- | Stanza sent by 'mucJoin'-mucJoinStanza :: JID -> Stanza-mucJoinStanza jid =- Presence Nothing (Just jid) "123" Default Available "" Nothing - [ toContent $- itag "x" [ xmlns "http://jabber.org/protocol/muc" ]- ]+-- | https://xmpp.org/extensions/xep-0045.html#disco-service+queryForAssociatedServicesStanza :: JID 'NodeResource -> Server -> UUID.UUID -> Stanza 'IQ 'Outgoing MUCPayload+queryForAssociatedServicesStanza from srv uuid =+ MkIQ+ { iqFrom = Just $ SomeJID from+ , iqTo = Just $ SomeJID $ DomainJID $ DomainID srv+ , iqId = UUID.toText uuid+ , iqType = Get+ , iqBody = [xml|<query xmlns='http://jabber.org/protocol/disco#items'/>|]+ , iqPurpose = SOutgoing+ } --- | Stanza sent by 'mucLeave'-mucLeaveStanza :: JID -> Stanza-mucLeaveStanza jid =- Presence Nothing (Just jid) "" Unavailable Available "" Nothing []+queryForRoomInfoStanza :: UserJID -> RoomJID -> UUID.UUID -> Stanza 'IQ 'Outgoing ()+queryForRoomInfoStanza from room uuid =+ MkIQ+ { iqFrom = Just $ SomeJID from+ , iqTo = Just $ SomeJID room+ , iqId = UUID.toText uuid+ , iqType = Get+ , iqBody = [xml|<query xmlns="http://jabber.org/protocol/disco#info">|]+ , iqPurpose = SOutgoing+ }++createRoomStanza :: UserJID -> UserJID -> UUID.UUID -> Stanza 'Presence 'Outgoing ()+createRoomStanza who room uuid =+ MkPresence+ { pFrom = Just $ SomeJID who+ , pTo = Just $ SomeJID room+ , pId = UUID.toText uuid+ , pType = Default+ , pShowType = Available+ , pStatus = ""+ , pPriority = Nothing+ , pExt = [xml|<x xmlns="http://jabber.org/protocol/muc">|]+ , pPurpose = SOutgoing+ }++leaveRoomStanza :: UserJID -> RoomMemberJID -> UUID.UUID -> Stanza 'Presence 'Outgoing ()+leaveRoomStanza user member uuid =+ MkPresence+ { pFrom = Just $ SomeJID user+ , pTo = Just $ SomeJID member+ , pId = UUID.toText uuid+ , pType = Unavailable+ , pShowType = Available+ , pStatus = ""+ , pPriority = Nothing+ , pExt = []+ , pPurpose = SOutgoing+ }++destroyRoomStanza :: UserJID -> RoomJID -> T.Text -> UUID.UUID -> Stanza 'IQ 'Outgoing ()+destroyRoomStanza owner room reason uuid =+ MkIQ+ { iqFrom = Just $ SomeJID owner+ , iqTo = Just $ SomeJID room+ , iqId = UUID.toText uuid+ , iqType = Set+ , iqBody = [xml|+ <query xmlns="http://jabber.org/protocol/muc#owner">+ <destroy jid="#{T.pack (show room)}">+ <reason>#{reason}</reason>+ |]+ , iqPurpose = SOutgoing+ }++privateMessageStanza+ :: UserJID+ -> RoomMemberJID+ -> T.Text+ -> UUID.UUID+ -> Stanza 'Message 'Outgoing ()+privateMessageStanza from to msg uuid = + MkMessage+ { mFrom = Just $ SomeJID from+ , mTo = Just $ SomeJID to+ , mId = UUID.toText uuid+ , mType = Chat+ , mSubject = ""+ , mBody = msg+ , mThread = ""+ , mExt = []+ , mPurpose = SOutgoing+ }++roomMessageStanza+ :: UserJID+ -> RoomJID+ -> T.Text+ -> UUID.UUID+ -> Stanza 'Message 'Outgoing ()+roomMessageStanza from to msg uuid =+ MkMessage+ { mFrom = Just $ SomeJID from+ , mTo = Just $ SomeJID to+ , mId = UUID.toText uuid+ , mType = GroupChat+ , mSubject = ""+ , mBody = msg+ , mThread = ""+ , mExt = []+ , mPurpose = SOutgoing+ }++queryInstantRoomConfigStanza :: UserJID -> RoomJID -> UUID.UUID -> Stanza 'IQ 'Outgoing ()+queryInstantRoomConfigStanza owner room uuid = + MkIQ+ { iqFrom = Just $ SomeJID owner+ , iqTo = Just $ SomeJID room+ , iqId = UUID.toText uuid+ , iqType = Get+ , iqBody = [xml| <query xmlns="http://jabber.org/protocol/muc#owner"> |]+ , iqPurpose = SOutgoing+ }++submitInstantRoomConfigStanza :: UserJID -> RoomJID -> XmppForm -> UUID.UUID -> Stanza 'IQ 'Outgoing ()+submitInstantRoomConfigStanza owner room form uuid =+ MkIQ+ { iqFrom = Just $ SomeJID owner+ , iqTo = Just $ SomeJID room+ , iqId = UUID.toText uuid+ , iqType = Set+ , iqBody = [xml|<query xmlns="http://jabber.org/protocol/muc#owner">^{encodeXml form}|]+ , iqPurpose = SOutgoing+ }++setRoomMembersListStanza :: RoomJID -> UserJID -> RoomMembersList -> UUID.UUID -> Stanza 'IQ 'Outgoing ()+setRoomMembersListStanza room admin members uuid =+ MkIQ+ { iqFrom = Just $ SomeJID admin+ , iqTo = Just $ SomeJID room+ , iqId = UUID.toText uuid+ , iqType = Set+ , iqBody = [xml|+ <query xmlns="http://jabber.org/protocol/muc#admin">+ ^{encodeXml members}+ |]+ , iqPurpose = SOutgoing+ }++data Affiliation =+ OwnerAffiliation+ | AdminAffiliation+ | MemberAffiliation+ | OutcastAffiliation+ | NoneAffiliation+ deriving (Eq, Show)++data Role =+ ModeratorRole+ | NoneRole+ | ParticipantRole+ | VisitorRole+ deriving (Eq, Show)++data MUCPayload =+ MUCRoomCreated Affiliation Role+ | MUCRoomQuery XmppForm+ | MUCRoomConfigRejected+ | MUCNotFound T.Text+ | MUCMembersPresences Affiliation Role+ | MUCMessageId T.Text+ | MUCArchivedMessage+ { mamMessage :: Stanza 'Message 'Incoming ()+ , mamFrom :: JID 'Domain+ , mamWhen :: UTCTime+ , mamStoredId :: T.Text+ }++deriving instance Show MUCPayload+newtype RoomMembersList = RoomMembersList [(UserJID, Affiliation)]+ deriving (Eq, Show)++instance ToXML RoomMembersList where+ encodeXml (RoomMembersList members) =+ [xml|+ $forall (jid, affiliation) <- members+ <item affiliation="#{encodeAffiliation affiliation}"+ jid="#{T.pack $ show $ toBareJID jid}">+ |]++instance FromXML MUCPayload where+ decodeXml m+ | matchPatterns m ["/x/item/@jid", "/x/item/@role", "/x/item/@affiliation"]+ = MUCRoomCreated+ <$> parseAffiliation (txtpat "/x/item/@affiliation" m)+ <*> parseRole (txtpat "/x/item/@role" m)+ | matchPatterns m ["/query/x"]+ = MUCRoomQuery <$> (listToMaybe (xtract id "/query/x" m) >>= decodeXml)+ | matchPatterns+ m+ ["/error[@code='404']", "/error[@type='cancel']", "/error/item-not-found"]+ = Just $ MUCNotFound $ txtpat "/error/text/-" m+ | matchPatterns+ m+ [ "/query[@type='cancel]"+ , "/query[@xmlns='http://jabber.org/protocol/muc#owner']"+ ]+ = Just MUCRoomConfigRejected+ | matchPatterns m ["/x/item/@affiliation", "/x/item/@role"]+ = MUCMembersPresences+ <$> parseAffiliation (txtpat "/x/item/@affiliation" m)+ <*> parseRole (txtpat "/x/item/@role" m)+ | matchPatterns m ["/result", "/result/forwarded/message"]+ = let+ mMsg =+ listToMaybe (xtract id "/result/forwarded/message" m) >>= decodeStanza+ mFrom = mread $ txtpat "/result/forwarded/delay/@from" m+ mTime =+ mread $ T.replace "T" " " $ txtpat "/result/forwarded/delay/@stamp" m+ storedId = txtpat "/result/forwarded/message/stanza-id/@id" m+ in+ MUCArchivedMessage <$> mMsg <*> mFrom <*> mTime <*> Just storedId+ | matchPatterns m ["/stanza-id/@id"]+ = Just $ MUCMessageId $ txtpat "/stanza-id/@id" m+ | otherwise+ = Nothing++encodeAffiliation :: Affiliation -> T.Text+encodeAffiliation OwnerAffiliation = "owner"+encodeAffiliation AdminAffiliation = "admin"+encodeAffiliation MemberAffiliation = "member"+encodeAffiliation OutcastAffiliation = "outcast"+encodeAffiliation NoneAffiliation = "none"++parseAffiliation :: T.Text -> Maybe Affiliation+parseAffiliation v = case v of+ "owner" -> Just OwnerAffiliation+ "admin" -> Just AdminAffiliation+ "member" -> Just MemberAffiliation+ "outcast" -> Just OutcastAffiliation+ _ -> Nothing++parseRole :: T.Text -> Maybe Role+parseRole v = case v of+ "moderator" -> Just ModeratorRole+ "participant" -> Just ParticipantRole+ "visitor" -> Just VisitorRole+ _ -> Nothing
src/Network/XMPP/XEP/Version.hs view
@@ -1,8 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module : Network.XMPP.XEP.Version -- Copyright : (c) pierre, 2007 -- License : BSD-style (see the file libraries/base/LICENSE)+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3 -- -- Maintainer : Dmitry Astapov <dastapov@gmail.com>, pierre <k.pierre.k@gmail.com> -- Stability : experimental@@ -13,28 +19,26 @@ ----------------------------------------------------------------------------- module Network.XMPP.XEP.Version ( isVersionReq- , versionAnswer + , versionAnswer ) where import Network.XMPP.Types-import Network.XMPP.Print -import Network.XMPP.Utils +import Network.XMPP.XML import Text.XML.HaXml -- | True, if stanza is a version request-isVersionReq :: Stanza -> Bool -isVersionReq (IQ { iqBody = ext }) =- isVal "jabber:iq:version" "/iq/query/@xmlns" ext-isVersionReq _ = False+isVersionReq :: Stanza 'IQ 'Incoming () -> Bool+isVersionReq MkIQ { iqBody = ext } =+ either (isVal "jabber:iq:version" "/iq/query/@xmlns") (const False) ext -- | Replies to version request-versionAnswer :: String -> String -> String -> (Stanza -> [CFilter i])-versionAnswer name version os (IQ { }) =- [ ptag "query"- [ xmlns "jabber:iq:version" ]- [ ptag "name" [] [literal name],- ptag "version" [] [literal version],- ptag "os" [] [literal os]- ]+versionAnswer :: String -> String -> String -> Stanza 'IQ 'Outgoing () -> [CFilter i]+versionAnswer name version os MkIQ { } =+ [ mkElemAttr "query"+ [ strAttr "xmlns" "jabber:iq:version" ]+ [ mkElemAttr "name" [] [literal name],+ mkElemAttr "version" [] [literal version],+ mkElemAttr "os" [] [literal os]+ ] ]
+ src/Network/XMPP/XML.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Copyright : (c) riskbook, 2020+-- SPDX-License-Identifier: BSD3+--+-----------------------------------------------------------------------------+module Network.XMPP.XML+ ( strAttr+ , getVals+ , isVal+ , getText+ , getText_+ , txtpat+ , xtractp+ , matchPatterns+ , mread+ , mattr+ , mattr'+ , literal -- from HaXML+ , noelem+ , lookupAttr+ , FromXML(..)+ , ToXML(..)+ ) where++import Text.XML (Node)+import Text.XML.HaXml hiding (tag)+import Text.XML.HaXml.Posn+import qualified Text.XML.HaXml.Pretty as P+import Text.XML.HaXml.Xtract.Parse (xtract)+import Text.PrettyPrint.HughesPJ (hcat)+import Data.Text (Text, pack, unpack)+import Text.Read+import Control.Applicative ((<|>))++class FromXML a where+ decodeXml :: Content Posn -> Maybe a++class ToXML a where+ encodeXml :: a -> [Node]++instance FromXML () where+ decodeXml _ = Just ()++instance (FromXML a, FromXML b) => FromXML (Either a b) where+ decodeXml m = (Left <$> decodeXml m) <|> (Right <$> decodeXml m)++strAttr :: a -> String -> (a, CFilter i)+strAttr s d = (s, literal d)++-- | Returns strings extracted by xtract query+getVals :: Text -> [Content Posn] -> [Text]+getVals q = map (getText_ . xtract id (unpack q))++-- | Queries xml for specific value+-- @isVal str = any (== str) . getVals@+isVal :: Text -> Text -> [Content Posn] -> Bool+isVal str cont = any (== str) . getVals cont++-- +getText :: Content i -> Text+getText cs@CString{} = pack . render . P.content $ cs+getText cs@CRef{} = pack . render . P.content $ cs+getText x =+ error+ $ "Attempt to extract text from content that is not a string: "+ ++ render (P.content x)++getText_ :: [Content i] -> Text+getText_ = pack . render . hcat . map P.content++-- | Extract text from `Content Posn' with supplied pattern+txtpat :: Text -- ^ xtract-like pattern to match+ -> Content Posn -- ^ message being processed+ -> Text -- ^ result of extraction+txtpat p m = getText_ $ xtract id (unpack p) m++xtractp :: (Text -> Text) -> Text -> Content i -> Bool+xtractp f p m = not . null $ xtract (unpack . f . pack) (unpack p) m++matchPatterns :: Content i -> [Text] -> Bool+matchPatterns m = all $ flip (xtractp id) m++mread :: Read a => Text -> Maybe a+mread "" = Nothing+mread a = readMaybe $ unpack a++mattr :: (Show a) => b -> Maybe a -> [(b, CFilter i)]+mattr s (Just a) = [ strAttr s (show a) ]+mattr _ Nothing = []++mattr' :: a -> Maybe String -> [(a, CFilter i)]+mattr' s (Just a) = [ strAttr s a ]+mattr' _ Nothing = []++noelem :: Content Posn+noelem = CElem (Elem (N "root") [] []) noPos++lookupAttr :: String -> [Attribute] -> Maybe String+lookupAttr k lst = do+ x <- lookup (N k) lst+ case x of+ AttValue [Left str] -> Just str+ AttValue _ -> Nothing
+ test/Main.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -fno-warn-implicit-prelude #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/RoomSpec.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}++-- | basic stuff like connecting to a room and sending messages+module RoomSpec where++import Network.XMPP.XML+import Network.XMPP.XEP.MUC+import Data.Text(Text)+import Control.Exception+import Test.Hspec+import Network.XMPP.Types+import Network.XMPP.Helpers+import Network.XMPP.Core+import Control.Monad.IO.Class+import Control.Monad+import Network.XMPP.Stream+import Network.XMPP.Ejabberd+import Network.XMPP.Types+import Network.XMPP.Concurrent+import Data.Traversable++deriving instance Exception XmppError++spec :: Spec+spec = describe "ejabbered server tests" $ do+ it "gets a connection" $ do+ handle <- liftIO $ connectViaTcp "localhost" 5222+ registerNewUser localEjabberdHost (EUser "jappie" "pass") (VHost "localhost")+ (result, stream) <- runXmppMonad $ initStream handle "localhost" "jappie" "pass" "someResource"+ nodeResource <- either throwIO pure result+ void $ runXmppMonad' stream closeStream++ it "can connect to a room" $ do+ handle <- liftIO $ connectViaTcp "localhost" 5222+ registerNewUser localEjabberdHost (EUser "jappie" "pass") (VHost "localhost")+ registerNewUser localEjabberdHost (EUser "jesiska" "pass") (VHost "localhost")+ (result, stream) <- runXmppMonad $ do+ jappie <- either (error "init failure") id <$> initStream handle "localhost" "jappie" "pass" "someResource"+ xmppSend =<< withUUID (createRoomStanza jappie (mkParticipantJIDForRoom "jappie" someRoom))+ xmppSend =<< withUUID (createRoomStanza jappie (mkParticipantJIDForRoom "jesiska" someRoom))++ pure $! seq result -- no lazy+ void $ runXmppMonad' stream closeStream++ it "can exchange messages" $ do+ handle <- liftIO $ connectViaTcp "localhost" 5222+ registerNewUser localEjabberdHost (EUser "jappie" "pass") (VHost "localhost")+ registerNewUser localEjabberdHost (EUser "jesiska" "pass") (VHost "localhost")+ void $ runXmppMonad $ do+ jappie <- either (error "init failure") id <$> initStream handle "localhost" "jappie" "pass" "someResource"+ xmppSend =<< withUUID (createRoomStanza jappie (mkParticipantJIDForRoom "jappie" someRoom))+ xmppSend =<< withUUID (createRoomStanza jappie (mkParticipantJIDForRoom "jesiska" someRoom ))+ let+ expectedMsg = "some-msg"+ stanza <- withUUID (roomMessageStanza jappie someRoom expectedMsg)+ xmppSend $ stanza+ stanze <- replicateM 10 parseM -- the order appears to be random+ -- liftIO $ print stanze+ for stanze $ \selected ->+ case selected of+ Left x -> liftIO $ throwIO x+ Right msg -> case msg :: SomeStanza MUCPayload of+ SomeStanza (MkMessage {mBody,mFrom, mPurpose = SIncoming}) -> do+ liftIO $ unless (mBody == "") $ mBody `shouldBe` "some-msg"+ unkown -> do+ pure () -- skip+ closeStream+someRoom :: JID 'Node+someRoom = mkRoomJID "localhost" "blah"++mkRoomJID :: Server -> Text -> JID 'Node+mkRoomJID srv roomId = NodeJID (NodeID roomId) $ DomainID $ "conference." <> srv++mkParticipantJIDForRoom :: Username -> RoomJID -> RoomMemberJID+mkParticipantJIDForRoom username NodeJID {..} =+ NodeResourceJID nNode nDomain $ ResourceID username
+ test/TestSuiteSpec.hs view
@@ -0,0 +1,8 @@++-- | see if we can run any test at all+module TestSuiteSpec where++import Test.Hspec++spec :: Spec+spec = describe "the test suite" $ it "works" $ 1 `shouldBe` 1