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

more refactoring

Browse source
This commit is contained in:
Joey Hess 2012-11-10 14:01:24 -04:00
parent 0cf4c3ba9c
commit 7a20b3f1d5
2 changed files with 33 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Assistant/Threads/XMPPClient.hs
View file

@ -146,11 +146,9 @@ relayNetMessage selfjid = convert =<< waitNetMessage
convert (PairingNotification stage c u) = withclient c $ \tojid -> do
changeBuddyPairing tojid True
return $ putStanza $ pairingNotification stage u tojid selfjid
convert (Pushing c pushstage) = sendclient c $
gitAnnexMessage $ encodePushStage pushstage
convert (Pushing c pushstage) = withclient c $ \tojid ->
return $ putStanza $ pushMessage pushstage tojid selfjid
sendclient c construct = withclient c $ \tojid ->
return $ putStanza $ construct tojid selfjid
withclient c a = case parseJID c of
Nothing -> return noop
Just tojid

60
Assistant/XMPP.hs
View file

@ -62,6 +62,8 @@ data GitAnnexTagInfo = GitAnnexTagInfo
, tagElement :: Element
}
type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
gitAnnexTagInfo :: GitAnnexTaggable a => a -> Maybe GitAnnexTagInfo
gitAnnexTagInfo v = case extractGitAnnexTag v of
{- Each git-annex tag has a single attribute. -}
@ -125,19 +127,19 @@ decodePairingNotification m = parse . words . T.unpack . tagValue
<*> pure (toUUID u)
parse _ = Nothing
encodePushStage :: PushStage -> Element
encodePushStage CanPush = gitAnnexTag canPushAttr T.empty
encodePushStage PushRequest = gitAnnexTag pushRequestAttr T.empty
encodePushStage StartingPush = gitAnnexTag startingPushAttr T.empty
encodePushStage (ReceivePackOutput b) =
gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b
encodePushStage (SendPackOutput b) =
gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b
encodePushStage (ReceivePackDone code) =
gitAnnexTag receivePackDoneAttr $ T.pack $ show $ toi code
pushMessage :: PushStage -> JID -> JID -> Message
pushMessage = gitAnnexMessage . encode
where
toi (ExitSuccess) = 0
toi (ExitFailure i) = i
encode CanPush = gitAnnexTag canPushAttr T.empty
encode PushRequest = gitAnnexTag pushRequestAttr T.empty
encode StartingPush = gitAnnexTag startingPushAttr T.empty
encode (ReceivePackOutput b) =
gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b
encode (SendPackOutput b) =
gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b
encode (ReceivePackDone code) =
gitAnnexTag receivePackDoneAttr $
T.pack $ show $ encodeExitCode code
decodeMessage :: Message -> Maybe NetMessage
decodeMessage m = decode =<< gitAnnexTagInfo m
@ -154,21 +156,28 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
, receivePackDoneAttr
]
[ decodePairingNotification
, mkPushDecoder $ const $ Just CanPush
, mkPushDecoder $ const $ Just PushRequest
, mkPushDecoder $ const $ Just StartingPush
, mkPushDecoder $
, pushdecoder $ const $ Just CanPush
, pushdecoder $ const $ Just PushRequest
, pushdecoder $ const $ Just StartingPush
, pushdecoder $
fmap ReceivePackOutput . decodeTagContent . tagElement
, mkPushDecoder $
, pushdecoder $
fmap SendPackOutput . decodeTagContent . tagElement
, mkPushDecoder $
fmap (ReceivePackDone . convertCode) . readish .
, pushdecoder $
fmap (ReceivePackDone . decodeExitCode) . readish .
T.unpack . tagValue
]
pushdecoder a m i = Pushing
<$> (formatJID <$> messageFrom m)
<*> a i
convertCode :: Int -> ExitCode
convertCode 0 = ExitSuccess
convertCode n = ExitFailure n
decodeExitCode :: Int -> ExitCode
decodeExitCode 0 = ExitSuccess
decodeExitCode n = ExitFailure n
encodeExitCode :: ExitCode -> Int
encodeExitCode ExitSuccess = 0
encodeExitCode (ExitFailure n) = n
{- Base 64 encoding a ByteString to use as the content of a tag. -}
encodeTagContent :: ByteString -> [Node]
@ -199,13 +208,6 @@ silentMessage = (emptyMessage MessageChat)
extendedAway :: Element
extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
type Decoder = Message -> GitAnnexTagInfo -> Maybe NetMessage
mkPushDecoder :: (GitAnnexTagInfo -> Maybe PushStage) -> Decoder
mkPushDecoder a m i = Pushing
<$> (formatJID <$> messageFrom m)
<*> a i
pushAttr :: Name
pushAttr = "push"