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

better data types allowed marvelous refactoring

Browse source
This commit is contained in:
Joey Hess 2012-11-10 12:33:55 -04:00
parent 81953c2131
commit 7ab993ffc9
1 changed files with 22 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
Assistant/XMPP.hs
View file

@ -136,8 +136,8 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
canPush :: JID -> JID -> Message canPush :: JID -> JID -> Message
canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty canPush = gitAnnexMessage $ gitAnnexTag canPushAttr T.empty
decodeCanPush :: Message -> GitAnnexTagInfo -> Maybe NetMessage decodeCanPush :: PushDecoder
decodeCanPush m _ = Pushing <$> (formatJID <$> messageFrom m) <*> pure CanPush decodeCanPush = mkPushDecoder $ const $ Just CanPush
canPushAttr :: Name canPushAttr :: Name
canPushAttr = "canpush" canPushAttr = "canpush"
@ -145,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 -> GitAnnexTagInfo -> Maybe NetMessage decodePushRequest :: PushDecoder
decodePushRequest m _ = Pushing <$> (formatJID <$> messageFrom m) <*> pure PushRequest decodePushRequest = mkPushDecoder $ const $ Just PushRequest
pushRequestAttr :: Name pushRequestAttr :: Name
pushRequestAttr = "pushrequest" pushRequestAttr = "pushrequest"
@ -157,8 +157,8 @@ startingPush = gitAnnexMessage $ gitAnnexTag startingPushAttr T.empty
startingPushAttr :: Name startingPushAttr :: Name
startingPushAttr = "startingpush" startingPushAttr = "startingpush"
decodeStartingPush :: Message -> GitAnnexTagInfo -> Maybe NetMessage decodeStartingPush :: PushDecoder
decodeStartingPush m _ = Pushing <$> (formatJID <$> messageFrom m) <*> pure StartingPush decodeStartingPush = mkPushDecoder $ const $ Just StartingPush
receivePackOutput :: ByteString -> JID -> JID -> Message receivePackOutput :: ByteString -> JID -> JID -> Message
receivePackOutput = gitAnnexMessage . receivePackOutput = gitAnnexMessage .
@ -167,10 +167,9 @@ receivePackOutput = gitAnnexMessage .
receivePackAttr :: Name receivePackAttr :: Name
receivePackAttr = "rp" receivePackAttr = "rp"
decodeReceivePackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage decodeReceivePackOutput :: PushDecoder
decodeReceivePackOutput m i = Pushing decodeReceivePackOutput = mkPushDecoder $
<$> (formatJID <$> messageFrom m) fmap ReceivePackOutput . decodeTagContent . tagElement
<*> (ReceivePackOutput <$> decodeTagContent (tagElement i))
sendPackOutput :: ByteString -> JID -> JID -> Message sendPackOutput :: ByteString -> JID -> JID -> Message
sendPackOutput = gitAnnexMessage . sendPackOutput = gitAnnexMessage .
@ -179,10 +178,9 @@ sendPackOutput = gitAnnexMessage .
sendPackAttr :: Name sendPackAttr :: Name
sendPackAttr = "sp" sendPackAttr = "sp"
decodeSendPackOutput :: Message -> GitAnnexTagInfo -> Maybe NetMessage decodeSendPackOutput :: PushDecoder
decodeSendPackOutput m i = Pushing decodeSendPackOutput = mkPushDecoder $
<$> (formatJID <$> messageFrom m) fmap SendPackOutput . decodeTagContent . tagElement
<*> (SendPackOutput <$> 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
@ -190,10 +188,9 @@ receivePackDone = gitAnnexMessage . gitAnnexTag receivePackDoneAttr . T.pack . s
toi (ExitSuccess) = 0 toi (ExitSuccess) = 0
toi (ExitFailure i) = i toi (ExitFailure i) = i
decodeReceivePackDone :: Message -> GitAnnexTagInfo -> Maybe NetMessage decodeReceivePackDone :: PushDecoder
decodeReceivePackDone m i = Pushing decodeReceivePackDone = mkPushDecoder $
<$> (formatJID <$> messageFrom m) fmap (ReceivePackDone . convert) . readish . T.unpack . tagValue
<*> (ReceivePackDone . convert <$> readish (T.unpack $ tagValue i))
where where
convert 0 = ExitSuccess convert 0 = ExitSuccess
convert n = ExitFailure n convert n = ExitFailure n
@ -229,3 +226,10 @@ silentMessage = (emptyMessage MessageChat)
{- Add to a presence to mark its client as extended away. -} {- Add to a presence to mark its client as extended away. -}
extendedAway :: Element extendedAway :: Element
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"] extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
type PushDecoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
mkPushDecoder :: (GitAnnexTagInfo -> Maybe PushStage) -> PushDecoder
mkPushDecoder a m i = Pushing
<$> (formatJID <$> messageFrom m)
<*> a i