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 convert (PairingNotification stage c u) = withclient c $ \tojid -> do
changeBuddyPairing tojid True changeBuddyPairing tojid True
return $ putStanza $ pairingNotification stage u tojid selfjid return $ putStanza $ pairingNotification stage u tojid selfjid
convert (Pushing c pushstage) = sendclient c $ convert (Pushing c pushstage) = withclient c $ \tojid ->
gitAnnexMessage $ encodePushStage pushstage return $ putStanza $ pushMessage pushstage tojid selfjid
sendclient c construct = withclient c $ \tojid ->
return $ putStanza $ construct tojid selfjid
withclient c a = case parseJID c of withclient c a = case parseJID c of
Nothing -> return noop Nothing -> return noop
Just tojid Just tojid

60
Assistant/XMPP.hs
View file

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