summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-10 02:18:19 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-10 02:18:19 -0400
commitbce81d8cc7551cd790e7ff3c5adb80593a7c88ee (patch)
tree13eaab29500073e1b6f472d1f283b62cd386e412
parent095eee8594f6f36b90898504f306409edc6fdddf (diff)
use a lookup table for speed
-rw-r--r--Assistant/Threads/XMPPClient.hs27
-rw-r--r--Assistant/XMPP.hs37
2 files changed, 32 insertions, 32 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 4d34e7eb8..d1cd375ed 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -122,9 +122,9 @@ decodeStanza selfjid s@(ReceivedPresence p)
| presenceFrom p == Just selfjid = [Ignorable s]
| otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p)
where
- decode (attr, v, _tag)
+ decode (attr, (val, _tag))
| attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
- decodePushNotification v
+ decodePushNotification val
| attr == queryAttr = impliedp $ GotNetMessage QueryPresence
| otherwise = [Unknown s]
{- Things sent via presence imply a presence message,
@@ -134,18 +134,19 @@ decodeStanza selfjid s@(ReceivedMessage m)
| messageFrom m == Nothing = [Ignorable s]
| messageFrom m == Just selfjid = [Ignorable s]
| messageType m == MessageError = [ProtocolError s]
- | otherwise = maybe [Unknown s] decode (getGitAnnexAttrValue m)
+ | otherwise = [fromMaybe (Unknown s) $ decode =<< getGitAnnexAttrValue m]
where
- decode (attr, v, tag)
- | attr == pairAttr = use $ decodePairingNotification v
- | attr == canPushAttr = use decodeCanPush
- | attr == pushRequestAttr = use decodePushRequest
- | attr == startingPushAttr = use decodeStartingPush
- | attr == receivePackAttr = use $ decodeReceivePackOutput tag
- | attr == sendPackAttr = use $ decodeSendPackOutput tag
- | attr == receivePackDoneAttr = use $ decodeReceivePackDone v
- | otherwise = [Unknown s]
- use v = [maybe (Unknown s) GotNetMessage (v m)]
+ decode (attr, (val, tag)) = GotNetMessage <$>
+ ((\d -> d m val tag) =<< M.lookup attr decoders)
+ decoders = M.fromList
+ [ (pairAttr, decodePairingNotification)
+ , (canPushAttr, decodeCanPush)
+ , (pushRequestAttr, decodePushRequest)
+ , (startingPushAttr, decodeStartingPush)
+ , (receivePackAttr, decodeReceivePackOutput)
+ , (sendPackAttr, decodeSendPackOutput)
+ , (receivePackDoneAttr, decodeReceivePackDone)
+ ]
decodeStanza _ s = [Unknown s]
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 02d4c10c6..29bd36c41 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -59,12 +59,11 @@ instance GitAnnexTaggable Presence where
- tag.
-
- Each git-annex tag has a single attribute. -}
-getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, Text, Element)
+getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, (Text, Element))
getGitAnnexAttrValue a = case extractGitAnnexTag a of
- Just (tag@(Element _ [(attr, _)] _)) -> (,,)
- <$> pure attr
- <*> attributeText attr tag
- <*> pure tag
+ Just (tag@(Element _ [(attr, _)] _)) -> do
+ val <- attributeText attr tag
+ return (attr, (val, tag))
_ -> Nothing
{- A presence with a git-annex tag in it. -}
@@ -121,8 +120,8 @@ encodePairingNotification pairstage u = T.unwords $ map T.pack
, fromUUID u
]
-decodePairingNotification :: Text -> Message -> Maybe NetMessage
-decodePairingNotification t m = parse $ words $ T.unpack t
+decodePairingNotification :: Message -> Text -> Element -> Maybe NetMessage
+decodePairingNotification m t _ = parse $ words $ T.unpack t
where
parse [stage, u] = PairingNotification
<$> readish stage
@@ -133,8 +132,8 @@ decodePairingNotification t m = parse $ words $ T.unpack t
canPush :: JID -> JID -> Message
canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty
-decodeCanPush :: Message -> Maybe NetMessage
-decodeCanPush m = CanPush <$> (formatJID <$> messageFrom m)
+decodeCanPush :: Message -> Text -> Element -> Maybe NetMessage
+decodeCanPush m _ _ = CanPush <$> (formatJID <$> messageFrom m)
canPushAttr :: Name
canPushAttr = "canpush"
@@ -142,8 +141,8 @@ canPushAttr = "canpush"
pushRequest :: JID -> JID -> Message
pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
-decodePushRequest :: Message -> Maybe NetMessage
-decodePushRequest m = PushRequest <$> (formatJID <$> messageFrom m)
+decodePushRequest :: Message -> Text -> Element -> Maybe NetMessage
+decodePushRequest m _ _ = PushRequest <$> (formatJID <$> messageFrom m)
pushRequestAttr :: Name
pushRequestAttr = "pushrequest"
@@ -154,8 +153,8 @@ startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
startingPushAttr :: Name
startingPushAttr = "startingpush"
-decodeStartingPush :: Message -> Maybe NetMessage
-decodeStartingPush m = StartingPush <$> (formatJID <$> messageFrom m)
+decodeStartingPush :: Message -> Text -> Element -> Maybe NetMessage
+decodeStartingPush m _ _ = StartingPush <$> (formatJID <$> messageFrom m)
receivePackOutput :: ByteString -> JID -> JID -> Message
receivePackOutput = gitAnnexMessage .
@@ -164,8 +163,8 @@ receivePackOutput = gitAnnexMessage .
receivePackAttr :: Name
receivePackAttr = "rp"
-decodeReceivePackOutput :: Element -> Message -> Maybe NetMessage
-decodeReceivePackOutput t m = ReceivePackOutput
+decodeReceivePackOutput :: Message -> Text -> Element -> Maybe NetMessage
+decodeReceivePackOutput m _ t = ReceivePackOutput
<$> (formatJID <$> messageFrom m)
<*> decodeTagContent t
@@ -176,8 +175,8 @@ sendPackOutput = gitAnnexMessage .
sendPackAttr :: Name
sendPackAttr = "sp"
-decodeSendPackOutput :: Element -> Message -> Maybe NetMessage
-decodeSendPackOutput t m = SendPackOutput
+decodeSendPackOutput :: Message -> Text -> Element -> Maybe NetMessage
+decodeSendPackOutput m _ t = SendPackOutput
<$> (formatJID <$> messageFrom m)
<*> decodeTagContent t
@@ -187,8 +186,8 @@ receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . s
toi (ExitSuccess) = 0
toi (ExitFailure i) = i
-decodeReceivePackDone :: Text -> Message -> Maybe NetMessage
-decodeReceivePackDone t m = ReceivePackDone
+decodeReceivePackDone :: Message -> Text -> Element -> Maybe NetMessage
+decodeReceivePackDone m t _ = ReceivePackDone
<$> (formatJID <$> messageFrom m)
<*> (fromi <$> readish (T.unpack t))
where