~singpolyma/cheogram-smtp

cheogram-smtp/VCard.hs -rw-r--r-- 2.0 KiB
7021b245Stephen Paul Weber jabber:iq:gateway working against my local Gajim 5 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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 $ bareJid 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