~singpolyma/cheogram-smtp

2e20ee0ff17e2f4162505a0f8b955c25ce35dbbd — Stephen Paul Weber 2 years ago 1de6f0c
Fetch vcard4 when sending message and use it for name and X-URL headers
5 files changed, 159 insertions(+), 14 deletions(-)

M Router.hs
A VCard.hs
M cheogram-smtp.cabal
M gateway.hs
A test/VCardTest.hs
M Router.hs => Router.hs +7 -2
@@ 4,11 4,16 @@ import Prelude ()
import BasicPrelude
import Control.Error                   (ExceptT (..))
import qualified Network.Protocol.XMPP as XMPP

import Util

runRoutedComponent :: XMPP.Server -> Text -> Routes -> ExceptT XMPP.Error IO ()
runRoutedComponent ::
	   XMPP.Server
	-> Text
	-> XMPP.XMPP Routes
	-> ExceptT XMPP.Error IO ()
runRoutedComponent server secret =
	ExceptT . XMPP.runComponent server secret . runRouted
	ExceptT . XMPP.runComponent server secret . (runRouted =<<)

runRouted :: Routes -> XMPP.XMPP ()
runRouted routes = forever $ XMPP.getStanza >>= (void . forkXMPP . handle)

A VCard.hs => VCard.hs +64 -0
@@ 0,0 1,64 @@
module VCard (
	VCard(..), emptyVCard, vcardRequest, parseVCard, vcardToElement
) where

import Prelude ()
import BasicPrelude
import Control.Error                   (headZ)
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP

import Util

data VCard = VCard {
	fn :: Maybe Text,
	nickname :: Maybe Text,
	url :: [Text]
} deriving (Show, Eq)

vcardToElement :: VCard -> XML.Element
vcardToElement vcard = XML.Element (s"{urn:ietf:params:xml:ns:vcard-4.0}vcard")
	[] $ map XML.NodeElement $
	maybeToList (mkItem "fn" "text" <$> fn vcard) ++
	maybeToList (mkItem "nickname" "text" <$> nickname vcard) ++
	(mkItem "url" "uri" <$> url vcard)

mkItem :: String -> String -> Text -> XML.Element
mkItem item typ content = XML.Element itemName []
	[XML.NodeElement $ mkElement typeName content]
	where
	itemName = fromString $ "{urn:ietf:params:xml:ns:vcard-4.0}" ++ item
	typeName = fromString $ "{urn:ietf:params:xml:ns:vcard-4.0}" ++ typ

emptyVCard :: VCard
emptyVCard = VCard Nothing Nothing []

vcardRequest :: XMPP.JID -> XMPP.IQ
vcardRequest jid = (XMPP.emptyIQ XMPP.IQGet) {
	XMPP.iqTo = Just jid,
	XMPP.iqPayload = Just $ XML.Element
		(s"{urn:ietf:params:xml:ns:vcard-4.0}vcard") [] []
}

parseVCard :: XMPP.IQ -> VCard
parseVCard XMPP.IQ { XMPP.iqType = XMPP.IQResult, XMPP.iqPayload = Just vcard }
	| XML.elementName vcard == s"{urn:ietf:params:xml:ns:vcard-4.0}vcard" =
		VCard {
			fn = mconcat . XML.elementText <$>
				headZ (vcardItems "fn" "text" vcard),
			nickname = mconcat . XML.elementText <$>
				headZ (vcardItems "nickname" "text" vcard),
			url = mconcat . XML.elementText <$>
				vcardItems "url" "uri" vcard
		}
parseVCard _ = emptyVCard

vcardItems :: String -> String -> XML.Element -> [XML.Element]
vcardItems item typ vcard =
	XML.isNamed typeName =<<
	XML.elementChildren =<<
	XML.isNamed itemName =<<
	XML.elementChildren vcard
	where
	itemName = fromString $ "{urn:ietf:params:xml:ns:vcard-4.0}" ++ item
	typeName = fromString $ "{urn:ietf:params:xml:ns:vcard-4.0}" ++ typ

M cheogram-smtp.cabal => cheogram-smtp.cabal +2 -2
@@ 37,7 37,7 @@ common defs
executable gateway
  import:              defs
  main-is:             gateway.hs
  other-modules:       Router, Util, Email
  other-modules:       Router, Util, Email, IQManager, VCard

executable incoming-email
  import:              defs


@@ 50,7 50,7 @@ test-suite test
  type:                exitcode-stdio-1.0
  hs-source-dirs:      ., test
  other-modules:       UtilTest, EmailTest, TestInstances, Util, Email,
                       IQManager, IQManagerTest
                       IQManager, IQManagerTest, VCard, VCardTest
  build-depends:       tasty,
                       tasty-hunit,
                       tasty-quickcheck,

M gateway.hs => gateway.hs +44 -10
@@ 5,7 5,9 @@ import BasicPrelude
import System.IO
	(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Concurrent              (threadDelay)
import Control.Error                   (exceptT)
import Control.Concurrent.STM          (STM)
import Control.Error                   (exceptT, headZ)
import Control.Lens                    (over, set, at, _Right, traverseOf)
import Network                         (PortID (PortNumber))
import Data.Time.Clock                 (getCurrentTime)
import qualified Focus


@@ 16,10 18,13 @@ import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP
import qualified Network.Protocol.XMPP.Internal as XMPP
import qualified Data.MIME             as MIME
import qualified Data.MIME.EncodedWord as MIME

import Util
import Router
import Email
import IQManager
import Router
import Util
import VCard

newtype RawComponentStanza = RawComponentStanza XML.Element



@@ 72,13 77,39 @@ iqSetHandler replyMap componentJid trustedJids iq@XMPP.IQ {
				XMPP.putStanza $ iqReply Nothing originalIQ
iqSetHandler _ _ _ iq = XMPP.putStanza $ iqError notImplemented iq

addVCardData :: VCard -> MIME.MIMEMessage -> MIME.MIMEMessage
addVCardData vcard =
	set (MIME.headers . at (s"X-URL"))
		(MIME.encodeEncodedWords <$> headZ (url vcard)) .
	over (MIME.headerFrom MIME.defaultCharsets) (map
		(\(MIME.Mailbox name addr) ->
			MIME.Mailbox (nickname vcard <|> fn vcard <|> name) addr
		)
	)

fetchAndAddVCardData ::
	   (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)))
	-> MIME.MIMEMessage
	-> XMPP.JID
	-> XMPP.XMPP MIME.MIMEMessage
fetchAndAddVCardData sendIQ email jid =
	(`addVCardData` email) .  maybe emptyVCard parseVCard <$>
	(atomicUIO =<< sendIQ (vcardRequest jid))

messageHandler ::
	   MIME.Domain
	-> (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ)))
	-> XMPP.Message
	-> XMPP.XMPP ()
messageHandler fromDomain message = do
messageHandler fromDomain sendIQ message = do
	now <- liftIO getCurrentTime
	either XMPP.putStanza sendEmail $ messageToEmail fromDomain now message
	either XMPP.putStanza sendEmail =<< traverseOf (_Right . emailMessage')
		(\msg ->
			maybe (return msg)
			(fetchAndAddVCardData sendIQ msg)
			(XMPP.messageFrom message)
		)
		(messageToEmail fromDomain now message)

messageErrorHandler ::
	   STMMap.Map (Maybe Text) XMPP.IQ


@@ 107,11 138,14 @@ main = do
	let server = XMPP.Server componentJid (textToString host) port

	replyMap <- STMMap.newIO
	exceptT print return $ runRoutedComponent server secret $ defaultRoutes{
	exceptT print return $ runRoutedComponent server secret $ do
		(sendIQ, iqReceived) <- iqManager
		return $ defaultRoutes {
			iqSetRoute =
				iqSetHandler replyMap componentJid trustedJids,
			messageNormalRoute = messageHandler emailDomain,
			messageChatRoute = messageHandler emailDomain,
			messageErrorRoute =
				messageErrorHandler replyMap
			iqResultRoute = iqReceived,
			iqErrorRoute = iqReceived,
			messageNormalRoute = messageHandler emailDomain sendIQ,
			messageChatRoute = messageHandler emailDomain sendIQ,
			messageErrorRoute = messageErrorHandler replyMap
		}

A test/VCardTest.hs => test/VCardTest.hs +42 -0
@@ 0,0 1,42 @@
module VCardTest where

import Prelude ()
import BasicPrelude
-- import Test.Tasty.HUnit
import Test.QuickCheck.Instances ()
import Test.QuickCheck.Arbitrary
import qualified Data.XML.Types as XML
import qualified Network.Protocol.XMPP as XMPP

import Util
import VCard
import TestInstances ()

prop_vcardRequest :: XMPP.JID -> Bool
prop_vcardRequest jid =
	XMPP.iqTo req == Just jid &&
	XMPP.iqPayload req == Just vcardEl
	where
	vcardEl = XML.Element (s"{urn:ietf:params:xml:ns:vcard-4.0}vcard") [] []
	req = vcardRequest jid

-- Odds of randomly producing the right payload are basically zero
prop_parseVCardRandomIQ :: XMPP.IQ -> Bool
prop_parseVCardRandomIQ iq = parseVCard iq == emptyVCard

data VCardResult = VCardResult VCard XMPP.IQ deriving (Show)

instance Arbitrary VCardResult where
	arbitrary = do
		vcard <- VCard <$> arbitrary <*> arbitrary <*> arbitrary
		iq <- XMPP.IQ <$>
			pure XMPP.IQResult <*>
			arbitrary <*>
			arbitrary <*>
			arbitrary <*>
			arbitrary <*>
			pure (Just $ vcardToElement vcard)
		return (VCardResult vcard iq)

prop_parseVCardValid :: VCardResult -> Bool
prop_parseVCardValid (VCardResult vcard iq) = parseVCard iq == vcard