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

refactor

Browse source
This commit is contained in:
Joey Hess 2012-11-10 02:35:54 -04:00
parent 235f2ecb91
commit 8b8964b523
2 changed files with 40 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

16
Assistant/Threads/XMPPClient.hs
View file

@ -120,12 +120,12 @@ decodeStanza selfjid s@(ReceivedPresence p)
| presenceType p == PresenceError = [ProtocolError s] | presenceType p == PresenceError = [ProtocolError s]
| presenceFrom p == Nothing = [Ignorable s] | presenceFrom p == Nothing = [Ignorable s]
| presenceFrom p == Just selfjid = [Ignorable s] | presenceFrom p == Just selfjid = [Ignorable s]
| otherwise = maybe [PresenceMessage p] decode (getGitAnnexAttrValue p) | otherwise = maybe [PresenceMessage p] decode (gitAnnexTagInfo p)
where where
decode (attr, (val, _tag)) decode i
| attr == pushAttr = impliedp $ GotNetMessage $ NotifyPush $ | tagAttr i == pushAttr = impliedp $ GotNetMessage $ NotifyPush $
decodePushNotification val decodePushNotification (tagValue i)
| attr == queryAttr = impliedp $ GotNetMessage QueryPresence | tagAttr i == 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,
- along with their real meaning. -} - along with their real meaning. -}
@ -134,10 +134,10 @@ 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 = [fromMaybe (Unknown s) $ decode =<< getGitAnnexAttrValue m] | otherwise = [fromMaybe (Unknown s) $ decode =<< gitAnnexTagInfo m]
where where
decode (attr, (val, tag)) = GotNetMessage <$> decode i = GotNetMessage <$>
((\d -> d m val tag) =<< M.lookup attr decoders) ((\d -> d m i) =<< M.lookup (tagAttr i) decoders)
decoders = M.fromList decoders = M.fromList
[ (pairAttr, decodePairingNotification) [ (pairAttr, decodePairingNotification)
, (canPushAttr, decodeCanPush) , (canPushAttr, decodeCanPush)

60
Assistant/XMPP.hs
View file

@ -55,15 +55,19 @@ instance GitAnnexTaggable Presence where
insertGitAnnexTag p elt = p { presencePayloads = extendedAway : elt : presencePayloads p } insertGitAnnexTag p elt = p { presencePayloads = extendedAway : elt : presencePayloads p }
extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
{- Gets the attr and its value value from a git-annex tag, as well as the data GitAnnexTagInfo = GitAnnexTagInfo
- tag. { tagAttr :: Name
- , tagValue :: Text
- Each git-annex tag has a single attribute. -} , tagElement :: Element
getGitAnnexAttrValue :: GitAnnexTaggable a => a -> Maybe (Name, (Text, Element)) }
getGitAnnexAttrValue a = case extractGitAnnexTag a of
Just (tag@(Element _ [(attr, _)] _)) -> do gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo
val <- attributeText attr tag gitAnnexTagInfo v = case extractGitAnnexTag v of
return (attr, (val, tag)) {- Each git-annex tag has a single attribute. -}
Just (tag@(Element _ [(attr, _)] _)) -> GitAnnexTagInfo
<$> pure attr
<*> attributeText attr tag
<*> pure tag
_ -> Nothing _ -> Nothing
{- A presence with a git-annex tag in it. -} {- A presence with a git-annex tag in it. -}
@ -120,8 +124,8 @@ encodePairingNotification pairstage u = T.unwords $ map T.pack
, fromUUID u , fromUUID u
] ]
decodePairingNotification :: Message -> Text -> Element -> Maybe NetMessage decodePairingNotification :: Message -> GitAnnexTagInfo -> Maybe NetMessage
decodePairingNotification m t _ = parse $ words $ T.unpack t decodePairingNotification m = parse . words . T.unpack . tagValue
where where
parse [stage, u] = PairingNotification parse [stage, u] = PairingNotification
<$> readish stage <$> readish stage
@ -132,8 +136,8 @@ decodePairingNotification m t _ = 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 -> Text -> Element -> Maybe NetMessage decodeCanPush :: Message -> GitAnnexTagInfo -> Maybe NetMessage
decodeCanPush m _ _ = CanPush <$> (formatJID <$> messageFrom m) decodeCanPush m _ = CanPush <$> (formatJID <$> messageFrom m)
canPushAttr :: Name canPushAttr :: Name
canPushAttr = "canpush" canPushAttr = "canpush"
@ -141,8 +145,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 -> Text -> Element -> Maybe NetMessage decodePushRequest :: Message -> GitAnnexTagInfo -> Maybe NetMessage
decodePushRequest m _ _ = PushRequest <$> (formatJID <$> messageFrom m) decodePushRequest m _ = PushRequest <$> (formatJID <$> messageFrom m)
pushRequestAttr :: Name pushRequestAttr :: Name
pushRequestAttr = "pushrequest" pushRequestAttr = "pushrequest"
@ -153,8 +157,8 @@ startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
startingPushAttr :: Name startingPushAttr :: Name
startingPushAttr = "startingpush" startingPushAttr = "startingpush"
decodeStartingPush :: Message -> Text -> Element -> Maybe NetMessage decodeStartingPush :: Message -> GitAnnexTagInfo -> 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 .
@ -163,10 +167,10 @@ receivePackOutput = gitAnnexMessage .
receivePackAttr :: Name receivePackAttr :: Name
receivePackAttr = "rp" receivePackAttr = "rp"
decodeReceivePackOutput :: Message -> Text -> Element -> Maybe NetMessage decodeReceivePackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage
decodeReceivePackOutput m _ t = ReceivePackOutput decodeReceivePackOutput m i = ReceivePackOutput
<$> (formatJID <$> messageFrom m) <$> (formatJID <$> messageFrom m)
<*> decodeTagContent t <*> decodeTagContent (tagElement i)
sendPackOutput :: ByteString -> JID -> JID -> Message sendPackOutput :: ByteString -> JID -> JID -> Message
sendPackOutput = gitAnnexMessage . sendPackOutput = gitAnnexMessage .
@ -175,10 +179,10 @@ sendPackOutput = gitAnnexMessage .
sendPackAttr :: Name sendPackAttr :: Name
sendPackAttr = "sp" sendPackAttr = "sp"
decodeSendPackOutput :: Message -> Text -> Element -> Maybe NetMessage decodeSendPackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage
decodeSendPackOutput m _ t = SendPackOutput decodeSendPackOutput m i = SendPackOutput
<$> (formatJID <$> messageFrom m) <$> (formatJID <$> messageFrom m)
<*> decodeTagContent t <*> decodeTagContent (tagElement i)
receivePackDone :: ExitCode -> JID -> JID -> Message receivePackDone :: ExitCode -> JID -> JID -> Message
receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . show . toi receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . show . toi
@ -186,13 +190,13 @@ receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . s
toi (ExitSuccess) = 0 toi (ExitSuccess) = 0
toi (ExitFailure i) = i toi (ExitFailure i) = i
decodeReceivePackDone :: Message -> Text -> Element -> Maybe NetMessage decodeReceivePackDone :: Message -> GitAnnexTagInfo -> Maybe NetMessage
decodeReceivePackDone m t _ = ReceivePackDone decodeReceivePackDone m i = ReceivePackDone
<$> (formatJID <$> messageFrom m) <$> (formatJID <$> messageFrom m)
<*> (fromi <$> readish (T.unpack t)) <*> (convert <$> readish (T.unpack $ tagValue i))
where where
fromi 0 = ExitSuccess convert 0 = ExitSuccess
fromi i = ExitFailure i convert n = ExitFailure n
receivePackDoneAttr :: Name receivePackDoneAttr :: Name
receivePackDoneAttr = "rpdone" receivePackDoneAttr = "rpdone"