diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -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 + + diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,33 @@ +[![Maintenance badge](https://img.shields.io/maintenance/yes/2020)](https://riskbook.com/) + +![Logo](https://raw.githubusercontent.com/riskbook/haskell-xmpp/master/haskell-logo-xmpp.svg) + +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 diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -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, diff --git a/haskell-xmpp.cabal b/haskell-xmpp.cabal --- a/haskell-xmpp.cabal +++ b/haskell-xmpp.cabal @@ -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 , pierre -Maintainer: Dmitry Astapov -Homepage: http://patch-tag.com/r/adept/haskell-xmpp/home +Author: Dmitry Astapov , pierre , riskbook +Maintainer: riskbook +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 diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs --- a/src/Network/XMPP.hs +++ b/src/Network/XMPP.hs @@ -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 -- 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 diff --git a/src/Network/XMPP/Base64.hs b/src/Network/XMPP/Base64.hs --- a/src/Network/XMPP/Base64.hs +++ b/src/Network/XMPP/Base64.hs @@ -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 diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -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 "" - threadDelay 30000000 + liftIO $ hPutStr h " " + liftIO $ debugIO "" + liftIO $ threadDelay 30000000 connPersist h - diff --git a/src/Network/XMPP/Core.hs b/src/Network/XMPP/Core.hs --- a/src/Network/XMPP/Core.hs +++ b/src/Network/XMPP/Core.hs @@ -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 -- 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| + + #{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| |] - 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 diff --git a/src/Network/XMPP/Ejabberd.hs b/src/Network/XMPP/Ejabberd.hs new file mode 100644 --- /dev/null +++ b/src/Network/XMPP/Ejabberd.hs @@ -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 diff --git a/src/Network/XMPP/Helpers.hs b/src/Network/XMPP/Helpers.hs --- a/src/Network/XMPP/Helpers.hs +++ b/src/Network/XMPP/Helpers.hs @@ -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 -- 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 diff --git a/src/Network/XMPP/IM/Presence.hs b/src/Network/XMPP/IM/Presence.hs --- a/src/Network/XMPP/IM/Presence.hs +++ b/src/Network/XMPP/IM/Presence.hs @@ -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 diff --git a/src/Network/XMPP/IQ.hs b/src/Network/XMPP/IQ.hs --- a/src/Network/XMPP/IQ.hs +++ b/src/Network/XMPP/IQ.hs @@ -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 diff --git a/src/Network/XMPP/JID.hs b/src/Network/XMPP/JID.hs deleted file mode 100644 --- a/src/Network/XMPP/JID.hs +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.XMPP.JID --- Copyright : (c) pierre, 2006 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : pierre --- 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) - - diff --git a/src/Network/XMPP/MD5.hs b/src/Network/XMPP/MD5.hs --- a/src/Network/XMPP/MD5.hs +++ b/src/Network/XMPP/MD5.hs @@ -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 diff --git a/src/Network/XMPP/Print.hs b/src/Network/XMPP/Print.hs --- a/src/Network/XMPP/Print.hs +++ b/src/Network/XMPP/Print.hs @@ -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 , pierre -- 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 and - 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 and + 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 `` +-- but hamlet autho close tags and i see no ways to control it +-- head [xml| +-- +-- -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" diff --git a/src/Network/XMPP/Sasl.hs b/src/Network/XMPP/Sasl.hs --- a/src/Network/XMPP/Sasl.hs +++ b/src/Network/XMPP/Sasl.hs @@ -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 , pierre -- 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||] + response resp = [xml| + + #{resp} + |] + sndResponse = [xml||] + 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!" diff --git a/src/Network/XMPP/Stanza.hs b/src/Network/XMPP/Stanza.hs --- a/src/Network/XMPP/Stanza.hs +++ b/src/Network/XMPP/Stanza.hs @@ -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| + + + #{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| + + ^{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| + + ^{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 + } diff --git a/src/Network/XMPP/Stream.hs b/src/Network/XMPP/Stream.hs --- a/src/Network/XMPP/Stream.hs +++ b/src/Network/XMPP/Stream.hs @@ -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 , pierre -- 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 '' 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 diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -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 , pierre -- 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 +-- - ["@"]["/"] +-- - []* - The node identifier (optional) +-- - ["."]* - The domain identifier (required) +-- - []* - 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 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) diff --git a/src/Network/XMPP/UTF8.hs b/src/Network/XMPP/UTF8.hs --- a/src/Network/XMPP/UTF8.hs +++ b/src/Network/XMPP/UTF8.hs @@ -43,6 +43,10 @@ -} +-- | +-- Copyright : (c) riskbook, 2020 +-- SPDX-License-Identifier: BSD3 + module Network.XMPP.UTF8 ( fromUTF8, toUTF8 ) where diff --git a/src/Network/XMPP/Utils.hs b/src/Network/XMPP/Utils.hs --- a/src/Network/XMPP/Utils.hs +++ b/src/Network/XMPP/Utils.hs @@ -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 , pierre -- 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 diff --git a/src/Network/XMPP/XEP/Delayed.hs b/src/Network/XMPP/XEP/Delayed.hs --- a/src/Network/XMPP/XEP/Delayed.hs +++ b/src/Network/XMPP/XEP/Delayed.hs @@ -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 , pierre -- 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 diff --git a/src/Network/XMPP/XEP/Form.hs b/src/Network/XMPP/XEP/Form.hs new file mode 100644 --- /dev/null +++ b/src/Network/XMPP/XEP/Form.hs @@ -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| + + $forall field <- fields + $case field + $of HiddenField name value + + #{value} + + $of SingleTextField name value + + #{value} + + $of BooleanField name value + + + $if value + 1 + $else + 0 + + $of ListSingleField name _opts value + + #{value} + + $of ListMultiField name _opts values + + $forall value <- values + #{value} + |] diff --git a/src/Network/XMPP/XEP/MAM.hs b/src/Network/XMPP/XEP/MAM.hs new file mode 100644 --- /dev/null +++ b/src/Network/XMPP/XEP/MAM.hs @@ -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| + + ^{encodeXml form} + + + #{pack $ show mqLimit} + $maybe afterId <- mqAfter + #{afterId} + + $if mqFromLatest + + $maybe beforeId <- mqBefore + #{beforeId} + $else + $maybe beforeId <- mqBefore + #{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 diff --git a/src/Network/XMPP/XEP/MUC.hs b/src/Network/XMPP/XEP/MUC.hs --- a/src/Network/XMPP/XEP/MUC.hs +++ b/src/Network/XMPP/XEP/MUC.hs @@ -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 , pierre -- 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||] + , 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||] + , 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||] + , 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| + + + #{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| |] + , 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|^{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| + + ^{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 + + |] + +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 diff --git a/src/Network/XMPP/XEP/Version.hs b/src/Network/XMPP/XEP/Version.hs --- a/src/Network/XMPP/XEP/Version.hs +++ b/src/Network/XMPP/XEP/Version.hs @@ -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 , pierre -- 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] + ] ] diff --git a/src/Network/XMPP/XML.hs b/src/Network/XMPP/XML.hs new file mode 100644 --- /dev/null +++ b/src/Network/XMPP/XML.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -fno-warn-implicit-prelude #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/RoomSpec.hs b/test/RoomSpec.hs new file mode 100644 --- /dev/null +++ b/test/RoomSpec.hs @@ -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 diff --git a/test/TestSuiteSpec.hs b/test/TestSuiteSpec.hs new file mode 100644 --- /dev/null +++ b/test/TestSuiteSpec.hs @@ -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