diff options
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 6 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 62 |
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" |