4aba1c74bd
I've tested all the dataenc to sandi conversions except Assistant.XMPP, and all have unchanged behavior, including behavior on large unicode code points.
275 lines
8.2 KiB
Haskell
275 lines
8.2 KiB
Haskell
{- core xmpp support
|
|
-
|
|
- Copyright 2012-2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Assistant.XMPP where
|
|
|
|
import Assistant.Common
|
|
import Assistant.Types.NetMessager
|
|
import Assistant.Pairing
|
|
import Git.Sha (extractSha)
|
|
import Git
|
|
|
|
import Network.Protocol.XMPP hiding (Node)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Map as M
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as B
|
|
import Data.XML.Types
|
|
import qualified "sandi" Codec.Binary.Base64 as B64
|
|
import Data.Bits.Utils
|
|
|
|
{- Name of the git-annex tag, in our own XML namespace.
|
|
- (Not using a namespace URL to avoid unnecessary bloat.) -}
|
|
gitAnnexTagName :: Name
|
|
gitAnnexTagName = "{git-annex}git-annex"
|
|
|
|
{- Creates a git-annex tag containing a particular attribute and value. -}
|
|
gitAnnexTag :: Name -> Text -> Element
|
|
gitAnnexTag attr val = gitAnnexTagContent attr val []
|
|
|
|
{- Also with some content. -}
|
|
gitAnnexTagContent :: Name -> Text -> [Node] -> Element
|
|
gitAnnexTagContent attr val = Element gitAnnexTagName [(attr, [ContentText val])]
|
|
|
|
isGitAnnexTag :: Element -> Bool
|
|
isGitAnnexTag t = elementName t == gitAnnexTagName
|
|
|
|
{- Things that a git-annex tag can inserted into. -}
|
|
class GitAnnexTaggable a where
|
|
insertGitAnnexTag :: a -> Element -> a
|
|
|
|
extractGitAnnexTag :: a -> Maybe Element
|
|
|
|
hasGitAnnexTag :: a -> Bool
|
|
hasGitAnnexTag = isJust . extractGitAnnexTag
|
|
|
|
instance GitAnnexTaggable Message where
|
|
insertGitAnnexTag m elt = m { messagePayloads = elt : messagePayloads m }
|
|
extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads
|
|
|
|
instance GitAnnexTaggable Presence where
|
|
-- always mark extended away and set presence priority to negative
|
|
insertGitAnnexTag p elt = p
|
|
{ presencePayloads = extendedAway : negativePriority : elt : presencePayloads p }
|
|
extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
|
|
|
|
data GitAnnexTagInfo = GitAnnexTagInfo
|
|
{ tagAttr :: Name
|
|
, tagValue :: Text
|
|
, tagElement :: Element
|
|
}
|
|
|
|
type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
|
|
|
|
gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo
|
|
gitAnnexTagInfo v = case extractGitAnnexTag v of
|
|
{- Each git-annex tag has a single attribute. -}
|
|
Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo
|
|
<$> pure attr
|
|
<*> attributeText attr tag
|
|
<*> pure tag
|
|
_ -> Nothing
|
|
|
|
{- A presence with a git-annex tag in it.
|
|
- Also includes a status tag, which may be visible in XMPP clients. -}
|
|
gitAnnexPresence :: Element -> Presence
|
|
gitAnnexPresence = insertGitAnnexTag $ addStatusTag $ emptyPresence PresenceAvailable
|
|
where
|
|
addStatusTag p = p
|
|
{ presencePayloads = status : presencePayloads p }
|
|
status = Element "status" [] [statusMessage]
|
|
statusMessage = NodeContent $ ContentText $ T.pack "git-annex"
|
|
|
|
{- A presence with an empty git-annex tag in it, used for letting other
|
|
- clients know we're around and are a git-annex client. -}
|
|
gitAnnexSignature :: Presence
|
|
gitAnnexSignature = gitAnnexPresence $ Element gitAnnexTagName [] []
|
|
|
|
{- XMPP client to server ping -}
|
|
xmppPing :: JID -> IQ
|
|
xmppPing selfjid = (emptyIQ IQGet)
|
|
{ iqID = Just "c2s1"
|
|
, iqFrom = Just selfjid
|
|
, iqTo = Just $ JID Nothing (jidDomain selfjid) Nothing
|
|
, iqPayload = Just $ Element xmppPingTagName [] []
|
|
}
|
|
|
|
xmppPingTagName :: Name
|
|
xmppPingTagName = "{urn:xmpp}ping"
|
|
|
|
{- A message with a git-annex tag in it. -}
|
|
gitAnnexMessage :: Element -> JID -> JID -> Message
|
|
gitAnnexMessage elt tojid fromjid = (insertGitAnnexTag silentMessage elt)
|
|
{ messageTo = Just tojid
|
|
, messageFrom = Just fromjid
|
|
}
|
|
|
|
{- A notification that we've pushed to some repositories, listing their
|
|
- UUIDs. -}
|
|
pushNotification :: [UUID] -> Presence
|
|
pushNotification = gitAnnexPresence . gitAnnexTag pushAttr . encodePushNotification
|
|
|
|
encodePushNotification :: [UUID] -> Text
|
|
encodePushNotification = T.intercalate uuidSep . map (T.pack . fromUUID)
|
|
|
|
decodePushNotification :: Text -> [UUID]
|
|
decodePushNotification = map (toUUID . T.unpack) . T.splitOn uuidSep
|
|
|
|
uuidSep :: Text
|
|
uuidSep = ","
|
|
|
|
{- A request for other git-annex clients to send presence. -}
|
|
presenceQuery :: Presence
|
|
presenceQuery = gitAnnexPresence $ gitAnnexTag queryAttr T.empty
|
|
|
|
{- A notification about a stage of pairing. -}
|
|
pairingNotification :: PairStage -> UUID -> JID -> JID -> Message
|
|
pairingNotification pairstage u = gitAnnexMessage $
|
|
gitAnnexTag pairAttr $ encodePairingNotification pairstage u
|
|
|
|
encodePairingNotification :: PairStage -> UUID -> Text
|
|
encodePairingNotification pairstage u = T.unwords $ map T.pack
|
|
[ show pairstage
|
|
, fromUUID u
|
|
]
|
|
|
|
decodePairingNotification :: Decoder
|
|
decodePairingNotification m = parse . words . T.unpack . tagValue
|
|
where
|
|
parse [stage, u] = PairingNotification
|
|
<$> readish stage
|
|
<*> (formatJID <$> messageFrom m)
|
|
<*> pure (toUUID u)
|
|
parse _ = Nothing
|
|
|
|
pushMessage :: PushStage -> JID -> JID -> Message
|
|
pushMessage = gitAnnexMessage . encode
|
|
where
|
|
encode (CanPush u shas) =
|
|
gitAnnexTag canPushAttr $ T.pack $ unwords $
|
|
fromUUID u : map fromRef shas
|
|
encode (PushRequest u) =
|
|
gitAnnexTag pushRequestAttr $ T.pack $ fromUUID u
|
|
encode (StartingPush u) =
|
|
gitAnnexTag startingPushAttr $ T.pack $ fromUUID u
|
|
encode (ReceivePackOutput n b) =
|
|
gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b
|
|
encode (SendPackOutput n b) =
|
|
gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b
|
|
encode (ReceivePackDone code) =
|
|
gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code
|
|
val = T.pack . show
|
|
|
|
decodeMessage :: Message -> Maybe NetMessage
|
|
decodeMessage m = decode =<< gitAnnexTagInfo m
|
|
where
|
|
decode i = M.lookup (tagAttr i) decoders >>= rundecoder i
|
|
rundecoder i d = d m i
|
|
decoders = M.fromList $ zip
|
|
[ pairAttr
|
|
, canPushAttr
|
|
, pushRequestAttr
|
|
, startingPushAttr
|
|
, receivePackAttr
|
|
, sendPackAttr
|
|
, receivePackDoneAttr
|
|
]
|
|
[ decodePairingNotification
|
|
, pushdecoder $ shasgen CanPush
|
|
, pushdecoder $ gen PushRequest
|
|
, pushdecoder $ gen StartingPush
|
|
, pushdecoder $ seqgen ReceivePackOutput
|
|
, pushdecoder $ seqgen SendPackOutput
|
|
, pushdecoder $
|
|
fmap (ReceivePackDone . decodeExitCode) . readish .
|
|
T.unpack . tagValue
|
|
]
|
|
pushdecoder a m' i = Pushing
|
|
<$> (formatJID <$> messageFrom m')
|
|
<*> a i
|
|
gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))
|
|
seqgen c i = do
|
|
packet <- decodeTagContent $ tagElement i
|
|
let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
|
|
return $ c seqnum packet
|
|
shasgen c i = do
|
|
let (u:shas) = words $ T.unpack $ tagValue i
|
|
return $ c (toUUID u) (mapMaybe extractSha shas)
|
|
|
|
decodeExitCode :: Int -> ExitCode
|
|
decodeExitCode 0 = ExitSuccess
|
|
decodeExitCode n = ExitFailure n
|
|
|
|
encodeExitCode :: ExitCode -> Int
|
|
encodeExitCode ExitSuccess = 0
|
|
encodeExitCode (ExitFailure n) = n
|
|
|
|
{- Base 64 encoding a ByteString to use as the content of a tag. -}
|
|
encodeTagContent :: ByteString -> [Node]
|
|
encodeTagContent b = [NodeContent $ ContentText $ T.pack $ w82s $ B.unpack $ B64.encode b]
|
|
|
|
decodeTagContent :: Element -> Maybe ByteString
|
|
decodeTagContent elt = either (const Nothing) Just (B64.decode $ B.pack $ s2w8 s)
|
|
where
|
|
s = T.unpack $ T.concat $ elementText elt
|
|
|
|
{- The JID without the client part. -}
|
|
baseJID :: JID -> JID
|
|
baseJID j = JID (jidNode j) (jidDomain j) Nothing
|
|
|
|
{- An XMPP chat message with an empty body. This should not be displayed
|
|
- by clients, but can be used for communications. -}
|
|
silentMessage :: Message
|
|
silentMessage = (emptyMessage MessageChat)
|
|
{ messagePayloads = [ emptybody ] }
|
|
where
|
|
emptybody = Element
|
|
{ elementName = "body"
|
|
, elementAttributes = []
|
|
, elementNodes = []
|
|
}
|
|
|
|
{- Add to a presence to mark its client as extended away. -}
|
|
extendedAway :: Element
|
|
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
|
|
|
|
{- Add to a presence to give it a negative priority. -}
|
|
negativePriority :: Element
|
|
negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"]
|
|
|
|
pushAttr :: Name
|
|
pushAttr = "push"
|
|
|
|
queryAttr :: Name
|
|
queryAttr = "query"
|
|
|
|
pairAttr :: Name
|
|
pairAttr = "pair"
|
|
|
|
canPushAttr :: Name
|
|
canPushAttr = "canpush"
|
|
|
|
pushRequestAttr :: Name
|
|
pushRequestAttr = "pushrequest"
|
|
|
|
startingPushAttr :: Name
|
|
startingPushAttr = "startingpush"
|
|
|
|
receivePackAttr :: Name
|
|
receivePackAttr = "rp"
|
|
|
|
sendPackAttr :: Name
|
|
sendPackAttr = "sp"
|
|
|
|
receivePackDoneAttr :: Name
|
|
receivePackDoneAttr = "rpdone"
|
|
|
|
shasAttr :: Name
|
|
shasAttr = "shas"
|