refactor

2 files changed, 40 insertions, 36 deletions

diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index d1cd375ed..6b6c14ea5 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -120,12 +120,12 @@ decodeStanza selfjid s@(ReceivedPresence p)
 	| presenceType p == PresenceError = [ProtocolError s]
 	| presenceFrom p == Nothing = [Ignorable s]
 	| presenceFrom p == Just selfjid = [Ignorable s]
-	| otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p)
+	| otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)
   where
-	decode (attr, (val, _tag))
-		| attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
-			decodePushNotification val
-		| attr == queryAttr = impliedp $ GotNetMessage QueryPresence
+	decode i
+		| tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
+			decodePushNotification (tagValue i)
+		| tagAttr i == queryAttr = impliedp $ GotNetMessage QueryPresence
 		| otherwise = [Unknown s]
 	{- Things sent via presence imply a presence message,
 	 - along with their real meaning. -}
@@ -134,10 +134,10 @@ decodeStanza selfjid s@(ReceivedMessage m)
 	| messageFrom m == Nothing = [Ignorable s]
 	| messageFrom m == Just selfjid = [Ignorable s]
 	| messageType m == MessageError = [ProtocolError s]
-	| otherwise = [fromMaybe (Unknown s) $ decode =<< getGitAnnexAttrValue m]
+	| otherwise = [fromMaybe (Unknown s) $ decode =<< gitAnnexTagInfo m]
   where
-	decode (attr, (val, tag)) = GotNetMessage <$>
-		((\d -> d m val tag) =<< M.lookup attr decoders)
+	decode i = GotNetMessage <$>
+		((\d -> d m i) =<< M.lookup (tagAttr i) decoders)
 	decoders = M.fromList
 		[ (pairAttr, decodePairingNotification)
 		, (canPushAttr, decodeCanPush)
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 29bd36c41..5532b8027 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -55,15 +55,19 @@ instance GitAnnexTaggable Presence where
 	insertGitAnnexTag p elt = p { presencePayloads = extendedAway : elt : presencePayloads p }
 	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
 
-{- Gets the attr and its value value from a git-annex tag, as well as the
- - tag.
- -
- - Each git-annex tag has a single attribute. -}
-getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, (Text, Element))
-getGitAnnexAttrValue a = case extractGitAnnexTag a of
-	Just (tag@(Element _ [(attr, _)] _)) -> do
-		val <- attributeText attr tag
-		return (attr, (val, tag))
+data GitAnnexTagInfo = GitAnnexTagInfo
+	{ tagAttr :: Name
+	, tagValue :: Text
+	, tagElement :: Element
+	}
+
+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. -}
@@ -120,8 +124,8 @@ encodePairingNotification pairstage u = T.unwords $ map T.pack
 	, fromUUID u
 	]
 
-decodePairingNotification :: Message -> Text -> Element -> Maybe NetMessage
-decodePairingNotification m t _ = parse $ words $ T.unpack t
+decodePairingNotification :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodePairingNotification m = parse . words . T.unpack . tagValue
   where
 	parse [stage, u] = PairingNotification
 		<$> readish stage
@@ -132,8 +136,8 @@ decodePairingNotification m t _ = parse $ words $ T.unpack t
 canPush :: JID -> JID -> Message
 canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty
 
-decodeCanPush :: Message -> Text -> Element -> Maybe NetMessage
-decodeCanPush m _ _ = CanPush <$> (formatJID <$> messageFrom m)
+decodeCanPush :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodeCanPush m _ = CanPush <$> (formatJID <$> messageFrom m)
 
 canPushAttr :: Name
 canPushAttr = "canpush"
@@ -141,8 +145,8 @@ canPushAttr = "canpush"
 pushRequest :: JID -> JID -> Message
 pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
 
-decodePushRequest :: Message -> Text -> Element -> Maybe NetMessage
-decodePushRequest m _ _ = PushRequest <$> (formatJID <$> messageFrom m)
+decodePushRequest :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodePushRequest m _ = PushRequest <$> (formatJID <$> messageFrom m)
 
 pushRequestAttr :: Name
 pushRequestAttr = "pushrequest"
@@ -153,8 +157,8 @@ startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
 startingPushAttr :: Name
 startingPushAttr = "startingpush"
 
-decodeStartingPush :: Message -> Text -> Element -> Maybe NetMessage
-decodeStartingPush m _ _ = StartingPush <$> (formatJID <$> messageFrom m)
+decodeStartingPush :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodeStartingPush m _ = StartingPush <$> (formatJID <$> messageFrom m)
 
 receivePackOutput :: ByteString -> JID -> JID -> Message
 receivePackOutput = gitAnnexMessage .
@@ -163,10 +167,10 @@ receivePackOutput = gitAnnexMessage .
 receivePackAttr :: Name
 receivePackAttr = "rp"
 
-decodeReceivePackOutput :: Message -> Text -> Element -> Maybe NetMessage
-decodeReceivePackOutput m _ t = ReceivePackOutput
+decodeReceivePackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodeReceivePackOutput m i = ReceivePackOutput
 	<$> (formatJID <$> messageFrom m)
-	<*> decodeTagContent t
+	<*> decodeTagContent (tagElement i)
 
 sendPackOutput :: ByteString -> JID -> JID -> Message
 sendPackOutput = gitAnnexMessage .
@@ -175,10 +179,10 @@ sendPackOutput = gitAnnexMessage .
 sendPackAttr :: Name
 sendPackAttr = "sp"
 
-decodeSendPackOutput :: Message -> Text -> Element -> Maybe NetMessage
-decodeSendPackOutput m _ t = SendPackOutput
+decodeSendPackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodeSendPackOutput m i = SendPackOutput
 	<$> (formatJID <$> messageFrom m)
-	<*> decodeTagContent t
+	<*> decodeTagContent (tagElement i)
 
 receivePackDone :: ExitCode -> JID -> JID -> Message
 receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . show . toi
@@ -186,13 +190,13 @@ receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . s
 	toi (ExitSuccess) = 0
 	toi (ExitFailure i) = i
 
-decodeReceivePackDone :: Message -> Text -> Element -> Maybe NetMessage
-decodeReceivePackDone m t _ = ReceivePackDone
+decodeReceivePackDone :: Message -> GitAnnexTagInfo -> Maybe NetMessage
+decodeReceivePackDone m i = ReceivePackDone
 	<$> (formatJID <$> messageFrom m)
-	<*> (fromi <$> readish (T.unpack t))
+	<*> (convert <$> readish (T.unpack $ tagValue i))
   where
-	fromi 0 = ExitSuccess
-	fromi i = ExitFailure i
+	convert 0 = ExitSuccess
+	convert n = ExitFailure n
 
 receivePackDoneAttr :: Name
 receivePackDoneAttr = "rpdone"