summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Assistant/Threads/XMPPClient.hs6
-rw-r--r--Assistant/XMPP.hs62
2 files changed, 34 insertions, 34 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 5a1323770..ee1db0666 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -146,11 +146,9 @@ relayNetMessage selfjid = convert =<< waitNetMessage
convert (PairingNotification stage c u) = withclient c $ \tojid -> do
changeBuddyPairing tojid True
return $ putStanza $ pairingNotification stage u tojid selfjid
- convert (Pushing c pushstage) = sendclient c $
- gitAnnexMessage $ encodePushStage pushstage
+ convert (Pushing c pushstage) = withclient c $ \tojid ->
+ return $ putStanza $ pushMessage pushstage tojid selfjid
- sendclient c construct = withclient c $ \tojid ->
- return $ putStanza $ construct tojid selfjid
withclient c a = case parseJID c of
Nothing -> return noop
Just tojid
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 6190c967a..d31712770 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -62,6 +62,8 @@ data GitAnnexTagInfo = GitAnnexTagInfo
, 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. -}
@@ -125,19 +127,19 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
<*> pure (toUUID u)
parse _ = Nothing
-encodePushStage :: PushStage -> Element
-encodePushStage CanPush = gitAnnexTag canPushAttr T.empty
-encodePushStage PushRequest = gitAnnexTag pushRequestAttr T.empty
-encodePushStage StartingPush = gitAnnexTag startingPushAttr T.empty
-encodePushStage (ReceivePackOutput b) =
- gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b
-encodePushStage (SendPackOutput b) =
- gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b
-encodePushStage (ReceivePackDone code) =
- gitAnnexTag receivePackDoneAttr $ T.pack $ show $ toi code
+pushMessage :: PushStage -> JID -> JID -> Message
+pushMessage = gitAnnexMessage . encode
where
- toi (ExitSuccess) = 0
- toi (ExitFailure i) = i
+ encode CanPush = gitAnnexTag canPushAttr T.empty
+ encode PushRequest = gitAnnexTag pushRequestAttr T.empty
+ encode StartingPush = gitAnnexTag startingPushAttr T.empty
+ encode (ReceivePackOutput b) =
+ gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b
+ encode (SendPackOutput b) =
+ gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b
+ encode (ReceivePackDone code) =
+ gitAnnexTag receivePackDoneAttr $
+ T.pack $ show $ encodeExitCode code
decodeMessage :: Message -> Maybe NetMessage
decodeMessage m = decode =<< gitAnnexTagInfo m
@@ -154,21 +156,28 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
, receivePackDoneAttr
]
[ decodePairingNotification
- , mkPushDecoder $ const $ Just CanPush
- , mkPushDecoder $ const $ Just PushRequest
- , mkPushDecoder $ const $ Just StartingPush
- , mkPushDecoder $
+ , pushdecoder $ const $ Just CanPush
+ , pushdecoder $ const $ Just PushRequest
+ , pushdecoder $ const $ Just StartingPush
+ , pushdecoder $
fmap ReceivePackOutput . decodeTagContent . tagElement
- , mkPushDecoder $
+ , pushdecoder $
fmap SendPackOutput . decodeTagContent . tagElement
- , mkPushDecoder $
- fmap (ReceivePackDone . convertCode) . readish .
+ , pushdecoder $
+ fmap (ReceivePackDone . decodeExitCode) . readish .
T.unpack . tagValue
]
-
-convertCode :: Int -> ExitCode
-convertCode 0 = ExitSuccess
-convertCode n = ExitFailure n
+ pushdecoder a m i = Pushing
+ <$> (formatJID <$> messageFrom m)
+ <*> a i
+
+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]
@@ -199,13 +208,6 @@ silentMessage = (emptyMessage MessageChat)
extendedAway :: Element
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
-type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
-
-mkPushDecoder :: (GitAnnexTagInfo -> Maybe PushStage) -> Decoder
-mkPushDecoder a m i = Pushing
- <$> (formatJID <$> messageFrom m)
- <*> a i
-
pushAttr :: Name
pushAttr = "push"