mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

use a lookup table for speed

Browse source
This commit is contained in:
Joey Hess 2012-11-10 02:18:19 -04:00
parent 2286032781
commit 235f2ecb91
2 changed files with 32 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

27
Assistant/Threads/XMPPClient.hs
View file

@ -122,9 +122,9 @@ decodeStanza selfjid s@(ReceivedPresence p)
| presenceFrom p == Just selfjid = [Ignorable s] | presenceFrom p == Just selfjid = [Ignorable s]
| otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p) | otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p)
where where
decode (attr, v, _tag) decode (attr, (val, _tag))
| attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $ | attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
decodePushNotification v decodePushNotification val
| attr == queryAttr = impliedp $ GotNetMessage QueryPresence | attr == queryAttr = impliedp $ GotNetMessage QueryPresence
| otherwise = [Unknown s] | otherwise = [Unknown s]
{- Things sent via presence imply a presence message, {- Things sent via presence imply a presence message,
@ -134,18 +134,19 @@ decodeStanza selfjid s@(ReceivedMessage m)
| messageFrom m == Nothing = [Ignorable s] | messageFrom m == Nothing = [Ignorable s]
| messageFrom m == Just selfjid = [Ignorable s] | messageFrom m == Just selfjid = [Ignorable s]
| messageType m == MessageError = [ProtocolError s] | messageType m == MessageError = [ProtocolError s]
| otherwise = maybe [Unknown s] decode (getGitAnnexAttrValue m) | otherwise = [fromMaybe (Unknown s) $ decode =<< getGitAnnexAttrValue m]
where where
decode (attr, v, tag) decode (attr, (val, tag)) = GotNetMessage <$>
| attr == pairAttr = use $ decodePairingNotification v ((\d -> d m val tag) =<< M.lookup attr decoders)
| attr == canPushAttr = use decodeCanPush decoders = M.fromList
| attr == pushRequestAttr = use decodePushRequest [ (pairAttr, decodePairingNotification)
| attr == startingPushAttr = use decodeStartingPush , (canPushAttr, decodeCanPush)
| attr == receivePackAttr = use $ decodeReceivePackOutput tag , (pushRequestAttr, decodePushRequest)
| attr == sendPackAttr = use $ decodeSendPackOutput tag , (startingPushAttr, decodeStartingPush)
| attr == receivePackDoneAttr = use $ decodeReceivePackDone v , (receivePackAttr, decodeReceivePackOutput)
| otherwise = [Unknown s] , (sendPackAttr, decodeSendPackOutput)
use v = [maybe (Unknown s) GotNetMessage (v m)] , (receivePackDoneAttr, decodeReceivePackDone)
]
decodeStanza _ s = [Unknown s] decodeStanza _ s = [Unknown s]
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -} {- Waits for a NetMessager message to be sent, and relays it to XMPP. -}

37
Assistant/XMPP.hs
View file

@ -59,12 +59,11 @@ instance GitAnnexTaggable Presence where
- tag. - tag.
- -
- Each git-annex tag has a single attribute. -} - 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 getGitAnnexAttrValue a = case extractGitAnnexTag a of
Just (tag@(Element _ [(attr, _)] _)) -> (,,) Just (tag@(Element _ [(attr, _)] _)) -> do
<$> pure attr val <- attributeText attr tag
<*> attributeText attr tag return (attr, (val, tag))
<*> pure tag
_ -> Nothing _ -> Nothing
{- A presence with a git-annex tag in it. -} {- A presence with a git-annex tag in it. -}
@ -121,8 +120,8 @@ encodePairingNotification pairstage u = T.unwords $ map T.pack
, fromUUID u , fromUUID u
] ]
decodePairingNotification :: Text -> Message -> Maybe NetMessage decodePairingNotification :: Message -> Text -> Element -> Maybe NetMessage
decodePairingNotification t m = parse $ words $ T.unpack t decodePairingNotification m t _ = parse $ words $ T.unpack t
where where
parse [stage, u] = PairingNotification parse [stage, u] = PairingNotification
<$> readish stage <$> readish stage
@ -133,8 +132,8 @@ decodePairingNotification t m = parse $ words $ T.unpack t
canPush :: JID -> JID -> Message canPush :: JID -> JID -> Message
canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty
decodeCanPush :: Message -> Maybe NetMessage decodeCanPush :: Message -> Text -> Element -> Maybe NetMessage
decodeCanPush m = CanPush <$> (formatJID <$> messageFrom m) decodeCanPush m _ _ = CanPush <$> (formatJID <$> messageFrom m)
canPushAttr :: Name canPushAttr :: Name
canPushAttr = "canpush" canPushAttr = "canpush"
@ -142,8 +141,8 @@ canPushAttr = "canpush"
pushRequest :: JID -> JID -> Message pushRequest :: JID -> JID -> Message
pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty pushRequest = gitAnnexMessage $ gitAnnexTag pushRequestAttr T.empty
decodePushRequest :: Message -> Maybe NetMessage decodePushRequest :: Message -> Text -> Element -> Maybe NetMessage
decodePushRequest m = PushRequest <$> (formatJID <$> messageFrom m) decodePushRequest m _ _ = PushRequest <$> (formatJID <$> messageFrom m)
pushRequestAttr :: Name pushRequestAttr :: Name
pushRequestAttr = "pushrequest" pushRequestAttr = "pushrequest"
@ -154,8 +153,8 @@ startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
startingPushAttr :: Name startingPushAttr :: Name
startingPushAttr = "startingpush" startingPushAttr = "startingpush"
decodeStartingPush :: Message -> Maybe NetMessage decodeStartingPush :: Message -> Text -> Element -> Maybe NetMessage
decodeStartingPush m = StartingPush <$> (formatJID <$> messageFrom m) decodeStartingPush m _ _ = StartingPush <$> (formatJID <$> messageFrom m)
receivePackOutput :: ByteString -> JID -> JID -> Message receivePackOutput :: ByteString -> JID -> JID -> Message
receivePackOutput = gitAnnexMessage . receivePackOutput = gitAnnexMessage .
@ -164,8 +163,8 @@ receivePackOutput = gitAnnexMessage .
receivePackAttr :: Name receivePackAttr :: Name
receivePackAttr = "rp" receivePackAttr = "rp"
decodeReceivePackOutput :: Element -> Message -> Maybe NetMessage decodeReceivePackOutput :: Message -> Text -> Element -> Maybe NetMessage
decodeReceivePackOutput t m = ReceivePackOutput decodeReceivePackOutput m _ t = ReceivePackOutput
<$> (formatJID <$> messageFrom m) <$> (formatJID <$> messageFrom m)
<*> decodeTagContent t <*> decodeTagContent t
@ -176,8 +175,8 @@ sendPackOutput = gitAnnexMessage .
sendPackAttr :: Name sendPackAttr :: Name
sendPackAttr = "sp" sendPackAttr = "sp"
decodeSendPackOutput :: Element -> Message -> Maybe NetMessage decodeSendPackOutput :: Message -> Text -> Element -> Maybe NetMessage
decodeSendPackOutput t m = SendPackOutput decodeSendPackOutput m _ t = SendPackOutput
<$> (formatJID <$> messageFrom m) <$> (formatJID <$> messageFrom m)
<*> decodeTagContent t <*> decodeTagContent t
@ -187,8 +186,8 @@ receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . s
toi (ExitSuccess) = 0 toi (ExitSuccess) = 0
toi (ExitFailure i) = i toi (ExitFailure i) = i
decodeReceivePackDone :: Text -> Message -> Maybe NetMessage decodeReceivePackDone :: Message -> Text -> Element -> Maybe NetMessage
decodeReceivePackDone t m = ReceivePackDone decodeReceivePackDone m t _ = ReceivePackDone
<$> (formatJID <$> messageFrom m) <$> (formatJID <$> messageFrom m)
<*> (fromi <$> readish (T.unpack t)) <*> (fromi <$> readish (T.unpack t))
where where